keiro-dsl 0.11.0.0 → 0.12.0.0

raw patch · 399 files changed

+44516/−22876 lines, 399 filesdep +cryptohash-sha256dep +hasqldep +keiro-test-supportdep ~aesondep ~bytestringdep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: cryptohash-sha256, hasql, keiro-test-support, vector

Dependency ranges changed: aeson, bytestring, containers, hasql-transaction, keiro-core, kiroku-store, shibuya-core

API changes (from Hackage documentation)

- Keiro.Dsl.Grammar: [rmConsistency] :: ReadModelNode -> !Consistency

- Keiro.Dsl.Grammar: [rmFeed] :: ReadModelNode -> !RmFeed

- Keiro.Dsl.Grammar: [rmScope] :: ReadModelNode -> !Maybe RmScope

- Keiro.Dsl.Grammar: [rmSubscription] :: ReadModelNode -> !Maybe Text

- Keiro.Dsl.ScaffoldRun: checkServiceDiagnostics :: Maybe RuntimePackageName -> Context -> CheckedService -> [Diagnostic]

- Keiro.Dsl.ScaffoldRun: constraintPlan :: Spec -> ConsumerPlan -> [Text]

- Keiro.Dsl.ScaffoldRun: planScaffold :: Context -> Spec -> Either [Refusal] [ScaffoldModule]

- Keiro.Dsl.ScaffoldRun: planScaffoldWithGoldens :: [GoldenPayload] -> Context -> Spec -> Either [Refusal] [ScaffoldModule]

- Keiro.Dsl.ScaffoldRun: planServiceScaffold :: Context -> CheckedService -> Either [Refusal] [ScaffoldModule]

- Keiro.Dsl.ScaffoldRun: planServiceScaffoldWithGoldens :: [GoldenPayload] -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]

- Keiro.Dsl.ScaffoldRun: planServiceScaffoldWithRuntimePackage :: Maybe RuntimePackageName -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]

- Keiro.Dsl.ScaffoldRun: planServiceScaffoldWithRuntimePackageAndGoldens :: [GoldenPayload] -> Maybe RuntimePackageName -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]

- Keiro.Dsl.ScaffoldRun: pureRefusals :: Context -> Spec -> [ScaffoldModule] -> [Refusal]

- Keiro.Dsl.SemanticContract: CheckedService :: !EffectiveLanguageContract -> !Spec -> CheckedService

- Keiro.Dsl.SemanticContract: [checkedLanguageContract] :: CheckedService -> !EffectiveLanguageContract

- Keiro.Dsl.SemanticContract: [checkedSpec] :: CheckedService -> !Spec

+ Keiro.Dsl.AggregateType: aggregateSymbolsFromGraph :: TypeGraph -> Spec -> AggregateSymbols

+ Keiro.Dsl.AggregateType: aggregateSymbolsFromGraphResult :: Either (NonEmpty TypeGraphError) TypeGraph -> Spec -> AggregateSymbols

+ Keiro.Dsl.BehaviorCoverage: BehaviorExactLocation :: !FilePath -> !Int -> !Int -> BehaviorExactLocation

+ Keiro.Dsl.BehaviorCoverage: RejectionRequirementOrigin :: !Name -> !Name -> RequirementOrigin

+ Keiro.Dsl.BehaviorCoverage: TransitionRequirementOrigin :: !Name -> !TransitionOrdinal -> RequirementOrigin

+ Keiro.Dsl.BehaviorCoverage: [exactSourceColumn] :: BehaviorExactLocation -> !Int

+ Keiro.Dsl.BehaviorCoverage: [exactSourceFile] :: BehaviorExactLocation -> !FilePath

+ Keiro.Dsl.BehaviorCoverage: [exactSourceLine] :: BehaviorExactLocation -> !Int

+ Keiro.Dsl.BehaviorCoverage: [requirementDomainOutcome] :: BehaviorRequirement -> !Maybe TransitionOutcome

+ Keiro.Dsl.BehaviorCoverage: [requirementExactLocation] :: BehaviorRequirement -> !Maybe BehaviorExactLocation

+ Keiro.Dsl.BehaviorCoverage: [requirementOrigin] :: BehaviorRequirement -> !RequirementOrigin

+ Keiro.Dsl.BehaviorCoverage: data BehaviorExactLocation

+ Keiro.Dsl.BehaviorCoverage: data RequirementOrigin

+ Keiro.Dsl.BehaviorCoverage: deriveBehaviorRequirementsForService :: CheckedService -> Either [BehaviorDerivationError] [BehaviorRequirement]

+ Keiro.Dsl.BehaviorCoverage: instance GHC.Classes.Eq Keiro.Dsl.BehaviorCoverage.BehaviorExactLocation

+ Keiro.Dsl.BehaviorCoverage: instance GHC.Classes.Eq Keiro.Dsl.BehaviorCoverage.RequirementOrigin

+ Keiro.Dsl.BehaviorCoverage: instance GHC.Classes.Ord Keiro.Dsl.BehaviorCoverage.BehaviorExactLocation

+ Keiro.Dsl.BehaviorCoverage: instance GHC.Classes.Ord Keiro.Dsl.BehaviorCoverage.RequirementOrigin

+ Keiro.Dsl.BehaviorCoverage: instance GHC.Internal.Show.Show Keiro.Dsl.BehaviorCoverage.BehaviorExactLocation

+ Keiro.Dsl.BehaviorCoverage: instance GHC.Internal.Show.Show Keiro.Dsl.BehaviorCoverage.RequirementOrigin

+ Keiro.Dsl.BehaviorSourceMap: BehaviorSourceAnchorCollision :: BehaviorSourceFailureCode

+ Keiro.Dsl.BehaviorSourceMap: BehaviorSourceAnchorInexact :: BehaviorSourceFailureCode

+ Keiro.Dsl.BehaviorSourceMap: BehaviorSourceAnchorMissing :: BehaviorSourceFailureCode

+ Keiro.Dsl.BehaviorSourceMap: BehaviorSourceEntry :: !BehaviorKey -> !FilePath -> !Int -> !Int -> BehaviorSourceEntry

+ Keiro.Dsl.BehaviorSourceMap: BehaviorSourceFailure :: !BehaviorSourceFailureCode -> !BehaviorKey -> !RequirementOrigin -> !Text -> !Text -> !Text -> !SourceSubject -> !Maybe SourceSpan -> !Text -> BehaviorSourceFailure

+ Keiro.Dsl.BehaviorSourceMap: [behaviorSourceColumn] :: BehaviorSourceEntry -> !Int

+ Keiro.Dsl.BehaviorSourceMap: [behaviorSourceFile] :: BehaviorSourceEntry -> !FilePath

+ Keiro.Dsl.BehaviorSourceMap: [behaviorSourceKey] :: BehaviorSourceEntry -> !BehaviorKey

+ Keiro.Dsl.BehaviorSourceMap: [behaviorSourceLine] :: BehaviorSourceEntry -> !Int

+ Keiro.Dsl.BehaviorSourceMap: [failureAggregate] :: BehaviorSourceFailure -> !Text

+ Keiro.Dsl.BehaviorSourceMap: [failureCode] :: BehaviorSourceFailure -> !BehaviorSourceFailureCode

+ Keiro.Dsl.BehaviorSourceMap: [failureCommand] :: BehaviorSourceFailure -> !Text

+ Keiro.Dsl.BehaviorSourceMap: [failureKey] :: BehaviorSourceFailure -> !BehaviorKey

+ Keiro.Dsl.BehaviorSourceMap: [failureMessage] :: BehaviorSourceFailure -> !Text

+ Keiro.Dsl.BehaviorSourceMap: [failureOrigin] :: BehaviorSourceFailure -> !RequirementOrigin

+ Keiro.Dsl.BehaviorSourceMap: [failureSourceSubject] :: BehaviorSourceFailure -> !SourceSubject

+ Keiro.Dsl.BehaviorSourceMap: [failureSpan] :: BehaviorSourceFailure -> !Maybe SourceSpan

+ Keiro.Dsl.BehaviorSourceMap: [failureState] :: BehaviorSourceFailure -> !Text

+ Keiro.Dsl.BehaviorSourceMap: attachBehaviorSourceLocations :: [BehaviorSourceEntry] -> [BehaviorRequirement] -> [BehaviorRequirement]

+ Keiro.Dsl.BehaviorSourceMap: data BehaviorSourceEntry

+ Keiro.Dsl.BehaviorSourceMap: data BehaviorSourceFailure

+ Keiro.Dsl.BehaviorSourceMap: data BehaviorSourceFailureCode

+ Keiro.Dsl.BehaviorSourceMap: instance GHC.Classes.Eq Keiro.Dsl.BehaviorSourceMap.BehaviorSourceEntry

+ Keiro.Dsl.BehaviorSourceMap: instance GHC.Classes.Eq Keiro.Dsl.BehaviorSourceMap.BehaviorSourceFailure

+ Keiro.Dsl.BehaviorSourceMap: instance GHC.Classes.Eq Keiro.Dsl.BehaviorSourceMap.BehaviorSourceFailureCode

+ Keiro.Dsl.BehaviorSourceMap: instance GHC.Classes.Ord Keiro.Dsl.BehaviorSourceMap.BehaviorSourceEntry

+ Keiro.Dsl.BehaviorSourceMap: instance GHC.Classes.Ord Keiro.Dsl.BehaviorSourceMap.BehaviorSourceFailureCode

+ Keiro.Dsl.BehaviorSourceMap: instance GHC.Internal.Show.Show Keiro.Dsl.BehaviorSourceMap.BehaviorSourceEntry

+ Keiro.Dsl.BehaviorSourceMap: instance GHC.Internal.Show.Show Keiro.Dsl.BehaviorSourceMap.BehaviorSourceFailure

+ Keiro.Dsl.BehaviorSourceMap: instance GHC.Internal.Show.Show Keiro.Dsl.BehaviorSourceMap.BehaviorSourceFailureCode

+ Keiro.Dsl.BehaviorSourceMap: planBehaviorSourceMap :: [BehaviorRequirement] -> SemanticSourceIndex -> Either [BehaviorSourceFailure] [BehaviorSourceEntry]

+ Keiro.Dsl.CanonicalEncoding: canonicalDomainOutcomeTypes :: Maybe DomainOutcomeTypes -> Text

+ Keiro.Dsl.CanonicalEncoding: canonicalTransitionOutcome :: Maybe TransitionOutcome -> Text

+ Keiro.Dsl.ConsumerTypePlan: ConsumerTypePlan :: !HaskellTypeOccurrence -> ![ImportRequirement] -> !Set MappedKey -> ConsumerTypePlan

+ Keiro.Dsl.ConsumerTypePlan: ConsumerTypePlanImportError :: !HaskellImportError -> ConsumerTypePlanError

+ Keiro.Dsl.ConsumerTypePlan: ConsumerTypePlanUnknownDeclaration :: !MappedKey -> ConsumerTypePlanError

+ Keiro.Dsl.ConsumerTypePlan: HaskellTypeOccurrence :: Text -> HaskellTypeOccurrence

+ Keiro.Dsl.ConsumerTypePlan: ImportRequirement :: !Text -> !Text -> !Text -> ImportRequirement

+ Keiro.Dsl.ConsumerTypePlan: [dependencies] :: ConsumerTypePlan -> !Set MappedKey

+ Keiro.Dsl.ConsumerTypePlan: [haskellType] :: ConsumerTypePlan -> !HaskellTypeOccurrence

+ Keiro.Dsl.ConsumerTypePlan: [imports] :: ConsumerTypePlan -> ![ImportRequirement]

+ Keiro.Dsl.ConsumerTypePlan: [moduleName] :: ImportRequirement -> !Text

+ Keiro.Dsl.ConsumerTypePlan: [occurrence] :: ImportRequirement -> !Text

+ Keiro.Dsl.ConsumerTypePlan: [package] :: ImportRequirement -> !Text

+ Keiro.Dsl.ConsumerTypePlan: [unHaskellTypeOccurrence] :: HaskellTypeOccurrence -> Text

+ Keiro.Dsl.ConsumerTypePlan: consumerTypeReferences :: ConsumerTypePlan -> Set HaskellReference

+ Keiro.Dsl.ConsumerTypePlan: data ConsumerTypePlan

+ Keiro.Dsl.ConsumerTypePlan: data ConsumerTypePlanError

+ Keiro.Dsl.ConsumerTypePlan: data ImportRequirement

+ Keiro.Dsl.ConsumerTypePlan: instance GHC.Classes.Eq Keiro.Dsl.ConsumerTypePlan.ConsumerTypePlan

+ Keiro.Dsl.ConsumerTypePlan: instance GHC.Classes.Eq Keiro.Dsl.ConsumerTypePlan.ConsumerTypePlanError

+ Keiro.Dsl.ConsumerTypePlan: instance GHC.Classes.Eq Keiro.Dsl.ConsumerTypePlan.HaskellTypeOccurrence

+ Keiro.Dsl.ConsumerTypePlan: instance GHC.Classes.Eq Keiro.Dsl.ConsumerTypePlan.ImportRequirement

+ Keiro.Dsl.ConsumerTypePlan: instance GHC.Classes.Ord Keiro.Dsl.ConsumerTypePlan.HaskellTypeOccurrence

+ Keiro.Dsl.ConsumerTypePlan: instance GHC.Classes.Ord Keiro.Dsl.ConsumerTypePlan.ImportRequirement

+ Keiro.Dsl.ConsumerTypePlan: instance GHC.Internal.Show.Show Keiro.Dsl.ConsumerTypePlan.ConsumerTypePlan

+ Keiro.Dsl.ConsumerTypePlan: instance GHC.Internal.Show.Show Keiro.Dsl.ConsumerTypePlan.ConsumerTypePlanError

+ Keiro.Dsl.ConsumerTypePlan: instance GHC.Internal.Show.Show Keiro.Dsl.ConsumerTypePlan.HaskellTypeOccurrence

+ Keiro.Dsl.ConsumerTypePlan: instance GHC.Internal.Show.Show Keiro.Dsl.ConsumerTypePlan.ImportRequirement

+ Keiro.Dsl.ConsumerTypePlan: newtype HaskellTypeOccurrence

+ Keiro.Dsl.ConsumerTypePlan: planConsumerType :: TypeGraph -> ResolvedTypeExpr -> Either ConsumerTypePlanError ConsumerTypePlan

+ Keiro.Dsl.ConsumerTypePlan: renderConsumerType :: HaskellImportPlan -> TypeGraph -> ResolvedTypeExpr -> Either ConsumerTypePlanError HaskellTypeOccurrence

+ Keiro.Dsl.CoordinationImpact: CoordinationAdvisory :: CoordinationSeverity

+ Keiro.Dsl.CoordinationImpact: CoordinationBreaking :: CoordinationSeverity

+ Keiro.Dsl.CoordinationImpact: CoordinationImpact :: !Name -> !CoordinationSeverity -> !CoordinationReason -> !SelectionVerification -> !SelectionVerification -> !Maybe Text -> !Maybe Text -> !Maybe Natural -> !Maybe Natural -> !Maybe Text -> !Maybe Text -> ![UseSite] -> CoordinationImpact

+ Keiro.Dsl.CoordinationImpact: CustomUnverified :: SelectionVerification

+ Keiro.Dsl.CoordinationImpact: DeclarativeVerified :: SelectionVerification

+ Keiro.Dsl.CoordinationImpact: RouterSelectionDrift :: !Name -> !Maybe RouterSelectionSnapshot -> !Maybe RouterSelectionSnapshot -> RouterSelectionDrift

+ Keiro.Dsl.CoordinationImpact: RouterSelectionSnapshot :: !Name -> !SelectionVerification -> !Maybe Text -> !Maybe Natural -> !Maybe Text -> RouterSelectionSnapshot

+ Keiro.Dsl.CoordinationImpact: SelectionFingerprintChangedWithVersionBump :: CoordinationReason

+ Keiro.Dsl.CoordinationImpact: SelectionFingerprintChangedWithoutVersionBump :: CoordinationReason

+ Keiro.Dsl.CoordinationImpact: SelectionIdentityChanged :: CoordinationReason

+ Keiro.Dsl.CoordinationImpact: SelectionMappedDependencyChanged :: CoordinationReason

+ Keiro.Dsl.CoordinationImpact: SelectionVerificationBoundaryChanged :: CoordinationReason

+ Keiro.Dsl.CoordinationImpact: SelectionVersionDecreased :: CoordinationReason

+ Keiro.Dsl.CoordinationImpact: SelectionVersionMetadataOnly :: CoordinationReason

+ Keiro.Dsl.CoordinationImpact: [affectedUseSites] :: CoordinationImpact -> ![UseSite]

+ Keiro.Dsl.CoordinationImpact: [coordinationReason] :: CoordinationImpact -> !CoordinationReason

+ Keiro.Dsl.CoordinationImpact: [coordinationRouter] :: CoordinationImpact -> !Name

+ Keiro.Dsl.CoordinationImpact: [coordinationSeverity] :: CoordinationImpact -> !CoordinationSeverity

+ Keiro.Dsl.CoordinationImpact: [currentFingerprint] :: CoordinationImpact -> !Maybe Text

+ Keiro.Dsl.CoordinationImpact: [currentIdentity] :: CoordinationImpact -> !Maybe Text

+ Keiro.Dsl.CoordinationImpact: [currentVerification] :: CoordinationImpact -> !SelectionVerification

+ Keiro.Dsl.CoordinationImpact: [currentVersion] :: CoordinationImpact -> !Maybe Natural

+ Keiro.Dsl.CoordinationImpact: [driftCurrentSelection] :: RouterSelectionDrift -> !Maybe RouterSelectionSnapshot

+ Keiro.Dsl.CoordinationImpact: [driftPreviousSelection] :: RouterSelectionDrift -> !Maybe RouterSelectionSnapshot

+ Keiro.Dsl.CoordinationImpact: [driftRouter] :: RouterSelectionDrift -> !Name

+ Keiro.Dsl.CoordinationImpact: [previousFingerprint] :: CoordinationImpact -> !Maybe Text

+ Keiro.Dsl.CoordinationImpact: [previousIdentity] :: CoordinationImpact -> !Maybe Text

+ Keiro.Dsl.CoordinationImpact: [previousVerification] :: CoordinationImpact -> !SelectionVerification

+ Keiro.Dsl.CoordinationImpact: [previousVersion] :: CoordinationImpact -> !Maybe Natural

+ Keiro.Dsl.CoordinationImpact: [selectionFingerprint] :: RouterSelectionSnapshot -> !Maybe Text

+ Keiro.Dsl.CoordinationImpact: [selectionIdentity] :: RouterSelectionSnapshot -> !Maybe Text

+ Keiro.Dsl.CoordinationImpact: [selectionRouter] :: RouterSelectionSnapshot -> !Name

+ Keiro.Dsl.CoordinationImpact: [selectionVerification] :: RouterSelectionSnapshot -> !SelectionVerification

+ Keiro.Dsl.CoordinationImpact: [selectionVersion] :: RouterSelectionSnapshot -> !Maybe Natural

+ Keiro.Dsl.CoordinationImpact: coordinationImpact :: CheckedService -> CheckedService -> [MappedImpactDelta] -> [CoordinationImpact]

+ Keiro.Dsl.CoordinationImpact: data CoordinationImpact

+ Keiro.Dsl.CoordinationImpact: data CoordinationReason

+ Keiro.Dsl.CoordinationImpact: data CoordinationSeverity

+ Keiro.Dsl.CoordinationImpact: data RouterSelectionDrift

+ Keiro.Dsl.CoordinationImpact: data RouterSelectionSnapshot

+ Keiro.Dsl.CoordinationImpact: data SelectionVerification

+ Keiro.Dsl.CoordinationImpact: instance Data.Aeson.Types.FromJSON.FromJSON Keiro.Dsl.CoordinationImpact.RouterSelectionSnapshot

+ Keiro.Dsl.CoordinationImpact: instance Data.Aeson.Types.FromJSON.FromJSON Keiro.Dsl.CoordinationImpact.SelectionVerification

+ Keiro.Dsl.CoordinationImpact: instance Data.Aeson.Types.ToJSON.ToJSON Keiro.Dsl.CoordinationImpact.CoordinationImpact

+ Keiro.Dsl.CoordinationImpact: instance Data.Aeson.Types.ToJSON.ToJSON Keiro.Dsl.CoordinationImpact.RouterSelectionSnapshot

+ Keiro.Dsl.CoordinationImpact: instance Data.Aeson.Types.ToJSON.ToJSON Keiro.Dsl.CoordinationImpact.SelectionVerification

+ Keiro.Dsl.CoordinationImpact: instance GHC.Classes.Eq Keiro.Dsl.CoordinationImpact.CoordinationImpact

+ Keiro.Dsl.CoordinationImpact: instance GHC.Classes.Eq Keiro.Dsl.CoordinationImpact.CoordinationReason

+ Keiro.Dsl.CoordinationImpact: instance GHC.Classes.Eq Keiro.Dsl.CoordinationImpact.CoordinationSeverity

+ Keiro.Dsl.CoordinationImpact: instance GHC.Classes.Eq Keiro.Dsl.CoordinationImpact.RouterSelectionDrift

+ Keiro.Dsl.CoordinationImpact: instance GHC.Classes.Eq Keiro.Dsl.CoordinationImpact.RouterSelectionSnapshot

+ Keiro.Dsl.CoordinationImpact: instance GHC.Classes.Eq Keiro.Dsl.CoordinationImpact.SelectionVerification

+ Keiro.Dsl.CoordinationImpact: instance GHC.Classes.Ord Keiro.Dsl.CoordinationImpact.CoordinationReason

+ Keiro.Dsl.CoordinationImpact: instance GHC.Classes.Ord Keiro.Dsl.CoordinationImpact.CoordinationSeverity

+ Keiro.Dsl.CoordinationImpact: instance GHC.Classes.Ord Keiro.Dsl.CoordinationImpact.RouterSelectionSnapshot

+ Keiro.Dsl.CoordinationImpact: instance GHC.Classes.Ord Keiro.Dsl.CoordinationImpact.SelectionVerification

+ Keiro.Dsl.CoordinationImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.CoordinationImpact.CoordinationImpact

+ Keiro.Dsl.CoordinationImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.CoordinationImpact.CoordinationReason

+ Keiro.Dsl.CoordinationImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.CoordinationImpact.CoordinationSeverity

+ Keiro.Dsl.CoordinationImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.CoordinationImpact.RouterSelectionDrift

+ Keiro.Dsl.CoordinationImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.CoordinationImpact.RouterSelectionSnapshot

+ Keiro.Dsl.CoordinationImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.CoordinationImpact.SelectionVerification

+ Keiro.Dsl.CoordinationImpact: instance GHC.Internal.Show.Show Keiro.Dsl.CoordinationImpact.CoordinationImpact

+ Keiro.Dsl.CoordinationImpact: instance GHC.Internal.Show.Show Keiro.Dsl.CoordinationImpact.CoordinationReason

+ Keiro.Dsl.CoordinationImpact: instance GHC.Internal.Show.Show Keiro.Dsl.CoordinationImpact.CoordinationSeverity

+ Keiro.Dsl.CoordinationImpact: instance GHC.Internal.Show.Show Keiro.Dsl.CoordinationImpact.RouterSelectionDrift

+ Keiro.Dsl.CoordinationImpact: instance GHC.Internal.Show.Show Keiro.Dsl.CoordinationImpact.RouterSelectionSnapshot

+ Keiro.Dsl.CoordinationImpact: instance GHC.Internal.Show.Show Keiro.Dsl.CoordinationImpact.SelectionVerification

+ Keiro.Dsl.CoordinationImpact: renderCoordinationImpact :: [CoordinationImpact] -> [Text]

+ Keiro.Dsl.CoordinationImpact: renderRouterSelectionDrift :: [RouterSelectionDrift] -> [Text]

+ Keiro.Dsl.CoordinationImpact: routerSelectionDrift :: [RouterSelectionSnapshot] -> [RouterSelectionSnapshot] -> [RouterSelectionDrift]

+ Keiro.Dsl.CoordinationImpact: routerSelectionSnapshots :: CheckedService -> [RouterSelectionSnapshot]

+ Keiro.Dsl.Coverage: AggregateCommandPayload :: CoverageSurface

+ Keiro.Dsl.Coverage: ProjectionTypedConsumer :: CoverageSurface

+ Keiro.Dsl.Coverage: ReadModelQueryInput :: CoverageSurface

+ Keiro.Dsl.Coverage: ReadModelQueryResult :: CoverageSurface

+ Keiro.Dsl.Coverage: WorkqueuePayload :: CoverageSurface

+ Keiro.Dsl.Coverage: [aggregateCommandPayloads] :: CoverageSummary -> !CoverageCounts

+ Keiro.Dsl.Coverage: [aggregateCommandRootDelta] :: CoverageDelta -> !Int

+ Keiro.Dsl.Coverage: [jsonSurface] :: JsonBoundary -> !CoverageSurface

+ Keiro.Dsl.Coverage: [projectionTypedConsumerRootDelta] :: CoverageDelta -> !Int

+ Keiro.Dsl.Coverage: [projectionTypedConsumers] :: CoverageSummary -> !CoverageCounts

+ Keiro.Dsl.Coverage: [readModelQueryInputRootDelta] :: CoverageDelta -> !Int

+ Keiro.Dsl.Coverage: [readModelQueryInputs] :: CoverageSummary -> !CoverageCounts

+ Keiro.Dsl.Coverage: [readModelQueryResultRootDelta] :: CoverageDelta -> !Int

+ Keiro.Dsl.Coverage: [readModelQueryResults] :: CoverageSummary -> !CoverageCounts

+ Keiro.Dsl.Coverage: [rootConsumer] :: CoverageRoot -> !Text

+ Keiro.Dsl.Coverage: [workqueuePayloadRootDelta] :: CoverageDelta -> !Int

+ Keiro.Dsl.Coverage: [workqueuePayloads] :: CoverageSummary -> !CoverageCounts

+ Keiro.Dsl.Coverage: coverageReportForService :: FilePath -> CheckedService -> Either (NonEmpty TypeGraphError) CoverageReport

+ Keiro.Dsl.Diff: FamExternalRead :: NodeFamily

+ Keiro.Dsl.Diff: FamProjectionOwner :: NodeFamily

+ Keiro.Dsl.Diff: FamProjectionRevision :: NodeFamily

+ Keiro.Dsl.Diff: FamProjectionTarget :: NodeFamily

+ Keiro.Dsl.Diff: FamRebuildGroup :: NodeFamily

+ Keiro.Dsl.Diff: MappedPersistedImpact :: !MappedPersistedSurface -> !SurfaceVerdict -> MappedPersistedImpact

+ Keiro.Dsl.Diff: PrivateEventHistory :: MappedPersistedSurface

+ Keiro.Dsl.Diff: SnapshotCache :: MappedPersistedSurface

+ Keiro.Dsl.Diff: WorkqueueHistory :: !Name -> MappedPersistedSurface

+ Keiro.Dsl.Diff: [ckMappedConsequences] :: ChangeKind -> !Set MappedConsequence

+ Keiro.Dsl.Diff: [ckMappedPersistedImpact] :: ChangeKind -> !Maybe MappedPersistedImpact

+ Keiro.Dsl.Diff: [mappedPersistedSurface] :: MappedPersistedImpact -> !MappedPersistedSurface

+ Keiro.Dsl.Diff: [mappedPersistedVerdict] :: MappedPersistedImpact -> !SurfaceVerdict

+ Keiro.Dsl.Diff: data MappedPersistedImpact

+ Keiro.Dsl.Diff: data MappedPersistedSurface

+ Keiro.Dsl.Diff: instance GHC.Classes.Eq Keiro.Dsl.Diff.MappedPersistedImpact

+ Keiro.Dsl.Diff: instance GHC.Classes.Eq Keiro.Dsl.Diff.MappedPersistedSurface

+ Keiro.Dsl.Diff: instance GHC.Classes.Ord Keiro.Dsl.Diff.MappedPersistedSurface

+ Keiro.Dsl.Diff: instance GHC.Internal.Show.Show Keiro.Dsl.Diff.MappedPersistedImpact

+ Keiro.Dsl.Diff: instance GHC.Internal.Show.Show Keiro.Dsl.Diff.MappedPersistedSurface

+ Keiro.Dsl.Diff: mappedSemanticImpact :: Spec -> Spec -> [MappedImpactDelta]

+ Keiro.Dsl.Diff: mappedSemanticImpactForServices :: CheckedService -> CheckedService -> [MappedImpactDelta]

+ Keiro.Dsl.DiffReport: RemedyDrainWorkqueue :: Remedy

+ Keiro.Dsl.DiffReport: RemedyTransitionalQueueCodec :: Remedy

+ Keiro.Dsl.DiffReport: diffReportWithCoordinationImpact :: Set CompatibilitySurface -> [Change] -> [CoordinationImpact] -> DiffReport

+ Keiro.Dsl.DiffReport: diffReportWithImpacts :: Set CompatibilitySurface -> [Change] -> [MappedImpactDelta] -> [CoordinationImpact] -> DiffReport

+ Keiro.Dsl.DiffReport: diffReportWithSemanticImpact :: Set CompatibilitySurface -> [Change] -> [MappedImpactDelta] -> DiffReport

+ Keiro.Dsl.DiffReport: renderCoordinationImpact :: [CoordinationImpact] -> [Text]

+ Keiro.Dsl.DiffReport: renderSemanticImpact :: [MappedImpactDelta] -> [Text]

+ Keiro.Dsl.DiffReport: workspaceDiffReportWithCoordinationImpact :: WorkspaceMeta -> Set CompatibilitySurface -> [WorkspaceChange] -> [CoordinationImpact] -> WorkspaceDiffReport

+ Keiro.Dsl.DiffReport: workspaceDiffReportWithImpacts :: WorkspaceMeta -> Set CompatibilitySurface -> [WorkspaceChange] -> [MappedImpactDelta] -> [CoordinationImpact] -> WorkspaceDiffReport

+ Keiro.Dsl.DiffReport: workspaceDiffReportWithSemanticImpact :: WorkspaceMeta -> Set CompatibilitySurface -> [WorkspaceChange] -> [MappedImpactDelta] -> WorkspaceDiffReport

+ Keiro.Dsl.EventOutput: eventOutputMappingFromGraph :: TypeGraph -> Spec -> Aggregate -> Transition -> Int -> Name -> Either EventOutputError EventOutputMapping

+ Keiro.Dsl.EventOutput: eventOutputMappingFromGraphResult :: Either (NonEmpty TypeGraphError) TypeGraph -> Spec -> Aggregate -> Transition -> Int -> Name -> Either EventOutputError EventOutputMapping

+ Keiro.Dsl.Expression: expressionEnvironmentFromGraph :: TypeGraph -> Spec -> Aggregate -> Transition -> ExpressionEnvironment

+ Keiro.Dsl.Expression: expressionEnvironmentFromGraphResult :: Either (NonEmpty TypeGraphError) TypeGraph -> Spec -> Aggregate -> Transition -> ExpressionEnvironment

+ Keiro.Dsl.Expression: expressionEnvironmentWith :: AggregateSymbols -> Maybe TypeGraph -> Spec -> Aggregate -> Transition -> ExpressionEnvironment

+ Keiro.Dsl.Frontend: SemanticSourceIndexInvalid :: !SourceIndexFailureCode -> LoweringFailureCode

+ Keiro.Dsl.Frontend: lowerSurfaceDocument :: SurfaceSource -> Either LoweringFailure ParsedSourceDocument

+ Keiro.Dsl.Grammar: CatalogAggregate :: !Name -> CatalogSource

+ Keiro.Dsl.Grammar: CatalogAll :: CatalogSource

+ Keiro.Dsl.Grammar: CatalogCategory :: !Text -> CatalogSource

+ Keiro.Dsl.Grammar: CheckpointFail :: CheckpointOnMissingNode

+ Keiro.Dsl.Grammar: CheckpointFromBeginning :: CheckpointOnMissingNode

+ Keiro.Dsl.Grammar: CheckpointFromCurrentHead :: CheckpointOnMissingNode

+ Keiro.Dsl.Grammar: DeliveryInline :: ProjectionDelivery

+ Keiro.Dsl.Grammar: DeliverySubscription :: ProjectionDelivery

+ Keiro.Dsl.Grammar: DomainOutcomeTypes :: !Name -> !Name -> !Loc -> DomainOutcomeTypes

+ Keiro.Dsl.Grammar: ExternalReadNode :: !Name -> !Int -> !Name -> !Text -> !Text -> ![Name] -> !Int -> !Loc -> ExternalReadNode

+ Keiro.Dsl.Grammar: FreshnessImmediate :: QueryFreshnessNode

+ Keiro.Dsl.Grammar: FreshnessWaitForHead :: !RmScope -> QueryFreshnessNode

+ Keiro.Dsl.Grammar: LegacyQueueScalar :: !QueueScalar -> QueuePayloadType

+ Keiro.Dsl.Grammar: LegacyReadModelSupply :: !Consistency -> !Maybe RmScope -> !RmFeed -> !Maybe Text -> ReadModelSupply

+ Keiro.Dsl.Grammar: NExternalRead :: ExternalReadNode -> Node

+ Keiro.Dsl.Grammar: NProjectionOwner :: ProjectionOwnerNode -> Node

+ Keiro.Dsl.Grammar: NProjectionRevision :: ProjectionRevisionNode -> Node

+ Keiro.Dsl.Grammar: NProjectionTarget :: ProjectionTargetNode -> Node

+ Keiro.Dsl.Grammar: NRebuildGroup :: RebuildGroupNode -> Node

+ Keiro.Dsl.Grammar: OutcomeAccepted :: !Loc -> TransitionOutcome

+ Keiro.Dsl.Grammar: OutcomeNoOp :: !Expr -> !Loc -> TransitionOutcome

+ Keiro.Dsl.Grammar: OutcomeRejected :: !Expr -> !Loc -> TransitionOutcome

+ Keiro.Dsl.Grammar: OwnerDerivedSupply :: ReadModelSupply

+ Keiro.Dsl.Grammar: ProjectionLiveOnly :: !Text -> ProjectionReplayPolicy

+ Keiro.Dsl.Grammar: ProjectionOwnerNode :: !Name -> ![CatalogSource] -> !ProjectionDelivery -> !Name -> ![Name] -> !Int -> !Maybe Text -> !Maybe Text -> ![CheckpointOnMissingNode] -> !ProjectionReplayPolicy -> !Loc -> ProjectionOwnerNode

+ Keiro.Dsl.Grammar: ProjectionReplayExplicit :: ProjectionReplayPolicy

+ Keiro.Dsl.Grammar: ProjectionRevisionNode :: !Name -> !Name -> ![RevisionTargetNode] -> !Loc -> ProjectionRevisionNode

+ Keiro.Dsl.Grammar: ProjectionTargetNode :: !Name -> !Text -> !Text -> !TargetResetPolicy -> ![Name] -> !Loc -> ProjectionTargetNode

+ Keiro.Dsl.Grammar: PromotionConstraintNode :: PromotionObjectKindNode

+ Keiro.Dsl.Grammar: PromotionIndexNode :: PromotionObjectKindNode

+ Keiro.Dsl.Grammar: PromotionObjectNode :: !PromotionObjectKindNode -> !Text -> !Text -> PromotionObjectNode

+ Keiro.Dsl.Grammar: PromotionOwnedSequenceNode :: PromotionObjectKindNode

+ Keiro.Dsl.Grammar: QueueBool :: QueueScalar

+ Keiro.Dsl.Grammar: QueueInt :: QueueScalar

+ Keiro.Dsl.Grammar: QueueOther :: !Name -> QueueScalar

+ Keiro.Dsl.Grammar: QueueText :: QueueScalar

+ Keiro.Dsl.Grammar: ReadModelQueryTypes :: !TypeExpr -> !TypeExpr -> !Loc -> !Loc -> ReadModelQueryTypes

+ Keiro.Dsl.Grammar: RebuildGroupNode :: !Name -> ![Name] -> ![Name] -> !Loc -> RebuildGroupNode

+ Keiro.Dsl.Grammar: ResolveDeclarative :: !RouterSelectionDecl -> ResolveSource

+ Keiro.Dsl.Grammar: RevisionTargetNode :: !Name -> !Text -> !Text -> !Int -> !Text -> !Text -> !Int -> ![PromotionObjectNode] -> RevisionTargetNode

+ Keiro.Dsl.Grammar: RouterSelectionDecl :: !Text -> !Loc -> !Natural -> !Loc -> !Name -> !Loc -> !Name -> !Loc -> !Expr -> !Expr -> !Maybe (Natural, Loc) -> !Name -> !Loc -> !Name -> !Loc -> !SelectionDispositionSyntax -> !Loc -> !SelectionDispositionSyntax -> !Loc -> !Name -> !Loc -> !Name -> !Loc -> !Loc -> RouterSelectionDecl

+ Keiro.Dsl.Grammar: SelectionAck :: SelectionDispositionSyntax

+ Keiro.Dsl.Grammar: SelectionDeadLetter :: SelectionDispositionSyntax

+ Keiro.Dsl.Grammar: SelectionHalt :: SelectionDispositionSyntax

+ Keiro.Dsl.Grammar: SelectionRetry :: SelectionDispositionSyntax

+ Keiro.Dsl.Grammar: TargetClear :: TargetResetPolicy

+ Keiro.Dsl.Grammar: TargetPreserve :: TargetResetPolicy

+ Keiro.Dsl.Grammar: TypedQueueExpression :: !TypeExpr -> QueuePayloadType

+ Keiro.Dsl.Grammar: [aggDomainOutcomeDuplicateLocs] :: Aggregate -> ![Loc]

+ Keiro.Dsl.Grammar: [aggDomainOutcomeTypes] :: Aggregate -> !Maybe DomainOutcomeTypes

+ Keiro.Dsl.Grammar: [erCompatibleRevisions] :: ExternalReadNode -> ![Name]

+ Keiro.Dsl.Grammar: [erLoc] :: ExternalReadNode -> !Loc

+ Keiro.Dsl.Grammar: [erName] :: ExternalReadNode -> !Name

+ Keiro.Dsl.Grammar: [erQueryModel] :: ExternalReadNode -> !Name

+ Keiro.Dsl.Grammar: [erResultSchema] :: ExternalReadNode -> !Text

+ Keiro.Dsl.Grammar: [erResultType] :: ExternalReadNode -> !Text

+ Keiro.Dsl.Grammar: [erSurfaceGeneration] :: ExternalReadNode -> !Int

+ Keiro.Dsl.Grammar: [erVersion] :: ExternalReadNode -> !Int

+ Keiro.Dsl.Grammar: [inLoc] :: InputDecl -> !Loc

+ Keiro.Dsl.Grammar: [inType] :: InputDecl -> !Maybe TypeExpr

+ Keiro.Dsl.Grammar: [inputLoc] :: ReadModelQueryTypes -> !Loc

+ Keiro.Dsl.Grammar: [input] :: ReadModelQueryTypes -> !TypeExpr

+ Keiro.Dsl.Grammar: [legacyConsistency] :: ReadModelSupply -> !Consistency

+ Keiro.Dsl.Grammar: [legacyFeed] :: ReadModelSupply -> !RmFeed

+ Keiro.Dsl.Grammar: [legacyScope] :: ReadModelSupply -> !Maybe RmScope

+ Keiro.Dsl.Grammar: [legacySubscription] :: ReadModelSupply -> !Maybe Text

+ Keiro.Dsl.Grammar: [noOpType] :: DomainOutcomeTypes -> !Name

+ Keiro.Dsl.Grammar: [outcomeTypesLoc] :: DomainOutcomeTypes -> !Loc

+ Keiro.Dsl.Grammar: [poCheckpointOnMissing] :: ProjectionOwnerNode -> ![CheckpointOnMissingNode]

+ Keiro.Dsl.Grammar: [poDedup] :: ProjectionOwnerNode -> !Maybe Text

+ Keiro.Dsl.Grammar: [poDelivery] :: ProjectionOwnerNode -> !ProjectionDelivery

+ Keiro.Dsl.Grammar: [poGroup] :: ProjectionOwnerNode -> !Name

+ Keiro.Dsl.Grammar: [poLoc] :: ProjectionOwnerNode -> !Loc

+ Keiro.Dsl.Grammar: [poName] :: ProjectionOwnerNode -> !Name

+ Keiro.Dsl.Grammar: [poOrder] :: ProjectionOwnerNode -> !Int

+ Keiro.Dsl.Grammar: [poReplay] :: ProjectionOwnerNode -> !ProjectionReplayPolicy

+ Keiro.Dsl.Grammar: [poSources] :: ProjectionOwnerNode -> ![CatalogSource]

+ Keiro.Dsl.Grammar: [poSubscription] :: ProjectionOwnerNode -> !Maybe Text

+ Keiro.Dsl.Grammar: [poTargets] :: ProjectionOwnerNode -> ![Name]

+ Keiro.Dsl.Grammar: [prtExpectedShape] :: RevisionTargetNode -> !Text

+ Keiro.Dsl.Grammar: [prtPromotionObjects] :: RevisionTargetNode -> ![PromotionObjectNode]

+ Keiro.Dsl.Grammar: [prtProvisionerVersion] :: RevisionTargetNode -> !Int

+ Keiro.Dsl.Grammar: [prtProvisioner] :: RevisionTargetNode -> !Text

+ Keiro.Dsl.Grammar: [prtSchemaVersion] :: RevisionTargetNode -> !Text

+ Keiro.Dsl.Grammar: [prtTarget] :: RevisionTargetNode -> !Name

+ Keiro.Dsl.Grammar: [prtValidatorVersion] :: RevisionTargetNode -> !Int

+ Keiro.Dsl.Grammar: [prtValidator] :: RevisionTargetNode -> !Text

+ Keiro.Dsl.Grammar: [prvGroup] :: ProjectionRevisionNode -> !Name

+ Keiro.Dsl.Grammar: [prvLoc] :: ProjectionRevisionNode -> !Loc

+ Keiro.Dsl.Grammar: [prvName] :: ProjectionRevisionNode -> !Name

+ Keiro.Dsl.Grammar: [prvTargets] :: ProjectionRevisionNode -> ![RevisionTargetNode]

+ Keiro.Dsl.Grammar: [ptDependsOn] :: ProjectionTargetNode -> ![Name]

+ Keiro.Dsl.Grammar: [ptLoc] :: ProjectionTargetNode -> !Loc

+ Keiro.Dsl.Grammar: [ptName] :: ProjectionTargetNode -> !Name

+ Keiro.Dsl.Grammar: [ptReset] :: ProjectionTargetNode -> !TargetResetPolicy

+ Keiro.Dsl.Grammar: [ptSchema] :: ProjectionTargetNode -> !Text

+ Keiro.Dsl.Grammar: [ptTable] :: ProjectionTargetNode -> !Text

+ Keiro.Dsl.Grammar: [queryTypes] :: ReadModelNode -> !Maybe ReadModelQueryTypes

+ Keiro.Dsl.Grammar: [rejectionType] :: DomainOutcomeTypes -> !Name

+ Keiro.Dsl.Grammar: [resultLoc] :: ReadModelQueryTypes -> !Loc

+ Keiro.Dsl.Grammar: [result] :: ReadModelQueryTypes -> !TypeExpr

+ Keiro.Dsl.Grammar: [rgLoc] :: RebuildGroupNode -> !Loc

+ Keiro.Dsl.Grammar: [rgName] :: RebuildGroupNode -> !Name

+ Keiro.Dsl.Grammar: [rgOrder] :: RebuildGroupNode -> ![Name]

+ Keiro.Dsl.Grammar: [rgTargets] :: RebuildGroupNode -> ![Name]

+ Keiro.Dsl.Grammar: [rmBackingTarget] :: ReadModelNode -> !Maybe Name

+ Keiro.Dsl.Grammar: [rmFreshness] :: ReadModelNode -> !QueryFreshnessNode

+ Keiro.Dsl.Grammar: [rmGroup] :: ReadModelNode -> !Maybe Name

+ Keiro.Dsl.Grammar: [rmObservedTargets] :: ReadModelNode -> ![Name]

+ Keiro.Dsl.Grammar: [rmSupply] :: ReadModelNode -> !ReadModelSupply

+ Keiro.Dsl.Grammar: [rpoCanonicalName] :: PromotionObjectNode -> !Text

+ Keiro.Dsl.Grammar: [rpoGenerationName] :: PromotionObjectNode -> !Text

+ Keiro.Dsl.Grammar: [rpoKind] :: PromotionObjectNode -> !PromotionObjectKindNode

+ Keiro.Dsl.Grammar: [rsDedupeLoc] :: RouterSelectionDecl -> !Loc

+ Keiro.Dsl.Grammar: [rsDedupe] :: RouterSelectionDecl -> !Name

+ Keiro.Dsl.Grammar: [rsEmptyPolicyLoc] :: RouterSelectionDecl -> !Loc

+ Keiro.Dsl.Grammar: [rsEmptyPolicy] :: RouterSelectionDecl -> !SelectionDispositionSyntax

+ Keiro.Dsl.Grammar: [rsFailurePolicyLoc] :: RouterSelectionDecl -> !Loc

+ Keiro.Dsl.Grammar: [rsFailurePolicy] :: RouterSelectionDecl -> !SelectionDispositionSyntax

+ Keiro.Dsl.Grammar: [rsIdentityLoc] :: RouterSelectionDecl -> !Loc

+ Keiro.Dsl.Grammar: [rsIdentity] :: RouterSelectionDecl -> !Text

+ Keiro.Dsl.Grammar: [rsLimit] :: RouterSelectionDecl -> !Maybe (Natural, Loc)

+ Keiro.Dsl.Grammar: [rsLoc] :: RouterSelectionDecl -> !Loc

+ Keiro.Dsl.Grammar: [rsOrderLoc] :: RouterSelectionDecl -> !Loc

+ Keiro.Dsl.Grammar: [rsOrder] :: RouterSelectionDecl -> !Name

+ Keiro.Dsl.Grammar: [rsPartialLoc] :: RouterSelectionDecl -> !Loc

+ Keiro.Dsl.Grammar: [rsPartial] :: RouterSelectionDecl -> !Name

+ Keiro.Dsl.Grammar: [rsPredicate] :: RouterSelectionDecl -> !Expr

+ Keiro.Dsl.Grammar: [rsQueryInputLoc] :: RouterSelectionDecl -> !Loc

+ Keiro.Dsl.Grammar: [rsQueryInput] :: RouterSelectionDecl -> !Name

+ Keiro.Dsl.Grammar: [rsQueryLoc] :: RouterSelectionDecl -> !Loc

+ Keiro.Dsl.Grammar: [rsQuery] :: RouterSelectionDecl -> !Name

+ Keiro.Dsl.Grammar: [rsRecipient] :: RouterSelectionDecl -> !Expr

+ Keiro.Dsl.Grammar: [rsRedeliveryLoc] :: RouterSelectionDecl -> !Loc

+ Keiro.Dsl.Grammar: [rsRedelivery] :: RouterSelectionDecl -> !Name

+ Keiro.Dsl.Grammar: [rsVersionLoc] :: RouterSelectionDecl -> !Loc

+ Keiro.Dsl.Grammar: [rsVersion] :: RouterSelectionDecl -> !Natural

+ Keiro.Dsl.Grammar: [tOutcomeDuplicateLocs] :: Transition -> ![Loc]

+ Keiro.Dsl.Grammar: [tOutcome] :: Transition -> !Maybe TransitionOutcome

+ Keiro.Dsl.Grammar: [wqfLoc] :: WqField -> !Loc

+ Keiro.Dsl.Grammar: data CatalogSource

+ Keiro.Dsl.Grammar: data CheckpointOnMissingNode

+ Keiro.Dsl.Grammar: data DomainOutcomeTypes

+ Keiro.Dsl.Grammar: data ExternalReadNode

+ Keiro.Dsl.Grammar: data ProjectionDelivery

+ Keiro.Dsl.Grammar: data ProjectionOwnerNode

+ Keiro.Dsl.Grammar: data ProjectionReplayPolicy

+ Keiro.Dsl.Grammar: data ProjectionRevisionNode

+ Keiro.Dsl.Grammar: data ProjectionTargetNode

+ Keiro.Dsl.Grammar: data PromotionObjectKindNode

+ Keiro.Dsl.Grammar: data PromotionObjectNode

+ Keiro.Dsl.Grammar: data QueryFreshnessNode

+ Keiro.Dsl.Grammar: data QueuePayloadType

+ Keiro.Dsl.Grammar: data QueueScalar

+ Keiro.Dsl.Grammar: data ReadModelQueryTypes

+ Keiro.Dsl.Grammar: data ReadModelSupply

+ Keiro.Dsl.Grammar: data RebuildGroupNode

+ Keiro.Dsl.Grammar: data RevisionTargetNode

+ Keiro.Dsl.Grammar: data RouterSelectionDecl

+ Keiro.Dsl.Grammar: data SelectionDispositionSyntax

+ Keiro.Dsl.Grammar: data TargetResetPolicy

+ Keiro.Dsl.Grammar: data TransitionOutcome

+ Keiro.Dsl.Grammar: externalReadNodeIdentity :: ExternalReadNode -> Name

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.CatalogSource

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.CheckpointOnMissingNode

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.DomainOutcomeTypes

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.ExternalReadNode

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.ProjectionDelivery

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.ProjectionOwnerNode

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.ProjectionReplayPolicy

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.ProjectionRevisionNode

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.ProjectionTargetNode

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.PromotionObjectKindNode

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.PromotionObjectNode

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.QueryFreshnessNode

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.QueuePayloadType

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.QueueScalar

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.ReadModelQueryTypes

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.ReadModelSupply

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.RebuildGroupNode

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.RevisionTargetNode

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.RouterSelectionDecl

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.SelectionDispositionSyntax

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.TargetResetPolicy

+ Keiro.Dsl.Grammar: instance GHC.Classes.Eq Keiro.Dsl.Grammar.TransitionOutcome

+ Keiro.Dsl.Grammar: instance GHC.Classes.Ord Keiro.Dsl.Grammar.ProjectionDelivery

+ Keiro.Dsl.Grammar: instance GHC.Classes.Ord Keiro.Dsl.Grammar.PromotionObjectKindNode

+ Keiro.Dsl.Grammar: instance GHC.Classes.Ord Keiro.Dsl.Grammar.SelectionDispositionSyntax

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.CatalogSource

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.CheckpointOnMissingNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.DomainOutcomeTypes

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.ExternalReadNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.ProjectionDelivery

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.ProjectionOwnerNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.ProjectionReplayPolicy

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.ProjectionRevisionNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.ProjectionTargetNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.PromotionObjectKindNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.PromotionObjectNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.QueryFreshnessNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.QueuePayloadType

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.QueueScalar

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.ReadModelQueryTypes

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.ReadModelSupply

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.RebuildGroupNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.RevisionTargetNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.RouterSelectionDecl

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.SelectionDispositionSyntax

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.TargetResetPolicy

+ Keiro.Dsl.Grammar: instance GHC.Internal.Generics.Generic Keiro.Dsl.Grammar.TransitionOutcome

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.CatalogSource

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.CheckpointOnMissingNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.DomainOutcomeTypes

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.ExternalReadNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.ProjectionDelivery

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.ProjectionOwnerNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.ProjectionReplayPolicy

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.ProjectionRevisionNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.ProjectionTargetNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.PromotionObjectKindNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.PromotionObjectNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.QueryFreshnessNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.QueuePayloadType

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.QueueScalar

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.ReadModelQueryTypes

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.ReadModelSupply

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.RebuildGroupNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.RevisionTargetNode

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.RouterSelectionDecl

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.SelectionDispositionSyntax

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.TargetResetPolicy

+ Keiro.Dsl.Grammar: instance GHC.Internal.Show.Show Keiro.Dsl.Grammar.TransitionOutcome

+ Keiro.Dsl.Grammar: legacyReadModelConsistency :: ReadModelNode -> Maybe Consistency

+ Keiro.Dsl.Grammar: legacyReadModelFeed :: ReadModelNode -> Maybe RmFeed

+ Keiro.Dsl.Grammar: legacyReadModelScope :: ReadModelNode -> Maybe RmScope

+ Keiro.Dsl.Grammar: legacyReadModelSubscription :: ReadModelNode -> Maybe Text

+ Keiro.Dsl.Grammar: queueScalarName :: QueueScalar -> Name

+ Keiro.Dsl.Grammar: transitionOutcomeLoc :: TransitionOutcome -> Loc

+ Keiro.Dsl.Harness: harnessReadModelForService :: Context -> CheckedService -> ReadModelNode -> [ScaffoldModule]

+ Keiro.Dsl.Harness: harnessRouterForService :: Context -> CheckedService -> RouterNode -> [ScaffoldModule]

+ Keiro.Dsl.Harness: routerHarnessFactValuesForService :: CheckedService -> RouterNode -> [(Text, Text)]

+ Keiro.Dsl.HaskellImport: ConstructorNamespace :: HaskellNamespace

+ Keiro.Dsl.HaskellImport: HaskellReference :: !Text -> !Text -> !HaskellNamespace -> !QualificationPreference -> HaskellReference

+ Keiro.Dsl.HaskellImport: HaskellSelfImport :: !Text -> HaskellImportError

+ Keiro.Dsl.HaskellImport: ImportEnvironment :: !Text -> !Set Text -> !Set Text -> ImportEnvironment

+ Keiro.Dsl.HaskellImport: ImpossibleHaskellAlias :: !Text -> !Set Text -> HaskellImportError

+ Keiro.Dsl.HaskellImport: InvalidHaskellModule :: !Text -> !Text -> HaskellImportError

+ Keiro.Dsl.HaskellImport: InvalidHaskellOccurrence :: !Text -> !HaskellNamespace -> !Text -> HaskellImportError

+ Keiro.Dsl.HaskellImport: MissingHaskellReference :: !Text -> !HaskellReference -> HaskellImportError

+ Keiro.Dsl.HaskellImport: PreferUnqualified :: QualificationPreference

+ Keiro.Dsl.HaskellImport: RequireQualified :: QualificationPreference

+ Keiro.Dsl.HaskellImport: TypeNamespace :: HaskellNamespace

+ Keiro.Dsl.HaskellImport: ValueNamespace :: HaskellNamespace

+ Keiro.Dsl.HaskellImport: [localNames] :: ImportEnvironment -> !Set Text

+ Keiro.Dsl.HaskellImport: [referenceModule] :: HaskellReference -> !Text

+ Keiro.Dsl.HaskellImport: [referenceName] :: HaskellReference -> !Text

+ Keiro.Dsl.HaskellImport: [referenceNamespace] :: HaskellReference -> !HaskellNamespace

+ Keiro.Dsl.HaskellImport: [referenceQualification] :: HaskellReference -> !QualificationPreference

+ Keiro.Dsl.HaskellImport: [reservedQualifiers] :: ImportEnvironment -> !Set Text

+ Keiro.Dsl.HaskellImport: [targetModule] :: ImportEnvironment -> !Text

+ Keiro.Dsl.HaskellImport: data HaskellImportError

+ Keiro.Dsl.HaskellImport: data HaskellImportPlan

+ Keiro.Dsl.HaskellImport: data HaskellNamespace

+ Keiro.Dsl.HaskellImport: data HaskellReference

+ Keiro.Dsl.HaskellImport: data ImportEnvironment

+ Keiro.Dsl.HaskellImport: data QualificationPreference

+ Keiro.Dsl.HaskellImport: instance GHC.Classes.Eq Keiro.Dsl.HaskellImport.HaskellImportError

+ Keiro.Dsl.HaskellImport: instance GHC.Classes.Eq Keiro.Dsl.HaskellImport.HaskellNamespace

+ Keiro.Dsl.HaskellImport: instance GHC.Classes.Eq Keiro.Dsl.HaskellImport.HaskellReference

+ Keiro.Dsl.HaskellImport: instance GHC.Classes.Eq Keiro.Dsl.HaskellImport.ImportEnvironment

+ Keiro.Dsl.HaskellImport: instance GHC.Classes.Eq Keiro.Dsl.HaskellImport.QualificationPreference

+ Keiro.Dsl.HaskellImport: instance GHC.Classes.Ord Keiro.Dsl.HaskellImport.HaskellNamespace

+ Keiro.Dsl.HaskellImport: instance GHC.Classes.Ord Keiro.Dsl.HaskellImport.HaskellReference

+ Keiro.Dsl.HaskellImport: instance GHC.Classes.Ord Keiro.Dsl.HaskellImport.QualificationPreference

+ Keiro.Dsl.HaskellImport: instance GHC.Internal.Show.Show Keiro.Dsl.HaskellImport.HaskellImportError

+ Keiro.Dsl.HaskellImport: instance GHC.Internal.Show.Show Keiro.Dsl.HaskellImport.HaskellNamespace

+ Keiro.Dsl.HaskellImport: instance GHC.Internal.Show.Show Keiro.Dsl.HaskellImport.HaskellReference

+ Keiro.Dsl.HaskellImport: instance GHC.Internal.Show.Show Keiro.Dsl.HaskellImport.ImportEnvironment

+ Keiro.Dsl.HaskellImport: instance GHC.Internal.Show.Show Keiro.Dsl.HaskellImport.QualificationPreference

+ Keiro.Dsl.HaskellImport: planHaskellImports :: ImportEnvironment -> Set HaskellReference -> Either HaskellImportError HaskellImportPlan

+ Keiro.Dsl.HaskellImport: renderPlannedImports :: HaskellImportPlan -> Text

+ Keiro.Dsl.HaskellImport: renderPlannedReference :: HaskellImportPlan -> HaskellReference -> Either HaskellImportError Text

+ Keiro.Dsl.LanguageVersion: Candidate :: LanguageSupport

+ Keiro.Dsl.LanguageVersion: CandidateLanguage :: LanguageMaturity

+ Keiro.Dsl.LanguageVersion: DeclarativeRouterSelectionSyntax :: LanguageFeature

+ Keiro.Dsl.LanguageVersion: DomainCommandOutcomeSyntax :: LanguageFeature

+ Keiro.Dsl.LanguageVersion: ExternalReadContractSyntax :: LanguageFeature

+ Keiro.Dsl.LanguageVersion: MappedConsumerSurfaceSyntax :: LanguageFeature

+ Keiro.Dsl.LanguageVersion: ProjectionCatalogRuntime :: RuntimeCapability

+ Keiro.Dsl.LanguageVersion: ProjectionCatalogSyntax :: LanguageFeature

+ Keiro.Dsl.LanguageVersion: PublishedLanguage :: LanguageMaturity

+ Keiro.Dsl.LanguageVersion: SeparatedProjectionQueryPolicy :: RuntimeCapability

+ Keiro.Dsl.LanguageVersion: SeparatedProjectionQueryPolicySyntax :: LanguageFeature

+ Keiro.Dsl.LanguageVersion: TypedDomainCommandOutcomes :: RuntimeCapability

+ Keiro.Dsl.LanguageVersion: [definitionMaturity] :: LanguageDefinition -> !LanguageMaturity

+ Keiro.Dsl.LanguageVersion: currentAuthoringLanguageVersion :: LanguageVersion

+ Keiro.Dsl.LanguageVersion: data LanguageMaturity

+ Keiro.Dsl.LanguageVersion: instance GHC.Classes.Eq Keiro.Dsl.LanguageVersion.LanguageMaturity

+ Keiro.Dsl.LanguageVersion: instance GHC.Classes.Ord Keiro.Dsl.LanguageVersion.LanguageMaturity

+ Keiro.Dsl.LanguageVersion: instance GHC.Internal.Show.Show Keiro.Dsl.LanguageVersion.LanguageMaturity

+ Keiro.Dsl.MappedCodecPlan: ConsumerValueBoundary :: MappedReferenceBoundary

+ Keiro.Dsl.MappedCodecPlan: ExplicitJsonAuthority :: MappedAuthorityMode

+ Keiro.Dsl.MappedCodecPlan: MappedCodecConsumerTypeError :: ConsumerTypePlanError -> MappedCodecPlanError

+ Keiro.Dsl.MappedCodecPlan: MappedCodecPlan :: !ConsumerTypePlan -> !ResolvedTypeExpr -> !Set MappedAuthorityMode -> MappedCodecPlan

+ Keiro.Dsl.MappedCodecPlan: OpaqueAuthority :: !MappedKey -> MappedAuthorityMode

+ Keiro.Dsl.MappedCodecPlan: PrimitiveAuthority :: MappedAuthorityMode

+ Keiro.Dsl.MappedCodecPlan: StructuralAuthority :: !MappedKey -> MappedAuthorityMode

+ Keiro.Dsl.MappedCodecPlan: StructuralShapeBoundary :: MappedReferenceBoundary

+ Keiro.Dsl.MappedCodecPlan: [authority] :: MappedCodecPlan -> !Set MappedAuthorityMode

+ Keiro.Dsl.MappedCodecPlan: [consumerType] :: MappedCodecPlan -> !ConsumerTypePlan

+ Keiro.Dsl.MappedCodecPlan: [resolvedExpression] :: MappedCodecPlan -> !ResolvedTypeExpr

+ Keiro.Dsl.MappedCodecPlan: data MappedAuthorityMode

+ Keiro.Dsl.MappedCodecPlan: data MappedCodecPlan

+ Keiro.Dsl.MappedCodecPlan: data MappedReferenceBoundary

+ Keiro.Dsl.MappedCodecPlan: instance GHC.Classes.Eq Keiro.Dsl.MappedCodecPlan.MappedAuthorityMode

+ Keiro.Dsl.MappedCodecPlan: instance GHC.Classes.Eq Keiro.Dsl.MappedCodecPlan.MappedCodecPlan

+ Keiro.Dsl.MappedCodecPlan: instance GHC.Classes.Eq Keiro.Dsl.MappedCodecPlan.MappedCodecPlanError

+ Keiro.Dsl.MappedCodecPlan: instance GHC.Classes.Eq Keiro.Dsl.MappedCodecPlan.MappedReferenceBoundary

+ Keiro.Dsl.MappedCodecPlan: instance GHC.Classes.Ord Keiro.Dsl.MappedCodecPlan.MappedAuthorityMode

+ Keiro.Dsl.MappedCodecPlan: instance GHC.Classes.Ord Keiro.Dsl.MappedCodecPlan.MappedReferenceBoundary

+ Keiro.Dsl.MappedCodecPlan: instance GHC.Internal.Show.Show Keiro.Dsl.MappedCodecPlan.MappedAuthorityMode

+ Keiro.Dsl.MappedCodecPlan: instance GHC.Internal.Show.Show Keiro.Dsl.MappedCodecPlan.MappedCodecPlan

+ Keiro.Dsl.MappedCodecPlan: instance GHC.Internal.Show.Show Keiro.Dsl.MappedCodecPlan.MappedCodecPlanError

+ Keiro.Dsl.MappedCodecPlan: instance GHC.Internal.Show.Show Keiro.Dsl.MappedCodecPlan.MappedReferenceBoundary

+ Keiro.Dsl.MappedCodecPlan: newtype MappedCodecPlanError

+ Keiro.Dsl.MappedCodecPlan: planMappedCodec :: TypeGraph -> ResolvedTypeExpr -> Either MappedCodecPlanError MappedCodecPlan

+ Keiro.Dsl.MappedCodecPlan: renderMappedEncode :: TypeGraph -> MappedReferenceBoundary -> MappedCodecPlan -> Text -> Text

+ Keiro.Dsl.MappedCodecPlan: renderMappedParse :: TypeGraph -> MappedReferenceBoundary -> MappedCodecPlan -> Text

+ Keiro.Dsl.MappedConsumer: consumerPlanForService :: CheckedService -> ConsumerPlan

+ Keiro.Dsl.Parser: ParsedSourceDocument :: !ParsedSource -> !SemanticSourceIndex -> ParsedSourceDocument

+ Keiro.Dsl.Parser: [documentParsedSource] :: ParsedSourceDocument -> !ParsedSource

+ Keiro.Dsl.Parser: [documentSourceIndex] :: ParsedSourceDocument -> !SemanticSourceIndex

+ Keiro.Dsl.Parser: data ParsedSourceDocument

+ Keiro.Dsl.Parser: parseSourceDocument :: FilePath -> Text -> Either ParseFailure ParsedSourceDocument

+ Keiro.Dsl.PrettyPrint: renderTypeExpr :: TypeExpr -> Text

+ Keiro.Dsl.ProjectionMappedImpact: ProjectionMappedImpact :: ![ProjectionMappedRoot] -> !Map MappedKey (Set DerivedMappedConsumer) -> !Map DerivedMappedConsumer ProjectionOperationalImpact -> ![UnsupportedProjectionImpact] -> ProjectionMappedImpact

+ Keiro.Dsl.ProjectionMappedImpact: ProjectionMappedRoot :: !DerivedMappedConsumer -> !MappedKey -> !UsePath -> ProjectionMappedRoot

+ Keiro.Dsl.ProjectionMappedImpact: ProjectionOperationalImpact :: !DerivedMappedConsumer -> !Maybe Name -> !Set Name -> !Set Name -> !Bool -> !Text -> ProjectionOperationalImpact

+ Keiro.Dsl.ProjectionMappedImpact: UnsupportedProjectionImpact :: !UnsupportedProjectionSource -> !Name -> !Set Name -> !Set Name -> !Bool -> UnsupportedProjectionImpact

+ Keiro.Dsl.ProjectionMappedImpact: [consumer] :: ProjectionOperationalImpact -> !DerivedMappedConsumer

+ Keiro.Dsl.ProjectionMappedImpact: [consumers] :: ProjectionMappedImpact -> !Map MappedKey (Set DerivedMappedConsumer)

+ Keiro.Dsl.ProjectionMappedImpact: [declaration] :: ProjectionMappedRoot -> !MappedKey

+ Keiro.Dsl.ProjectionMappedImpact: [group] :: UnsupportedProjectionImpact -> !Name

+ Keiro.Dsl.ProjectionMappedImpact: [operations] :: ProjectionMappedImpact -> !Map DerivedMappedConsumer ProjectionOperationalImpact

+ Keiro.Dsl.ProjectionMappedImpact: [path] :: ProjectionMappedRoot -> !UsePath

+ Keiro.Dsl.ProjectionMappedImpact: [readModels] :: UnsupportedProjectionImpact -> !Set Name

+ Keiro.Dsl.ProjectionMappedImpact: [replayable] :: UnsupportedProjectionImpact -> !Bool

+ Keiro.Dsl.ProjectionMappedImpact: [roots] :: ProjectionMappedImpact -> ![ProjectionMappedRoot]

+ Keiro.Dsl.ProjectionMappedImpact: [sourceFingerprint] :: ProjectionOperationalImpact -> !Text

+ Keiro.Dsl.ProjectionMappedImpact: [source] :: UnsupportedProjectionImpact -> !UnsupportedProjectionSource

+ Keiro.Dsl.ProjectionMappedImpact: [targets] :: UnsupportedProjectionImpact -> !Set Name

+ Keiro.Dsl.ProjectionMappedImpact: [unsupported] :: ProjectionMappedImpact -> ![UnsupportedProjectionImpact]

+ Keiro.Dsl.ProjectionMappedImpact: data ProjectionMappedImpact

+ Keiro.Dsl.ProjectionMappedImpact: data ProjectionMappedRoot

+ Keiro.Dsl.ProjectionMappedImpact: data ProjectionOperationalImpact

+ Keiro.Dsl.ProjectionMappedImpact: data UnsupportedProjectionImpact

+ Keiro.Dsl.ProjectionMappedImpact: instance GHC.Classes.Eq Keiro.Dsl.ProjectionMappedImpact.ProjectionMappedImpact

+ Keiro.Dsl.ProjectionMappedImpact: instance GHC.Classes.Eq Keiro.Dsl.ProjectionMappedImpact.ProjectionMappedRoot

+ Keiro.Dsl.ProjectionMappedImpact: instance GHC.Classes.Eq Keiro.Dsl.ProjectionMappedImpact.ProjectionOperationalImpact

+ Keiro.Dsl.ProjectionMappedImpact: instance GHC.Classes.Eq Keiro.Dsl.ProjectionMappedImpact.UnsupportedProjectionImpact

+ Keiro.Dsl.ProjectionMappedImpact: instance GHC.Classes.Ord Keiro.Dsl.ProjectionMappedImpact.ProjectionMappedRoot

+ Keiro.Dsl.ProjectionMappedImpact: instance GHC.Classes.Ord Keiro.Dsl.ProjectionMappedImpact.ProjectionOperationalImpact

+ Keiro.Dsl.ProjectionMappedImpact: instance GHC.Classes.Ord Keiro.Dsl.ProjectionMappedImpact.UnsupportedProjectionImpact

+ Keiro.Dsl.ProjectionMappedImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.ProjectionMappedImpact.ProjectionMappedImpact

+ Keiro.Dsl.ProjectionMappedImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.ProjectionMappedImpact.ProjectionMappedRoot

+ Keiro.Dsl.ProjectionMappedImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.ProjectionMappedImpact.ProjectionOperationalImpact

+ Keiro.Dsl.ProjectionMappedImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.ProjectionMappedImpact.UnsupportedProjectionImpact

+ Keiro.Dsl.ProjectionMappedImpact: instance GHC.Internal.Show.Show Keiro.Dsl.ProjectionMappedImpact.ProjectionMappedImpact

+ Keiro.Dsl.ProjectionMappedImpact: instance GHC.Internal.Show.Show Keiro.Dsl.ProjectionMappedImpact.ProjectionMappedRoot

+ Keiro.Dsl.ProjectionMappedImpact: instance GHC.Internal.Show.Show Keiro.Dsl.ProjectionMappedImpact.ProjectionOperationalImpact

+ Keiro.Dsl.ProjectionMappedImpact: instance GHC.Internal.Show.Show Keiro.Dsl.ProjectionMappedImpact.UnsupportedProjectionImpact

+ Keiro.Dsl.ProjectionMappedImpact: projectionAggregateSourceFingerprint :: Spec -> Name -> Text

+ Keiro.Dsl.ProjectionMappedImpact: projectionAggregateSourceFingerprintForService :: CheckedService -> Name -> Text

+ Keiro.Dsl.ProjectionMappedImpact: projectionConsumersFor :: ProjectionMappedImpact -> MappedKey -> Set DerivedMappedConsumer

+ Keiro.Dsl.ProjectionMappedImpact: projectionMappedImpact :: CheckedService -> SemanticImpact -> ProjectionMappedImpact

+ Keiro.Dsl.ProjectionMappedImpact: projectionMappedImpactForService :: CheckedService -> Maybe ProjectionMappedImpact

+ Keiro.Dsl.ProjectionMappedImpact: projectionOperationsFor :: ProjectionMappedImpact -> MappedKey -> [ProjectionOperationalImpact]

+ Keiro.Dsl.ProjectionMappedImpact: renderProjectionMappedImpact :: ProjectionMappedImpact -> [Text]

+ Keiro.Dsl.ProjectionSupply: ProjectionSupplyAnalysis :: ![ResolvedProjectionSupply] -> ![ProjectionSupplyIssue] -> ProjectionSupplyAnalysis

+ Keiro.Dsl.ProjectionSupply: ResolvedProjectionSupply :: !Name -> !Name -> !Name -> !NonEmpty Name -> !Loc -> !Loc -> ResolvedProjectionSupply

+ Keiro.Dsl.ProjectionSupply: SupplyLegacyProjectionConflict :: !ReadModelNode -> !Aggregate -> !ProjectionSpec -> ProjectionSupplyIssue

+ Keiro.Dsl.ProjectionSupply: SupplyObservedTargetOutsideGroup :: !ReadModelNode -> !Name -> ProjectionSupplyIssue

+ Keiro.Dsl.ProjectionSupply: SupplyObservedTargetUnknown :: !ReadModelNode -> !Name -> ProjectionSupplyIssue

+ Keiro.Dsl.ProjectionSupply: SupplyObservedTargetWithMultipleOwners :: !ReadModelNode -> !Name -> ![ProjectionOwnerNode] -> ProjectionSupplyIssue

+ Keiro.Dsl.ProjectionSupply: SupplyObservedTargetWithoutOwner :: !ReadModelNode -> !Name -> ProjectionSupplyIssue

+ Keiro.Dsl.ProjectionSupply: SupplyObservedTargetsEmpty :: !ReadModelNode -> ProjectionSupplyIssue

+ Keiro.Dsl.ProjectionSupply: SupplyOwnerGroupMismatch :: !ReadModelNode -> !Name -> !ProjectionOwnerNode -> ProjectionSupplyIssue

+ Keiro.Dsl.ProjectionSupply: SupplyQueryWithMultipleOwners :: !ReadModelNode -> ![ProjectionOwnerNode] -> ProjectionSupplyIssue

+ Keiro.Dsl.ProjectionSupply: SupplyQueryWithoutOwner :: !ReadModelNode -> ProjectionSupplyIssue

+ Keiro.Dsl.ProjectionSupply: [projectionSupplyIssues] :: ProjectionSupplyAnalysis -> ![ProjectionSupplyIssue]

+ Keiro.Dsl.ProjectionSupply: [resolvedProjectionSupplies] :: ProjectionSupplyAnalysis -> ![ResolvedProjectionSupply]

+ Keiro.Dsl.ProjectionSupply: [supplyObservedTargets] :: ResolvedProjectionSupply -> !NonEmpty Name

+ Keiro.Dsl.ProjectionSupply: [supplyOwnerLoc] :: ResolvedProjectionSupply -> !Loc

+ Keiro.Dsl.ProjectionSupply: [supplyProjectionOwner] :: ResolvedProjectionSupply -> !Name

+ Keiro.Dsl.ProjectionSupply: [supplyQueryLoc] :: ResolvedProjectionSupply -> !Loc

+ Keiro.Dsl.ProjectionSupply: [supplyQueryModel] :: ResolvedProjectionSupply -> !Name

+ Keiro.Dsl.ProjectionSupply: [supplyRebuildGroup] :: ResolvedProjectionSupply -> !Name

+ Keiro.Dsl.ProjectionSupply: analyzeProjectionSupplies :: Spec -> ProjectionSupplyAnalysis

+ Keiro.Dsl.ProjectionSupply: data ProjectionSupplyAnalysis

+ Keiro.Dsl.ProjectionSupply: data ProjectionSupplyIssue

+ Keiro.Dsl.ProjectionSupply: data ResolvedProjectionSupply

+ Keiro.Dsl.ProjectionSupply: instance GHC.Classes.Eq Keiro.Dsl.ProjectionSupply.ProjectionSupplyAnalysis

+ Keiro.Dsl.ProjectionSupply: instance GHC.Classes.Eq Keiro.Dsl.ProjectionSupply.ProjectionSupplyIssue

+ Keiro.Dsl.ProjectionSupply: instance GHC.Classes.Eq Keiro.Dsl.ProjectionSupply.ResolvedProjectionSupply

+ Keiro.Dsl.ProjectionSupply: instance GHC.Internal.Show.Show Keiro.Dsl.ProjectionSupply.ProjectionSupplyAnalysis

+ Keiro.Dsl.ProjectionSupply: instance GHC.Internal.Show.Show Keiro.Dsl.ProjectionSupply.ProjectionSupplyIssue

+ Keiro.Dsl.ProjectionSupply: instance GHC.Internal.Show.Show Keiro.Dsl.ProjectionSupply.ResolvedProjectionSupply

+ Keiro.Dsl.ReadModelQueryContract: QueryContractDrift :: !(Name, QueryContractPosition) -> !Maybe QueryContractIdentity -> !Maybe QueryContractIdentity -> QueryContractDrift

+ Keiro.Dsl.ReadModelQueryContract: QueryContractIdentity :: !Name -> !QueryContractPosition -> !Text -> ![Name] -> QueryContractIdentity

+ Keiro.Dsl.ReadModelQueryContract: QueryInputConsumer :: QueryContractPosition

+ Keiro.Dsl.ReadModelQueryContract: QueryResultConsumer :: QueryContractPosition

+ Keiro.Dsl.ReadModelQueryContract: [qcdCurrent] :: QueryContractDrift -> !Maybe QueryContractIdentity

+ Keiro.Dsl.ReadModelQueryContract: [qcdKey] :: QueryContractDrift -> !(Name, QueryContractPosition)

+ Keiro.Dsl.ReadModelQueryContract: [qcdPrevious] :: QueryContractDrift -> !Maybe QueryContractIdentity

+ Keiro.Dsl.ReadModelQueryContract: [qciMappedDependencies] :: QueryContractIdentity -> ![Name]

+ Keiro.Dsl.ReadModelQueryContract: [qciPosition] :: QueryContractIdentity -> !QueryContractPosition

+ Keiro.Dsl.ReadModelQueryContract: [qciReadModel] :: QueryContractIdentity -> !Name

+ Keiro.Dsl.ReadModelQueryContract: [qciTypeExpression] :: QueryContractIdentity -> !Text

+ Keiro.Dsl.ReadModelQueryContract: data QueryContractDrift

+ Keiro.Dsl.ReadModelQueryContract: data QueryContractIdentity

+ Keiro.Dsl.ReadModelQueryContract: data QueryContractPosition

+ Keiro.Dsl.ReadModelQueryContract: instance Data.Aeson.Types.FromJSON.FromJSON Keiro.Dsl.ReadModelQueryContract.QueryContractIdentity

+ Keiro.Dsl.ReadModelQueryContract: instance Data.Aeson.Types.FromJSON.FromJSON Keiro.Dsl.ReadModelQueryContract.QueryContractPosition

+ Keiro.Dsl.ReadModelQueryContract: instance Data.Aeson.Types.ToJSON.ToJSON Keiro.Dsl.ReadModelQueryContract.QueryContractIdentity

+ Keiro.Dsl.ReadModelQueryContract: instance Data.Aeson.Types.ToJSON.ToJSON Keiro.Dsl.ReadModelQueryContract.QueryContractPosition

+ Keiro.Dsl.ReadModelQueryContract: instance GHC.Classes.Eq Keiro.Dsl.ReadModelQueryContract.QueryContractDrift

+ Keiro.Dsl.ReadModelQueryContract: instance GHC.Classes.Eq Keiro.Dsl.ReadModelQueryContract.QueryContractIdentity

+ Keiro.Dsl.ReadModelQueryContract: instance GHC.Classes.Eq Keiro.Dsl.ReadModelQueryContract.QueryContractPosition

+ Keiro.Dsl.ReadModelQueryContract: instance GHC.Classes.Ord Keiro.Dsl.ReadModelQueryContract.QueryContractIdentity

+ Keiro.Dsl.ReadModelQueryContract: instance GHC.Classes.Ord Keiro.Dsl.ReadModelQueryContract.QueryContractPosition

+ Keiro.Dsl.ReadModelQueryContract: instance GHC.Internal.Show.Show Keiro.Dsl.ReadModelQueryContract.QueryContractDrift

+ Keiro.Dsl.ReadModelQueryContract: instance GHC.Internal.Show.Show Keiro.Dsl.ReadModelQueryContract.QueryContractIdentity

+ Keiro.Dsl.ReadModelQueryContract: instance GHC.Internal.Show.Show Keiro.Dsl.ReadModelQueryContract.QueryContractPosition

+ Keiro.Dsl.ReadModelQueryContract: queryContractDrift :: [QueryContractIdentity] -> [QueryContractIdentity] -> [QueryContractDrift]

+ Keiro.Dsl.ReadModelQueryContract: queryContractIdentities :: Spec -> Either (NonEmpty TypeGraphError) [QueryContractIdentity]

+ Keiro.Dsl.ReadModelQueryContract: queryContractIdentitiesForService :: CheckedService -> Either (NonEmpty TypeGraphError) [QueryContractIdentity]

+ Keiro.Dsl.ReadModelQueryContract: queryContractIdentityKey :: QueryContractIdentity -> (Name, QueryContractPosition)

+ Keiro.Dsl.ReplayImpact: CatalogReplayAffected :: !Set Name -> !Set Name -> !Set Text -> !Set Name -> !Bool -> CatalogReplayImpact

+ Keiro.Dsl.ReplayImpact: CatalogReplayNeutral :: CatalogReplayImpact

+ Keiro.Dsl.ReplayImpact: [affectedAdapters] :: CatalogReplayImpact -> !Set Name

+ Keiro.Dsl.ReplayImpact: [affectedGroups] :: CatalogReplayImpact -> !Set Name

+ Keiro.Dsl.ReplayImpact: [affectedSources] :: CatalogReplayImpact -> !Set Text

+ Keiro.Dsl.ReplayImpact: [affectedTargets] :: CatalogReplayImpact -> !Set Name

+ Keiro.Dsl.ReplayImpact: [invalidatesRunningFingerprint] :: CatalogReplayImpact -> !Bool

+ Keiro.Dsl.ReplayImpact: catalogReplayImpactServices :: CheckedService -> CheckedService -> CatalogReplayImpact

+ Keiro.Dsl.ReplayImpact: data CatalogReplayImpact

+ Keiro.Dsl.ReplayImpact: instance Data.Aeson.Types.ToJSON.ToJSON Keiro.Dsl.ReplayImpact.CatalogReplayImpact

+ Keiro.Dsl.ReplayImpact: instance GHC.Classes.Eq Keiro.Dsl.ReplayImpact.CatalogReplayImpact

+ Keiro.Dsl.ReplayImpact: instance GHC.Internal.Show.Show Keiro.Dsl.ReplayImpact.CatalogReplayImpact

+ Keiro.Dsl.RouterSelection: CheckedAnd :: !CheckedScalarExpr -> !CheckedScalarExpr -> CheckedScalarNode

+ Keiro.Dsl.RouterSelection: CheckedBoolLiteral :: !Bool -> CheckedScalarNode

+ Keiro.Dsl.RouterSelection: CheckedCompare :: !CmpOp -> !CheckedScalarExpr -> !CheckedScalarExpr -> CheckedScalarNode

+ Keiro.Dsl.RouterSelection: CheckedDedupeByTargetStream :: CheckedSelectionDedupe

+ Keiro.Dsl.RouterSelection: CheckedEmptyAck :: CheckedEmptySelectionPolicy

+ Keiro.Dsl.RouterSelection: CheckedEmptyDeadLetter :: CheckedEmptySelectionPolicy

+ Keiro.Dsl.RouterSelection: CheckedEmptyHalt :: CheckedEmptySelectionPolicy

+ Keiro.Dsl.RouterSelection: CheckedEmptyRetry :: CheckedEmptySelectionPolicy

+ Keiro.Dsl.RouterSelection: CheckedFailureDeadLetter :: CheckedSelectionFailurePolicy

+ Keiro.Dsl.RouterSelection: CheckedFailureHalt :: CheckedSelectionFailurePolicy

+ Keiro.Dsl.RouterSelection: CheckedFailureRetry :: CheckedSelectionFailurePolicy

+ Keiro.Dsl.RouterSelection: CheckedIntegralLiteral :: !Integer -> CheckedScalarNode

+ Keiro.Dsl.RouterSelection: CheckedMappedExpr :: !SelectionRoot -> !ResolvedTypeExpr -> CheckedMappedExpr

+ Keiro.Dsl.RouterSelection: CheckedMappedType :: !MappedKey -> !Name -> ![ResolvedWireField] -> CheckedMappedType

+ Keiro.Dsl.RouterSelection: CheckedOr :: !CheckedScalarExpr -> !CheckedScalarExpr -> CheckedScalarNode

+ Keiro.Dsl.RouterSelection: CheckedOrderByTargetStream :: CheckedSelectionOrder

+ Keiro.Dsl.RouterSelection: CheckedPath :: !SelectionRoot -> ![CheckedSelectionPathSegment] -> CheckedScalarNode

+ Keiro.Dsl.RouterSelection: CheckedReadModelQuery :: !Name -> !ResolvedTypeExpr -> !ResolvedTypeExpr -> CheckedReadModelQuery

+ Keiro.Dsl.RouterSelection: CheckedRetainSuccesses :: CheckedPartialDispatchPolicy

+ Keiro.Dsl.RouterSelection: CheckedRouterSelection :: !Text -> !Natural -> !CheckedReadModelQuery -> !CheckedMappedExpr -> !CheckedMappedType -> !CheckedScalarExpr -> !CheckedScalarExpr -> !CheckedScalarExpr -> !Map Name CheckedScalarExpr -> !Name -> !Name -> !Natural -> !CheckedSelectionOrder -> !CheckedSelectionDedupe -> !CheckedEmptySelectionPolicy -> !CheckedSelectionFailurePolicy -> !CheckedRedeliveryPolicy -> !CheckedPartialDispatchPolicy -> !Text -> ![UseSite] -> CheckedRouterSelection

+ Keiro.Dsl.RouterSelection: CheckedScalarExpr :: !SelectionScalarType -> !CheckedScalarNode -> !Loc -> CheckedScalarExpr

+ Keiro.Dsl.RouterSelection: CheckedSelectionPathSegment :: !Name -> !Text -> !MappedKey -> CheckedSelectionPathSegment

+ Keiro.Dsl.RouterSelection: CheckedStableUnion :: CheckedRedeliveryPolicy

+ Keiro.Dsl.RouterSelection: CheckedTextLiteral :: !Text -> CheckedScalarNode

+ Keiro.Dsl.RouterSelection: RouterSelectionDiagnostic :: !Loc -> !RouterSelectionDiagnosticCode -> !Text -> RouterSelectionDiagnostic

+ Keiro.Dsl.RouterSelection: SelectionBool :: SelectionScalarType

+ Keiro.Dsl.RouterSelection: SelectionCapabilityUnavailable :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionCommandMappingDuplicate :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionCommandMappingIncomplete :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionCommandMappingTypeMismatch :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionCommandUnknown :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionDedupeUnsupported :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionExpressionFieldOptional :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionExpressionFieldUnknown :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionExpressionRootUnknown :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionExpressionTypeMismatch :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionFailureAckForbidden :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionIdentityEmpty :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionInput :: SelectionRoot

+ Keiro.Dsl.RouterSelection: SelectionInt :: SelectionScalarType

+ Keiro.Dsl.RouterSelection: SelectionInteger :: SelectionScalarType

+ Keiro.Dsl.RouterSelection: SelectionNatural :: SelectionScalarType

+ Keiro.Dsl.RouterSelection: SelectionNotDeclarative :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionOperatorUnsupported :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionOrderUnsupported :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionPartialDispatchUnsupported :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionPredicateNotBool :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionQueryContractMissing :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionQueryInputBindingInvalid :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionQueryInputTypeMismatch :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionQueryResultNotList :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionQueryRowNotStructural :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionQueryUnknown :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionRecipientLimitInvalid :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionRecipientLimitMissing :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionRecipientNotText :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionRedeliveryUnsupported :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionRow :: SelectionRoot

+ Keiro.Dsl.RouterSelection: SelectionTargetAmbiguous :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: SelectionText :: SelectionScalarType

+ Keiro.Dsl.RouterSelection: SelectionTime :: SelectionScalarType

+ Keiro.Dsl.RouterSelection: SelectionVersionInvalid :: RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: [checkedCommandFields] :: CheckedRouterSelection -> !Map Name CheckedScalarExpr

+ Keiro.Dsl.RouterSelection: [checkedCommand] :: CheckedRouterSelection -> !Name

+ Keiro.Dsl.RouterSelection: [checkedDedupe] :: CheckedRouterSelection -> !CheckedSelectionDedupe

+ Keiro.Dsl.RouterSelection: [checkedEmptyPolicy] :: CheckedRouterSelection -> !CheckedEmptySelectionPolicy

+ Keiro.Dsl.RouterSelection: [checkedFailurePolicy] :: CheckedRouterSelection -> !CheckedSelectionFailurePolicy

+ Keiro.Dsl.RouterSelection: [checkedFingerprint] :: CheckedRouterSelection -> !Text

+ Keiro.Dsl.RouterSelection: [checkedIdentity] :: CheckedRouterSelection -> !Text

+ Keiro.Dsl.RouterSelection: [checkedInputBinding] :: CheckedRouterSelection -> !CheckedMappedExpr

+ Keiro.Dsl.RouterSelection: [checkedKey] :: CheckedRouterSelection -> !CheckedScalarExpr

+ Keiro.Dsl.RouterSelection: [checkedLimit] :: CheckedRouterSelection -> !Natural

+ Keiro.Dsl.RouterSelection: [checkedMappedExprRoot] :: CheckedMappedExpr -> !SelectionRoot

+ Keiro.Dsl.RouterSelection: [checkedMappedExprType] :: CheckedMappedExpr -> !ResolvedTypeExpr

+ Keiro.Dsl.RouterSelection: [checkedMappedTypeConstructor] :: CheckedMappedType -> !Name

+ Keiro.Dsl.RouterSelection: [checkedMappedTypeFields] :: CheckedMappedType -> ![ResolvedWireField]

+ Keiro.Dsl.RouterSelection: [checkedMappedTypeKey] :: CheckedMappedType -> !MappedKey

+ Keiro.Dsl.RouterSelection: [checkedOrder] :: CheckedRouterSelection -> !CheckedSelectionOrder

+ Keiro.Dsl.RouterSelection: [checkedPartialPolicy] :: CheckedRouterSelection -> !CheckedPartialDispatchPolicy

+ Keiro.Dsl.RouterSelection: [checkedPathField] :: CheckedSelectionPathSegment -> !Name

+ Keiro.Dsl.RouterSelection: [checkedPathOwner] :: CheckedSelectionPathSegment -> !MappedKey

+ Keiro.Dsl.RouterSelection: [checkedPathWireKey] :: CheckedSelectionPathSegment -> !Text

+ Keiro.Dsl.RouterSelection: [checkedPredicate] :: CheckedRouterSelection -> !CheckedScalarExpr

+ Keiro.Dsl.RouterSelection: [checkedQueryInputType] :: CheckedReadModelQuery -> !ResolvedTypeExpr

+ Keiro.Dsl.RouterSelection: [checkedQueryName] :: CheckedReadModelQuery -> !Name

+ Keiro.Dsl.RouterSelection: [checkedQueryResultType] :: CheckedReadModelQuery -> !ResolvedTypeExpr

+ Keiro.Dsl.RouterSelection: [checkedQuery] :: CheckedRouterSelection -> !CheckedReadModelQuery

+ Keiro.Dsl.RouterSelection: [checkedRecipient] :: CheckedRouterSelection -> !CheckedScalarExpr

+ Keiro.Dsl.RouterSelection: [checkedRedeliveryPolicy] :: CheckedRouterSelection -> !CheckedRedeliveryPolicy

+ Keiro.Dsl.RouterSelection: [checkedRowBinding] :: CheckedRouterSelection -> !CheckedMappedType

+ Keiro.Dsl.RouterSelection: [checkedScalarLoc] :: CheckedScalarExpr -> !Loc

+ Keiro.Dsl.RouterSelection: [checkedScalarNode] :: CheckedScalarExpr -> !CheckedScalarNode

+ Keiro.Dsl.RouterSelection: [checkedScalarType] :: CheckedScalarExpr -> !SelectionScalarType

+ Keiro.Dsl.RouterSelection: [checkedTarget] :: CheckedRouterSelection -> !Name

+ Keiro.Dsl.RouterSelection: [checkedUseSites] :: CheckedRouterSelection -> ![UseSite]

+ Keiro.Dsl.RouterSelection: [checkedVersion] :: CheckedRouterSelection -> !Natural

+ Keiro.Dsl.RouterSelection: [selectionDiagnosticCode] :: RouterSelectionDiagnostic -> !RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: [selectionDiagnosticLoc] :: RouterSelectionDiagnostic -> !Loc

+ Keiro.Dsl.RouterSelection: [selectionDiagnosticMessage] :: RouterSelectionDiagnostic -> !Text

+ Keiro.Dsl.RouterSelection: checkRouterSelection :: EffectiveLanguageContract -> TypeGraph -> Spec -> RouterNode -> Either (NonEmpty RouterSelectionDiagnostic) CheckedRouterSelection

+ Keiro.Dsl.RouterSelection: data CheckedEmptySelectionPolicy

+ Keiro.Dsl.RouterSelection: data CheckedMappedExpr

+ Keiro.Dsl.RouterSelection: data CheckedMappedType

+ Keiro.Dsl.RouterSelection: data CheckedPartialDispatchPolicy

+ Keiro.Dsl.RouterSelection: data CheckedReadModelQuery

+ Keiro.Dsl.RouterSelection: data CheckedRedeliveryPolicy

+ Keiro.Dsl.RouterSelection: data CheckedRouterSelection

+ Keiro.Dsl.RouterSelection: data CheckedScalarExpr

+ Keiro.Dsl.RouterSelection: data CheckedScalarNode

+ Keiro.Dsl.RouterSelection: data CheckedSelectionDedupe

+ Keiro.Dsl.RouterSelection: data CheckedSelectionFailurePolicy

+ Keiro.Dsl.RouterSelection: data CheckedSelectionOrder

+ Keiro.Dsl.RouterSelection: data CheckedSelectionPathSegment

+ Keiro.Dsl.RouterSelection: data RouterSelectionDiagnostic

+ Keiro.Dsl.RouterSelection: data RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: data SelectionRoot

+ Keiro.Dsl.RouterSelection: data SelectionScalarType

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.CheckedEmptySelectionPolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.CheckedMappedExpr

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.CheckedMappedType

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.CheckedPartialDispatchPolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.CheckedReadModelQuery

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.CheckedRedeliveryPolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.CheckedRouterSelection

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.CheckedScalarExpr

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.CheckedScalarNode

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.CheckedSelectionDedupe

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.CheckedSelectionFailurePolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.CheckedSelectionOrder

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.CheckedSelectionPathSegment

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.RouterSelectionDiagnostic

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.SelectionRoot

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Eq Keiro.Dsl.RouterSelection.SelectionScalarType

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Ord Keiro.Dsl.RouterSelection.CheckedEmptySelectionPolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Ord Keiro.Dsl.RouterSelection.CheckedPartialDispatchPolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Ord Keiro.Dsl.RouterSelection.CheckedRedeliveryPolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Ord Keiro.Dsl.RouterSelection.CheckedSelectionDedupe

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Ord Keiro.Dsl.RouterSelection.CheckedSelectionFailurePolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Ord Keiro.Dsl.RouterSelection.CheckedSelectionOrder

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Ord Keiro.Dsl.RouterSelection.CheckedSelectionPathSegment

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Ord Keiro.Dsl.RouterSelection.RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Ord Keiro.Dsl.RouterSelection.SelectionRoot

+ Keiro.Dsl.RouterSelection: instance GHC.Classes.Ord Keiro.Dsl.RouterSelection.SelectionScalarType

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Enum.Bounded Keiro.Dsl.RouterSelection.RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Enum.Bounded Keiro.Dsl.RouterSelection.SelectionScalarType

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Enum.Enum Keiro.Dsl.RouterSelection.RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Enum.Enum Keiro.Dsl.RouterSelection.SelectionScalarType

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.CheckedEmptySelectionPolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.CheckedMappedExpr

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.CheckedMappedType

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.CheckedPartialDispatchPolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.CheckedReadModelQuery

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.CheckedRedeliveryPolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.CheckedRouterSelection

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.CheckedScalarExpr

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.CheckedScalarNode

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.CheckedSelectionDedupe

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.CheckedSelectionFailurePolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.CheckedSelectionOrder

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.CheckedSelectionPathSegment

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.RouterSelectionDiagnostic

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.SelectionRoot

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Generics.Generic Keiro.Dsl.RouterSelection.SelectionScalarType

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.CheckedEmptySelectionPolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.CheckedMappedExpr

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.CheckedMappedType

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.CheckedPartialDispatchPolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.CheckedReadModelQuery

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.CheckedRedeliveryPolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.CheckedRouterSelection

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.CheckedScalarExpr

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.CheckedScalarNode

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.CheckedSelectionDedupe

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.CheckedSelectionFailurePolicy

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.CheckedSelectionOrder

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.CheckedSelectionPathSegment

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.RouterSelectionDiagnostic

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.RouterSelectionDiagnosticCode

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.SelectionRoot

+ Keiro.Dsl.RouterSelection: instance GHC.Internal.Show.Show Keiro.Dsl.RouterSelection.SelectionScalarType

+ Keiro.Dsl.RouterSelection: routerSelectionFingerprint :: CheckedRouterSelection -> Text

+ Keiro.Dsl.Scaffold: ResolvedDomainOutcomeTypes :: !ResolvedAggregateType -> !ResolvedAggregateType -> ResolvedDomainOutcomeTypes

+ Keiro.Dsl.Scaffold: [aCheckedService] :: Agg -> !CheckedService

+ Keiro.Dsl.Scaffold: [aDomainOutcomeTypes] :: Agg -> !Maybe ResolvedDomainOutcomeTypes

+ Keiro.Dsl.Scaffold: [resolvedNoOpType] :: ResolvedDomainOutcomeTypes -> !ResolvedAggregateType

+ Keiro.Dsl.Scaffold: [resolvedRejectionType] :: ResolvedDomainOutcomeTypes -> !ResolvedAggregateType

+ Keiro.Dsl.Scaffold: behaviorSourceMapModule :: Context -> [BehaviorSourceEntry] -> Maybe ScaffoldModule

+ Keiro.Dsl.Scaffold: data ResolvedDomainOutcomeTypes

+ Keiro.Dsl.Scaffold: instance GHC.Classes.Eq Keiro.Dsl.Scaffold.ResolvedDomainOutcomeTypes

+ Keiro.Dsl.Scaffold: instance GHC.Classes.Eq Keiro.Dsl.Scaffold.ResolvedSilentOutcome

+ Keiro.Dsl.Scaffold: instance GHC.Classes.Eq Keiro.Dsl.Scaffold.SilentOutcomeKind

+ Keiro.Dsl.Scaffold: instance GHC.Internal.Show.Show Keiro.Dsl.Scaffold.ResolvedDomainOutcomeTypes

+ Keiro.Dsl.Scaffold: instance GHC.Internal.Show.Show Keiro.Dsl.Scaffold.ResolvedSilentOutcome

+ Keiro.Dsl.Scaffold: instance GHC.Internal.Show.Show Keiro.Dsl.Scaffold.SilentOutcomeKind

+ Keiro.Dsl.Scaffold: obsoleteGeneratedOutputHooksForService :: CheckedService -> [(Name, Text)]

+ Keiro.Dsl.Scaffold: resolveCatalogReadModel :: Spec -> ReadModelNode -> ReadModelNode

+ Keiro.Dsl.Scaffold: scaffoldProjectionCatalog :: Context -> Spec -> [ScaffoldModule]

+ Keiro.Dsl.Scaffold: scaffoldProjectionCatalogForService :: Context -> CheckedService -> [ScaffoldModule]

+ Keiro.Dsl.Scaffold: scaffoldReadModelForService :: Context -> CheckedService -> ReadModelNode -> [ScaffoldModule]

+ Keiro.Dsl.Scaffold: scaffoldRefusalsForService :: CheckedService -> [Text]

+ Keiro.Dsl.Scaffold: scaffoldRouterForService :: Context -> CheckedService -> RouterNode -> [ScaffoldModule]

+ Keiro.Dsl.Scaffold: scaffoldWorkqueueForService :: Context -> CheckedService -> WorkqueueNode -> [ScaffoldModule]

+ Keiro.Dsl.ScaffoldRecord: [recProjectionCatalogFacts] :: ScaffoldRecord -> ![Text]

+ Keiro.Dsl.ScaffoldRecord: [recQueryContractBaseline] :: ScaffoldRecord -> !Bool

+ Keiro.Dsl.ScaffoldRecord: [recQueryContracts] :: ScaffoldRecord -> ![QueryContractIdentity]

+ Keiro.Dsl.ScaffoldRecord: [recRouterSelections] :: ScaffoldRecord -> ![RouterSelectionSnapshot]

+ Keiro.Dsl.ScaffoldRecord: [recSemanticImpact] :: ScaffoldRecord -> !Maybe SemanticImpactSnapshot

+ Keiro.Dsl.ScaffoldRecord: projectionCatalogFacts :: Spec -> [Text]

+ Keiro.Dsl.ScaffoldRecord: projectionCatalogFactsForService :: CheckedService -> [Text]

+ Keiro.Dsl.ScaffoldRun: AggregateGeneratedArtifact :: GeneratedArtifactCategory

+ Keiro.Dsl.ScaffoldRun: BehaviorSourceMapArtifact :: GeneratedArtifactCategory

+ Keiro.Dsl.ScaffoldRun: BehaviorSourceRefusal :: ![BehaviorSourceFailure] -> Refusal

+ Keiro.Dsl.ScaffoldRun: GeneratedArtifactImpact :: !GeneratedArtifactCategory -> !ModuleRole -> !FilePath -> !WriteDisposition -> GeneratedArtifactImpact

+ Keiro.Dsl.ScaffoldRun: OtherGeneratedArtifact :: GeneratedArtifactCategory

+ Keiro.Dsl.ScaffoldRun: QueryContractMigration :: !Text -> !FilePath -> !Text -> QueryContractMigration

+ Keiro.Dsl.ScaffoldRun: ServiceStructuralConformanceArtifact :: GeneratedArtifactCategory

+ Keiro.Dsl.ScaffoldRun: [artifactCategory] :: GeneratedArtifactImpact -> !GeneratedArtifactCategory

+ Keiro.Dsl.ScaffoldRun: [artifactDisposition] :: GeneratedArtifactImpact -> !WriteDisposition

+ Keiro.Dsl.ScaffoldRun: [artifactPath] :: GeneratedArtifactImpact -> !FilePath

+ Keiro.Dsl.ScaffoldRun: [artifactRole] :: GeneratedArtifactImpact -> !ModuleRole

+ Keiro.Dsl.ScaffoldRun: [qcmHolePath] :: QueryContractMigration -> !FilePath

+ Keiro.Dsl.ScaffoldRun: [qcmOwner] :: QueryContractMigration -> !Text

+ Keiro.Dsl.ScaffoldRun: [qcmRequiredImport] :: QueryContractMigration -> !Text

+ Keiro.Dsl.ScaffoldRun: [reportGeneratedArtifactImpact] :: ScaffoldReport -> ![GeneratedArtifactImpact]

+ Keiro.Dsl.ScaffoldRun: [reportProjectionMappedImpact] :: ScaffoldReport -> !Maybe ProjectionMappedImpact

+ Keiro.Dsl.ScaffoldRun: [reportQueryContractBaselineUnavailable] :: ScaffoldReport -> !Bool

+ Keiro.Dsl.ScaffoldRun: [reportQueryContractDrift] :: ScaffoldReport -> ![QueryContractDrift]

+ Keiro.Dsl.ScaffoldRun: [reportQueryContractMigrations] :: ScaffoldReport -> ![QueryContractMigration]

+ Keiro.Dsl.ScaffoldRun: [reportRouterSelectionDrift] :: ScaffoldReport -> ![RouterSelectionDrift]

+ Keiro.Dsl.ScaffoldRun: [reportSemanticImpact] :: ScaffoldReport -> !SemanticImpactReport

+ Keiro.Dsl.ScaffoldRun: checkIndexedServiceDiagnostics :: Maybe RuntimePackageName -> SemanticSourceIndex -> Context -> CheckedService -> [Diagnostic]

+ Keiro.Dsl.ScaffoldRun: checkedSemanticImpactSnapshot :: CheckedService -> SemanticImpactSnapshot

+ Keiro.Dsl.ScaffoldRun: constraintPlanForService :: CheckedService -> ConsumerPlan -> [Text]

+ Keiro.Dsl.ScaffoldRun: data GeneratedArtifactCategory

+ Keiro.Dsl.ScaffoldRun: data GeneratedArtifactImpact

+ Keiro.Dsl.ScaffoldRun: data QueryContractMigration

+ Keiro.Dsl.ScaffoldRun: generatedArtifactImpact :: [(ScaffoldModule, WriteDisposition)] -> [GeneratedArtifactImpact]

+ Keiro.Dsl.ScaffoldRun: instance GHC.Classes.Eq Keiro.Dsl.ScaffoldRun.GeneratedArtifactCategory

+ Keiro.Dsl.ScaffoldRun: instance GHC.Classes.Eq Keiro.Dsl.ScaffoldRun.GeneratedArtifactImpact

+ Keiro.Dsl.ScaffoldRun: instance GHC.Classes.Eq Keiro.Dsl.ScaffoldRun.QueryContractMigration

+ Keiro.Dsl.ScaffoldRun: instance GHC.Classes.Ord Keiro.Dsl.ScaffoldRun.GeneratedArtifactCategory

+ Keiro.Dsl.ScaffoldRun: instance GHC.Internal.Show.Show Keiro.Dsl.ScaffoldRun.GeneratedArtifactCategory

+ Keiro.Dsl.ScaffoldRun: instance GHC.Internal.Show.Show Keiro.Dsl.ScaffoldRun.GeneratedArtifactImpact

+ Keiro.Dsl.ScaffoldRun: instance GHC.Internal.Show.Show Keiro.Dsl.ScaffoldRun.QueryContractMigration

+ Keiro.Dsl.ScaffoldRun: planIndexedServiceScaffold :: SemanticSourceIndex -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]

+ Keiro.Dsl.ScaffoldRun: planIndexedServiceScaffoldWithGoldens :: [GoldenPayload] -> SemanticSourceIndex -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]

+ Keiro.Dsl.ScaffoldRun: planIndexedServiceScaffoldWithRuntimePackage :: Maybe RuntimePackageName -> SemanticSourceIndex -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]

+ Keiro.Dsl.ScaffoldRun: planIndexedServiceScaffoldWithRuntimePackageAndGoldens :: [GoldenPayload] -> Maybe RuntimePackageName -> SemanticSourceIndex -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]

+ Keiro.Dsl.ScaffoldRun: pureRefusalsForService :: Context -> CheckedService -> [ScaffoldModule] -> [Refusal]

+ Keiro.Dsl.ScaffoldRun: queryContractMigrations :: FilePath -> [ScaffoldModule] -> IO [QueryContractMigration]

+ Keiro.Dsl.ScaffoldRun: renderGeneratedArtifactImpact :: SemanticImpactReport -> [GeneratedArtifactImpact] -> [Text]

+ Keiro.Dsl.ScaffoldRun: renderRouterSelectionDrift :: [RouterSelectionDrift] -> [Text]

+ Keiro.Dsl.ScaffoldRun: renderSemanticImpactReport :: SemanticImpactReport -> [Text]

+ Keiro.Dsl.ScaffoldRun: semanticImpactForMappingDrift :: Maybe SemanticImpactSnapshot -> SemanticImpactSnapshot -> [MappingDrift] -> SemanticImpactReport

+ Keiro.Dsl.SemanticContract: checkedLanguageContract :: CheckedService -> EffectiveLanguageContract

+ Keiro.Dsl.SemanticContract: checkedProjectionSupplies :: CheckedService -> ProjectionSupplyAnalysis

+ Keiro.Dsl.SemanticContract: checkedServiceForContract :: EffectiveLanguageContract -> Spec -> CheckedService

+ Keiro.Dsl.SemanticContract: checkedServiceWithSpec :: Spec -> CheckedService -> CheckedService

+ Keiro.Dsl.SemanticContract: checkedSpec :: CheckedService -> Spec

+ Keiro.Dsl.SemanticContract: checkedTypeGraph :: CheckedService -> Either (NonEmpty TypeGraphError) TypeGraph

+ Keiro.Dsl.SemanticImpact: AggregateConsumer :: !Name -> MappedConsumer

+ Keiro.Dsl.SemanticImpact: AggregateInlineProjectionConsumer :: !Name -> !Name -> DerivedMappedConsumer

+ Keiro.Dsl.SemanticImpact: CatalogProjectionConsumer :: !Name -> !Name -> DerivedMappedConsumer

+ Keiro.Dsl.SemanticImpact: DerivedProjectionConsumer :: !DerivedMappedConsumer -> MappedConsumer

+ Keiro.Dsl.SemanticImpact: MappedCommandFieldRoot :: MappedRootKind

+ Keiro.Dsl.SemanticImpact: MappedConsumerBuild :: !MappedConsumer -> MappedConsequence

+ Keiro.Dsl.SemanticImpact: MappedEventFieldRoot :: MappedRootKind

+ Keiro.Dsl.SemanticImpact: MappedImpactDelta :: !MappedKey -> !Set MappedConsumer -> !Set MappedConsumer -> !Maybe (Set MappedRootEvidence) -> !Maybe (Set MappedRootEvidence) -> !Maybe (Set MappedConsequence) -> !Maybe (Set MappedConsequence) -> !Bool -> MappedImpactDelta

+ Keiro.Dsl.SemanticImpact: MappedPrivateEventHistory :: !Name -> MappedConsequence

+ Keiro.Dsl.SemanticImpact: MappedProjectionEventRoot :: MappedRootKind

+ Keiro.Dsl.SemanticImpact: MappedProjectionHandlerReview :: !DerivedMappedConsumer -> MappedConsequence

+ Keiro.Dsl.SemanticImpact: MappedProjectionRebuild :: !DerivedMappedConsumer -> !Name -> MappedConsequence

+ Keiro.Dsl.SemanticImpact: MappedQueryApi :: !Name -> !MappedQueryPosition -> MappedConsequence

+ Keiro.Dsl.SemanticImpact: MappedQueryInput :: MappedQueryPosition

+ Keiro.Dsl.SemanticImpact: MappedQueryResult :: MappedQueryPosition

+ Keiro.Dsl.SemanticImpact: MappedReadModelQueryInputRoot :: MappedRootKind

+ Keiro.Dsl.SemanticImpact: MappedReadModelQueryResultRoot :: MappedRootKind

+ Keiro.Dsl.SemanticImpact: MappedRegisterRoot :: MappedRootKind

+ Keiro.Dsl.SemanticImpact: MappedRoot :: !MappedConsumer -> !MappedRootKind -> !UseSite -> !MappedKey -> MappedRoot

+ Keiro.Dsl.SemanticImpact: MappedRootEvidence :: !MappedConsumer -> !MappedRootKind -> !Text -> !Maybe Text -> MappedRootEvidence

+ Keiro.Dsl.SemanticImpact: MappedRouterSelectionBuild :: !Name -> MappedConsequence

+ Keiro.Dsl.SemanticImpact: MappedRouterSelectionCommandFieldRoot :: MappedRootKind

+ Keiro.Dsl.SemanticImpact: MappedRouterSelectionCoordinationReview :: !Name -> MappedConsequence

+ Keiro.Dsl.SemanticImpact: MappedRouterSelectionPredicateRoot :: MappedRootKind

+ Keiro.Dsl.SemanticImpact: MappedRouterSelectionQueryInputRoot :: MappedRootKind

+ Keiro.Dsl.SemanticImpact: MappedRouterSelectionRecipientRoot :: MappedRootKind

+ Keiro.Dsl.SemanticImpact: MappedSnapshotHydration :: !Name -> MappedConsequence

+ Keiro.Dsl.SemanticImpact: MappedWorkqueueFieldRoot :: MappedRootKind

+ Keiro.Dsl.SemanticImpact: MappedWorkqueueHistory :: !Name -> MappedConsequence

+ Keiro.Dsl.SemanticImpact: ReadModelQueryConsumer :: !Name -> !MappedQueryPosition -> MappedConsumer

+ Keiro.Dsl.SemanticImpact: RouterSelectionConsumer :: !Name -> !RouterSelectionPosition -> MappedConsumer

+ Keiro.Dsl.SemanticImpact: SelectionCommandField :: !Name -> RouterSelectionPosition

+ Keiro.Dsl.SemanticImpact: SelectionPredicate :: RouterSelectionPosition

+ Keiro.Dsl.SemanticImpact: SelectionQueryInput :: RouterSelectionPosition

+ Keiro.Dsl.SemanticImpact: SelectionRecipient :: RouterSelectionPosition

+ Keiro.Dsl.SemanticImpact: SemanticImpact :: ![MappedRoot] -> !Map MappedKey [UsePath] -> !Map MappedConsumer (Set MappedKey) -> !Map MappedKey (Set MappedConsumer) -> !Map MappedKey (Set MappedRootEvidence) -> !Map MappedKey (Set MappedConsequence) -> !Set MappedKey -> !Map MappedKey Text -> ![UnsupportedProjectionSource] -> SemanticImpact

+ Keiro.Dsl.SemanticImpact: SemanticImpactReport :: !Maybe SemanticImpactSnapshot -> !SemanticImpactSnapshot -> ![MappedKey] -> ![MappedImpactDelta] -> SemanticImpactReport

+ Keiro.Dsl.SemanticImpact: SemanticImpactSnapshot :: !Map MappedKey (Set MappedConsumer) -> !Maybe (Map MappedKey (Set MappedRootEvidence)) -> !Maybe (Map MappedKey (Set MappedConsequence)) -> !Set MappedKey -> !Map MappedKey Text -> SemanticImpactSnapshot

+ Keiro.Dsl.SemanticImpact: UnsupportedCatalogAll :: !Name -> UnsupportedProjectionSource

+ Keiro.Dsl.SemanticImpact: UnsupportedCatalogCategory :: !Name -> !Text -> UnsupportedProjectionSource

+ Keiro.Dsl.SemanticImpact: WorkqueueConsumer :: !Name -> MappedConsumer

+ Keiro.Dsl.SemanticImpact: [evidenceConsumer] :: MappedRootEvidence -> !MappedConsumer

+ Keiro.Dsl.SemanticImpact: [evidenceOperation] :: MappedRootEvidence -> !Maybe Text

+ Keiro.Dsl.SemanticImpact: [evidencePath] :: MappedRootEvidence -> !Text

+ Keiro.Dsl.SemanticImpact: [evidenceRootKind] :: MappedRootEvidence -> !MappedRootKind

+ Keiro.Dsl.SemanticImpact: [impactAggregateDeclarations] :: SemanticImpact -> !Map MappedConsumer (Set MappedKey)

+ Keiro.Dsl.SemanticImpact: [impactCurrentConsequences] :: MappedImpactDelta -> !Maybe (Set MappedConsequence)

+ Keiro.Dsl.SemanticImpact: [impactCurrentConsumers] :: MappedImpactDelta -> !Set MappedConsumer

+ Keiro.Dsl.SemanticImpact: [impactCurrentEvidence] :: MappedImpactDelta -> !Maybe (Set MappedRootEvidence)

+ Keiro.Dsl.SemanticImpact: [impactDeclarationConsequences] :: SemanticImpact -> !Map MappedKey (Set MappedConsequence)

+ Keiro.Dsl.SemanticImpact: [impactDeclarationConsumers] :: SemanticImpact -> !Map MappedKey (Set MappedConsumer)

+ Keiro.Dsl.SemanticImpact: [impactDeclarationEvidence] :: SemanticImpact -> !Map MappedKey (Set MappedRootEvidence)

+ Keiro.Dsl.SemanticImpact: [impactDeclarationIdentities] :: SemanticImpact -> !Map MappedKey Text

+ Keiro.Dsl.SemanticImpact: [impactDeclaration] :: MappedImpactDelta -> !MappedKey

+ Keiro.Dsl.SemanticImpact: [impactPreviousConsequences] :: MappedImpactDelta -> !Maybe (Set MappedConsequence)

+ Keiro.Dsl.SemanticImpact: [impactPreviousConsumers] :: MappedImpactDelta -> !Set MappedConsumer

+ Keiro.Dsl.SemanticImpact: [impactPreviousEvidence] :: MappedImpactDelta -> !Maybe (Set MappedRootEvidence)

+ Keiro.Dsl.SemanticImpact: [impactRoots] :: SemanticImpact -> ![MappedRoot]

+ Keiro.Dsl.SemanticImpact: [impactServiceConformance] :: MappedImpactDelta -> !Bool

+ Keiro.Dsl.SemanticImpact: [impactServiceDeclarations] :: SemanticImpact -> !Set MappedKey

+ Keiro.Dsl.SemanticImpact: [impactUnsupportedProjectionSources] :: SemanticImpact -> ![UnsupportedProjectionSource]

+ Keiro.Dsl.SemanticImpact: [impactUsePaths] :: SemanticImpact -> !Map MappedKey [UsePath]

+ Keiro.Dsl.SemanticImpact: [mappedRootConsumer] :: MappedRoot -> !MappedConsumer

+ Keiro.Dsl.SemanticImpact: [mappedRootDeclaration] :: MappedRoot -> !MappedKey

+ Keiro.Dsl.SemanticImpact: [mappedRootKind] :: MappedRoot -> !MappedRootKind

+ Keiro.Dsl.SemanticImpact: [mappedRootUseSite] :: MappedRoot -> !UseSite

+ Keiro.Dsl.SemanticImpact: [semanticReportCurrent] :: SemanticImpactReport -> !SemanticImpactSnapshot

+ Keiro.Dsl.SemanticImpact: [semanticReportDeclarations] :: SemanticImpactReport -> ![MappedKey]

+ Keiro.Dsl.SemanticImpact: [semanticReportDeltas] :: SemanticImpactReport -> ![MappedImpactDelta]

+ Keiro.Dsl.SemanticImpact: [semanticReportPrevious] :: SemanticImpactReport -> !Maybe SemanticImpactSnapshot

+ Keiro.Dsl.SemanticImpact: [snapshotDeclarationIdentities] :: SemanticImpactSnapshot -> !Map MappedKey Text

+ Keiro.Dsl.SemanticImpact: [snapshotMappedConsequences] :: SemanticImpactSnapshot -> !Maybe (Map MappedKey (Set MappedConsequence))

+ Keiro.Dsl.SemanticImpact: [snapshotMappedConsumers] :: SemanticImpactSnapshot -> !Map MappedKey (Set MappedConsumer)

+ Keiro.Dsl.SemanticImpact: [snapshotMappedEvidence] :: SemanticImpactSnapshot -> !Maybe (Map MappedKey (Set MappedRootEvidence))

+ Keiro.Dsl.SemanticImpact: [snapshotServiceInventory] :: SemanticImpactSnapshot -> !Set MappedKey

+ Keiro.Dsl.SemanticImpact: aggregateMappedClosure :: SemanticImpact -> Name -> [MappedKey]

+ Keiro.Dsl.SemanticImpact: aggregateMappedRoots :: SemanticImpact -> Name -> [MappedRoot]

+ Keiro.Dsl.SemanticImpact: data DerivedMappedConsumer

+ Keiro.Dsl.SemanticImpact: data MappedConsequence

+ Keiro.Dsl.SemanticImpact: data MappedConsumer

+ Keiro.Dsl.SemanticImpact: data MappedImpactDelta

+ Keiro.Dsl.SemanticImpact: data MappedQueryPosition

+ Keiro.Dsl.SemanticImpact: data MappedRoot

+ Keiro.Dsl.SemanticImpact: data MappedRootEvidence

+ Keiro.Dsl.SemanticImpact: data MappedRootKind

+ Keiro.Dsl.SemanticImpact: data RouterSelectionPosition

+ Keiro.Dsl.SemanticImpact: data SemanticImpact

+ Keiro.Dsl.SemanticImpact: data SemanticImpactReport

+ Keiro.Dsl.SemanticImpact: data SemanticImpactSnapshot

+ Keiro.Dsl.SemanticImpact: data UnsupportedProjectionSource

+ Keiro.Dsl.SemanticImpact: diffSemanticImpact :: SemanticImpactSnapshot -> SemanticImpactSnapshot -> [MappedImpactDelta]

+ Keiro.Dsl.SemanticImpact: instance Data.Aeson.Types.FromJSON.FromJSON Keiro.Dsl.SemanticImpact.MappedConsequence

+ Keiro.Dsl.SemanticImpact: instance Data.Aeson.Types.FromJSON.FromJSON Keiro.Dsl.SemanticImpact.MappedImpactDelta

+ Keiro.Dsl.SemanticImpact: instance Data.Aeson.Types.FromJSON.FromJSON Keiro.Dsl.SemanticImpact.MappedRootEvidence

+ Keiro.Dsl.SemanticImpact: instance Data.Aeson.Types.FromJSON.FromJSON Keiro.Dsl.SemanticImpact.SemanticImpactSnapshot

+ Keiro.Dsl.SemanticImpact: instance Data.Aeson.Types.ToJSON.ToJSON Keiro.Dsl.SemanticImpact.MappedConsequence

+ Keiro.Dsl.SemanticImpact: instance Data.Aeson.Types.ToJSON.ToJSON Keiro.Dsl.SemanticImpact.MappedImpactDelta

+ Keiro.Dsl.SemanticImpact: instance Data.Aeson.Types.ToJSON.ToJSON Keiro.Dsl.SemanticImpact.MappedRootEvidence

+ Keiro.Dsl.SemanticImpact: instance Data.Aeson.Types.ToJSON.ToJSON Keiro.Dsl.SemanticImpact.SemanticImpactSnapshot

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Eq Keiro.Dsl.SemanticImpact.MappedConsequence

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Eq Keiro.Dsl.SemanticImpact.MappedConsumer

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Eq Keiro.Dsl.SemanticImpact.MappedImpactDelta

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Eq Keiro.Dsl.SemanticImpact.MappedQueryPosition

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Eq Keiro.Dsl.SemanticImpact.MappedRoot

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Eq Keiro.Dsl.SemanticImpact.MappedRootEvidence

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Eq Keiro.Dsl.SemanticImpact.MappedRootKind

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Eq Keiro.Dsl.SemanticImpact.RouterSelectionPosition

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Eq Keiro.Dsl.SemanticImpact.SemanticImpact

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Eq Keiro.Dsl.SemanticImpact.SemanticImpactReport

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Eq Keiro.Dsl.SemanticImpact.SemanticImpactSnapshot

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Ord Keiro.Dsl.SemanticImpact.MappedConsequence

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Ord Keiro.Dsl.SemanticImpact.MappedConsumer

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Ord Keiro.Dsl.SemanticImpact.MappedQueryPosition

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Ord Keiro.Dsl.SemanticImpact.MappedRoot

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Ord Keiro.Dsl.SemanticImpact.MappedRootEvidence

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Ord Keiro.Dsl.SemanticImpact.MappedRootKind

+ Keiro.Dsl.SemanticImpact: instance GHC.Classes.Ord Keiro.Dsl.SemanticImpact.RouterSelectionPosition

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.SemanticImpact.MappedConsequence

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.SemanticImpact.MappedConsumer

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.SemanticImpact.MappedImpactDelta

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.SemanticImpact.MappedQueryPosition

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.SemanticImpact.MappedRoot

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.SemanticImpact.MappedRootEvidence

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.SemanticImpact.MappedRootKind

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.SemanticImpact.RouterSelectionPosition

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.SemanticImpact.SemanticImpact

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.SemanticImpact.SemanticImpactReport

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Generics.Generic Keiro.Dsl.SemanticImpact.SemanticImpactSnapshot

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Show.Show Keiro.Dsl.SemanticImpact.MappedConsequence

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Show.Show Keiro.Dsl.SemanticImpact.MappedConsumer

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Show.Show Keiro.Dsl.SemanticImpact.MappedImpactDelta

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Show.Show Keiro.Dsl.SemanticImpact.MappedQueryPosition

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Show.Show Keiro.Dsl.SemanticImpact.MappedRoot

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Show.Show Keiro.Dsl.SemanticImpact.MappedRootEvidence

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Show.Show Keiro.Dsl.SemanticImpact.MappedRootKind

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Show.Show Keiro.Dsl.SemanticImpact.RouterSelectionPosition

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Show.Show Keiro.Dsl.SemanticImpact.SemanticImpact

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Show.Show Keiro.Dsl.SemanticImpact.SemanticImpactReport

+ Keiro.Dsl.SemanticImpact: instance GHC.Internal.Show.Show Keiro.Dsl.SemanticImpact.SemanticImpactSnapshot

+ Keiro.Dsl.SemanticImpact: mappedConsequenceIdentity :: MappedConsequence -> Text

+ Keiro.Dsl.SemanticImpact: mappedConsumerIdentity :: MappedConsumer -> Name

+ Keiro.Dsl.SemanticImpact: mappedDeclarationConsumers :: SemanticImpact -> MappedKey -> [MappedConsumer]

+ Keiro.Dsl.SemanticImpact: mappedImpactForDeclarations :: [MappedKey] -> SemanticImpactSnapshot -> SemanticImpactSnapshot -> [MappedImpactDelta]

+ Keiro.Dsl.SemanticImpact: mappedRootKindIdentity :: MappedRootKind -> Text

+ Keiro.Dsl.SemanticImpact: mappedSurfaceFactValues :: SemanticImpact -> [(Text, Text)]

+ Keiro.Dsl.SemanticImpact: semanticImpact :: TypeGraph -> SemanticImpact

+ Keiro.Dsl.SemanticImpact: semanticImpactForService :: CheckedService -> TypeGraph -> SemanticImpact

+ Keiro.Dsl.SemanticImpact: semanticImpactReport :: Maybe SemanticImpactSnapshot -> SemanticImpactSnapshot -> [MappedKey] -> SemanticImpactReport

+ Keiro.Dsl.SemanticImpact: semanticImpactSnapshot :: SemanticImpact -> SemanticImpactSnapshot

+ Keiro.Dsl.SemanticImpact: serviceMappedInventory :: SemanticImpact -> [MappedKey]

+ Keiro.Dsl.SourceIndex: AggregateStateSubject :: !Name -> !Name -> SourceSubject

+ Keiro.Dsl.SourceIndex: AggregateTransitionSubject :: !Name -> !TransitionOrdinal -> SourceSubject

+ Keiro.Dsl.SourceIndex: CompatibilityLineOnly :: SourcePositionQuality

+ Keiro.Dsl.SourceIndex: DuplicateSourceSubject :: SourceIndexFailureCode

+ Keiro.Dsl.SourceIndex: ExactSourcePosition :: SourcePositionQuality

+ Keiro.Dsl.SourceIndex: MissingSourceSubject :: SourceIndexFailureCode

+ Keiro.Dsl.SourceIndex: ParsedSourceDocument :: !ParsedSource -> !SemanticSourceIndex -> ParsedSourceDocument

+ Keiro.Dsl.SourceIndex: SourceIndexFailure :: !SourceIndexFailureCode -> !Maybe SourceSubject -> !Maybe SourceSpan -> !Text -> SourceIndexFailure

+ Keiro.Dsl.SourceIndex: SourceIndexFileMismatch :: SourceIndexFailureCode

+ Keiro.Dsl.SourceIndex: TransitionOrdinal :: Int -> TransitionOrdinal

+ Keiro.Dsl.SourceIndex: UnexpectedSourceSubject :: SourceIndexFailureCode

+ Keiro.Dsl.SourceIndex: [documentParsedSource] :: ParsedSourceDocument -> !ParsedSource

+ Keiro.Dsl.SourceIndex: [documentSourceIndex] :: ParsedSourceDocument -> !SemanticSourceIndex

+ Keiro.Dsl.SourceIndex: [failureCode] :: SourceIndexFailure -> !SourceIndexFailureCode

+ Keiro.Dsl.SourceIndex: [failureMessage] :: SourceIndexFailure -> !Text

+ Keiro.Dsl.SourceIndex: [failureSpan] :: SourceIndexFailure -> !Maybe SourceSpan

+ Keiro.Dsl.SourceIndex: [failureSubject] :: SourceIndexFailure -> !Maybe SourceSubject

+ Keiro.Dsl.SourceIndex: compatibilitySemanticSourceIndex :: FilePath -> Spec -> Either SourceIndexFailure SemanticSourceIndex

+ Keiro.Dsl.SourceIndex: data ParsedSourceDocument

+ Keiro.Dsl.SourceIndex: data SemanticSourceIndex

+ Keiro.Dsl.SourceIndex: data SourceIndexFailure

+ Keiro.Dsl.SourceIndex: data SourceIndexFailureCode

+ Keiro.Dsl.SourceIndex: data SourcePositionQuality

+ Keiro.Dsl.SourceIndex: data SourceSubject

+ Keiro.Dsl.SourceIndex: emptySemanticSourceIndex :: SemanticSourceIndex

+ Keiro.Dsl.SourceIndex: exactSemanticSourceIndex :: FilePath -> [SourceSubject] -> [(SourceSubject, SourceSpan)] -> Either SourceIndexFailure SemanticSourceIndex

+ Keiro.Dsl.SourceIndex: instance GHC.Classes.Eq Keiro.Dsl.SourceIndex.IndexedSourcePosition

+ Keiro.Dsl.SourceIndex: instance GHC.Classes.Eq Keiro.Dsl.SourceIndex.ParsedSourceDocument

+ Keiro.Dsl.SourceIndex: instance GHC.Classes.Eq Keiro.Dsl.SourceIndex.SemanticSourceIndex

+ Keiro.Dsl.SourceIndex: instance GHC.Classes.Eq Keiro.Dsl.SourceIndex.SourceIndexFailure

+ Keiro.Dsl.SourceIndex: instance GHC.Classes.Eq Keiro.Dsl.SourceIndex.SourceIndexFailureCode

+ Keiro.Dsl.SourceIndex: instance GHC.Classes.Eq Keiro.Dsl.SourceIndex.SourcePositionQuality

+ Keiro.Dsl.SourceIndex: instance GHC.Classes.Eq Keiro.Dsl.SourceIndex.SourceSubject

+ Keiro.Dsl.SourceIndex: instance GHC.Classes.Eq Keiro.Dsl.SourceIndex.TransitionOrdinal

+ Keiro.Dsl.SourceIndex: instance GHC.Classes.Ord Keiro.Dsl.SourceIndex.SourceIndexFailureCode

+ Keiro.Dsl.SourceIndex: instance GHC.Classes.Ord Keiro.Dsl.SourceIndex.SourcePositionQuality

+ Keiro.Dsl.SourceIndex: instance GHC.Classes.Ord Keiro.Dsl.SourceIndex.SourceSubject

+ Keiro.Dsl.SourceIndex: instance GHC.Classes.Ord Keiro.Dsl.SourceIndex.TransitionOrdinal

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Generics.Generic Keiro.Dsl.SourceIndex.IndexedSourcePosition

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Generics.Generic Keiro.Dsl.SourceIndex.ParsedSourceDocument

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Generics.Generic Keiro.Dsl.SourceIndex.SemanticSourceIndex

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Generics.Generic Keiro.Dsl.SourceIndex.SourceIndexFailure

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Generics.Generic Keiro.Dsl.SourceIndex.SourceIndexFailureCode

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Generics.Generic Keiro.Dsl.SourceIndex.SourcePositionQuality

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Generics.Generic Keiro.Dsl.SourceIndex.SourceSubject

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Generics.Generic Keiro.Dsl.SourceIndex.TransitionOrdinal

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Show.Show Keiro.Dsl.SourceIndex.IndexedSourcePosition

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Show.Show Keiro.Dsl.SourceIndex.ParsedSourceDocument

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Show.Show Keiro.Dsl.SourceIndex.SemanticSourceIndex

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Show.Show Keiro.Dsl.SourceIndex.SourceIndexFailure

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Show.Show Keiro.Dsl.SourceIndex.SourceIndexFailureCode

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Show.Show Keiro.Dsl.SourceIndex.SourcePositionQuality

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Show.Show Keiro.Dsl.SourceIndex.SourceSubject

+ Keiro.Dsl.SourceIndex: instance GHC.Internal.Show.Show Keiro.Dsl.SourceIndex.TransitionOrdinal

+ Keiro.Dsl.SourceIndex: lookupSourceSpan :: SourceSubject -> SemanticSourceIndex -> Maybe (SourcePositionQuality, SourceSpan)

+ Keiro.Dsl.SourceIndex: newtype TransitionOrdinal

+ Keiro.Dsl.SourceIndex: repathSemanticSourceIndex :: FilePath -> FilePath -> SemanticSourceIndex -> Either SourceIndexFailure SemanticSourceIndex

+ Keiro.Dsl.SourceIndex: semanticSourceEntries :: SemanticSourceIndex -> [(SourceSubject, SourcePositionQuality, SourceSpan)]

+ Keiro.Dsl.SourceIndex: semanticSourceSubjects :: Spec -> [SourceSubject]

+ Keiro.Dsl.SourceIndex: unionSemanticSourceIndexes :: [SemanticSourceIndex] -> Either SourceIndexFailure SemanticSourceIndex

+ Keiro.Dsl.StructuralConformance: StructuralConformanceGraphFailure :: !Text -> StructuralConformanceFailure

+ Keiro.Dsl.StructuralConformance: StructuralConformanceInventoryMissing :: !MappedKey -> StructuralConformanceFailure

+ Keiro.Dsl.StructuralConformance: data StructuralConformanceFailure

+ Keiro.Dsl.StructuralConformance: hasStructuralConformance :: CheckedService -> Bool

+ Keiro.Dsl.StructuralConformance: instance GHC.Classes.Eq Keiro.Dsl.StructuralConformance.StructuralConformanceFailure

+ Keiro.Dsl.StructuralConformance: instance GHC.Internal.Show.Show Keiro.Dsl.StructuralConformance.StructuralConformanceFailure

+ Keiro.Dsl.StructuralConformance: structuralConformanceModule :: Context -> CheckedService -> Either [StructuralConformanceFailure] (Maybe ScaffoldModule)

+ Keiro.Dsl.StructuralConformance: structuralConformanceModuleName :: Context -> Text

+ Keiro.Dsl.Syntax: SurfaceAggregateState :: !Name -> !Name -> SurfaceElement

+ Keiro.Dsl.Syntax: SurfaceAggregateTransition :: !Name -> !Int -> SurfaceElement

+ Keiro.Dsl.TypeGraph: AggregateInlineProjectionConsumer :: !Name -> !Name -> DerivedMappedConsumer

+ Keiro.Dsl.TypeGraph: CatalogProjectionConsumer :: !Name -> !Name -> DerivedMappedConsumer

+ Keiro.Dsl.TypeGraph: RootReadModelQueryInput :: !Name -> !MappedKey -> UseSite

+ Keiro.Dsl.TypeGraph: RootReadModelQueryResult :: !Name -> !MappedKey -> UseSite

+ Keiro.Dsl.TypeGraph: RootWorkqueueField :: !Name -> !Name -> !MappedKey -> UseSite

+ Keiro.Dsl.TypeGraph: TGUnresolvedConsumerRef :: !Text -> !Name -> !Loc -> TypeGraphError

+ Keiro.Dsl.TypeGraph: UnsupportedCatalogAll :: !Name -> UnsupportedProjectionSource

+ Keiro.Dsl.TypeGraph: UnsupportedCatalogCategory :: !Name -> !Text -> UnsupportedProjectionSource

+ Keiro.Dsl.TypeGraph: [tgDerivedMappedConsumers] :: TypeGraph -> ![DerivedMappedConsumer]

+ Keiro.Dsl.TypeGraph: [tgProjectionOperationalIdentities] :: TypeGraph -> !Map DerivedMappedConsumer Text

+ Keiro.Dsl.TypeGraph: [tgReplayableProjectionGroups] :: TypeGraph -> !Map DerivedMappedConsumer Name

+ Keiro.Dsl.TypeGraph: [tgRootSegments] :: TypeGraph -> !Map UseSite [PathSeg]

+ Keiro.Dsl.TypeGraph: [tgUnsupportedProjectionSources] :: TypeGraph -> ![UnsupportedProjectionSource]

+ Keiro.Dsl.TypeGraph: data DerivedMappedConsumer

+ Keiro.Dsl.TypeGraph: data UnsupportedProjectionSource

+ Keiro.Dsl.TypeGraph: instance GHC.Classes.Eq Keiro.Dsl.TypeGraph.DerivedMappedConsumer

+ Keiro.Dsl.TypeGraph: instance GHC.Classes.Eq Keiro.Dsl.TypeGraph.UnsupportedProjectionSource

+ Keiro.Dsl.TypeGraph: instance GHC.Classes.Ord Keiro.Dsl.TypeGraph.DerivedMappedConsumer

+ Keiro.Dsl.TypeGraph: instance GHC.Classes.Ord Keiro.Dsl.TypeGraph.UnsupportedProjectionSource

+ Keiro.Dsl.TypeGraph: instance GHC.Internal.Generics.Generic Keiro.Dsl.TypeGraph.DerivedMappedConsumer

+ Keiro.Dsl.TypeGraph: instance GHC.Internal.Generics.Generic Keiro.Dsl.TypeGraph.UnsupportedProjectionSource

+ Keiro.Dsl.TypeGraph: instance GHC.Internal.Show.Show Keiro.Dsl.TypeGraph.DerivedMappedConsumer

+ Keiro.Dsl.TypeGraph: instance GHC.Internal.Show.Show Keiro.Dsl.TypeGraph.UnsupportedProjectionSource

+ Keiro.Dsl.TypeGraph: resolveTypeExpression :: TypeGraph -> Text -> Loc -> TypeExpr -> Either TypeGraphError ResolvedTypeExpr

+ Keiro.Dsl.TypeGraph: useSiteSegments :: TypeGraph -> UseSite -> [PathSeg]

+ Keiro.Dsl.Validate: BehaviorSourceAnchorCollision :: DiagnosticCode

+ Keiro.Dsl.Validate: BehaviorSourceAnchorInexact :: DiagnosticCode

+ Keiro.Dsl.Validate: BehaviorSourceAnchorMissing :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogAmbiguousSourceOrdering :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogAsyncIdentityMissing :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogAsyncQueryBindingMissing :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogCheckpointPolicyChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogCheckpointPolicyDuplicate :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogCheckpointPolicyMissing :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogCheckpointPolicyReplayUnsafe :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogCheckpointPolicyUnexpected :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogClearTargetLiveOnly :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogDuplicateHandlerOrder :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogExternalReadCompatibilityChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogExternalReadCompatibilityInvalid :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogExternalReadContractChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogExternalReadIdentityInvalid :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogExternalReadQueryUnknown :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogExternalReadResultShapeChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogExternalReadRetired :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogExternalReadRevisionGroupMismatch :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogExternalReadRevisionUnknown :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogExternalReadSurfaceGenerationInvalid :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogExternalReadTargetCardinalityInvalid :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogExternalReadVersionAdded :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogExternalReadVersionInvalid :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogFeedIdentityChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogGroupChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogGroupEmpty :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogGroupOrderMismatch :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogGroupUnknown :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogHandlerOrderChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogInlineIdentityUnexpected :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogOwnerChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogOwnerRemoved :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogPhysicalTargetDuplicate :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogProjectionNoSource :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogProjectionNoTarget :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogProjectionRevisionChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogProjectionRevisionRemoved :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogProjectionTargetOutsideGroup :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogQueryBindingChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogQueryWaitWithAmbiguousCursor :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogQueryWaitWithoutCompatibleCursor :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogReadModelBackingRequired :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogReadModelBackingUnobserved :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogReadModelBindingMissing :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogReadModelLegacyProjectionConflict :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogReadModelMultipleSuppliers :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogReadModelPhysicalOverride :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogReadModelSupplierMissing :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogReadModelTargetOutsideGroup :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogReplayPolicyChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogRevisionDuplicateTarget :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogRevisionGroupUnknown :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogRevisionIdentityInvalid :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogRevisionNoTarget :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogRevisionPromotionNameInvalid :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogRevisionTargetSetMismatch :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogRevisionTargetUnknown :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogSourceChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogSourceOverlap :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogSourceUnresolved :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogTargetAdded :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogTargetDependencyChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogTargetDependencyCycle :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogTargetDependencyOutsideGroup :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogTargetDependencyUnknown :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogTargetLocationChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogTargetMultiplyOwned :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogTargetRemoved :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogTargetResetPolicyChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogTargetSchemaChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogTargetUnknown :: DiagnosticCode

+ Keiro.Dsl.Validate: CatalogTargetUnowned :: DiagnosticCode

+ Keiro.Dsl.Validate: DomainOutcomeAcceptedWithoutEvents :: DiagnosticCode

+ Keiro.Dsl.Validate: DomainOutcomeClauseDuplicate :: DiagnosticCode

+ Keiro.Dsl.Validate: DomainOutcomeClauseMissing :: DiagnosticCode

+ Keiro.Dsl.Validate: DomainOutcomeDeclarationDuplicate :: DiagnosticCode

+ Keiro.Dsl.Validate: DomainOutcomeDeclarationMissing :: DiagnosticCode

+ Keiro.Dsl.Validate: DomainOutcomeReasonTypeMismatch :: DiagnosticCode

+ Keiro.Dsl.Validate: DomainOutcomeReplayOnlyClause :: DiagnosticCode

+ Keiro.Dsl.Validate: DomainOutcomeSilentEmits :: DiagnosticCode

+ Keiro.Dsl.Validate: DomainOutcomeSilentStateChange :: DiagnosticCode

+ Keiro.Dsl.Validate: DomainOutcomeSilentWrites :: DiagnosticCode

+ Keiro.Dsl.Validate: DomainOutcomeTypeUnresolved :: DiagnosticCode

+ Keiro.Dsl.Validate: DomainOutcomeTypesChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: DomainTransitionOutcomeChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: MappedQueueLoweringPending :: DiagnosticCode

+ Keiro.Dsl.Validate: MappedReadModelLoweringPending :: DiagnosticCode

+ Keiro.Dsl.Validate: ProjectionDeliveryChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: QueryFreshnessChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: ReadModelQueryInputChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: ReadModelQueryResultChanged :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionCapabilityUnavailable :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionCommandMappingDuplicate :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionCommandMappingIncomplete :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionCommandMappingTypeMismatch :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionCommandUnknown :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionDedupeUnsupported :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionExpressionFieldOptional :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionExpressionFieldUnknown :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionExpressionRootUnknown :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionExpressionTypeMismatch :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionFailureAckForbidden :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionIdentityEmpty :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionNotDeclarative :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionOperatorUnsupported :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionOrderUnsupported :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionPartialDispatchUnsupported :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionPredicateNotBool :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionQueryContractMissing :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionQueryInputBindingInvalid :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionQueryInputTypeMismatch :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionQueryResultNotList :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionQueryRowNotStructural :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionQueryUnknown :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionRecipientLimitInvalid :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionRecipientLimitMissing :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionRecipientNotText :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionRedeliveryUnsupported :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionTargetAmbiguous :: DiagnosticCode

+ Keiro.Dsl.Validate: RouterSelectionVersionInvalid :: DiagnosticCode

+ Keiro.Dsl.Validate: WorkspaceSourceIndexInvalid :: DiagnosticCode

+ Keiro.Dsl.Workspace: [wmSourceIndex] :: WorkspaceMember -> !SemanticSourceIndex

+ Keiro.Dsl.Workspace: [wsSourceIndex] :: WorkspaceSpec -> !SemanticSourceIndex

+ Keiro.Dsl.Workspace: checkWorkspaceForService :: WorkspaceSpec -> CheckedService -> [WorkspaceDiagnostic]

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs GHC.Num.Natural.Natural

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.CatalogSource

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.CheckpointOnMissingNode

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.DomainOutcomeTypes

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.ExternalReadNode

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.ProjectionDelivery

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.ProjectionOwnerNode

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.ProjectionReplayPolicy

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.ProjectionRevisionNode

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.ProjectionTargetNode

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.PromotionObjectKindNode

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.PromotionObjectNode

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.QueryFreshnessNode

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.QueuePayloadType

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.QueueScalar

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.ReadModelQueryTypes

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.ReadModelSupply

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.RebuildGroupNode

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.RevisionTargetNode

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.RouterSelectionDecl

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.SelectionDispositionSyntax

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.TargetResetPolicy

+ Keiro.Dsl.Workspace: instance Keiro.Dsl.Workspace.HasLocs Keiro.Dsl.Grammar.TransitionOutcome

+ Keiro.Dsl.Workspace: oneMemberParsedDocumentWorkspace :: FilePath -> ParsedSourceDocument -> Either SourceIndexFailure WorkspaceSpec

+ Keiro.Dsl.WorkspaceDiff: workspaceDiffReportWithCoordinationImpact :: WorkspaceMeta -> Set CompatibilitySurface -> [WorkspaceChange] -> [CoordinationImpact] -> WorkspaceDiffReport

+ Keiro.Dsl.WorkspaceDiff: workspaceDiffReportWithImpacts :: WorkspaceMeta -> Set CompatibilitySurface -> [WorkspaceChange] -> [MappedImpactDelta] -> [CoordinationImpact] -> WorkspaceDiffReport

+ Keiro.Dsl.WorkspaceDiff: workspaceDiffReportWithSemanticImpact :: WorkspaceMeta -> Set CompatibilitySurface -> [WorkspaceChange] -> [MappedImpactDelta] -> WorkspaceDiffReport

+ Keiro.Dsl.WorkspaceRecord: [wrProjectionCatalogFacts] :: WorkspaceRecord -> ![Text]

+ Keiro.Dsl.WorkspaceRecord: [wrQueryContractBaseline] :: WorkspaceRecord -> !Bool

+ Keiro.Dsl.WorkspaceRecord: [wrQueryContracts] :: WorkspaceRecord -> ![QueryContractIdentity]

+ Keiro.Dsl.WorkspaceRecord: [wrRouterSelections] :: WorkspaceRecord -> ![RouterSelectionSnapshot]

+ Keiro.Dsl.WorkspaceRecord: [wrSemanticImpact] :: WorkspaceRecord -> !Maybe SemanticImpactSnapshot

+ Keiro.Dsl.WorkspaceScaffold: [wsrGeneratedArtifactImpact] :: WorkspaceScaffoldReport -> ![GeneratedArtifactImpact]

+ Keiro.Dsl.WorkspaceScaffold: [wsrProjectionMappedImpact] :: WorkspaceScaffoldReport -> !Maybe ProjectionMappedImpact

+ Keiro.Dsl.WorkspaceScaffold: [wsrQueryContractBaselineUnavailable] :: WorkspaceScaffoldReport -> !Bool

+ Keiro.Dsl.WorkspaceScaffold: [wsrQueryContractDrift] :: WorkspaceScaffoldReport -> ![QueryContractDrift]

+ Keiro.Dsl.WorkspaceScaffold: [wsrQueryContractMigrations] :: WorkspaceScaffoldReport -> ![QueryContractMigration]

+ Keiro.Dsl.WorkspaceScaffold: [wsrRouterSelectionDrift] :: WorkspaceScaffoldReport -> ![RouterSelectionDrift]

+ Keiro.Dsl.WorkspaceScaffold: [wsrSemanticImpact] :: WorkspaceScaffoldReport -> !SemanticImpactReport

- Keiro.Dsl.BehaviorCoverage: BehaviorRequirement :: !BehaviorKey -> !ObligationKind -> !EvidenceLevel -> !GuardCoverage -> !Name -> !Name -> !Name -> !Name -> !Maybe Name -> !Maybe TransitionMode -> ![Name] -> ![OutputEvidence] -> !Loc -> !Maybe FilePath -> !Text -> BehaviorRequirement

+ Keiro.Dsl.BehaviorCoverage: BehaviorRequirement :: !BehaviorKey -> !RequirementOrigin -> !ObligationKind -> !EvidenceLevel -> !GuardCoverage -> !Name -> !Name -> !Name -> !Name -> !Maybe Name -> !Maybe TransitionMode -> ![Name] -> ![OutputEvidence] -> !Maybe TransitionOutcome -> !Loc -> !Maybe BehaviorExactLocation -> !Maybe FilePath -> !Text -> BehaviorRequirement

- Keiro.Dsl.Coverage: CoverageDelta :: !Int -> !Int -> !Int -> ![OpaqueBoundary] -> ![OpaqueBoundary] -> CoverageDelta

+ Keiro.Dsl.Coverage: CoverageDelta :: !Int -> !Int -> !Int -> !Int -> !Int -> !Int -> !Int -> !Int -> ![OpaqueBoundary] -> ![OpaqueBoundary] -> CoverageDelta

- Keiro.Dsl.Coverage: CoverageRoot :: !CoverageSurface -> !Text -> !Text -> !CoverageMode -> !Maybe Text -> !Maybe Text -> !Maybe Text -> !Text -> CoverageRoot

+ Keiro.Dsl.Coverage: CoverageRoot :: !CoverageSurface -> !Text -> !Text -> !Text -> !CoverageMode -> !Maybe Text -> !Maybe Text -> !Maybe Text -> !Text -> CoverageRoot

- Keiro.Dsl.Coverage: CoverageSummary :: !CoverageCounts -> !CoverageCounts -> CoverageSummary

+ Keiro.Dsl.Coverage: CoverageSummary :: !CoverageCounts -> !CoverageCounts -> !CoverageCounts -> !CoverageCounts -> !CoverageCounts -> !CoverageCounts -> !CoverageCounts -> CoverageSummary

- Keiro.Dsl.Coverage: JsonBoundary :: !Text -> !Text -> JsonBoundary

+ Keiro.Dsl.Coverage: JsonBoundary :: !CoverageSurface -> !Text -> !Text -> JsonBoundary

- Keiro.Dsl.Diff: ChangeKind :: !Name -> !Text -> !Text -> !DiagnosticCode -> !ChangeContext -> !CompatibilityVector -> ![Text] -> !Text -> ChangeKind

+ Keiro.Dsl.Diff: ChangeKind :: !Name -> !Text -> !Text -> !DiagnosticCode -> !ChangeContext -> !CompatibilityVector -> !Maybe MappedPersistedImpact -> !Set MappedConsequence -> ![Text] -> !Text -> ChangeKind

- Keiro.Dsl.Grammar: Aggregate :: !Name -> ![RegDecl] -> ![StateDecl] -> ![Command] -> ![Event] -> ![Transition] -> !Maybe WireSpec -> !Maybe ProjectionSpec -> !Maybe SnapshotSpec -> !Loc -> Aggregate

+ Keiro.Dsl.Grammar: Aggregate :: !Name -> ![RegDecl] -> ![StateDecl] -> ![Command] -> ![Event] -> ![Transition] -> !Maybe DomainOutcomeTypes -> ![Loc] -> !Maybe WireSpec -> !Maybe ProjectionSpec -> !Maybe SnapshotSpec -> !Loc -> Aggregate

- Keiro.Dsl.Grammar: InputDecl :: !Name -> ![Field] -> InputDecl

+ Keiro.Dsl.Grammar: InputDecl :: !Name -> ![Field] -> !Maybe TypeExpr -> !Loc -> InputDecl

- Keiro.Dsl.Grammar: ReadModelNode :: !Name -> !Text -> !Text -> ![RmColumn] -> !Int -> !Text -> !Consistency -> !Maybe RmScope -> !RmFeed -> !Maybe Text -> !Loc -> ReadModelNode

+ Keiro.Dsl.Grammar: ReadModelNode :: !Name -> !Text -> !Text -> ![RmColumn] -> !Int -> !Text -> !QueryFreshnessNode -> !ReadModelSupply -> !Maybe Name -> ![Name] -> !Maybe Name -> !Maybe ReadModelQueryTypes -> !Loc -> ReadModelNode

- Keiro.Dsl.Grammar: Transition :: !Name -> !Name -> !TransitionImplementation -> !Maybe Expr -> ![(Name, Expr)] -> ![Name] -> !Name -> !TransitionMode -> !Loc -> Transition

+ Keiro.Dsl.Grammar: Transition :: !Name -> !Name -> !TransitionImplementation -> !Maybe Expr -> ![(Name, Expr)] -> ![Name] -> !Maybe TransitionOutcome -> ![Loc] -> !Name -> !TransitionMode -> !Loc -> Transition

- Keiro.Dsl.Grammar: WqField :: !Name -> !Text -> !Name -> WqField

+ Keiro.Dsl.Grammar: WqField :: !Name -> !Text -> !QueuePayloadType -> !Loc -> WqField

- Keiro.Dsl.Grammar: [wqfType] :: WqField -> !Name

+ Keiro.Dsl.Grammar: [wqfType] :: WqField -> !QueuePayloadType

- Keiro.Dsl.Harness: harnessReadModel :: Context -> ReadModelNode -> [ScaffoldModule]

+ Keiro.Dsl.Harness: harnessReadModel :: Context -> Spec -> ReadModelNode -> [ScaffoldModule]

- Keiro.Dsl.LanguageVersion: LanguageDefinition :: !LanguageVersion -> !Maybe LanguageVersion -> !LanguageBodyParser -> !SyntaxProfile -> !RuntimeSemanticsProfile -> !LanguageSupport -> LanguageDefinition

+ Keiro.Dsl.LanguageVersion: LanguageDefinition :: !LanguageVersion -> !Maybe LanguageVersion -> !LanguageBodyParser -> !SyntaxProfile -> !RuntimeSemanticsProfile -> !LanguageSupport -> !LanguageMaturity -> LanguageDefinition

- Keiro.Dsl.Scaffold: Agg :: !Context -> !EffectiveLanguageContract -> !Spec -> !Aggregate -> !Text -> !Text -> !Loc -> !Text -> ![IdDecl] -> ![EnumDecl] -> ![ResolvedRegister] -> ![StateDecl] -> ![ResolvedCtor] -> ![ResolvedCtor] -> ![ResolvedNominalType] -> ![Transition] -> !Map (Int, Int) EventOutputMapping -> !WireSpec -> !Maybe ProjectionSpec -> !Maybe SnapshotSpec -> !Text -> ![ReadModelNode] -> !Maybe TypeGraph -> !AggregateSymbols -> !Text -> !Text -> Agg

+ Keiro.Dsl.Scaffold: Agg :: !Context -> !CheckedService -> !EffectiveLanguageContract -> !Spec -> !Aggregate -> !Text -> !Text -> !Loc -> !Text -> ![IdDecl] -> ![EnumDecl] -> ![ResolvedRegister] -> ![StateDecl] -> ![ResolvedCtor] -> ![ResolvedCtor] -> !Maybe ResolvedDomainOutcomeTypes -> ![ResolvedNominalType] -> ![Transition] -> !Map (Int, Int) EventOutputMapping -> !WireSpec -> !Maybe ProjectionSpec -> !Maybe SnapshotSpec -> !Text -> ![ReadModelNode] -> !Maybe TypeGraph -> !AggregateSymbols -> !Text -> !Text -> Agg

- Keiro.Dsl.ScaffoldRecord: ScaffoldRecord :: !Text -> !Text -> !Text -> !SourceLanguage -> !EffectiveLanguageContract -> !GeneratedHaskellNamingEdition -> ![ScaffoldModuleRoleRow] -> ![(ModuleKind, FilePath)] -> ![MappingIdentity] -> ![Text] -> ![Text] -> ![BindingHole] -> ![BehaviorRecordRow] -> ScaffoldRecord

+ Keiro.Dsl.ScaffoldRecord: ScaffoldRecord :: !Text -> !Text -> !Text -> !SourceLanguage -> !EffectiveLanguageContract -> !GeneratedHaskellNamingEdition -> ![ScaffoldModuleRoleRow] -> ![(ModuleKind, FilePath)] -> ![MappingIdentity] -> ![Text] -> ![Text] -> ![BindingHole] -> ![BehaviorRecordRow] -> ![Text] -> !Bool -> ![QueryContractIdentity] -> ![RouterSelectionSnapshot] -> !Maybe SemanticImpactSnapshot -> ScaffoldRecord

- Keiro.Dsl.ScaffoldRun: ScaffoldReport :: !FilePath -> !FilePath -> !Context -> ![(ScaffoldModule, WriteDisposition)] -> ![(Text, Text)] -> !FilePath -> !FilePath -> !Maybe Text -> ![StaleModule] -> !ConsumerPlan -> ![Text] -> ![MappingDrift] -> !Maybe SourceLanguageDrift -> ![BindingHole] -> ![BehaviorRecordRow] -> ![BehaviorRecordRow] -> ![(Text, Text)] -> !Maybe ConformancePackageReport -> ![SourceMove] -> ![SidecarMove] -> ScaffoldReport

+ Keiro.Dsl.ScaffoldRun: ScaffoldReport :: !FilePath -> !FilePath -> !Context -> ![(ScaffoldModule, WriteDisposition)] -> ![(Text, Text)] -> !FilePath -> !FilePath -> !Maybe Text -> ![StaleModule] -> !ConsumerPlan -> ![Text] -> ![MappingDrift] -> !Bool -> ![QueryContractDrift] -> ![QueryContractMigration] -> !SemanticImpactReport -> ![RouterSelectionDrift] -> !Maybe ProjectionMappedImpact -> ![GeneratedArtifactImpact] -> !Maybe SourceLanguageDrift -> ![BindingHole] -> ![BehaviorRecordRow] -> ![BehaviorRecordRow] -> ![(Text, Text)] -> !Maybe ConformancePackageReport -> ![SourceMove] -> ![SidecarMove] -> ScaffoldReport

- Keiro.Dsl.TypeGraph: TypeGraph :: !Map MappedKey ResolvedMappedDecl -> !Map MappedKey (Set MappedKey) -> ![UseSite] -> TypeGraph

+ Keiro.Dsl.TypeGraph: TypeGraph :: !Map MappedKey ResolvedMappedDecl -> !Map MappedKey (Set MappedKey) -> ![UseSite] -> !Map UseSite [PathSeg] -> ![DerivedMappedConsumer] -> !Map DerivedMappedConsumer Name -> !Map DerivedMappedConsumer Text -> ![UnsupportedProjectionSource] -> TypeGraph

- Keiro.Dsl.Workspace: WorkspaceMember :: !FilePath -> !Spec -> !SourceLanguage -> !Int -> !Int -> WorkspaceMember

+ Keiro.Dsl.Workspace: WorkspaceMember :: !FilePath -> !Spec -> !SourceLanguage -> !SemanticSourceIndex -> !Int -> !Int -> WorkspaceMember

- Keiro.Dsl.Workspace: WorkspaceSpec :: !Text -> !FilePath -> !EffectiveLanguageContract -> !Name -> !Maybe RuntimePackageName -> !Maybe Text -> !Maybe Placement -> ![WorkspaceMember] -> !Spec -> !LineMap -> !OwnershipIndex -> WorkspaceSpec

+ Keiro.Dsl.Workspace: WorkspaceSpec :: !Text -> !FilePath -> !EffectiveLanguageContract -> !Name -> !Maybe RuntimePackageName -> !Maybe Text -> !Maybe Placement -> ![WorkspaceMember] -> !Spec -> !SemanticSourceIndex -> !LineMap -> !OwnershipIndex -> WorkspaceSpec

- Keiro.Dsl.Workspace: composeWorkspace :: FilePath -> WorkspaceManifest -> [(FilePath, Text, ParsedSource)] -> Either (NonEmpty WorkspaceDiagnostic) WorkspaceSpec

+ Keiro.Dsl.Workspace: composeWorkspace :: FilePath -> WorkspaceManifest -> [(FilePath, Text, ParsedSourceDocument)] -> Either (NonEmpty WorkspaceDiagnostic) WorkspaceSpec

- Keiro.Dsl.WorkspaceRecord: WorkspaceRecord :: !Text -> !Text -> !Text -> !Text -> !Text -> ![FilePath] -> ![WorkspaceSourceLanguageRow] -> !EffectiveLanguageContract -> !GeneratedHaskellNamingEdition -> ![WorkspaceModuleRow] -> ![MappingIdentity] -> ![Text] -> ![Text] -> ![BindingHole] -> ![BehaviorRecordRow] -> ![AdoptedRow] -> WorkspaceRecord

+ Keiro.Dsl.WorkspaceRecord: WorkspaceRecord :: !Text -> !Text -> !Text -> !Text -> !Text -> ![FilePath] -> ![WorkspaceSourceLanguageRow] -> !EffectiveLanguageContract -> !GeneratedHaskellNamingEdition -> ![WorkspaceModuleRow] -> ![MappingIdentity] -> ![Text] -> ![Text] -> ![BindingHole] -> ![BehaviorRecordRow] -> ![Text] -> !Bool -> ![QueryContractIdentity] -> ![RouterSelectionSnapshot] -> ![AdoptedRow] -> !Maybe SemanticImpactSnapshot -> WorkspaceRecord

- Keiro.Dsl.WorkspaceScaffold: WorkspaceScaffoldReport :: !FilePath -> !FilePath -> !Text -> !Context -> ![FilePath] -> ![(ScaffoldModule, ModuleProvenance, WriteDisposition)] -> !FilePath -> !FilePath -> !Maybe Text -> ![StaleModule] -> ![OwnershipMove] -> !ConsumerPlan -> ![Text] -> ![MappingDrift] -> ![WorkspaceSourceLanguageDrift] -> ![BindingHole] -> ![BehaviorRecordRow] -> ![BehaviorRecordRow] -> ![(Text, Text)] -> ![(Text, Text)] -> !Maybe ConformancePackageReport -> ![SourceMove] -> ![SidecarMove] -> !Maybe MigrationReport -> WorkspaceScaffoldReport

+ Keiro.Dsl.WorkspaceScaffold: WorkspaceScaffoldReport :: !FilePath -> !FilePath -> !Text -> !Context -> ![FilePath] -> ![(ScaffoldModule, ModuleProvenance, WriteDisposition)] -> !FilePath -> !FilePath -> !Maybe Text -> ![StaleModule] -> ![OwnershipMove] -> !ConsumerPlan -> ![Text] -> ![MappingDrift] -> !Bool -> ![QueryContractDrift] -> ![QueryContractMigration] -> !SemanticImpactReport -> ![RouterSelectionDrift] -> !Maybe ProjectionMappedImpact -> ![GeneratedArtifactImpact] -> ![WorkspaceSourceLanguageDrift] -> ![BindingHole] -> ![BehaviorRecordRow] -> ![BehaviorRecordRow] -> ![(Text, Text)] -> ![(Text, Text)] -> !Maybe ConformancePackageReport -> ![SourceMove] -> ![SidecarMove] -> !Maybe MigrationReport -> WorkspaceScaffoldReport

Files

CHANGELOG.md +200/−0
LICENSE +28/−0
app/Main.hs +111/−59
bench/parser-scaling/Main.hs +610/−0
keiro-dsl.cabal +304/−19
src/Keiro/Dsl/AggregateType.hs +14/−1
src/Keiro/Dsl/BehaviorCoverage.hs +118/−41
src/Keiro/Dsl/BehaviorSourceMap.hs +179/−0
src/Keiro/Dsl/CanonicalEncoding.hs +19/−0
src/Keiro/Dsl/ConformancePackage.hs +1/−1
src/Keiro/Dsl/ConsumerTypePlan.hs +183/−0
src/Keiro/Dsl/CoordinationImpact.hs +334/−0
src/Keiro/Dsl/Coverage.hs +172/−50
src/Keiro/Dsl/Diff.hs +607/−29
src/Keiro/Dsl/DiffReport.hs +130/−12
src/Keiro/Dsl/EventOutput.hs +12/−2
src/Keiro/Dsl/ExplainBindings.hs +5/−8
src/Keiro/Dsl/Expression.hs +21/−3
src/Keiro/Dsl/FoldFingerprint.hs +12/−12
src/Keiro/Dsl/Frontend.hs +1/−0
src/Keiro/Dsl/Frontend/Internal.hs +51/−2
src/Keiro/Dsl/Grammar.hs +319/−7
src/Keiro/Dsl/Harness.hs +376/−317
src/Keiro/Dsl/HaskellName.hs +10/−0
src/Keiro/Dsl/IdDomain.hs +1/−1
src/Keiro/Dsl/LanguageVersion.hs +103/−12
src/Keiro/Dsl/Manifest.hs +61/−14
src/Keiro/Dsl/MappedCodecPlan.hs +136/−0
src/Keiro/Dsl/MappedConsumer.hs +8/−1
src/Keiro/Dsl/NominalType.hs +6/−1
src/Keiro/Dsl/Parser.hs +11/−1
src/Keiro/Dsl/Parser/Aggregate.hs +89/−12
src/Keiro/Dsl/Parser/Coordination.hs +129/−12
src/Keiro/Dsl/Parser/Core.hs +2/−5
src/Keiro/Dsl/Parser/Document.hs +9/−3
src/Keiro/Dsl/Parser/Preamble.hs +6/−1
src/Keiro/Dsl/Parser/ProjectionCatalog.hs +171/−0
src/Keiro/Dsl/Parser/Queue.hs +20/−4
src/Keiro/Dsl/Parser/ReadModel.hs +102/−16
src/Keiro/Dsl/PrettyPrint.hs +190/−25
src/Keiro/Dsl/ProjectionMappedImpact.hs +300/−0
src/Keiro/Dsl/ProjectionSupply.hs +163/−0
src/Keiro/Dsl/ReadModelQueryContract.hs +147/−0
src/Keiro/Dsl/ReadModelShape.hs +9/−4
src/Keiro/Dsl/ReplayImpact.hs +149/−26
src/Keiro/Dsl/RouterSelection.hs +584/−0
src/Keiro/Dsl/Scaffold.hs +8701/−6772
src/Keiro/Dsl/ScaffoldRecord.hs +213/−5
src/Keiro/Dsl/ScaffoldRun.hs +411/−80
src/Keiro/Dsl/SemanticContract.hs +64/−10
src/Keiro/Dsl/SemanticImpact.hs +923/−0
src/Keiro/Dsl/ServiceHarness.hs +54/−21
src/Keiro/Dsl/Skeleton.hs +50/−11
src/Keiro/Dsl/SourceIndex.hs +253/−0
src/Keiro/Dsl/StructuralConformance.hs +388/−0
src/Keiro/Dsl/Syntax.hs +3/−0
src/Keiro/Dsl/TypeGraph.hs +190/−10
src/Keiro/Dsl/Validate.hs +4672/−3733
src/Keiro/Dsl/Workspace.hs +158/−28
src/Keiro/Dsl/WorkspaceDiff.hs +4/−1
src/Keiro/Dsl/WorkspaceRecord.hs +36/−2
src/Keiro/Dsl/WorkspaceScaffold.hs +161/−47
test/Keiro/Dsl/ConformanceBaseline.hs +107/−32
test/Keiro/Dsl/FrontendProfiles.hs +175/−23
test/Keiro/Dsl/FrontendPublicApiProbe.hs +29/−15
test/Keiro/Dsl/FrontendSurface.hs +238/−1
test/Main.hs +13757/−10805
test/conformance-aggregate-scalars/Generated/AggregateScalars/BehaviorSourceMap.hs +30/−0
test/conformance-aggregate-scalars/Generated/AggregateScalars/ReplayAudit.hs +1/−1
test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Codec.hs +1/−1
test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Domain.hs +1/−1
test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/EventStream.hs +1/−1
test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Harness.hs +1/−1
test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Projection.hs +1/−1
test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Transducer.hs +1/−1
test/conformance-behavior-complete/Generated/BehaviorComplete/BehaviorSourceMap.hs +47/−0
test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/BehaviorContract.hs +22/−41
test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Codec.hs +1/−1
test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Domain.hs +1/−1
test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/EventStream.hs +1/−1
test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Harness.hs +4/−43
test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Projection.hs +1/−1
test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Transducer.hs +1/−1
test/conformance-behavior-complete/Generated/BehaviorComplete/Nominals.hs +1/−1
test/conformance-behavior-complete/Generated/BehaviorComplete/Nominals/Internal.hs +1/−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/StructuralConformance.hs +54/−0
test/conformance-behavior-complete/Generated/BehaviorComplete/StructuralProjections.hs +1/−1
test/conformance-coldstart/Generated/Billing/BehaviorSourceMap.hs +34/−0
test/conformance-coldstart/Generated/Billing/Nominals.hs +1/−1
test/conformance-coldstart/Generated/Billing/Nominals/Internal.hs +1/−1
test/conformance-coldstart/Generated/Billing/ReplayAudit.hs +1/−1
test/conformance-coldstart/Generated/Billing/Subscription/Codec.hs +1/−1
test/conformance-coldstart/Generated/Billing/Subscription/Domain.hs +1/−1
test/conformance-coldstart/Generated/Billing/Subscription/EventStream.hs +1/−1
test/conformance-coldstart/Generated/Billing/Subscription/Harness.hs +1/−1
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 +1/−1
test/conformance-declarative-router/Conformance/DeclarativeRouter/Bindings.hs +45/−0
test/conformance-declarative-router/Conformance/DeclarativeRouter/Domain.hs +33/−0
test/conformance-declarative-router/Generated/TransferRouting/BehaviorSourceMap.hs +30/−0
test/conformance-declarative-router/Generated/TransferRouting/Hospital/BehaviorContract.hs +346/−0
test/conformance-declarative-router/Generated/TransferRouting/Hospital/Codec.hs +67/−0
test/conformance-declarative-router/Generated/TransferRouting/Hospital/Domain.hs +45/−0
test/conformance-declarative-router/Generated/TransferRouting/Hospital/EventStream.hs +49/−0
test/conformance-declarative-router/Generated/TransferRouting/Hospital/Harness.hs +52/−0
test/conformance-declarative-router/Generated/TransferRouting/Hospital/Projection.hs +4/−0
test/conformance-declarative-router/Generated/TransferRouting/Hospital/Transducer.hs +58/−0
test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/QueryContract.hs +10/−0
test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/ReadModel.hs +28/−0
test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/ReadModelHarness.hs +58/−0
test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/ReadModelTable.hs +9/−0
test/conformance-declarative-router/Generated/TransferRouting/HospitalTransferRouter/Router.hs +118/−0
test/conformance-declarative-router/Generated/TransferRouting/HospitalTransferRouter/RouterHarness.hs +28/−0
test/conformance-declarative-router/Generated/TransferRouting/ProjectionCatalog.hs +81/−0
test/conformance-declarative-router/Generated/TransferRouting/ReplayAudit.hs +23/−0
test/conformance-declarative-router/Generated/TransferRouting/Structural/Shape/HospitalLoadRow.hs +12/−0
test/conformance-declarative-router/Generated/TransferRouting/Structural/Shape/TransferRouteInput.hs +11/−0
test/conformance-declarative-router/Generated/TransferRouting/StructuralConformance.hs +74/−0
test/conformance-declarative-router/Generated/TransferRouting/StructuralProjections.hs +79/−0
test/conformance-declarative-router/Main.hs +203/−0
test/conformance-declarative-router/TransferRouting/Hospital/BehaviorHoles.hs +10/−0
test/conformance-declarative-router/TransferRouting/HospitalLoad/ReadModelHoles.hs +38/−0
test/conformance-declarative-router/TransferRouting/ProjectionCatalog/ProjectionCatalogHoles.hs +23/−0
test/conformance-dispatch-full/Generated/HospitalCapacity/ReservationWork/Queue.hs +1/−1
test/conformance-dispatch-full/Generated/HospitalCapacity/ReservationWork/QueueCodec.hs +1/−1
test/conformance-dispatch-full/Generated/HospitalCapacity/ReservationWork/QueuePolicy.hs +1/−1
test/conformance-domain-outcomes/DomainOutcomes/Reservation/BehaviorHoles.hs +31/−0
test/conformance-domain-outcomes/Generated/DomainOutcomes/BehaviorSourceMap.hs +31/−0
test/conformance-domain-outcomes/Generated/DomainOutcomes/Nominals.hs +29/−0
test/conformance-domain-outcomes/Generated/DomainOutcomes/ReplayAudit.hs +23/−0
test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/BehaviorContract.hs +385/−0
test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Codec.hs +65/−0
test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Domain.hs +43/−0
test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/EventStream.hs +82/−0
test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Harness.hs +52/−0
test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Projection.hs +4/−0
test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Transducer.hs +70/−0
test/conformance-domain-outcomes/Main.hs +14/−0
test/conformance-id-domain-migration/Generated/IdDomainMigration/BehaviorSourceMap.hs +30/−0
test/conformance-id-domain-migration/Generated/IdDomainMigration/Nominals.hs +1/−1
test/conformance-id-domain-migration/Generated/IdDomainMigration/Nominals/Internal.hs +1/−1
test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Codec.hs +1/−1
test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Domain.hs +1/−1
test/conformance-import-planning/Generated/ImportPlanningCollisions/BehaviorSourceMap.hs +30/−0
test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/BehaviorContract.hs +5/−7
test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Codec.hs +1/−1
test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Domain.hs +1/−1
test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/EventStream.hs +1/−1
test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Harness.hs +3/−39
test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Projection.hs +1/−1
test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Transducer.hs +1/−1
test/conformance-import-planning/Generated/ImportPlanningCollisions/NominalProjections.hs +1/−1
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/StructuralConformance.hs +51/−0
test/conformance-import-planning/Generated/ImportPlanningCollisions/StructuralProjections.hs +1/−1
test/conformance-intake-full/Generated/HospitalCapacity/IncidentInbox/Inbox.hs +1/−1
test/conformance-intake-runtime/Generated/HospitalCapacity/IncidentInbox/Inbox.hs +1/−1
test/conformance-mapped-queue/Conformance/MappedQueue/Bindings.hs +63/−0
test/conformance-mapped-queue/Conformance/MappedQueue/Domain.hs +47/−0
test/conformance-mapped-queue/Generated/MappedQueue/MappedJobs/Queue.hs +107/−0
test/conformance-mapped-queue/Generated/MappedQueue/MappedJobs/QueueCodec.hs +29/−0
test/conformance-mapped-queue/Generated/MappedQueue/MappedJobs/QueuePolicy.hs +43/−0
test/conformance-mapped-queue/Generated/MappedQueue/Structural/Shape/JobMetadata.hs +10/−0
test/conformance-mapped-queue/Generated/MappedQueue/Structural/Shape/JobPayload.hs +15/−0
test/conformance-mapped-queue/Generated/MappedQueue/StructuralConformance.hs +87/−0
test/conformance-mapped-queue/Generated/MappedQueue/StructuralProjections.hs +39/−0
test/conformance-mapped-queue/Main.hs +62/−0
test/conformance-mapped-readmodel/Conformance/MappedReadModel/Bindings.hs +86/−0
test/conformance-mapped-readmodel/Conformance/MappedReadModel/Domain.hs +76/−0
test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/QueryContract.hs +10/−0
test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/ReadModel.hs +28/−0
test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/ReadModelHarness.hs +58/−0
test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/ReadModelTable.hs +9/−0
test/conformance-mapped-readmodel/Generated/MappedReadmodel/ProjectionCatalog.hs +80/−0
test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/AccountLookup.hs +12/−0
test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/AccountProfile.hs +10/−0
test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/AccountSummary.hs +14/−0
test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/TenantKey.hs +10/−0
test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/UnusedFilter.hs +10/−0
test/conformance-mapped-readmodel/Generated/MappedReadmodel/StructuralConformance.hs +136/−0
test/conformance-mapped-readmodel/Generated/MappedReadmodel/StructuralProjections.hs +108/−0
test/conformance-mapped-readmodel/Main.hs +37/−0
test/conformance-mapped-readmodel/MappedReadmodel/AccountSummary/ReadModelHoles.hs +14/−0
test/conformance-mapped-readmodel/MappedReadmodel/ProjectionCatalog/ProjectionCatalogHoles.hs +26/−0
test/conformance-newsurface/Generated/TransferRouting/BehaviorSourceMap.hs +29/−0
test/conformance-newsurface/Generated/TransferRouting/Hospital/Codec.hs +1/−1
test/conformance-newsurface/Generated/TransferRouting/Hospital/Domain.hs +1/−1
test/conformance-newsurface/Generated/TransferRouting/Hospital/EventStream.hs +1/−1
test/conformance-newsurface/Generated/TransferRouting/Hospital/Harness.hs +1/−1
test/conformance-newsurface/Generated/TransferRouting/Hospital/Projection.hs +1/−1
test/conformance-newsurface/Generated/TransferRouting/Hospital/Transducer.hs +1/−1
test/conformance-newsurface/Generated/TransferRouting/HospitalLoad/ReadModel.hs +1/−1
test/conformance-newsurface/Generated/TransferRouting/HospitalLoad/ReadModelHarness.hs +1/−1
test/conformance-newsurface/Generated/TransferRouting/HospitalLoad/ReadModelTable.hs +1/−1
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/ReplayAudit.hs +1/−1
test/conformance-nominal-scalars/Generated/NominalScalars/BehaviorSourceMap.hs +30/−0
test/conformance-nominal-scalars/Generated/NominalScalars/Nominal/Shape/OrderStatus.hs +1/−1
test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/BehaviorContract.hs +5/−7
test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Codec.hs +1/−1
test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Domain.hs +1/−1
test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/EventStream.hs +1/−1
test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Harness.hs +1/−1
test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Projection.hs +1/−1
test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Transducer.hs +1/−1
test/conformance-nominal-scalars/Generated/NominalScalars/NominalProjections.hs +1/−1
test/conformance-nominal-scalars/Generated/NominalScalars/ReplayAudit.hs +1/−1
test/conformance-process-full/Generated/SurgeDemo/BehaviorSourceMap.hs +36/−0
test/conformance-process-full/Generated/SurgeDemo/Hospital/Codec.hs +1/−1
test/conformance-process-full/Generated/SurgeDemo/Hospital/Domain.hs +1/−1
test/conformance-process-full/Generated/SurgeDemo/Hospital/EventStream.hs +1/−1
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/−1
test/conformance-process-full/Generated/SurgeDemo/Nominals/Internal.hs +1/−1
test/conformance-process-full/Generated/SurgeDemo/ReplayAudit.hs +1/−1
test/conformance-process-full/Generated/SurgeDemo/Surge/Codec.hs +1/−1
test/conformance-process-full/Generated/SurgeDemo/Surge/Domain.hs +1/−1
test/conformance-process-full/Generated/SurgeDemo/Surge/EventStream.hs +1/−1
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/BehaviorSourceMap.hs +31/−0
test/conformance-process-runtime/Generated/HospitalCapacity/HospitalSurge/Process.hs +1/−1
test/conformance-process-runtime/Generated/HospitalCapacity/Nominals.hs +1/−1
test/conformance-process-runtime/Generated/HospitalCapacity/Nominals/Internal.hs +1/−1
test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Codec.hs +1/−1
test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Domain.hs +1/−1
test/conformance-process-runtime/Generated/HospitalCapacity/Surge/EventStream.hs +1/−1
test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Transducer.hs +1/−1
test/conformance-process/Generated/HospitalCapacity/BehaviorSourceMap.hs +31/−0
test/conformance-process/Generated/HospitalCapacity/HospitalSurge/ProcessHarness.hs +1/−1
test/conformance-projection-catalog/CatalogDemo/CatalogAudit/ReadModelHoles.hs +19/−0
test/conformance-projection-catalog/CatalogDemo/MappedBindings.hs +81/−0
test/conformance-projection-catalog/CatalogDemo/MappedDomain.hs +59/−0
test/conformance-projection-catalog/CatalogDemo/OrderInline/ReadModelHoles.hs +15/−0
test/conformance-projection-catalog/CatalogDemo/OrderTotalsLookup/ReadModelHoles.hs +18/−0
test/conformance-projection-catalog/CatalogDemo/Orders/BehaviorHoles.hs +10/−0
test/conformance-projection-catalog/CatalogDemo/Orders/Holes.hs +27/−0
test/conformance-projection-catalog/CatalogDemo/ProjectionCatalog/ProjectionCatalogHoles.hs +139/−0
test/conformance-projection-catalog/CatalogDemo/ShipmentLookup/ReadModelHoles.hs +19/−0
test/conformance-projection-catalog/CatalogDemo/Shipments/BehaviorHoles.hs +10/−0
test/conformance-projection-catalog/Generated/CatalogDemo/BehaviorSourceMap.hs +32/−0
test/conformance-projection-catalog/Generated/CatalogDemo/CatalogAudit/ReadModel.hs +25/−0
test/conformance-projection-catalog/Generated/CatalogDemo/CatalogAudit/ReadModelHarness.hs +58/−0
test/conformance-projection-catalog/Generated/CatalogDemo/CatalogAudit/ReadModelTable.hs +9/−0
test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/QueryContract.hs +10/−0
test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/ReadModel.hs +26/−0
test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/ReadModelHarness.hs +53/−0
test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/ReadModelTable.hs +9/−0
test/conformance-projection-catalog/Generated/CatalogDemo/OrderTotalsLookup/ReadModel.hs +25/−0
test/conformance-projection-catalog/Generated/CatalogDemo/OrderTotalsLookup/ReadModelHarness.hs +53/−0
test/conformance-projection-catalog/Generated/CatalogDemo/OrderTotalsLookup/ReadModelTable.hs +9/−0
test/conformance-projection-catalog/Generated/CatalogDemo/Orders/BehaviorContract.hs +346/−0
test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Codec.hs +71/−0
test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Domain.hs +51/−0
test/conformance-projection-catalog/Generated/CatalogDemo/Orders/EventStream.hs +49/−0
test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Harness.hs +77/−0
test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Projection.hs +4/−0
test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Transducer.hs +59/−0
test/conformance-projection-catalog/Generated/CatalogDemo/ProjectionCatalog.hs +142/−0
test/conformance-projection-catalog/Generated/CatalogDemo/QualificationJobs/Queue.hs +86/−0
test/conformance-projection-catalog/Generated/CatalogDemo/QualificationJobs/QueueCodec.hs +29/−0
test/conformance-projection-catalog/Generated/CatalogDemo/QualificationJobs/QueuePolicy.hs +43/−0
test/conformance-projection-catalog/Generated/CatalogDemo/ReplayAudit.hs +30/−0
test/conformance-projection-catalog/Generated/CatalogDemo/ShipmentLookup/ReadModel.hs +25/−0
test/conformance-projection-catalog/Generated/CatalogDemo/ShipmentLookup/ReadModelHarness.hs +53/−0
test/conformance-projection-catalog/Generated/CatalogDemo/ShipmentLookup/ReadModelTable.hs +9/−0
test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/BehaviorContract.hs +346/−0
test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Codec.hs +69/−0
test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Domain.hs +45/−0
test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/EventStream.hs +49/−0
test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Harness.hs +69/−0
test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Projection.hs +4/−0
test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Transducer.hs +58/−0
test/conformance-projection-catalog/Generated/CatalogDemo/Structural/Shape/QualificationPayload.hs +11/−0
test/conformance-projection-catalog/Generated/CatalogDemo/StructuralConformance.hs +125/−0
test/conformance-projection-catalog/Generated/CatalogDemo/StructuralProjections.hs +26/−0
test/conformance-projection-catalog/Main.hs +170/−0
test/conformance-publisher-runtime/Generated/HospitalCapacity/HospitalPublisher/Publisher.hs +1/−1
test/conformance-queue-runtime/Generated/HospitalCapacity/ReservationWork/Queue.hs +1/−1
test/conformance-queue-runtime/Generated/HospitalCapacity/ReservationWork/QueueCodec.hs +1/−1
test/conformance-queue-runtime/Generated/HospitalCapacity/ReservationWork/QueuePolicy.hs +1/−1
test/conformance-queue/Generated/HospitalCapacity/ReservationWork/Queue.hs +1/−1
test/conformance-queue/Generated/HospitalCapacity/ReservationWork/QueueCodec.hs +1/−1
test/conformance-readmodel-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModel.hs +1/−1
test/conformance-readmodel-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs +1/−1
test/conformance-readmodel-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs +1/−1
test/conformance-replay/Generated/ReplayDivergence/BehaviorSourceMap.hs +30/−0
test/conformance-replay/Generated/ReplayDivergence/Note/Codec.hs +1/−1
test/conformance-replay/Generated/ReplayDivergence/Note/Domain.hs +1/−1
test/conformance-replay/Generated/ReplayDivergence/Note/EventStream.hs +1/−1
test/conformance-replay/Generated/ReplayDivergence/Note/Harness.hs +1/−1
test/conformance-replay/Generated/ReplayDivergence/Note/Projection.hs +1/−1
test/conformance-replay/Generated/ReplayDivergence/Note/Transducer.hs +1/−1
test/conformance-replay/Generated/ReplayDivergence/ReplayAudit.hs +1/−1
test/conformance-router-full/Generated/IncidentPaging/BehaviorSourceMap.hs +30/−0
test/conformance-router-full/Generated/IncidentPaging/Page/Codec.hs +1/−1
test/conformance-router-full/Generated/IncidentPaging/Page/Domain.hs +1/−1
test/conformance-router-full/Generated/IncidentPaging/Page/EventStream.hs +1/−1
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/BehaviorSourceMap.hs +30/−0
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/BehaviorSourceMap.hs +30/−0
test/conformance-router/Generated/IncidentPaging/PagingRouter/RouterHarness.hs +1/−1
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/BehaviorSourceMap.hs +34/−0
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Nominals.hs +1/−1
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Nominals/Internal.hs +1/−1
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ReplayAudit.hs +1/−1
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/BehaviorContract.hs +9/−15
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Codec.hs +1/−1
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Domain.hs +1/−1
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/EventStream.hs +1/−1
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Harness.hs +4/−41
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Projection.hs +1/−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/StructuralConformance.hs +52/−0
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/StructuralProjections.hs +1/−1
test/conformance-scalar-expressions/Main.hs +3/−1
test/conformance-skeletons/SkelRouter/MyService/Page/Holes.hs +2/−3
test/conformance-skeletons/SkelWorkflow/Generated/MyService/HospitalTransferReservation/WorkflowRuntime.hs +21/−8
test/conformance-snapshot/Generated/HospitalCapacity/BehaviorSourceMap.hs +34/−0
test/conformance-snapshot/Generated/HospitalCapacity/Nominals.hs +1/−1
test/conformance-snapshot/Generated/HospitalCapacity/Nominals/Internal.hs +1/−1
test/conformance-snapshot/Generated/HospitalCapacity/ReplayAudit.hs +1/−1
test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Codec.hs +1/−1
test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Domain.hs +1/−1
test/conformance-snapshot/Generated/HospitalCapacity/Reservation/EventStream.hs +1/−1
test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Transducer.hs +1/−1
test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/BehaviorContract.hs +5/−7
test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Codec.hs +1/−1
test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Domain.hs +1/−1
test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/EventStream.hs +1/−1
test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Harness.hs +4/−117
test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Projection.hs +1/−1
test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Transducer.hs +1/−1
test/conformance-structural/Generated/StructuralConformance/BehaviorSourceMap.hs +30/−0
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/StructuralConformance.hs +129/−0
test/conformance-structural/Generated/StructuralConformance/StructuralProjections.hs +1/−1
test/conformance-structural/Main.hs +7/−1
test/conformance-v2/Generated/HospitalCapacity/BehaviorSourceMap.hs +34/−0
test/conformance-v2/Generated/HospitalCapacity/Nominals.hs +1/−1
test/conformance-v2/Generated/HospitalCapacity/Nominals/Internal.hs +1/−1
test/conformance-v2/Generated/HospitalCapacity/ReplayAudit.hs +1/−1
test/conformance-v2/Generated/HospitalCapacity/Reservation/Codec.hs +1/−1
test/conformance-v2/Generated/HospitalCapacity/Reservation/Domain.hs +1/−1
test/conformance-v2/Generated/HospitalCapacity/Reservation/EventStream.hs +1/−1
test/conformance-v2/Generated/HospitalCapacity/Reservation/Harness.hs +1/−1
test/conformance-v2/Generated/HospitalCapacity/Reservation/Projection.hs +1/−1
test/conformance-v2/Generated/HospitalCapacity/Reservation/Transducer.hs +1/−1
test/conformance-workflow-full/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs +22/−9
test/conformance-workflow-runtime/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs +22/−9
test/conformance-workflow-runtime/Main.hs +64/−32
test/conformance-workflow/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowFacts.hs +1/−1
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/BehaviorSourceMap.hs +36/−0
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Nominals.hs +1/−1
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Nominals/Internal.hs +1/−1
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/BehaviorContract.hs +9/−15
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Codec.hs +1/−1
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Domain.hs +1/−1
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/EventStream.hs +1/−1
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Harness.hs +1/−1
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Projection.hs +1/−1
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Transducer.hs +1/−1
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/BehaviorContract.hs +5/−7
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Codec.hs +1/−1
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Domain.hs +1/−1
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/EventStream.hs +1/−1
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Harness.hs +1/−1
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Projection.hs +1/−1
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Transducer.hs +1/−1
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ReplayAudit.hs +1/−1
test/conformance/Generated/HospitalCapacity/BehaviorSourceMap.hs +34/−0
test/conformance/Generated/HospitalCapacity/Nominals.hs +1/−1
test/conformance/Generated/HospitalCapacity/Nominals/Internal.hs +1/−1
test/conformance/Generated/HospitalCapacity/ReplayAudit.hs +1/−1
test/conformance/Generated/HospitalCapacity/Reservation/Codec.hs +1/−1
test/conformance/Generated/HospitalCapacity/Reservation/Domain.hs +1/−1
test/conformance/Generated/HospitalCapacity/Reservation/EventStream.hs +1/−1
test/conformance/Generated/HospitalCapacity/Reservation/Harness.hs +1/−1
test/conformance/Generated/HospitalCapacity/Reservation/Projection.hs +1/−1
test/conformance/Generated/HospitalCapacity/Reservation/Transducer.hs +1/−1
test/runtime-vocabulary/Main.hs +46/−0

CHANGELOG.md view

@@ -4,6 +4,206 @@ [Keep a Changelog](https://keepachangelog.com/), and the package follows the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## Unreleased++## 0.12.0.0 — 2026-08-14++### Breaking Changes++- Generated `WorkflowRuntime` modules no longer expose the pure+  `awaitAwakeableId` coordinate helper. They instead expose an abstract+  `AwaitBinding`, one value per declared await, and `allocateDeclaredAwait`, which+  allocates through the runtime and returns the opaque `AwakeableId` together with+  its await action. Compiled generated-runtime consumers now need the direct+  dependencies required by that effectful allocation surface.+- Removes the zero-caller Spec-only `pureRefusals` and `constraintPlan` shims+  from `Keiro.Dsl.ScaffoldRun`. Use `pureRefusalsForService` and+  `constraintPlanForService`; callers that genuinely have only a `Spec` can+  cross the compatibility boundary explicitly with `legacyCheckedService`.+- The public DSL AST replaces read-model `rmConsistency`/`rmScope`/`rmFeed`/+  `rmSubscription` with `rmFreshness` and `rmSupply`, replaces projection-owner+  `poFeed` with `poDelivery`, and adds `ProjectionDelivery`,+  `QueryFreshnessNode`, and `ReadModelSupply`. `DiagnosticCode` gains the+  catalog cursor/source-ordering and delivery/freshness evolution cases.+  Exhaustive consumers and direct record construction must migrate; released+  source-language behavior is unchanged.+- Removes the semantic-only planning and check entry points from+  `Keiro.Dsl.ScaffoldRun`: `planServiceScaffold`, `planServiceScaffoldWithGoldens`,+  `planServiceScaffoldWithRuntimePackage`,+  `planServiceScaffoldWithRuntimePackageAndGoldens`, `planScaffold`,+  `planScaffoldWithGoldens`, and `checkServiceDiagnostics`. Once behavior provenance+  became part of planning, these wrappers could only derive a `CompatibilityLineOnly`+  source index, whose behavior-source join refuses every aggregate transition and+  rejection anchor — so they refused every transition-bearing service that they+  planned cleanly under 0.11.0.0. Migrate by parsing with `parseSourceDocument` and+  passing the document's `documentSourceIndex` to `planIndexedServiceScaffold`,+  `planIndexedServiceScaffoldWithGoldens`,+  `planIndexedServiceScaffoldWithRuntimePackage`,+  `planIndexedServiceScaffoldWithRuntimePackageAndGoldens`, or+  `checkIndexedServiceDiagnostics`. A `Spec` constructed programmatically can still+  be planned by building a complete exact index with+  `Keiro.Dsl.SourceIndex.exactSemanticSourceIndex` over `semanticSourceSubjects`,+  taking responsibility for the spans it asserts. The Spec-only module-set builders+  (`scaffoldModules`, `scaffoldModulesWithGoldens`) and every execution entry point+  are unchanged.+- The public DSL AST adds `DomainOutcomeTypes`, `TransitionOutcome`, outcome+  fields to `Aggregate`/`Transition`, and corresponding located duplicate+  evidence. `LanguageFeature`, `RuntimeCapability`, and `DiagnosticCode` gain+  typed-outcome cases, and `BehaviorRequirement` gains+  `requirementDomainOutcome`; exhaustive consumers and direct record+  construction must be updated. The syntax and generated API exist only in+  candidate language 5.+- The public DSL AST changes `WqField.wqfType` from `Name` to+  `QueuePayloadType`, adds `wqfLoc`, and adds optional `queryTypes` to+  `ReadModelNode`. `UseSite`, `MappedRootKind`, `MappedConsumer`,+  `TypeGraphError`, `DiagnosticCode`, and `TypeGraph` gain mapped+  queue/read-model/projection cases or fields; exhaustive consumers and direct+  record construction must be updated. Existing language-1–4 source and+  generated meaning is unchanged.+- `WorkspaceMember` gains `wmSourceIndex`, `WorkspaceSpec` gains `wsSourceIndex`, and+  `composeWorkspace` now accepts `ParsedSourceDocument` inputs. `DiagnosticCode` gains+  `WorkspaceSourceIndexInvalid`; exhaustive matches and direct record construction must be+  extended. Bare-`Spec` adapters remain available but expose only `CompatibilityLineOnly`+  positions rather than fabricated exact columns.+- `BehaviorRequirement` gains stable `requirementOrigin` and optional+  `requirementExactLocation` fields; `Refusal` and `DiagnosticCode` gain behavior-source-anchor+  cases. Exhaustive library consumers must extend their matches. Scaffold and check planning now+  require a complete exact source index and refuse missing, inexact, duplicate, or colliding+  behavior anchors before writes.+- `ScaffoldRecord` and `WorkspaceRecord` gain optional semantic-impact snapshots;+  `ScaffoldReport` and `WorkspaceScaffoldReport` gain typed semantic and generated-artifact impact+  fields. Exhaustive direct record construction must initialize the new fields. Standalone+  scaffolding now reports an existing byte-identical generated module as `Unchanged`, matching the+  workspace path instead of rewriting it.+- Regenerate mapped-service output once: declaration-wide assertions moved from every aggregate+  `Harness` into the context `StructuralConformance` module, which must be added to the consuming+  Cabal module inventory; the context `BehaviorSourceMap` and additive ledger `semantic-impact`+  row must be added at the same baseline. Compile the runtime package and run the generated service+  conformance target after reconciling the Cabal fragment. Unrelated aggregate files are now+  byte-stable when a declaration outside their semantic closure changes, and source-only movement+  rewrites the source map rather than behavior contracts or create-once witnesses.+- Requires `kiroku-store >=0.7 && <0.8`, keeping generated conformance and+  runtime fixtures on the same Kiroku effect surface as Keiro 0.12.++### New Features++- Publishes Language 5 as the sole stable and default authoring contract. Language 4 remains an+  immutable published compatibility contract. The conformance manifest now records explicit+  per-suite language ownership, retains Language 4 generated bytes, and includes the live+  workflow allocate/signal/completion proof in the stable Language 5 lane.+- Candidate Language 5 accepts bounded `external-read` declarations and lowers them to+  versioned `AllRowsExternalRead` catalog contracts whose result shape is derived from+  the checked query binding. Validation covers SQL identities, query/target cardinality,+  revision compatibility, and surface generations; diff, ledger, pretty-print, and+  workspace paths distinguish retirement, version addition, compatibility changes, and+  result-shape changes. Create-once catalog holes include a typed keyed-contract helper+  for application-owned private SQL implementations.+- Candidate Language 5 accepts projection-revision bridges and generates catalog+  provisioner, schema-validator, physical-target live/replay, and verification holes.+  Revision/provisioner identities and ordered promotion names participate in canonical+  catalog and group-slice identity; published Languages 1–4 are unchanged.++- Exposes `checkedProjectionSupplies`, the lazily shared projection-supply+  analysis attached to each `CheckedService`.+- Candidate Language 5 separates projection delivery from query freshness.+  Projection owners declare `delivery = inline | subscription`; catalog-bound+  read models declare `freshness = immediate | wait-for-head ...` and derive any+  durable cursor from their validated owner. Capability diagnostics reject+  missing, ambiguous, or unreachable waits before generation. Generated code+  uses the truthful read-model builders, while diffs, ledgers, workspaces,+  harnesses, fingerprints, and compiled conformance expose delivery, freshness,+  and cursor facts independently. Languages 1–4 retain byte-compatible+  `feed`/`consistency`/`scope` behavior.+- Exposes `Keiro.Dsl.ProjectionSupply` as the shared order-independent authority for+  catalog query-to-owner resolution. Candidate Language 5 accepts several query models+  supplied by one owner without legacy aggregate projection clauses, rejects split or+  double ownership with located diagnostics, generates source-selected inline handlers+  once, and records separate backing-target and supplier facts in scaffold ledgers,+  diffs, harnesses, workspaces, and compiled conformance.++- Candidate language 5 adds exhaustive typed domain outcomes. Aggregates may+  declare rejection/no-op result types and label each live transition as+  accepted, rejected with a checked reason, or no-op with a checked reason.+  Scaffolding exports the aggregate `DomainCommandHandler`, dispatches directly+  on Keiki's exact selected edge, and evaluates only the selected reason term.+  Exact-reason conformance, mutation coverage, semantic diff/behavior identity,+  and 8/32/128/512 linear generation scaling are included; fold fingerprints,+  event history, snapshots, replay, and published languages 1–4 are unchanged.+- Candidate language 5 registers and generates mapped workqueue fields+  (`field -> "wire" : TypeExpr`) and atomic read-model query input/result+  clauses. Both resolve recursively into located `TypeGraph` roots, while+  languages 1–4 reject the owned colon or `query` token. Workqueues receive+  exact structural/opaque payload codecs inside their schema-version-1 envelope;+  read models receive deterministic Haskell query aliases without claiming SQL+  conversion or migration ownership.+- Adds one integrated mapped-surface qualification gate across events,+  registers, workqueues, query contracts, and aggregate-derived projections.+  Exact-tree tests prove locality remains constant under unrelated workspace+  growth; restoring mutations cover bindings, queue arms/null policy, query+  signatures, projection fingerprints, semantic consumers/reports, service-law+  uniqueness, and semantic-impact ledger tags.+- Exposes `Keiro.Dsl.ConsumerTypePlan`, the codec-agnostic authority for+  rendering a resolved mapped expression's consumer Haskell occurrence,+  deterministic imports, and transitive mapped dependencies. Projection+  semantic impact now derives event-only consumers for aggregate sources and+  records category/all sources as unsupported heterogeneous boundaries.+- Exposes `Keiro.Dsl.SemanticImpact`, the checked and deterministic authority for mapping current+  command-field, private-event-field, and register roots to aggregate declaration closures and the+  complete service declaration inventory. Future mapped root constructors must extend its+  exhaustive `UseSite` fold before the package compiles.+- Exposes `Keiro.Dsl.StructuralConformance` and emits one context module for declaration-wide+  mapped binding, fixture, opaque-boundary, coverage, and projection-witness checks. The generated+  service facade runs that list once under `structural/`; aggregate harnesses retain codec,+  wire-policy, snapshot/register, and replay evidence only for their checked mapped closure.+- Exposes `Keiro.Dsl.SourceIndex`. `parseSourceDocument` and `lowerSurfaceDocument` return exact,+  checked aggregate state and transition spans beside the unchanged semantic `ParsedSource`;+  compatibility parser entry points retain syntax-valid duplicate-name graphs while reusing the+  same surface/lowering seam. Workspace members retain normalized member-local indices and+  `WorkspaceSpec` retains their checked, unrelocated union.+- Exposes `Keiro.Dsl.BehaviorSourceMap` and emits one deterministic context source map from frozen+  behavior keys to exact current file, line, and column. Generated behavior contracts resolve+  failure positions through that map; contracts and newly created witness comments no longer+  embed volatile source lines. `behavior-obligations` appends exact `file`, `column`, and `quality`+  location fields without changing schema `keiro-dsl/behavior-obligations/1`.+- `SemanticImpactSnapshot`, `MappedImpactDelta`, and `SemanticImpactReport` provide one canonical+  checked-consumer projection for diff and scaffold explanations. Current single/workspace ledgers+  persist an additive `semantic-impact` row, and current diff CLI JSON appends `semanticImpact` to+  `keiro-dsl/diff-report/1`; legacy ledgers retain an explicitly unavailable old baseline.++### Bug Fixes++- Generated await helper names now use the same suffix-aware derivation in+  validation and emission, so colliding declarations such as `foo-bar` and+  `foo_bar` are rejected before generation. Compiled workflow-runtime conformance+  now proves the opaque generated allocation/signalling/resume path against a live+  migrated PostgreSQL database.+- `keiro-dsl diff` now classifies read-model query-policy changes across the language+  4-to-5 migration. Weakening legacy `consistency = Strong` to+  `freshness = immediate`, or narrowing the waited head scope, is a breaking+  `QueryFreshnessChanged` finding. Scope-preserving rewrites are equivalent,+  strengthenings are additive `CompatibilityStrengthened` findings, and the spurious+  additive `Strong scope widened` verdict from mixed-policy comparisons is gone.+  Same-language diff classification is unchanged.+- Published languages 1–4 once again accept `outcome` as an ordinary identifier, restoring the+  0.11.0.0 grammar that candidate-language-5 outcome syntax accidentally narrowed. Outcome clause+  words are contextual rather than globally reserved, so language-5 sources may also use+  `outcome` as an identifier while retaining typed accepted, rejected, and no-op clauses.++### Other Changes++- Requires `keiro-core ^>=0.12.0.0`, matching the stable Language 5 runtime+  contract and the lockstep package release.+- The source distribution now includes the BSD-3-Clause license file.+- Regenerates the 39-entry checked-in conformance corpus so every generated+  provenance banner records `keiro-dsl 0.12.0.0`; generated behavior and all+  non-banner bytes remain unchanged.+- Check, scaffold, harness, and diff paths now share one projection-supply+  analysis per run and per diff side, while replay-impact planning reads each+  checked service's cached type graph. Diagnostics, generated bytes, scaffold+  records, and diff reports are unchanged.+- Source-span capture now uses Megaparsec's offset-derived consumed chunk instead of repeatedly+  measuring the complete remaining `Text` suffix. Exact half-open spans, parser compatibility, and+  generated service behavior are unchanged; the effect is limited to DSL parse-time tooling. ## [0.11.0.0] - 2026-08-05  ### Breaking Changes

+ LICENSE view

@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2026, Nadeem Bitar++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors+   may be used to endorse or promote products derived from this software without+   specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS+OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT INCLUDING+NEGLIGENCE OR OTHERWISE ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

app/Main.hs view

@@ -13,26 +13,30 @@ 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.BehaviorSourceMap qualified as BehaviorSource import Keiro.Dsl.CheckReport qualified as CheckReport+import Keiro.Dsl.CoordinationImpact (CoordinationImpact (..), CoordinationSeverity (..), coordinationImpact) 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.Diff qualified as CheckedDiff+import Keiro.Dsl.DiffReport (diffReportWithImpacts, parseSurfaceName, renderCoordinationImpact, renderExplainBlock, renderFinding, renderSemanticImpact) import Keiro.Dsl.ExplainBindings (bindingObligationsForService, renderBindingObligations) import Keiro.Dsl.FoldFingerprint (renderFoldSurfaceError) import Keiro.Dsl.Goldens (emitGoldenPayloads, loadGoldenPayloads) 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.Parser (parseSourceDocument, 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 (checkServiceDiagnostics, executeServiceScaffoldWithRuntimePackageAndNameMigrations, planServiceScaffoldWithRuntimePackageAndGoldens, renderRefusals, renderScaffoldReport)-import Keiro.Dsl.SemanticContract (CheckedService (..), checkedSource, effectiveContractLanguageVersion, languageContractNotice)+import Keiro.Dsl.ScaffoldRun (checkIndexedServiceDiagnostics, executeServiceScaffoldWithRuntimePackageAndNameMigrations, planIndexedServiceScaffoldWithRuntimePackageAndGoldens, renderRefusals, renderScaffoldReport)+import Keiro.Dsl.SemanticContract (CheckedService, checkedLanguageContract, checkedSource, checkedSpec, effectiveContractLanguageVersion, languageContractNotice) import Keiro.Dsl.Skeleton (skeletonFor)+import Keiro.Dsl.SourceIndex (ParsedSourceDocument (..), SemanticSourceIndex, emptySemanticSourceIndex) 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.Workspace (ContentSource (..), LineMap (..), OwnershipIndex (..), WorkspaceDiagnostic (..), WorkspaceFailure (..), WorkspaceFile (..), WorkspaceLocation (..), WorkspaceManifest (..), WorkspaceMember (..), WorkspaceMemberRef (..), WorkspaceSpec (..), checkWorkspace, checkWorkspaceForService, checkedWorkspace, fileContentSource, isWorkspacePath, loadWorkspace, nodeOwner, parseWorkspaceManifest, renderWorkspaceDiagnostic, renderWorkspaceFailure, renderWorkspaceManifest)+import Keiro.Dsl.WorkspaceDiff (WorkspaceChange (..), WorkspaceMeta (..), diffWorkspaces, renderWorkspaceFinding, workspaceDiffReportWithImpacts) import Keiro.Dsl.WorkspaceScaffold (executeWorkspaceScaffoldWithNameMigrations, planWorkspaceScaffoldWithRuntimePackageAndGoldens, renderWorkspaceScaffoldReport) import Numeric.Natural (Natural) import Options.Applicative@@ -496,23 +500,23 @@   | isWorkspacePath fp = runWorkspaceDiff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions run (Parse fp) = do   input <- TIO.readFile fp-  case parseSource fp input of+  case parseSourceDocument fp input of     Left failure -> do       hPutStrLn stderr (T.unpack (renderParseFailure failure))       exitFailure-    Right parsedSource -> TIO.putStrLn (renderSource parsedSource)+    Right ParsedSourceDocument {documentParsedSource = parsedSource} -> TIO.putStrLn (renderSource parsedSource) run (Check fp options) = do   input <- TIO.readFile fp-  case parseSource fp input of+  case parseSourceDocument fp input of     Left failure -> do       hPutStrLn stderr (T.unpack (renderParseFailure failure))       exitFailure-    Right parsedSource -> do+    Right ParsedSourceDocument {documentParsedSource = parsedSource, documentSourceIndex = sourceIndex} -> do       validateCheckDenyCodes options       let service = checkedSource parsedSource           spec = checkedSpec service           floorDiags = maybe [] (\floorVersion -> minimumLanguageDiagnostics floorVersion (parsedSourceLanguage parsedSource)) (checkMinLanguage options)-          semanticDiags = floorDiags <> checkServiceDiagnostics Nothing (mkContext Nothing False spec) service+          semanticDiags = floorDiags <> checkIndexedServiceDiagnostics Nothing sourceIndex (mkContext Nothing False spec) service           semanticFailed = any ((== Error) . severity) semanticDiags       emitLanguageContractNotice fp (sourceFormText (parsedSourceLanguage parsedSource)) service       mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) semanticDiags@@ -520,7 +524,7 @@       -- 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)+      coveragePlan <- planCheckCoverage fp service (if semanticFailed then Nothing else checkCoverage options)       coverageOk <- emitPlannedCoverage coveragePlan       let diags = semanticDiags <> plannedCoverageDiagnostics coveragePlan           deniedWarningCodes = deniedSourceWarningCodes options diags@@ -540,11 +544,11 @@           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+  case parseSourceDocument fp input of     Left failure -> do       hPutStrLn stderr (T.unpack (renderParseFailure failure))       exitFailure-    Right parsedSource -> do+    Right ParsedSourceDocument {documentParsedSource = parsedSource, documentSourceIndex = sourceIndex} -> do       let service = checkedSource parsedSource           spec = checkedSpec service       emitLanguageContractNotice fp (sourceFormText (parsedSourceLanguage parsedSource)) service@@ -556,7 +560,7 @@       let ctx = mkContext cliRoot cliCollocate spec           goldenRoot = fromMaybe (takeDirectory fp </> "golden-payloads") cliGoldens       goldens <- loadGoldenPayloads goldenRoot spec-      case (planServiceScaffoldWithRuntimePackageAndGoldens goldens cliRuntimePackage ctx service, traverse (\(name, _) -> codecComparisonModule ctx spec (T.pack name)) comparisonRequest) of+      case (planIndexedServiceScaffoldWithRuntimePackageAndGoldens goldens cliRuntimePackage sourceIndex ctx service, traverse (\(name, _) -> codecComparisonModule ctx spec (T.pack name)) comparisonRequest) of         (Left refusals, _) -> do           mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)           exitFailure@@ -580,24 +584,24 @@     Right skel -> TIO.putStr skel run (Inspect fp InspectionJson) = do   input <- TIO.readFile fp-  case parseSource fp input of+  case parseSourceDocument fp input of     Left failure -> hPutStrLn stderr (T.unpack (renderParseFailure failure)) >> exitFailure-    Right parsedSource ->+    Right ParsedSourceDocument {documentParsedSource = parsedSource} ->       TLIO.putStrLn         (AesonText.encodeToLazyText (sourceInspection fp (parsedSourceLanguage parsedSource) (checkedSource parsedSource))) run (BehaviorObligations fp format) = do   input <- TIO.readFile fp-  case parseSource fp input of+  case parseSourceDocument fp input of     Left failure -> hPutStrLn stderr (T.unpack (renderParseFailure failure)) >> exitFailure-    Right parsedSource -> do+    Right ParsedSourceDocument {documentParsedSource = parsedSource, documentSourceIndex = sourceIndex} -> do       let service = checkedSource parsedSource           spec = checkedSpec service           diagnostics = validateService service       mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diagnostics       if any ((== Error) . severity) diagnostics         then exitFailure-        else case Behavior.behaviorObligationsReport fp spec of-          Left errors -> renderBehaviorErrors errors+        else case sourceAwareBehaviorReport fp Nothing sourceIndex spec of+          Left failure -> renderBehaviorReportFailure failure           Right report -> writeBehaviorReport format report run (Diff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions) = do   -- Resolve the spec to a repo-relative path so `git show <ref>:<relpath>` works.@@ -614,28 +618,35 @@         Left err -> hPutStrLn stderr ("git show " <> ref <> ":" <> relPath <> " failed:\n" <> err) >> exitFailure         Right oldText -> do           newText <- TIO.readFile fp-          case (,) <$> parseSource (ref <> ":" <> relPath) (T.pack oldText) <*> parseSource fp newText of+          case (,) <$> parseSourceDocument (ref <> ":" <> relPath) (T.pack oldText) <*> parseSourceDocument fp newText of             Left failure -> hPutStrLn stderr (T.unpack (renderParseFailure failure)) >> exitFailure-            Right (oldSource, newSource) -> do-              let oldService = checkedSource oldSource-                  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-                  written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) emitGoldensRoot-                  mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written-                  let effectiveGate = gateWith gatedSurfaces-                  mapM_ (TIO.putStrLn . renderFinding) changes-                  when explain $-                    mapM_ (TIO.putStrLn . renderExplainBlock) (filter shouldExplain changes)-                  TIO.putStrLn (renderReplayImpact impact)-                  mapM_ (`Aeson.encodeFile` impact) replayImpactOut-                  mapM_ (\path -> Aeson.encodeFile path (diffReport effectiveGate changes)) reportOut-                  coverageOk <- runDiffCoverage fp (T.pack ref) oldSpec newSpec coverageOptions-                  if any (gatedBreaking effectiveGate) changes || not coverageOk then exitFailure else pure ()+            Right+              ( ParsedSourceDocument {documentParsedSource = oldSource},+                ParsedSourceDocument {documentParsedSource = newSource}+                ) -> do+                let oldService = checkedSource oldSource+                    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+                    written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) emitGoldensRoot+                    mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written+                    let effectiveGate = gateWith gatedSurfaces+                        semanticImpact = CheckedDiff.mappedSemanticImpactForServices oldService newService+                        coordination = coordinationImpact oldService newService semanticImpact+                    mapM_ (TIO.putStrLn . renderFinding) changes+                    mapM_ TIO.putStrLn (renderSemanticImpact semanticImpact)+                    mapM_ TIO.putStrLn (renderCoordinationImpact coordination)+                    when explain $+                      mapM_ (TIO.putStrLn . renderExplainBlock) (filter shouldExplain changes)+                    TIO.putStrLn (renderReplayImpact impact)+                    mapM_ (`Aeson.encodeFile` impact) replayImpactOut+                    mapM_ (\path -> Aeson.encodeFile path (diffReportWithImpacts effectiveGate changes semanticImpact coordination)) reportOut+                    coverageOk <- runDiffCoverage fp (T.pack ref) oldSpec newSpec coverageOptions+                    if any (gatedBreaking effectiveGate) changes || any ((== CoordinationBreaking) . coordinationSeverity) coordination || not coverageOk then exitFailure else pure ()  -- | @parse@ on a workspace manifest: read it, parse it, and print it back in -- canonical form (clauses in order, members codepoint-sorted).@@ -702,20 +713,38 @@       if any ((== Error) . wdSeverity) diagnostics         then exitFailure         else case workspaceBehaviorReport workspace of-          Left errors -> renderBehaviorErrors errors+          Left failure -> renderBehaviorReportFailure failure           Right report -> writeBehaviorReport format report -workspaceBehaviorReport :: WorkspaceSpec -> Either [Behavior.BehaviorDerivationError] Behavior.BehaviorObligationsReport-workspaceBehaviorReport workspace = do-  requirements <- Behavior.deriveBehaviorRequirements (checkedSpec (checkedWorkspace workspace))+workspaceBehaviorReport :: WorkspaceSpec -> Either BehaviorReportFailure Behavior.BehaviorObligationsReport+workspaceBehaviorReport workspace =+  sourceAwareBehaviorReport+    (wsManifestPath workspace)+    (Just (wsService workspace))+    (wsSourceIndex workspace)+    (checkedSpec (checkedWorkspace workspace))+    >>= \report ->+      pure+        report+          { Behavior.behaviorRequirements =+              map+                (Behavior.attributeBehaviorOwner (fmap fst . nodeOwner (wsOwnership workspace) "aggregate"))+                (Behavior.behaviorRequirements report)+          }++data BehaviorReportFailure+  = BehaviorReportDerivationFailed ![Behavior.BehaviorDerivationError]+  | BehaviorReportSourceFailed ![BehaviorSource.BehaviorSourceFailure]++sourceAwareBehaviorReport :: FilePath -> Maybe T.Text -> SemanticSourceIndex -> Spec -> Either BehaviorReportFailure Behavior.BehaviorObligationsReport+sourceAwareBehaviorReport subject workspaceService sourceIndex spec = do+  requirements <- either (Left . BehaviorReportDerivationFailed) Right (Behavior.deriveBehaviorRequirements spec)+  sourceEntries <- either (Left . BehaviorReportSourceFailed) Right (BehaviorSource.planBehaviorSourceMap requirements sourceIndex)   pure     Behavior.BehaviorObligationsReport-      { Behavior.behaviorSubject = wsManifestPath workspace,-        Behavior.behaviorWorkspaceService = Just (wsService workspace),-        Behavior.behaviorRequirements =-          map-            (Behavior.attributeBehaviorOwner (fmap fst . nodeOwner (wsOwnership workspace) "aggregate"))-            requirements+      { Behavior.behaviorSubject = subject,+        Behavior.behaviorWorkspaceService = workspaceService,+        Behavior.behaviorRequirements = BehaviorSource.attachBehaviorSourceLocations sourceEntries requirements       }  writeBehaviorReport :: BehaviorFormat -> Behavior.BehaviorObligationsReport -> IO ()@@ -728,6 +757,24 @@   mapM_ (hPutStrLn stderr . ("behavior obligation derivation failed: " <>) . show) errors   exitFailure +renderBehaviorReportFailure :: BehaviorReportFailure -> IO ()+renderBehaviorReportFailure failure = case failure of+  BehaviorReportDerivationFailed errors -> renderBehaviorErrors errors+  BehaviorReportSourceFailed errors -> do+    mapM_+      ( \sourceFailure ->+          hPutStrLn+            stderr+            ( show (BehaviorSource.failureCode sourceFailure)+                <> " "+                <> T.unpack (Behavior.unBehaviorKey (BehaviorSource.failureKey sourceFailure))+                <> ": "+                <> T.unpack (BehaviorSource.failureMessage sourceFailure)+            )+      )+      errors+    exitFailure+ -- | @check@ on a workspace manifest: compose the whole service from its member -- @.keiro@ files and validate it as one contract. Diagnostics are rendered -- against the member file and line that produced them, and a single diagnostic@@ -749,14 +796,14 @@     Right workspace -> do       let service = checkedWorkspace workspace           floorDiags = maybe [] (\floorVersion -> minimumWorkspaceLanguageDiagnostics floorVersion workspace) (checkMinLanguage options)-          semanticDiags = floorDiags <> checkWorkspace workspace+          semanticDiags = floorDiags <> checkWorkspaceForService workspace service           spec = checkedSpec service           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)+      coveragePlan <- planCheckCoverage fp service (if semanticFailed then Nothing else checkCoverage options)       coverageOk <- emitPlannedCoverage coveragePlan       let diags = semanticDiags <> map (workspaceCoverageDiagnostic fp) (plannedCoverageFindings coveragePlan)           deniedWarningCodes = deniedWorkspaceWarningCodes options diags@@ -918,6 +965,8 @@                           mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written                           let changes = map wcChange workspaceChanges                               effectiveGate = gateWith gatedSurfaces+                              semanticImpact = CheckedDiff.mappedSemanticImpactForServices oldService newService+                              coordination = coordinationImpact oldService newService semanticImpact                               reportMeta =                                 WorkspaceMeta                                   { wmIdentity = wsService newWorkspace,@@ -928,13 +977,15 @@                                     wmAdoptionBaseline = adoptionBaseline                                   }                           mapM_ (TIO.putStrLn . renderWorkspaceFinding) workspaceChanges+                          mapM_ TIO.putStrLn (renderSemanticImpact semanticImpact)+                          mapM_ TIO.putStrLn (renderCoordinationImpact coordination)                           when explain $                             mapM_ (TIO.putStrLn . renderExplainBlock) (filter shouldExplain changes)                           TIO.putStrLn (renderReplayImpact impact)                           mapM_ (`Aeson.encodeFile` impact) replayImpactOut-                          mapM_ (\path -> Aeson.encodeFile path (workspaceDiffReport reportMeta effectiveGate workspaceChanges)) reportOut+                          mapM_ (\path -> Aeson.encodeFile path (workspaceDiffReportWithImpacts reportMeta effectiveGate workspaceChanges semanticImpact coordination)) reportOut                           coverageOk <- runDiffCoverage fp (T.pack ref) oldSpec newSpec coverageOptions-                          if any (gatedBreaking effectiveGate) changes || not coverageOk then exitFailure else pure ()+                          if any (gatedBreaking effectiveGate) changes || any ((== CoordinationBreaking) . coordinationSeverity) coordination || not coverageOk then exitFailure else pure ()  -- | A @git show@ backed source rooted at a workspace manifest directory. gitContentSource :: FilePath -> String -> FilePath -> ContentSource@@ -991,6 +1042,7 @@             specMapped = [],             specNodes = []           },+      wsSourceIndex = emptySemanticSourceIndex,       wsLineMap = LineMap [],       wsOwnership = OwnershipIndex mempty mempty     }@@ -1082,10 +1134,10 @@   | -- | The mapped-type graph did not resolve; the pass cannot run.     CoverageUnresolved !String -planCheckCoverage :: FilePath -> Spec -> Maybe CheckCoverageOptions -> IO PlannedCoverage+planCheckCoverage :: FilePath -> CheckedService -> Maybe CheckCoverageOptions -> IO PlannedCoverage planCheckCoverage _ _ Nothing = pure NoCoverage-planCheckCoverage specPath spec (Just options) =-  pure $ case Coverage.coverageReport specPath spec of+planCheckCoverage specPath service (Just options) =+  pure $ case Coverage.coverageReportForService specPath service of     Left graphErrors -> CoverageUnresolved (show graphErrors)     Right baseReport ->       PlannedCoverage

+ bench/parser-scaling/Main.hs view

@@ -0,0 +1,610 @@+module Main (main) where++import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Monad (forM_, unless)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Frontend (parseSurfaceSource, renderFrontendFailure)+import Keiro.Dsl.Grammar (Node (..), Spec (..))+import Keiro.Dsl.LanguageVersion (ParsedSource (..))+import Keiro.Dsl.Parser (parseSource, renderParseFailure)+import Keiro.Dsl.Scaffold (ScaffoldModule, defaultContext, firewallBreaches, modulePath, moduleText, scaffoldAggregateForService)+import Keiro.Dsl.ScaffoldRun (scaffoldServiceModules)+import Keiro.Dsl.SemanticContract (checkedSource)+import Keiro.Dsl.Syntax (SurfaceSource)+import Keiro.Dsl.Validate (validateService)+import Keiro.Dsl.Workspace+  ( ContentSource (..),+    WorkspaceSpec,+    loadWorkspace,+    renderWorkspaceFailure,+  )+import Test.Tasty.Bench (Benchmark, bench, bgroup, defaultMain, whnf, whnfIO)++data SourceFixture = SourceFixture+  { fixtureAggregateCount :: !Int,+    fixtureConstructCount :: !Int,+    fixtureSource :: !Text+  }++data WorkspaceFixture = WorkspaceFixture+  { fixtureMemberCount :: !Int,+    fixtureAggregateCount :: !Int,+    fixtureTotalConstructCount :: !Int,+    fixtureManifestPath :: !FilePath,+    fixtureContents :: !(Map FilePath Text)+  }++data OutcomeFixture = OutcomeFixture+  { fixtureSilentEdgeCount :: !Int,+    fixtureOutcomeSource :: !Text+  }++data TypeGraphFixture = TypeGraphFixture+  { fixtureMappedCount :: !Int,+    fixtureRouterCount :: !Int,+    fixtureTypeGraphParsed :: !ParsedSource+  }++main :: IO ()+main = do+  let sourceFixtures = map (uncurry sourceFixture) sourceShapes+      outcomeFixtures = map outcomeFixture outcomeShapes+      typeGraphFixtures = map (uncurry typeGraphFixture) typeGraphShapes+      workspaceFixtures =+        [ workspaceFixture memberCount aggregateCount transitionsPerAggregate+        | (memberCount, aggregateCount, transitionsPerAggregate) <- workspaceShapes+        ]+  -- Build and force immutable inputs directly before registering benchmarks.+  -- tasty-bench's env accessor is deliberately unnecessary here and would+  -- reintroduce a lazy resource thunk around these already prepared values.+  forceFixtures sourceFixtures workspaceFixtures outcomeFixtures typeGraphFixtures+  preflightFixtures sourceFixtures workspaceFixtures outcomeFixtures typeGraphFixtures+  defaultMain (benchmarks sourceFixtures workspaceFixtures outcomeFixtures typeGraphFixtures)++sourceShapes :: [(Int, Int)]+sourceShapes = [(8, 4), (8, 8), (8, 16), (8, 32)]++workspaceShapes :: [(Int, Int, Int)]+workspaceShapes = [(1, 8, 16), (2, 8, 16), (4, 8, 16), (8, 8, 16)]++outcomeShapes :: [Int]+outcomeShapes = [8, 32, 128, 512]++typeGraphShapes :: [(Int, Int)]+typeGraphShapes = [(16, 2), (32, 4), (64, 8), (64, 16)]++forceFixtures :: [SourceFixture] -> [WorkspaceFixture] -> [OutcomeFixture] -> [TypeGraphFixture] -> IO ()+forceFixtures sourceFixtures workspaceFixtures outcomeFixtures typeGraphFixtures = do+  forM_ sourceFixtures $ \SourceFixture {fixtureSource} ->+    evaluate (force fixtureSource)+  forM_ workspaceFixtures $ \WorkspaceFixture {fixtureContents} ->+    evaluate (force fixtureContents)+  forM_ outcomeFixtures $ \OutcomeFixture {fixtureOutcomeSource} ->+    evaluate (force fixtureOutcomeSource)+  forM_ typeGraphFixtures $ \TypeGraphFixture {fixtureTypeGraphParsed} ->+    evaluate fixtureTypeGraphParsed++preflightFixtures :: [SourceFixture] -> [WorkspaceFixture] -> [OutcomeFixture] -> [TypeGraphFixture] -> IO ()+preflightFixtures sourceFixtures workspaceFixtures outcomeFixtures typeGraphFixtures = do+  forM_ sourceFixtures $ \fixture@SourceFixture {fixtureSource} -> do+    _ <- evaluate (parseSurfaceOrFail (sourcePath fixture) fixtureSource)+    _ <- evaluate (parseCompatibilityOrFail (sourcePath fixture) fixtureSource)+    pure ()+  forM_ workspaceFixtures loadWorkspaceOrFail+  forM_ outcomeFixtures $ \fixture -> do+    _ <- evaluate (checkOutcomeOrFail fixture)+    let modules = generateOutcomeModulesOrFail fixture+        eventStream = outcomeEventStreamOrFail modules+        armCount = T.count " -> SilentRejected" eventStream + T.count " -> SilentNoOp" eventStream+    _ <- evaluate (sum (map (T.length . moduleText) modules))+    unless (armCount == fixtureSilentEdgeCount fixture) $+      error ("outcome classifier arm count mismatch for " <> outcomeLabel fixture)+    unless (firewallBreaches modules == []) $+      error ("outcome fixture breached generated symbolic firewall for " <> outcomeLabel fixture)+    forM_ ["Data.Map", "lookup", "find", "edgesOut"] $ \forbidden ->+      unless (not (forbidden `T.isInfixOf` eventStream)) $+        error ("outcome classifier contains forbidden dispatch token " <> T.unpack forbidden)+    pure ()+  forM_ (zip outcomeFixtures (drop 1 outcomeFixtures)) $ \(smaller, larger) -> do+    let smallerBytes = generateOutcomeBytesOrFail smaller+        largerBytes = generateOutcomeBytesOrFail larger+    unless (largerBytes <= 6 * smallerBytes) $+      error+        ( "outcome generated source grew by more than sixfold across a fourfold edge increase: "+            <> show smallerBytes+            <> " -> "+            <> show largerBytes+        )+  forM_ typeGraphFixtures $ \fixture -> do+    _ <- evaluate (checkTypeGraphOrFail fixture)+    _ <- evaluate (scaffoldTypeGraphBytes fixture)+    pure ()++benchmarks :: [SourceFixture] -> [WorkspaceFixture] -> [OutcomeFixture] -> [TypeGraphFixture] -> [Benchmark]+benchmarks sourceFixtures workspaceFixtures outcomeFixtures typeGraphFixtures =+  -- Weak-head evaluation is sufficient: producing the outer Right requires+  -- each Megaparsec route to consume its explicit eof, and loadWorkspace does+  -- all member reads, parses, and composition before returning its Either.+  -- The public parse results intentionally have no NFData instance.+  [ bgroup "surface-source" (map surfaceBenchmark sourceFixtures),+    bgroup "compatibility-source" (map compatibilityBenchmark sourceFixtures),+    bgroup "workspace" (map workspaceBenchmark workspaceFixtures),+    bgroup+      "domain-outcomes"+      [ bgroup "check" (map outcomeCheckBenchmark outcomeFixtures),+        bgroup "generate" (map outcomeGenerationBenchmark outcomeFixtures)+      ],+    bgroup+      "type-graph"+      [ bgroup "service-check" (map typeGraphCheckBenchmark typeGraphFixtures),+        bgroup "service-scaffold-plan" (map typeGraphScaffoldBenchmark typeGraphFixtures)+      ]+  ]++surfaceBenchmark :: SourceFixture -> Benchmark+surfaceBenchmark fixture@SourceFixture {fixtureSource} =+  bench (sourceLabel fixture) $+    whnf (parseSurfaceSource (sourcePath fixture)) fixtureSource++compatibilityBenchmark :: SourceFixture -> Benchmark+compatibilityBenchmark fixture@SourceFixture {fixtureSource} =+  bench (sourceLabel fixture) $+    whnf (parseSource (sourcePath fixture)) fixtureSource++workspaceBenchmark :: WorkspaceFixture -> Benchmark+workspaceBenchmark fixture@WorkspaceFixture {fixtureMemberCount, fixtureAggregateCount, fixtureTotalConstructCount, fixtureContents} =+  bench+    ( "members-"+        <> show fixtureMemberCount+        <> "-aggregates-"+        <> show fixtureAggregateCount+        <> "-transitions-"+        <> show fixtureTotalConstructCount+        <> "-chars-"+        <> show (sum (map T.length (Map.elems fixtureContents)))+    )+    (whnfIO (loadWorkspaceOrFail fixture))++outcomeCheckBenchmark :: OutcomeFixture -> Benchmark+outcomeCheckBenchmark fixture =+  bench (outcomeLabel fixture) $ whnf checkOutcomeOrFail fixture++outcomeGenerationBenchmark :: OutcomeFixture -> Benchmark+outcomeGenerationBenchmark fixture =+  bench (outcomeLabel fixture) $ whnf generateOutcomeBytesOrFail fixture++typeGraphCheckBenchmark :: TypeGraphFixture -> Benchmark+typeGraphCheckBenchmark fixture =+  bench (typeGraphLabel fixture) $ whnf checkTypeGraphOrFail fixture++typeGraphScaffoldBenchmark :: TypeGraphFixture -> Benchmark+typeGraphScaffoldBenchmark fixture =+  bench (typeGraphLabel fixture) $ whnf scaffoldTypeGraphBytes fixture++sourceFixture :: Int -> Int -> SourceFixture+sourceFixture fixtureAggregateCount fixtureTransitionsPerAggregate =+  SourceFixture+    { fixtureAggregateCount,+      fixtureConstructCount = fixtureAggregateCount * fixtureTransitionsPerAggregate,+      fixtureSource = nestedSpecification "parser-bench" 0 fixtureAggregateCount fixtureTransitionsPerAggregate+    }++sourceLabel :: SourceFixture -> String+sourceLabel SourceFixture {fixtureAggregateCount, fixtureConstructCount, fixtureSource} =+  "aggregates-"+    <> show fixtureAggregateCount+    <> "-transitions-"+    <> show fixtureConstructCount+    <> "-chars-"+    <> show (T.length fixtureSource)++sourcePath :: SourceFixture -> FilePath+sourcePath SourceFixture {fixtureConstructCount} = "parser-bench-" <> show fixtureConstructCount <> ".keiro"++nestedSpecification :: Text -> Int -> Int -> Int -> Text+nestedSpecification contextName firstAggregate aggregateCount transitionsPerAggregate =+  T.unlines+    [ "language keiro-dsl 4",+      "context " <> contextName+    ]+    <> T.concat+      [ aggregateDefinition index transitionsPerAggregate+      | index <- [firstAggregate .. firstAggregate + aggregateCount - 1]+      ]++aggregateDefinition :: Int -> Int -> Text+aggregateDefinition index transitionCount =+  T.unlines+    ( [ "",+        "aggregate " <> aggregateName,+        "  regs",+        "    count Natural = 0",+        "    limit Natural = 100",+        "    label Text = \"ready # literal\"",+        "  states " <> T.unwords [stateName stateIndex <> terminalMarker stateIndex | stateIndex <- [0 .. transitionCount]]+      ]+        <> concatMap commandAndEvent transitionIndexes+        <> concatMap transition transitionIndexes+    )+  where+    aggregateName = "BenchAggregate" <> paddedDecimal index+    transitionIndexes = [0 .. transitionCount - 1]+    stateName stateIndex = "State" <> paddedDecimal stateIndex+    terminalMarker stateIndex+      | stateIndex == transitionCount = "!"+      | otherwise = ""+    commandName transitionIndex = "Advance" <> paddedDecimal transitionIndex+    eventName transitionIndex = "Advanced" <> paddedDecimal transitionIndex+    commandAndEvent transitionIndex =+      [ "  command " <> commandName transitionIndex <> " { amount:Natural delta:Natural note:Text }",+        "  event " <> eventName transitionIndex <> " = fields(" <> commandName transitionIndex <> ")"+      ]+    transition transitionIndex =+      [ "  " <> stateName transitionIndex <> " -- " <> commandName transitionIndex <> " -->",+        "    guard cmd.amount + cmd.delta > reg.count && reg.limit >= cmd.amount",+        "    write count := reg.count + cmd.amount",+        "    write limit := reg.limit + cmd.delta",+        "    write label := cmd.note",+        "    emit " <> eventName transitionIndex,+        "    goto " <> stateName (transitionIndex + 1)+      ]++paddedDecimal :: Int -> Text+paddedDecimal number =+  let rendered = T.pack (show number)+   in T.replicate (6 - T.length rendered) "0" <> rendered++outcomeFixture :: Int -> OutcomeFixture+outcomeFixture fixtureSilentEdgeCount =+  OutcomeFixture+    { fixtureSilentEdgeCount,+      fixtureOutcomeSource = outcomeSpecification fixtureSilentEdgeCount+    }++outcomeLabel :: OutcomeFixture -> String+outcomeLabel fixture@OutcomeFixture {fixtureSilentEdgeCount, fixtureOutcomeSource} =+  "silent-edges-"+    <> show fixtureSilentEdgeCount+    <> "-chars-"+    <> show (T.length fixtureOutcomeSource)+    <> "-generated-bytes-"+    <> show (generateOutcomeBytesOrFail fixture)++outcomePath :: OutcomeFixture -> FilePath+outcomePath OutcomeFixture {fixtureSilentEdgeCount} =+  "domain-outcomes-" <> show fixtureSilentEdgeCount <> ".keiro"++outcomeSpecification :: Int -> Text+outcomeSpecification silentEdgeCount =+  T.unlines+    [ "language keiro-dsl 5",+      "context domain-outcome-bench",+      "",+      "enum BenchRejection { Rejected=rejected }",+      "enum BenchNoOp { Duplicate=duplicate }",+      "",+      "aggregate BenchOutcome",+      "  domain-outcomes rejection=BenchRejection no-op=BenchNoOp",+      "  regs",+      "    marker Text = \"ready\"",+      "  states Ready",+      "",+      "  command Accept { token:Text }",+      "  event Accepted = fields(Accept)"+    ]+    <> T.concat+      [ T.unlines+          [ "  command Silent" <> paddedDecimal edgeIndex <> " { token:Text }"+          ]+      | edgeIndex <- [0 .. silentEdgeCount - 1]+      ]+    <> T.unlines+      [ "",+        "  Ready -- Accept -->",+        "    outcome accepted",+        "    emit Accepted",+        "    goto Ready"+      ]+    <> T.concat+      [ T.unlines+          [ "",+            "  Ready -- Silent" <> paddedDecimal edgeIndex <> " -->",+            if even edgeIndex+              then "    outcome rejected BenchRejection.Rejected"+              else "    outcome no-op BenchNoOp.Duplicate",+            "    goto Ready"+          ]+      | edgeIndex <- [0 .. silentEdgeCount - 1]+      ]++checkOutcomeOrFail :: OutcomeFixture -> Int+checkOutcomeOrFail fixture =+  case parseSource (outcomePath fixture) (fixtureOutcomeSource fixture) of+    Left failure -> error (T.unpack (renderParseFailure failure))+    Right parsed -> case validateService (checkedSource parsed) of+      [] -> fixtureSilentEdgeCount fixture+      diagnostics -> error ("outcome benchmark validation failed: " <> show diagnostics)++generateOutcomeBytesOrFail :: OutcomeFixture -> Int+generateOutcomeBytesOrFail = sum . map (T.length . moduleText) . generateOutcomeModulesOrFail++generateOutcomeModulesOrFail :: OutcomeFixture -> [ScaffoldModule]+generateOutcomeModulesOrFail fixture =+  case parseSource (outcomePath fixture) (fixtureOutcomeSource fixture) of+    Left failure -> error (T.unpack (renderParseFailure failure))+    Right parsed -> case [aggregate | NAggregate aggregate <- specNodes (parsedSpec parsed)] of+      [aggregate] ->+        scaffoldAggregateForService+          (defaultContext (specContext (parsedSpec parsed)))+          (checkedSource parsed)+          aggregate+      aggregates -> error ("outcome benchmark expected one aggregate, got " <> show (length aggregates))++outcomeEventStreamOrFail :: [ScaffoldModule] -> Text+outcomeEventStreamOrFail modules =+  case [ moduleText scaffoldModule+       | scaffoldModule <- modules,+         "/EventStream.hs" `T.isSuffixOf` T.pack (modulePath scaffoldModule)+       ] of+    [eventStream] -> eventStream+    eventStreams -> error ("outcome benchmark expected one event-stream module, got " <> show (length eventStreams))++typeGraphFixture :: Int -> Int -> TypeGraphFixture+typeGraphFixture fixtureMappedCount fixtureRouterCount =+  TypeGraphFixture+    { fixtureMappedCount,+      fixtureRouterCount,+      fixtureTypeGraphParsed =+        parseCompatibilityOrFail+          ("type-graph-" <> show fixtureMappedCount <> "-" <> show fixtureRouterCount <> ".keiro")+          (typeGraphSpecification fixtureMappedCount fixtureRouterCount)+    }++typeGraphLabel :: TypeGraphFixture -> String+typeGraphLabel TypeGraphFixture {fixtureMappedCount, fixtureRouterCount} =+  "m" <> show fixtureMappedCount <> "-r" <> show fixtureRouterCount++checkTypeGraphOrFail :: TypeGraphFixture -> Int+checkTypeGraphOrFail fixture@TypeGraphFixture {fixtureTypeGraphParsed} =+  case validateService (checkedSource fixtureTypeGraphParsed) of+    [] -> fixtureMappedCount fixture + fixtureRouterCount fixture+    diagnostics -> error ("type-graph benchmark validation failed: " <> show diagnostics)++scaffoldTypeGraphBytes :: TypeGraphFixture -> Int+scaffoldTypeGraphBytes TypeGraphFixture {fixtureTypeGraphParsed} =+  let spec = parsedSpec fixtureTypeGraphParsed+      service = checkedSource fixtureTypeGraphParsed+   in sum+        ( map+            (T.length . moduleText)+            (scaffoldServiceModules (defaultContext (specContext spec)) service)+        )++typeGraphSpecification :: Int -> Int -> Text+typeGraphSpecification mappedCount routerCount+  | mappedCount < 2 = error "type-graph fixture needs at least two mapped declarations"+  | routerCount < 1 = error "type-graph fixture needs at least one router"+  | otherwise =+      T.unlines+        [ "language keiro-dsl 5",+          "context type-graph-bench",+          ""+        ]+        <> T.concat (map chainedMappedDefinition [0 .. mappedCount - 3])+        <> routeInputDefinition+        <> routeRowDefinition+        <> typeGraphServiceDefinition+        <> T.concat (map routerDefinition [0 .. routerCount - 1])++chainedMappedDefinition :: Int -> Text+chainedMappedDefinition index =+  T.unlines+    [ "mapped structural record " <> typeName <> " {",+      "  haskell package=keiro-dsl module=Benchmark.TypeGraph.Domain type=" <> typeName,+      "  binding = \"Benchmark.TypeGraph.Bindings." <> lowerName <> "Binding\"",+      "  binding-version = \"1\"",+      "  canonical-type = \"benchmark.type-graph." <> typeName <> ".v1\"",+      "  fixtures = \"Benchmark.TypeGraph.Bindings." <> lowerName <> "Cases\"",+      "  wire object constructor=" <> typeName <> " unknown-fields=reject {",+      "    value as \"value\" : " <> fieldType <> " required",+      "  }",+      "}",+      ""+    ]+  where+    typeName = "BenchMapped" <> paddedDecimal index+    lowerName = "benchMapped" <> paddedDecimal index+    fieldType+      | index == 0 = "Text"+      | otherwise = "BenchMapped" <> paddedDecimal (index - 1)++routeInputDefinition :: Text+routeInputDefinition =+  T.unlines+    [ "mapped structural record BenchRouteInput {",+      "  haskell package=keiro-dsl module=Benchmark.TypeGraph.Domain type=BenchRouteInput",+      "  binding = \"Benchmark.TypeGraph.Bindings.benchRouteInputBinding\"",+      "  binding-version = \"1\"",+      "  canonical-type = \"benchmark.type-graph.BenchRouteInput.v1\"",+      "  fixtures = \"Benchmark.TypeGraph.Bindings.benchRouteInputCases\"",+      "  wire object constructor=BenchRouteInput unknown-fields=reject {",+      "    transferNeedId as \"transfer_need_id\" : Text required",+      "    region as \"region\" : Text required",+      "  }",+      "}",+      ""+    ]++routeRowDefinition :: Text+routeRowDefinition =+  T.unlines+    [ "mapped structural record BenchRouteRow {",+      "  haskell package=keiro-dsl module=Benchmark.TypeGraph.Domain type=BenchRouteRow",+      "  binding = \"Benchmark.TypeGraph.Bindings.benchRouteRowBinding\"",+      "  binding-version = \"1\"",+      "  canonical-type = \"benchmark.type-graph.BenchRouteRow.v1\"",+      "  fixtures = \"Benchmark.TypeGraph.Bindings.benchRouteRowCases\"",+      "  wire object constructor=BenchRouteRow unknown-fields=reject {",+      "    hospitalId as \"hospital_id\" : Text required",+      "    region as \"region\" : Text required",+      "    availableBeds as \"available_beds\" : Int required",+      "  }",+      "}",+      ""+    ]++typeGraphServiceDefinition :: Text+typeGraphServiceDefinition =+  T.unlines+    [ "target bench_route_table {",+      "  schema = \"public\"",+      "  table = \"bench_route\"",+      "  reset = clear",+      "}",+      "",+      "rebuild-group reporting {",+      "  targets = [ bench_route_table ]",+      "  order = [ bench_route_table ]",+      "}",+      "",+      "projection-owner bench_route_writer {",+      "  source = category \"benchRoute\"",+      "  feed = subscription",+      "  group = reporting",+      "  targets = [ bench_route_table ]",+      "  order = 10",+      "  subscription = \"type-graph-bench-route\"",+      "  dedup = \"type-graph-bench-route-v1\"",+      "  checkpoint-on-missing = fail",+      "  replay = explicit",+      "}",+      "",+      "readmodel bench_route {",+      "  columns {}",+      "  query input = BenchRouteInput",+      "  query result = List BenchRouteRow",+      "  version = 1",+      "  shape = \"fnv1a:3c07a19c552c3547\"",+      "  consistency = Eventual",+      "  feed = subscription",+      "  group = reporting",+      "  targets = [ bench_route_table ]",+      "}",+      "",+      "aggregate BenchHospital",+      "  regs",+      "    routed Bool = False",+      "  states Open Routed!",+      "",+      "  command RouteAcceptedTransferNeed { transferNeedId:Text hospitalId:Text }",+      "  event TransferNeedRouted = fields(RouteAcceptedTransferNeed)",+      "",+      "  Open -- RouteAcceptedTransferNeed --> write routed := true ; emit TransferNeedRouted ; goto Routed",+      "",+      "  wire kind=ctorName fields=camelCase schemaVersion=1",+      ""+    ]++routerDefinition :: Int -> Text+routerDefinition index =+  T.unlines+    [ "router BenchRouter" <> suffix,+      "  name \"bench-router-" <> suffix <> "\"",+      "  input AcceptedHospitalTransferNeed" <> suffix <> " : BenchRouteInput",+      "  key input.transferNeedId",+      "  resolve declarative {",+      "    identity = \"bench-route-selection-" <> suffix <> "\"",+      "    version = 1",+      "    query = read-model bench_route with input",+      "    where = row.region == input.region && row.availableBeds > 0",+      "    recipient = row.hospitalId",+      "    order = target-stream",+      "    dedupe = target-stream",+      "    max-recipients = 64",+      "    empty => ack",+      "    failure => retry",+      "    redelivery = stable-union",+      "    partial = retain-successes",+      "  }",+      "  target BenchHospital",+      "  projections []",+      "  dispatch-each RouteAcceptedTransferNeed {",+      "    transferNeedId=input.transferNeedId",+      "    hospitalId=row.hospitalId",+      "  }",+      "    on-appended AckOk ; on-duplicate Retry ; on-failed Retry",+      "  dispatch-id strategy=uuidv5 from=(name, key, sourceEventId, targetStreamName, occurrence)",+      "  rejected => halt",+      "  poison => halt",+      ""+    ]+  where+    suffix = paddedDecimal index++workspaceFixture :: Int -> Int -> Int -> WorkspaceFixture+workspaceFixture memberCount aggregateCount transitionsPerAggregate+  | aggregateCount `mod` memberCount /= 0 =+      error "workspace fixture aggregate count must divide evenly across members"+  | otherwise =+      WorkspaceFixture+        { fixtureMemberCount = memberCount,+          fixtureAggregateCount = aggregateCount,+          fixtureTotalConstructCount = aggregateCount * transitionsPerAggregate,+          fixtureManifestPath = manifestPath,+          fixtureContents = Map.insert manifestPath manifest members+        }+  where+    manifestPath = "service.keiro-workspace"+    aggregatesPerMember = aggregateCount `div` memberCount+    memberRows =+      [ ( memberPath memberIndex,+          nestedSpecification+            "parser-bench-workspace"+            (memberIndex * aggregatesPerMember)+            aggregatesPerMember+            transitionsPerAggregate+        )+      | memberIndex <- [0 .. memberCount - 1]+      ]+    members = Map.fromList memberRows+    manifest =+      T.unlines+        ( "service parser-bench-workspace"+            : ["spec " <> T.pack path | (path, _) <- memberRows]+        )++memberPath :: Int -> FilePath+memberPath memberIndex = "member-" <> T.unpack (paddedDecimal memberIndex) <> ".keiro"++parseSurfaceOrFail :: FilePath -> Text -> SurfaceSource+parseSurfaceOrFail path source =+  case parseSurfaceSource path source of+    Left failure -> error (T.unpack (renderFrontendFailure failure))+    Right parsed -> parsed++parseCompatibilityOrFail :: FilePath -> Text -> ParsedSource+parseCompatibilityOrFail path source =+  case parseSource path source of+    Left failure -> error (T.unpack (renderParseFailure failure))+    Right parsed -> parsed++loadWorkspaceOrFail :: WorkspaceFixture -> IO WorkspaceSpec+loadWorkspaceOrFail WorkspaceFixture {fixtureManifestPath, fixtureContents} = do+  result <- loadWorkspace contentSource fixtureManifestPath+  case result of+    Left failure -> error (T.unpack (T.unlines (renderWorkspaceFailure fixtureManifestPath failure)))+    Right workspace -> pure workspace+  where+    contentSource =+      ContentSource+        { csRead = \path ->+            pure $+              maybe+                (Left ("missing in-memory benchmark fixture: " <> T.pack path))+                Right+                (Map.lookup path fixtureContents)+        }

keiro-dsl.cabal view

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            keiro-dsl-version:         0.11.0.0+version:         0.12.0.0 synopsis:        Typed specification toolchain for keiro services description:   keiro-dsl is the toolchain over a typed `.keiro` specification of a keiro@@ -9,6 +9,7 @@   operator (the firewall invariant).  license:         BSD-3-Clause+license-file:    LICENSE author:          Nadeem Bitar maintainer:      nadeem@gmail.com copyright:       2026 Nadeem Bitar@@ -47,6 +48,13 @@   default-language:   GHC2024   default-extensions: OverloadedStrings +  -- Published Languages 1-4 intentionally retain the frozen 0.11 ReadModel+  -- spelling during the 0.12 migration window. Those generated bytes are not+  -- user-maintained and cannot act on Keiro's Haskell API deprecations, so keep+  -- them compilable under the generated-output -Werror gate. Candidate Language+  -- 5 emits the truthful API and does not rely on this compatibility allowance.+  ghc-options:        -Wno-deprecations+   if flag(werror-generated)     ghc-options: -Werror @@ -57,10 +65,13 @@   exposed-modules:     Keiro.Dsl.AggregateType     Keiro.Dsl.BehaviorCoverage+    Keiro.Dsl.BehaviorSourceMap     Keiro.Dsl.CanonicalEncoding     Keiro.Dsl.CheckReport     Keiro.Dsl.CodecCompare     Keiro.Dsl.ConformancePackage+    Keiro.Dsl.ConsumerTypePlan+    Keiro.Dsl.CoordinationImpact     Keiro.Dsl.Coverage     Keiro.Dsl.Diff     Keiro.Dsl.DiffReport@@ -72,27 +83,36 @@     Keiro.Dsl.Goldens     Keiro.Dsl.Grammar     Keiro.Dsl.Harness+    Keiro.Dsl.HaskellImport     Keiro.Dsl.HaskellSourceMove     Keiro.Dsl.IdDomain     Keiro.Dsl.LanguageVersion     Keiro.Dsl.Manifest+    Keiro.Dsl.MappedCodecPlan     Keiro.Dsl.MappedConsumer     Keiro.Dsl.MappedDiff     Keiro.Dsl.NominalType     Keiro.Dsl.Parser     Keiro.Dsl.PrettyPrint+    Keiro.Dsl.ProjectionMappedImpact+    Keiro.Dsl.ProjectionSupply+    Keiro.Dsl.ReadModelQueryContract     Keiro.Dsl.ReadModelShape     Keiro.Dsl.ReplayImpact+    Keiro.Dsl.RouterSelection     Keiro.Dsl.RuntimePackage     Keiro.Dsl.Scaffold     Keiro.Dsl.ScaffoldRecord     Keiro.Dsl.ScaffoldRun     Keiro.Dsl.SemanticContract+    Keiro.Dsl.SemanticImpact     Keiro.Dsl.ServiceHarness     Keiro.Dsl.SidecarMigration     Keiro.Dsl.SidecarNames     Keiro.Dsl.Skeleton     Keiro.Dsl.Source+    Keiro.Dsl.SourceIndex+    Keiro.Dsl.StructuralConformance     Keiro.Dsl.Syntax     Keiro.Dsl.TypeGraph     Keiro.Dsl.Validate@@ -107,7 +127,6 @@     Keiro.Dsl.FieldIdentity     Keiro.Dsl.Frontend.Internal     Keiro.Dsl.GeneratedHaskellLanguage-    Keiro.Dsl.HaskellImport     Keiro.Dsl.HaskellName     Keiro.Dsl.Parser.Aggregate     Keiro.Dsl.Parser.Coordination@@ -118,6 +137,7 @@     Keiro.Dsl.Parser.Integration     Keiro.Dsl.Parser.Mapped     Keiro.Dsl.Parser.Preamble+    Keiro.Dsl.Parser.ProjectionCatalog     Keiro.Dsl.Parser.Queue     Keiro.Dsl.Parser.ReadModel     Keiro.Dsl.Parser.Workflow@@ -128,10 +148,11 @@     , base                >=4.21      && <5     , bytestring          >=0.12      && <0.13     , containers          >=0.6       && <0.8+    , cryptohash-sha256   >=0.11.102  && <0.12     , directory           >=1.3       && <1.4     , filepath            >=1.4       && <1.6     , keiki               >=0.9       && <0.10-    , keiro-core          ^>=0.11.0.0+    , keiro-core          ^>=0.12.0.0     , megaparsec          >=9.6       && <9.9     , mmzk-typeid         >=0.7       && <0.8     , parser-combinators  >=1.3       && <1.4@@ -154,11 +175,12 @@     , text                  >=2.1  && <2.2  test-suite keiro-dsl-test-  import:          warnings, shared-  type:            exitcode-stdio-1.0-  hs-source-dirs:  test-  main-is:         Main.hs-  autogen-modules: Paths_keiro_dsl+  import:             warnings, shared+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test+  main-is:            Main.hs+  build-tool-depends: keiro-dsl:keiro-dsl+  autogen-modules:    Paths_keiro_dsl   other-modules:     Keiro.Dsl.ConformanceBaseline     Keiro.Dsl.FrontendCompatibility@@ -220,10 +242,11 @@   hs-source-dirs: test/runtime-vocabulary   main-is:        Main.hs   build-depends:-    , base       >=4.21 && <5+    , base          >=4.21 && <5     , keiro     , keiro-dsl-    , text       >=2.1  && <2.2+    , shibuya-core+    , 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@@ -236,6 +259,7 @@   hs-source-dirs: test/conformance   main-is:        Main.hs   other-modules:+    Generated.HospitalCapacity.BehaviorSourceMap     Generated.HospitalCapacity.Nominals     Generated.HospitalCapacity.Nominals.Internal     Generated.HospitalCapacity.ReplayAudit@@ -265,6 +289,7 @@   main-is:        Main.hs   other-modules:     AggregateScalars.ScalarLedger.Holes+    Generated.AggregateScalars.BehaviorSourceMap     Generated.AggregateScalars.ReplayAudit     Generated.AggregateScalars.ScalarLedger.Codec     Generated.AggregateScalars.ScalarLedger.Domain@@ -292,6 +317,7 @@   other-modules:     AggregateScalarExpressions.ScalarAccount.BehaviorHoles     AggregateScalarExpressions.ScalarAccount.Holes+    Generated.AggregateScalarExpressions.BehaviorSourceMap     Generated.AggregateScalarExpressions.Nominals     Generated.AggregateScalarExpressions.Nominals.Internal     Generated.AggregateScalarExpressions.ReplayAudit@@ -303,6 +329,7 @@     Generated.AggregateScalarExpressions.ScalarAccount.Projection     Generated.AggregateScalarExpressions.ScalarAccount.Transducer     Generated.AggregateScalarExpressions.Structural.Shape.Limits+    Generated.AggregateScalarExpressions.StructuralConformance     Generated.AggregateScalarExpressions.StructuralProjections     ScalarExpressions.Bindings     ScalarExpressions.Domain@@ -327,6 +354,7 @@     BehaviorComplete.Domain     BehaviorComplete.Journey.BehaviorHoles     BehaviorComplete.Journey.Holes+    Generated.BehaviorComplete.BehaviorSourceMap     Generated.BehaviorComplete.Journey.BehaviorContract     Generated.BehaviorComplete.Journey.Codec     Generated.BehaviorComplete.Journey.Domain@@ -338,6 +366,7 @@     Generated.BehaviorComplete.Nominals.Internal     Generated.BehaviorComplete.ReplayAudit     Generated.BehaviorComplete.Structural.Shape.StartPayload+    Generated.BehaviorComplete.StructuralConformance     Generated.BehaviorComplete.StructuralProjections    build-depends:@@ -350,6 +379,32 @@     , text        >=2.1  && <2.2     , time        >=1.12 && <1.15 +test-suite keiro-dsl-conformance-domain-outcomes+  import:         warnings, generated-output+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-domain-outcomes+  main-is:        Main.hs+  other-modules:+    DomainOutcomes.Reservation.BehaviorHoles+    Generated.DomainOutcomes.BehaviorSourceMap+    Generated.DomainOutcomes.Nominals+    Generated.DomainOutcomes.ReplayAudit+    Generated.DomainOutcomes.Reservation.BehaviorContract+    Generated.DomainOutcomes.Reservation.Codec+    Generated.DomainOutcomes.Reservation.Domain+    Generated.DomainOutcomes.Reservation.EventStream+    Generated.DomainOutcomes.Reservation.Harness+    Generated.DomainOutcomes.Reservation.Projection+    Generated.DomainOutcomes.Reservation.Transducer++  build-depends:+    , aeson       >=2.2  && <2.3+    , base        >=4.21 && <5+    , containers  >=0.6  && <0.8+    , keiki       >=0.9  && <0.10+    , keiro+    , text        >=2.1  && <2.2+ -- EP-158: consumer-owned direct IDs, enums, and nominal scalar wrappers, -- checked KindID decoding, total bindings, projections, and snapshot caches. test-suite keiro-dsl-conformance-nominal-scalars@@ -358,6 +413,7 @@   hs-source-dirs: test/conformance-nominal-scalars   main-is:        Main.hs   other-modules:+    Generated.NominalScalars.BehaviorSourceMap     Generated.NominalScalars.Nominal.Shape.OrderStatus     Generated.NominalScalars.NominalLedger.BehaviorContract     Generated.NominalScalars.NominalLedger.Codec@@ -392,6 +448,7 @@   hs-source-dirs: test/conformance-workspace-nominals   main-is:        Main.hs   other-modules:+    Generated.WorkspaceNominalProof.BehaviorSourceMap     Generated.WorkspaceNominalProof.Nominals     Generated.WorkspaceNominalProof.Nominals.Internal     Generated.WorkspaceNominalProof.Project.BehaviorContract@@ -438,11 +495,13 @@     Generated.StructuralConformance.ArtifactCatalog.Harness     Generated.StructuralConformance.ArtifactCatalog.Projection     Generated.StructuralConformance.ArtifactCatalog.Transducer+    Generated.StructuralConformance.BehaviorSourceMap     Generated.StructuralConformance.ReplayAudit     Generated.StructuralConformance.Structural.Shape.ArtifactInfo     Generated.StructuralConformance.Structural.Shape.ArtifactKind     Generated.StructuralConformance.Structural.Shape.ArtifactLocation     Generated.StructuralConformance.Structural.Shape.ArtifactMetadata+    Generated.StructuralConformance.StructuralConformance     Generated.StructuralConformance.StructuralProjections     StructuralConformance.ArtifactCatalog.Holes @@ -457,6 +516,69 @@     , text        >=2.1  && <2.2     , time        >=1.12 && <1.15 +-- Plan 224: candidate language-5 mapped workqueue payloads share structural+-- codec authority while preserving the queue schema-version-1 envelope.+test-suite keiro-dsl-conformance-mapped-queue+  import:         warnings, generated-output+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-mapped-queue+  main-is:        Main.hs+  other-modules:+    Conformance.MappedQueue.Bindings+    Conformance.MappedQueue.Domain+    Generated.MappedQueue.MappedJobs.Queue+    Generated.MappedQueue.MappedJobs.QueueCodec+    Generated.MappedQueue.MappedJobs.QueuePolicy+    Generated.MappedQueue.Structural.Shape.JobMetadata+    Generated.MappedQueue.Structural.Shape.JobPayload+    Generated.MappedQueue.StructuralConformance+    Generated.MappedQueue.StructuralProjections++  build-depends:+    , aeson       >=2.2  && <2.3+    , base        >=4.21 && <5+    , keiki       >=0.9  && <0.10+    , keiro+    , keiro-core+    , keiro-dsl+    , keiro-pgmq+    , text        >=2.1  && <2.2++-- Plan 225: candidate language-5 read-model input/result expressions lower to+-- generated mapped domain aliases while SQL and query bodies remain hand-owned.+test-suite keiro-dsl-conformance-mapped-readmodel+  import:         warnings, generated-output+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-mapped-readmodel+  main-is:        Main.hs+  other-modules:+    Conformance.MappedReadModel.Bindings+    Conformance.MappedReadModel.Domain+    Generated.MappedReadmodel.AccountSummary.QueryContract+    Generated.MappedReadmodel.AccountSummary.ReadModel+    Generated.MappedReadmodel.AccountSummary.ReadModelHarness+    Generated.MappedReadmodel.AccountSummary.ReadModelTable+    Generated.MappedReadmodel.ProjectionCatalog+    Generated.MappedReadmodel.Structural.Shape.AccountLookup+    Generated.MappedReadmodel.Structural.Shape.AccountProfile+    Generated.MappedReadmodel.Structural.Shape.AccountSummary+    Generated.MappedReadmodel.Structural.Shape.TenantKey+    Generated.MappedReadmodel.Structural.Shape.UnusedFilter+    Generated.MappedReadmodel.StructuralConformance+    Generated.MappedReadmodel.StructuralProjections+    MappedReadmodel.AccountSummary.ReadModelHoles+    MappedReadmodel.ProjectionCatalog.ProjectionCatalogHoles++  build-depends:+    , base               >=4.21 && <5+    , effectful-core+    , hasql-transaction+    , keiki              >=0.9  && <0.10+    , keiro+    , keiro-dsl+    , kiroku-store+    , text               >=2.1  && <2.2+ -- Plan 184: colliding consumer type occurrences, local-name conflicts, and -- repeated binding/shape references compile with deterministic short aliases. test-suite keiro-dsl-conformance-import-planning@@ -465,6 +587,7 @@   hs-source-dirs: test/conformance-import-planning   main-is:        Main.hs   other-modules:+    Generated.ImportPlanningCollisions.BehaviorSourceMap     Generated.ImportPlanningCollisions.CollisionLedger.BehaviorContract     Generated.ImportPlanningCollisions.CollisionLedger.Codec     Generated.ImportPlanningCollisions.CollisionLedger.Domain@@ -475,6 +598,7 @@     Generated.ImportPlanningCollisions.NominalProjections     Generated.ImportPlanningCollisions.ReplayAudit     Generated.ImportPlanningCollisions.Structural.Shape.Details+    Generated.ImportPlanningCollisions.StructuralConformance     Generated.ImportPlanningCollisions.StructuralProjections     ImportPlanning.Bindings     ImportPlanning.Consumer.Domain@@ -537,6 +661,7 @@   hs-source-dirs: test/conformance-replay   main-is:        Main.hs   other-modules:+    Generated.ReplayDivergence.BehaviorSourceMap     Generated.ReplayDivergence.Note.Codec     Generated.ReplayDivergence.Note.Domain     Generated.ReplayDivergence.Note.EventStream@@ -579,6 +704,19 @@     , text         >=2.1  && <2.2     , time         >=1.12 && <1.15 +benchmark keiro-dsl-parser-bench+  import:         warnings, shared+  type:           exitcode-stdio-1.0+  hs-source-dirs: bench/parser-scaling+  main-is:        Main.hs+  build-depends:+    , base         >=4.21 && <5+    , containers   >=0.6  && <0.8+    , deepseq      >=1.5  && <1.6+    , keiro-dsl+    , tasty-bench  >=0.5  && <0.6+    , text         >=2.1  && <2.2+ -- EP-109 M2: snapshot-enabled aggregate scaffolding compiled against the live -- defaultStateCodec and stream-construction guards, with the captured codec -- identity checked against keiki's regFileShapeHash.@@ -588,6 +726,7 @@   hs-source-dirs: test/conformance-snapshot   main-is:        Main.hs   other-modules:+    Generated.HospitalCapacity.BehaviorSourceMap     Generated.HospitalCapacity.Nominals     Generated.HospitalCapacity.Nominals.Internal     Generated.HospitalCapacity.ReplayAudit@@ -711,6 +850,7 @@   main-is:        Main.hs   other-modules:     Billing.Subscription.Holes+    Generated.Billing.BehaviorSourceMap     Generated.Billing.Nominals     Generated.Billing.Nominals.Internal     Generated.Billing.ReplayAudit@@ -788,7 +928,7 @@     , effectful-core     , hasql-transaction     , keiro-    , kiroku-store       >=0.3  && <0.4+    , kiroku-store       >=0.7  && <0.8     , text               >=2.1  && <2.2  -- EP-4 publisher runtime conformance: the scaffolded Publisher config compiled@@ -866,6 +1006,76 @@     , kiroku-store     , text               >=2.1  && <2.2 +-- MasterPlan 32 / EP-4: language-5 catalog declarations lower into one+-- generated runtime-owned facade with typed inline views, catalog-derived+-- async/query registration, and a group-scoped history-runner entry point.+test-suite keiro-dsl-conformance-projection-catalog+  import:         warnings, generated-output+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-projection-catalog+  main-is:        Main.hs+  other-modules:+    CatalogDemo.CatalogAudit.ReadModelHoles+    CatalogDemo.MappedBindings+    CatalogDemo.MappedDomain+    CatalogDemo.OrderInline.ReadModelHoles+    CatalogDemo.Orders.BehaviorHoles+    CatalogDemo.Orders.Holes+    CatalogDemo.OrderTotalsLookup.ReadModelHoles+    CatalogDemo.ProjectionCatalog.ProjectionCatalogHoles+    CatalogDemo.ShipmentLookup.ReadModelHoles+    CatalogDemo.Shipments.BehaviorHoles+    Generated.CatalogDemo.BehaviorSourceMap+    Generated.CatalogDemo.CatalogAudit.ReadModel+    Generated.CatalogDemo.CatalogAudit.ReadModelHarness+    Generated.CatalogDemo.CatalogAudit.ReadModelTable+    Generated.CatalogDemo.OrderInline.QueryContract+    Generated.CatalogDemo.OrderInline.ReadModel+    Generated.CatalogDemo.OrderInline.ReadModelHarness+    Generated.CatalogDemo.OrderInline.ReadModelTable+    Generated.CatalogDemo.Orders.BehaviorContract+    Generated.CatalogDemo.Orders.Codec+    Generated.CatalogDemo.Orders.Domain+    Generated.CatalogDemo.Orders.EventStream+    Generated.CatalogDemo.Orders.Harness+    Generated.CatalogDemo.Orders.Projection+    Generated.CatalogDemo.Orders.Transducer+    Generated.CatalogDemo.OrderTotalsLookup.ReadModel+    Generated.CatalogDemo.OrderTotalsLookup.ReadModelHarness+    Generated.CatalogDemo.OrderTotalsLookup.ReadModelTable+    Generated.CatalogDemo.ProjectionCatalog+    Generated.CatalogDemo.QualificationJobs.Queue+    Generated.CatalogDemo.QualificationJobs.QueueCodec+    Generated.CatalogDemo.QualificationJobs.QueuePolicy+    Generated.CatalogDemo.ReplayAudit+    Generated.CatalogDemo.ShipmentLookup.ReadModel+    Generated.CatalogDemo.ShipmentLookup.ReadModelHarness+    Generated.CatalogDemo.ShipmentLookup.ReadModelTable+    Generated.CatalogDemo.Shipments.BehaviorContract+    Generated.CatalogDemo.Shipments.Codec+    Generated.CatalogDemo.Shipments.Domain+    Generated.CatalogDemo.Shipments.EventStream+    Generated.CatalogDemo.Shipments.Harness+    Generated.CatalogDemo.Shipments.Projection+    Generated.CatalogDemo.Shipments.Transducer+    Generated.CatalogDemo.Structural.Shape.QualificationPayload+    Generated.CatalogDemo.StructuralConformance+    Generated.CatalogDemo.StructuralProjections++  build-depends:+    , aeson              >=2.2  && <2.3+    , base               >=4.21 && <5+    , containers         >=0.6  && <0.8+    , effectful-core+    , hasql-transaction+    , keiki              >=0.9  && <0.10+    , keiro+    , keiro-core+    , keiro-dsl+    , keiro-pgmq+    , kiroku-store+    , text               >=2.1  && <2.2+ -- EP-5 M5 full-service conformance: a complete pgmq dispatch service — scaffolded -- Job codec + retry policy + a filled worker handler assembled into a live -- Keiro.PGMQ.Job.Job value — compiled against keiro-pgmq.@@ -900,22 +1110,27 @@    build-depends:  base >=4.21 && <5 --- EP-6 workflow runtime conformance: the scaffolded WorkflowRuntime--- (WorkflowName + awakeable-id derivation) compiled against the LIVE--- Keiro.Workflow; pins the await<->signal id match over deterministicAwakeableId.+-- Workflow runtime conformance: the scaffolded WorkflowRuntime allocates its+-- declared await through the live Keiro.Workflow effect and exercises the+-- returned opaque id against PostgreSQL. test-suite keiro-dsl-conformance-workflow-runtime   import:         warnings, generated-output   type:           exitcode-stdio-1.0   hs-source-dirs: test/conformance-workflow-runtime   main-is:        Main.hs+  ghc-options:    -threaded -rtsopts -with-rtsopts=-N   other-modules:     Generated.HospitalCapacity.HospitalTransferReservation.WorkflowRuntime    build-depends:-    , base        >=4.21 && <5+    , aeson               >=2.2  && <2.3+    , base                >=4.21 && <5     , containers+    , effectful-core     , keiro-    , text        >=2.1  && <2.2+    , keiro-test-support+    , kiroku-store+    , text                >=2.1  && <2.2  -- EP-3 M5 full-service conformance: a complete process service — the scaffolded -- Surge (saga) + Hospital (target) aggregates with filled transducers, plus a@@ -926,6 +1141,7 @@   hs-source-dirs: test/conformance-process-full   main-is:        Main.hs   other-modules:+    Generated.SurgeDemo.BehaviorSourceMap     Generated.SurgeDemo.Hospital.Codec     Generated.SurgeDemo.Hospital.Domain     Generated.SurgeDemo.Hospital.EventStream@@ -972,6 +1188,7 @@     , containers     , effectful-core     , keiro+    , kiroku-store     , text            >=2.1  && <2.2  -- EP-3 process runtime conformance: the scaffolded Process module's@@ -983,6 +1200,7 @@   hs-source-dirs: test/conformance-process-runtime   main-is:        Main.hs   other-modules:+    Generated.HospitalCapacity.BehaviorSourceMap     Generated.HospitalCapacity.HospitalSurge.Process     Generated.HospitalCapacity.Nominals     Generated.HospitalCapacity.Nominals.Internal@@ -1011,6 +1229,7 @@   hs-source-dirs: test/conformance-router-runtime   main-is:        Main.hs   other-modules:+    Generated.IncidentPaging.BehaviorSourceMap     Generated.IncidentPaging.PagingRouter.Router     Generated.IncidentPaging.PagingRouter.RouterHarness @@ -1022,15 +1241,74 @@     , text          >=2.1  && <2.2     , uuid          >=1.3  && <1.4 +-- Plan 230: the checked language-5 selection is generated, compiled against+-- the public runtime, and exercised through a real read-model query and ledger.+test-suite keiro-dsl-conformance-declarative-router+  import:         generated-output+  type:           exitcode-stdio-1.0+  hs-source-dirs: test/conformance-declarative-router+  main-is:        Main.hs+  ghc-options:    -threaded -rtsopts -with-rtsopts=-N+  other-modules:+    Conformance.DeclarativeRouter.Bindings+    Conformance.DeclarativeRouter.Domain+    Generated.TransferRouting.BehaviorSourceMap+    Generated.TransferRouting.Hospital.BehaviorContract+    Generated.TransferRouting.Hospital.Codec+    Generated.TransferRouting.Hospital.Domain+    Generated.TransferRouting.Hospital.EventStream+    Generated.TransferRouting.Hospital.Harness+    Generated.TransferRouting.Hospital.Projection+    Generated.TransferRouting.Hospital.Transducer+    Generated.TransferRouting.HospitalLoad.QueryContract+    Generated.TransferRouting.HospitalLoad.ReadModel+    Generated.TransferRouting.HospitalLoad.ReadModelHarness+    Generated.TransferRouting.HospitalLoad.ReadModelTable+    Generated.TransferRouting.HospitalTransferRouter.Router+    Generated.TransferRouting.HospitalTransferRouter.RouterHarness+    Generated.TransferRouting.ProjectionCatalog+    Generated.TransferRouting.ReplayAudit+    Generated.TransferRouting.Structural.Shape.HospitalLoadRow+    Generated.TransferRouting.Structural.Shape.TransferRouteInput+    Generated.TransferRouting.StructuralConformance+    Generated.TransferRouting.StructuralProjections+    TransferRouting.Hospital.BehaviorHoles+    TransferRouting.HospitalLoad.ReadModelHoles+    TransferRouting.ProjectionCatalog.ProjectionCatalogHoles++  build-depends:+    , aeson               >=2.2      && <2.3+    , base                >=4.21     && <5+    , bytestring          >=0.11     && <0.13+    , containers          >=0.6      && <0.8+    , effectful-core+    , hasql               >=1.10     && <1.11+    , hasql-transaction   >=1.1      && <1.3+    , keiki               >=0.9      && <0.10+    , keiro+    , keiro-dsl+    , keiro-test-support+    , kiroku-store        >=0.7      && <0.8+    , shibuya-core        ^>=0.9.0.0+    , text                >=2.1      && <2.2+    , time                >=1.12     && <1.15+    , uuid                >=1.3      && <1.4+    , vector              >=0.13     && <0.14+ -- EP-108 generated router-facts harness with hand-written expectations. test-suite keiro-dsl-conformance-router   import:         warnings, generated-output   type:           exitcode-stdio-1.0   hs-source-dirs: test/conformance-router   main-is:        Main.hs-  other-modules:  Generated.IncidentPaging.PagingRouter.RouterHarness-  build-depends:  base >=4.21 && <5+  other-modules:+    Generated.IncidentPaging.BehaviorSourceMap+    Generated.IncidentPaging.PagingRouter.RouterHarness +  build-depends:+    , base  >=4.21 && <5+    , text  >=2.1  && <2.2+ -- EP-108 filled-router conformance: scaffolded Page aggregate plus a filled -- resolver and Router value compiled against the live API. test-suite keiro-dsl-conformance-router-full@@ -1039,6 +1317,7 @@   hs-source-dirs: test/conformance-router-full   main-is:        Main.hs   other-modules:+    Generated.IncidentPaging.BehaviorSourceMap     Generated.IncidentPaging.Page.Codec     Generated.IncidentPaging.Page.Domain     Generated.IncidentPaging.Page.EventStream@@ -1068,6 +1347,7 @@   hs-source-dirs: test/conformance-newsurface   main-is:        Main.hs   other-modules:+    Generated.TransferRouting.BehaviorSourceMap     Generated.TransferRouting.Conformance     Generated.TransferRouting.Hospital.Codec     Generated.TransferRouting.Hospital.Domain@@ -1107,7 +1387,10 @@   type:           exitcode-stdio-1.0   hs-source-dirs: test/conformance-process   main-is:        Main.hs-  other-modules:  Generated.HospitalCapacity.HospitalSurge.ProcessHarness+  other-modules:+    Generated.HospitalCapacity.BehaviorSourceMap+    Generated.HospitalCapacity.HospitalSurge.ProcessHarness+   build-depends:     , base  >=4.21 && <5     , text  >=2.1  && <2.2@@ -1123,6 +1406,7 @@   hs-source-dirs: test/conformance-v2   main-is:        Main.hs   other-modules:+    Generated.HospitalCapacity.BehaviorSourceMap     Generated.HospitalCapacity.Nominals     Generated.HospitalCapacity.Nominals.Internal     Generated.HospitalCapacity.ReplayAudit@@ -1151,6 +1435,7 @@   hs-source-dirs: test/conformance-id-domain-migration   main-is:        Main.hs   other-modules:+    Generated.IdDomainMigration.BehaviorSourceMap     Generated.IdDomainMigration.Nominals     Generated.IdDomainMigration.Nominals.Internal     Generated.IdDomainMigration.OrderBook.Codec

src/Keiro/Dsl/AggregateType.hs view

@@ -11,6 +11,8 @@     ResolvedAggregateType (..),     AggregateSymbols,     aggregateSymbols,+    aggregateSymbolsFromGraph,+    aggregateSymbolsFromGraphResult,     AggregateTypeErrorReason (..),     AggregateTypeError (..),     resolveAggregateType,@@ -87,6 +89,17 @@  aggregateSymbols :: Spec -> AggregateSymbols aggregateSymbols spec =+  aggregateSymbolsFromGraphResult (resolveTypeGraph spec) spec++aggregateSymbolsFromGraph :: TypeGraph -> Spec -> AggregateSymbols+aggregateSymbolsFromGraph graph = aggregateSymbolsFromDeclarations (tgDeclarations graph)++aggregateSymbolsFromGraphResult :: Either (NE.NonEmpty TypeGraphError) TypeGraph -> Spec -> AggregateSymbols+aggregateSymbolsFromGraphResult graphResult =+  aggregateSymbolsFromDeclarations (either (const Map.empty) tgDeclarations graphResult)++aggregateSymbolsFromDeclarations :: Map MappedKey ResolvedMappedDecl -> Spec -> AggregateSymbols+aggregateSymbolsFromDeclarations mappedDeclarations spec =   AggregateSymbols     { symbolNominals = either (const Map.empty) nominalTypes (resolveNominalTypes spec),       symbolVertices =@@ -94,7 +107,7 @@           [ (aggName aggregate <> "Vertex", map stName (aggStates aggregate))           | NAggregate aggregate <- specNodes spec           ],-      symbolMapped = either (const Map.empty) tgDeclarations (resolveTypeGraph spec)+      symbolMapped = mappedDeclarations     }  data AggregateTypeErrorReason

src/Keiro/Dsl/BehaviorCoverage.hs view

@@ -11,12 +11,15 @@     EvidenceLevel (..),     GuardCoverage (..),     OutputEvidence (..),+    RequirementOrigin (..),+    BehaviorExactLocation (..),     BehaviorRequirement (..),     BehaviorRecordRow (..),     BehaviorDerivationError (..),     BehaviorObligationsReport (..),     deriveAggregateBehaviorRequirements,     deriveBehaviorRequirements,+    deriveBehaviorRequirementsForService,     behaviorRecordRows,     attributeBehaviorOwner,     behaviorObligationsReport,@@ -29,15 +32,20 @@ import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as BL import Data.List (find, groupBy, sortOn)+import Data.List.NonEmpty (NonEmpty) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as Text+import Keiro.Dsl.CanonicalEncoding (canonicalTransitionOutcome) import Keiro.Dsl.EventOutput import Keiro.Dsl.Grammar import Keiro.Dsl.PrettyPrint (renderExpr) import Keiro.Dsl.ReadModelShape (fnv1a64)+import Keiro.Dsl.SemanticContract (CheckedService, checkedSpec, checkedTypeGraph)+import Keiro.Dsl.SourceIndex (TransitionOrdinal (..))+import Keiro.Dsl.TypeGraph (TypeGraph, TypeGraphError, resolveTypeGraph)  newtype BehaviorKey = BehaviorKey {unBehaviorKey :: Text}   deriving stock (Eq, Ord, Show)@@ -66,8 +74,26 @@   | HandOwnedOutput !OutputObligationKey   deriving stock (Eq, Ord, Show) +-- | The semantic source subject that owns an obligation. Unlike 'Loc', this+-- identity does not change when source text moves and can therefore be joined+-- to an independently checked exact source index.+data RequirementOrigin+  = TransitionRequirementOrigin !Name !TransitionOrdinal+  | RejectionRequirementOrigin !Name !Name+  deriving stock (Eq, Ord, Show)++-- | Current exact presentation data attached only by a source-aware reporting+-- path. It never contributes to 'requirementCanonical' or 'BehaviorKey'.+data BehaviorExactLocation = BehaviorExactLocation+  { exactSourceFile :: !FilePath,+    exactSourceLine :: !Int,+    exactSourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)+ data BehaviorRequirement = BehaviorRequirement   { requirementKey :: !BehaviorKey,+    requirementOrigin :: !RequirementOrigin,     requirementKind :: !ObligationKind,     requirementEvidence :: !EvidenceLevel,     requirementGuardCoverage :: !GuardCoverage,@@ -79,7 +105,9 @@     requirementMode :: !(Maybe TransitionMode),     requirementEvents :: ![Name],     requirementOutputs :: ![OutputEvidence],+    requirementDomainOutcome :: !(Maybe TransitionOutcome),     requirementLocation :: !Loc,+    requirementExactLocation :: !(Maybe BehaviorExactLocation),     requirementOwner :: !(Maybe FilePath),     requirementCanonical :: !Text   }@@ -187,20 +215,29 @@ instance ToJSON BehaviorRequirement where   toJSON requirement =     object-      [ "key" .= requirementKey requirement,-        "kind" .= requirementKind requirement,-        "evidence" .= requirementEvidence requirement,-        "guardCoverage" .= requirementGuardCoverage requirement,-        "context" .= requirementContext requirement,-        "aggregate" .= requirementAggregate requirement,-        "source" .= requirementSource requirement,-        "command" .= requirementCommand requirement,-        "target" .= requirementTarget requirement,-        "mode" .= fmap transitionModeText (requirementMode requirement),-        "events" .= requirementEvents requirement,-        "outputs" .= requirementOutputs requirement,-        "location" .= object (["line" .= unLoc (requirementLocation requirement)] <> ["member" .= owner | Just owner <- [requirementOwner requirement]])-      ]+      ( [ "key" .= requirementKey requirement,+          "kind" .= requirementKind requirement,+          "evidence" .= requirementEvidence requirement,+          "guardCoverage" .= requirementGuardCoverage requirement,+          "context" .= requirementContext requirement,+          "aggregate" .= requirementAggregate requirement,+          "source" .= requirementSource requirement,+          "command" .= requirementCommand requirement,+          "target" .= requirementTarget requirement,+          "mode" .= fmap transitionModeText (requirementMode requirement),+          "events" .= requirementEvents requirement,+          "outputs" .= requirementOutputs requirement,+          "location"+            .= object+              ( ["line" .= maybe (unLoc (requirementLocation requirement)) exactSourceLine (requirementExactLocation requirement)]+                  <> ["member" .= owner | Just owner <- [requirementOwner requirement]]+                  <> ["file" .= exactSourceFile exact | Just exact <- [requirementExactLocation requirement]]+                  <> ["column" .= exactSourceColumn exact | Just exact <- [requirementExactLocation requirement]]+                  <> ["quality" .= maybe ("line-only" :: Text) (const "exact") (requirementExactLocation requirement)]+              )+        ]+          <> ["domainOutcome" .= canonicalTransitionOutcome (Just outcome) | Just outcome <- [requirementDomainOutcome requirement]]+      )  instance ToJSON BehaviorObligationsReport where   toJSON report =@@ -213,7 +250,14 @@       )  deriveBehaviorRequirements :: Spec -> Either [BehaviorDerivationError] [BehaviorRequirement]-deriveBehaviorRequirements spec = case fmap concat (traverse (deriveAggregateBehaviorRequirements spec) aggregates) of+deriveBehaviorRequirements spec = deriveBehaviorRequirementsWithGraphResult (resolveTypeGraph spec) spec++deriveBehaviorRequirementsForService :: CheckedService -> Either [BehaviorDerivationError] [BehaviorRequirement]+deriveBehaviorRequirementsForService service =+  deriveBehaviorRequirementsWithGraphResult (checkedTypeGraph service) (checkedSpec service)++deriveBehaviorRequirementsWithGraphResult :: Either (NonEmpty TypeGraphError) TypeGraph -> Spec -> Either [BehaviorDerivationError] [BehaviorRequirement]+deriveBehaviorRequirementsWithGraphResult typeGraphResult spec = case fmap concat (traverse (deriveAggregateBehaviorRequirementsWithGraphResult typeGraphResult spec) aggregates) of   Left derivationError -> Left [derivationError]   Right raw -> do     rejectIdentityDefects raw@@ -222,35 +266,39 @@     aggregates = [aggregate | NAggregate aggregate <- specNodes spec]  deriveAggregateBehaviorRequirements :: Spec -> Aggregate -> Either BehaviorDerivationError [BehaviorRequirement]-deriveAggregateBehaviorRequirements spec aggregate = do+deriveAggregateBehaviorRequirements spec = deriveAggregateBehaviorRequirementsWithGraphResult (resolveTypeGraph spec) spec++deriveAggregateBehaviorRequirementsWithGraphResult :: Either (NonEmpty TypeGraphError) TypeGraph -> Spec -> Aggregate -> Either BehaviorDerivationError [BehaviorRequirement]+deriveAggregateBehaviorRequirementsWithGraphResult typeGraphResult spec aggregate = do   let reachable = liveReachableStates aggregate+      indexedTransitions = zip (map TransitionOrdinal [0 ..]) (aggTransitions aggregate)       liveTransitions =-        [ transition-        | transition <- aggTransitions aggregate,+        [ (ordinal, transition)+        | (ordinal, transition) <- indexedTransitions,           tMode transition == TmLive,           tSource transition `Set.member` reachable         ]-      replayTransitions = [transition | transition <- aggTransitions aggregate, tMode transition == TmReplayOnly]+      replayTransitions = [(ordinal, transition) | (ordinal, transition) <- indexedTransitions, tMode transition == TmReplayOnly]       commands = map cmdName (aggCommands aggregate)       cells = [(state, command) | state <- Set.toAscList reachable, command <- commands]       cellTransitions state command =-        [ transition-        | transition <- liveTransitions,+        [ (ordinal, transition)+        | (ordinal, transition) <- liveTransitions,           tSource transition == state,           tCommand transition == command         ]       transitionRows =-        [ transitionRequirement spec aggregate (cellGuardCoverage siblings) transition+        [ transitionRequirement typeGraphResult spec aggregate (cellGuardCoverage (map snd siblings)) ordinal transition         | (state, command) <- cells,           let siblings = cellTransitions state command,-          transition <- siblings+          (ordinal, transition) <- siblings         ]       rejectionRows =         [ pure (rejectionRequirement spec aggregate state command)         | (state, command) <- cells,           null (cellTransitions state command)         ]-      replayRows = [transitionRequirement spec aggregate (replayGuardCoverage transition) transition | transition <- replayTransitions]+      replayRows = [transitionRequirement typeGraphResult spec aggregate (replayGuardCoverage transition) ordinal transition | (ordinal, transition) <- replayTransitions]   sequence (transitionRows <> rejectionRows <> replayRows)  behaviorRecordRows :: [BehaviorRequirement] -> [BehaviorRecordRow]@@ -276,14 +324,14 @@ behaviorObligationsReport subject spec =   BehaviorObligationsReport subject Nothing <$> deriveBehaviorRequirements spec -transitionRequirement :: Spec -> Aggregate -> GuardCoverage -> Transition -> Either BehaviorDerivationError BehaviorRequirement-transitionRequirement spec aggregate guardCoverage transition = do+transitionRequirement :: Either (NonEmpty TypeGraphError) TypeGraph -> Spec -> Aggregate -> GuardCoverage -> TransitionOrdinal -> Transition -> Either BehaviorDerivationError BehaviorRequirement+transitionRequirement typeGraphResult spec aggregate guardCoverage ordinal transition = do   if null (tEmits transition) && (tSource transition /= tGoto transition || not (null (tWrites transition)))     then Left (EventlessStateChange (aggName aggregate) (tSource transition) (tCommand transition))     else pure ()   mappings <-     traverse-      (\(emitIndex, eventName) -> either (Left . InvalidEventOutput eventName) Right (eventOutputMapping spec aggregate transition emitIndex eventName))+      (\(emitIndex, eventName) -> either (Left . InvalidEventOutput eventName) Right (eventOutputMappingFromGraphResult typeGraphResult spec aggregate transition emitIndex eventName))       (zip [1 ..] (tEmits transition))   let kind = if tMode transition == TmLive then LiveTransition else ReplayTransition       outputs = map outputEvidence mappings@@ -291,6 +339,7 @@   pure     BehaviorRequirement       { requirementKey = canonicalKey canonical,+        requirementOrigin = TransitionRequirementOrigin (aggName aggregate) ordinal,         requirementKind = kind,         requirementEvidence = transitionEvidence transition,         requirementGuardCoverage = guardCoverage,@@ -302,7 +351,9 @@         requirementMode = Just (tMode transition),         requirementEvents = tEmits transition,         requirementOutputs = outputs,+        requirementDomainOutcome = tOutcome transition,         requirementLocation = tLoc transition,+        requirementExactLocation = Nothing,         requirementOwner = Nothing,         requirementCanonical = canonical       }@@ -311,6 +362,7 @@ rejectionRequirement spec aggregate state command =   BehaviorRequirement     { requirementKey = canonicalKey canonical,+      requirementOrigin = RejectionRequirementOrigin (aggName aggregate) state,       requirementKind = RequiredRejection,       requirementEvidence = aggregateEvidence aggregate,       requirementGuardCoverage = GuardNotApplicable,@@ -322,7 +374,9 @@       requirementMode = Nothing,       requirementEvents = [],       requirementOutputs = [],+      requirementDomainOutcome = Nothing,       requirementLocation = maybe (aggLoc aggregate) stLoc (find ((== state) . stName) (aggStates aggregate)),+      requirementExactLocation = Nothing,       requirementOwner = Nothing,       requirementCanonical = canonical     }@@ -342,20 +396,30 @@ transitionCanonical spec aggregate kind transition mappings =   T.intercalate     "|"-    [ "behavior-v1",-      "kind=" <> obligationKindText kind,-      "context=" <> specContext spec,-      "aggregate=" <> aggName aggregate,-      "mode=" <> transitionModeText (tMode transition),-      "source=" <> tSource transition,-      "command=" <> tCommand transition,-      "implementation=" <> implementationText (tImplementation transition),-      "guard=" <> maybe "" renderExpr (tGuard transition),-      "writes=" <> T.intercalate ";" [name <> ":=" <> renderExpr expression | (name, expression) <- tWrites transition],-      "events=" <> T.intercalate "," (tEmits transition),-      "outputs=" <> T.intercalate "," (map eventOutputCanonical mappings),-      "target=" <> tGoto transition-    ]+    ( [ "behavior-v1",+        "kind=" <> obligationKindText kind,+        "context=" <> specContext spec,+        "aggregate=" <> aggName aggregate,+        "mode=" <> transitionModeText (tMode transition),+        "source=" <> tSource transition,+        "command=" <> tCommand transition,+        "implementation=" <> implementationText (tImplementation transition),+        "guard=" <> maybe "" renderExpr (tGuard transition),+        "writes=" <> T.intercalate ";" [name <> ":=" <> renderExpr expression | (name, expression) <- tWrites transition],+        "events=" <> T.intercalate "," (tEmits transition),+        "outputs=" <> T.intercalate "," (map eventOutputCanonical mappings),+        "target=" <> tGoto transition+      ]+        ++ outcomeSegments+    )+  where+    outcomeSegments = case aggDomainOutcomeTypes aggregate of+      Nothing -> []+      Just declaration ->+        [ "outcome-rejection-type=" <> rejectionType declaration,+          "outcome-no-op-type=" <> noOpType declaration,+          "domain-outcome=" <> canonicalTransitionOutcome (tOutcome transition)+        ]  canonicalKey :: Text -> BehaviorKey canonicalKey canonical = BehaviorKey ("behavior-v1-" <> fnv1a64 canonical)@@ -471,6 +535,19 @@         <> ", guard="         <> guardCoverageText (requirementGuardCoverage requirement)         <> "]"+        <> maybe (renderLineOnly requirement) renderExact (requirementExactLocation requirement)+    renderExact exact =+      " "+        <> T.pack (exactSourceFile exact)+        <> ":"+        <> tshow (exactSourceLine exact)+        <> ":"+        <> tshow (exactSourceColumn exact)+        <> " [location-quality=exact]"+    renderLineOnly requirement =+      " line "+        <> tshow (unLoc (requirementLocation requirement))+        <> " [location-quality=line-only]"  encodeBehaviorObligationsJson :: BehaviorObligationsReport -> Text encodeBehaviorObligationsJson = Text.decodeUtf8 . BL.toStrict . Aeson.encode

+ src/Keiro/Dsl/BehaviorSourceMap.hs view

@@ -0,0 +1,179 @@+-- | Join source-stable behavior requirements to exact, independently stored+-- source provenance. The resulting rows are suitable for deterministic+-- context-level generation; failures are complete and contain no write plan.+module Keiro.Dsl.BehaviorSourceMap+  ( BehaviorSourceFailureCode (..),+    BehaviorSourceFailure (..),+    BehaviorSourceEntry (..),+    planBehaviorSourceMap,+    attachBehaviorSourceLocations,+  )+where++import Data.List (groupBy, sortOn)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Keiro.Dsl.BehaviorCoverage+  ( BehaviorExactLocation (..),+    BehaviorKey,+    BehaviorRequirement,+    RequirementOrigin (..),+    requirementAggregate,+    requirementCanonical,+    requirementCommand,+    requirementExactLocation,+    requirementKey,+    requirementOrigin,+    requirementSource,+  )+import Keiro.Dsl.Source (SourcePoint (..), SourceSpan (..))+import Keiro.Dsl.SourceIndex+  ( SemanticSourceIndex,+    SourcePositionQuality (..),+    SourceSubject (..),+    lookupSourceSpan,+  )++data BehaviorSourceFailureCode+  = BehaviorSourceAnchorMissing+  | BehaviorSourceAnchorInexact+  | BehaviorSourceAnchorCollision+  deriving stock (Eq, Ord, Show)++data BehaviorSourceFailure = BehaviorSourceFailure+  { failureCode :: !BehaviorSourceFailureCode,+    failureKey :: !BehaviorKey,+    failureOrigin :: !RequirementOrigin,+    failureAggregate :: !Text,+    failureState :: !Text,+    failureCommand :: !Text,+    failureSourceSubject :: !SourceSubject,+    failureSpan :: !(Maybe SourceSpan),+    failureMessage :: !Text+  }+  deriving stock (Eq, Show)++data BehaviorSourceEntry = BehaviorSourceEntry+  { behaviorSourceKey :: !BehaviorKey,+    behaviorSourceFile :: !FilePath,+    behaviorSourceLine :: !Int,+    behaviorSourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++-- | Resolve every requirement exactly once. Duplicate keys are rejected even+-- when their canonical text matches, because a generated lookup must be a+-- total one-to-one join rather than a lossy 'Map.fromList'.+planBehaviorSourceMap ::+  [BehaviorRequirement] ->+  SemanticSourceIndex ->+  Either [BehaviorSourceFailure] [BehaviorSourceEntry]+planBehaviorSourceMap requirements sourceIndex =+  case duplicateFailures <> anchorFailures of+    []+      | entryKeys == requirementKeys -> Right sortedEntries+      | otherwise -> Left (missingJoinFailures requirementKeys entryKeys)+    failures -> Left (sortOn failureSortKey failures)+  where+    duplicateFailures = concatMap duplicateKeyFailure (groupsOn requirementKey requirements)+    duplicateKeyFailure duplicates@(first : _ : _) =+      [ BehaviorSourceFailure+          { failureCode = BehaviorSourceAnchorCollision,+            failureKey = requirementKey first,+            failureOrigin = requirementOrigin first,+            failureAggregate = requirementAggregate first,+            failureState = requirementSource first,+            failureCommand = requirementCommand first,+            failureSourceSubject = requirementSourceSubject (requirementOrigin first),+            failureSpan = Nothing,+            failureMessage =+              if Set.size (Set.fromList (map requirementCanonical duplicates)) > 1+                then "behavior key identifies more than one canonical obligation"+                else "behavior key occurs more than once in the requirement inventory"+          }+      ]+    duplicateKeyFailure _ = []+    uniqueRequirements = [requirement | [requirement] <- groupsOn requirementKey requirements]+    planned = map (planEntry sourceIndex) uniqueRequirements+    anchorFailures = [failure | Left failure <- planned]+    sortedEntries = sortOn behaviorSourceKey [entry | Right entry <- planned]+    requirementKeys = Set.fromList (map requirementKey requirements)+    entryKeys = Set.fromList (map behaviorSourceKey sortedEntries)+    missingJoinFailures expected actual =+      [ BehaviorSourceFailure+          { failureCode = BehaviorSourceAnchorMissing,+            failureKey = requirementKey requirement,+            failureOrigin = requirementOrigin requirement,+            failureAggregate = requirementAggregate requirement,+            failureState = requirementSource requirement,+            failureCommand = requirementCommand requirement,+            failureSourceSubject = requirementSourceSubject (requirementOrigin requirement),+            failureSpan = Nothing,+            failureMessage = "behavior requirement is absent from the completed source-map join"+          }+      | requirement <- requirements,+        requirementKey requirement `Set.member` (expected Set.\\ actual)+      ]++-- | Attach exact presentation data after a successful complete join. Unknown+-- keys are left unchanged so compatibility reports can remain explicitly+-- line-only; production paths call this only with 'planBehaviorSourceMap'+-- output, whose key-set equality has already been checked.+attachBehaviorSourceLocations :: [BehaviorSourceEntry] -> [BehaviorRequirement] -> [BehaviorRequirement]+attachBehaviorSourceLocations entries = map attach+  where+    byKey = Map.fromList [(behaviorSourceKey entry, entry) | entry <- entries]+    attach requirement = case Map.lookup (requirementKey requirement) byKey of+      Nothing -> requirement+      Just entry ->+        requirement+          { requirementExactLocation =+              Just+                BehaviorExactLocation+                  { exactSourceFile = behaviorSourceFile entry,+                    exactSourceLine = behaviorSourceLine entry,+                    exactSourceColumn = behaviorSourceColumn entry+                  }+          }++planEntry :: SemanticSourceIndex -> BehaviorRequirement -> Either BehaviorSourceFailure BehaviorSourceEntry+planEntry sourceIndex requirement =+  case lookupSourceSpan subject sourceIndex of+    Nothing -> Left (failure BehaviorSourceAnchorMissing Nothing "behavior source subject is absent from the semantic source index")+    Just (CompatibilityLineOnly, sourceSpan) ->+      Left (failure BehaviorSourceAnchorInexact (Just sourceSpan) "behavior source subject has only a compatibility line, not an exact position")+    Just (ExactSourcePosition, SourceSpan {source, start = SourcePoint {line, column}}) ->+      Right+        BehaviorSourceEntry+          { behaviorSourceKey = requirementKey requirement,+            behaviorSourceFile = source,+            behaviorSourceLine = line,+            behaviorSourceColumn = column+          }+  where+    subject = requirementSourceSubject (requirementOrigin requirement)+    failure failureCode failureSpan failureMessage =+      BehaviorSourceFailure+        { failureCode,+          failureKey = requirementKey requirement,+          failureOrigin = requirementOrigin requirement,+          failureAggregate = requirementAggregate requirement,+          failureState = requirementSource requirement,+          failureCommand = requirementCommand requirement,+          failureSourceSubject = subject,+          failureSpan,+          failureMessage+        }++requirementSourceSubject :: RequirementOrigin -> SourceSubject+requirementSourceSubject origin = case origin of+  TransitionRequirementOrigin aggregate ordinal -> AggregateTransitionSubject aggregate ordinal+  RejectionRequirementOrigin aggregate state -> AggregateStateSubject aggregate state++groupsOn :: (Ord key) => (value -> key) -> [value] -> [[value]]+groupsOn key = groupBy (\left right -> key left == key right) . sortOn key++failureSortKey :: BehaviorSourceFailure -> (BehaviorSourceFailureCode, BehaviorKey, RequirementOrigin)+failureSortKey BehaviorSourceFailure {failureCode, failureKey, failureOrigin} =+  (failureCode, failureKey, failureOrigin)

src/Keiro/Dsl/CanonicalEncoding.hs view

@@ -8,6 +8,8 @@ module Keiro.Dsl.CanonicalEncoding   ( canonicalExpr,     canonicalTransition,+    canonicalDomainOutcomeTypes,+    canonicalTransitionOutcome,     foldFingerprint128,   ) where@@ -33,6 +35,23 @@   renderStrict     . layoutPretty LayoutOptions {layoutPageWidth = Unbounded}     . docTransition++-- | Deterministic command-behavior identity for the aggregate-wide outcome+-- types. This is deliberately separate from 'canonicalTransition', whose bytes+-- are the frozen replay-fold surface.+canonicalDomainOutcomeTypes :: Maybe DomainOutcomeTypes -> Text+canonicalDomainOutcomeTypes Nothing = ""+canonicalDomainOutcomeTypes (Just declaration) =+  "rejection=" <> rejectionType declaration <> "|no-op=" <> noOpType declaration++-- | Deterministic command-behavior identity for one transition outcome. It is+-- excluded from persisted fold identity because it labels a selected edge+-- without changing that edge's state update or event word.+canonicalTransitionOutcome :: Maybe TransitionOutcome -> Text+canonicalTransitionOutcome Nothing = ""+canonicalTransitionOutcome (Just (OutcomeAccepted _)) = "accepted"+canonicalTransitionOutcome (Just (OutcomeRejected expression _)) = "rejected:" <> canonicalExpr expression+canonicalTransitionOutcome (Just (OutcomeNoOp expression _)) = "no-op:" <> canonicalExpr expression  -- | A fixed-width FNV-1a-128 digest over the frozen fold surface's UTF-8 -- bytes. The constants and octet fold are the standard values from RFC 9923;

src/Keiro/Dsl/ConformancePackage.hs view

@@ -42,7 +42,7 @@ 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.SemanticContract (CheckedService, checkedLanguageContract) import Keiro.Dsl.ServiceHarness (serviceConformanceFactValues) import Keiro.Dsl.SidecarNames (conformanceLedgerFileName) import Numeric (showHex)

+ src/Keiro/Dsl/ConsumerTypePlan.hs view

@@ -0,0 +1,183 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++-- | Consumer-facing Haskell type requirements for one checked mapped+-- expression. This module deliberately plans no JSON, SQL, or runtime codec;+-- queue and read-model emitters add their own surface authority around it.+module Keiro.Dsl.ConsumerTypePlan+  ( HaskellTypeOccurrence (..),+    ImportRequirement (..),+    ConsumerTypePlan (..),+    ConsumerTypePlanError (..),+    planConsumerType,+    consumerTypeReferences,+    renderConsumerType,+  )+where++import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Keiro.Dsl.Grammar (HaskellSource (..))+import Keiro.Dsl.HaskellImport+import Keiro.Dsl.TypeGraph++newtype HaskellTypeOccurrence = HaskellTypeOccurrence+  { unHaskellTypeOccurrence :: Text+  }+  deriving stock (Eq, Ord, Show)++-- | One deterministic import needed to render the planned type. Consumer+-- package provenance is retained so later Cabal planning does not need to+-- rediscover it from the raw specification.+data ImportRequirement = ImportRequirement+  { package :: !Text,+    moduleName :: !Text,+    occurrence :: !Text+  }+  deriving stock (Eq, Ord, Show)++data ConsumerTypePlan = ConsumerTypePlan+  { haskellType :: !HaskellTypeOccurrence,+    imports :: ![ImportRequirement],+    dependencies :: !(Set MappedKey)+  }+  deriving stock (Eq, Show)++data ConsumerTypePlanError+  = ConsumerTypePlanUnknownDeclaration !MappedKey+  | ConsumerTypePlanImportError !HaskellImportError+  deriving stock (Eq, Show)++planConsumerType :: TypeGraph -> ResolvedTypeExpr -> Either ConsumerTypePlanError ConsumerTypePlan+planConsumerType graph expression = do+  RenderedType {rendered, requirements, mappedDependencies} <- plan expression+  pure+    ConsumerTypePlan+      { haskellType = HaskellTypeOccurrence rendered,+        imports = Set.toAscList requirements,+        dependencies = mappedDependencies+      }+  where+    plan = \case+      RText -> atom "Text" [ImportRequirement "text" "Data.Text" "Text"]+      RInt -> atom "Int" []+      RInteger -> atom "Integer" []+      RBool -> atom "Bool" []+      RNatural -> atom "Natural" [ImportRequirement "base" "Numeric.Natural" "Natural"]+      RTime -> atom "UTCTime" [ImportRequirement "time" "Data.Time" "UTCTime"]+      RJson -> atom "Value" [ImportRequirement "aeson" "Data.Aeson" "Value"]+      ROptional value -> application "Maybe" [ImportRequirement "base" "Data.Maybe" "Maybe"] <$> plan value+      RList value -> listType <$> plan value+      RMap value -> mapType <$> plan value+      RRef key -> case Map.lookup key (tgDeclarations graph) of+        Nothing -> Left (ConsumerTypePlanUnknownDeclaration key)+        Just declaration ->+          let source = mappedSource declaration+           in Right+                RenderedType+                  { rendered = hsType source,+                    precedence = AtomicType,+                    requirements = Set.singleton (ImportRequirement (hsPackage source) (hsModule source) (hsType source)),+                    mappedDependencies = Set.insert key (Map.findWithDefault Set.empty key (tgReachability graph))+                  }++    atom rendered requiredImports =+      Right+        RenderedType+          { rendered,+            precedence = AtomicType,+            requirements = Set.fromList requiredImports,+            mappedDependencies = Set.empty+          }++    application constructor requiredImports value =+      value+        { rendered = constructor <> " " <> argument value,+          precedence = ApplicationType,+          requirements = Set.fromList requiredImports <> requirements value+        }++    listType value =+      value+        { rendered = "[" <> rendered value <> "]",+          precedence = AtomicType+        }++    mapType value =+      value+        { rendered = "Map Text " <> argument value,+          precedence = ApplicationType,+          requirements =+            Set.fromList+              [ ImportRequirement "containers" "Data.Map.Strict" "Map",+                ImportRequirement "text" "Data.Text" "Text"+              ]+              <> requirements value+        }++    argument value = case precedence value of+      AtomicType -> rendered value+      ApplicationType -> "(" <> rendered value <> ")"++data TypePrecedence = AtomicType | ApplicationType++data RenderedType = RenderedType+  { rendered :: !Text,+    precedence :: !TypePrecedence,+    requirements :: !(Set ImportRequirement),+    mappedDependencies :: !(Set MappedKey)+  }++mappedSource :: ResolvedMappedDecl -> HaskellSource+mappedSource (ResolvedStructural declaration _) = sdHaskell declaration+mappedSource (ResolvedOpaque declaration) = odHaskell declaration++consumerTypeReferences :: ConsumerTypePlan -> Set HaskellReference+consumerTypeReferences planned =+  Set.fromList+    [ HaskellReference moduleName occurrence TypeNamespace PreferUnqualified+    | ImportRequirement {package, moduleName, occurrence} <- imports planned,+      package `Set.notMember` standardPackages+    ]+  where+    standardPackages = Set.fromList ["base", "aeson", "containers", "text", "time"]++-- | Render a planned type through the target module's complete deterministic+-- import plan. This is the collision-safe counterpart to 'haskellType', whose+-- unqualified text remains useful for diagnostics and dependency reports.+renderConsumerType :: HaskellImportPlan -> TypeGraph -> ResolvedTypeExpr -> Either ConsumerTypePlanError HaskellTypeOccurrence+renderConsumerType importPlan graph = fmap (HaskellTypeOccurrence . rendered) . render+  where+    render = \case+      RText -> pure (plainAtom "Text")+      RInt -> pure (plainAtom "Int")+      RInteger -> pure (plainAtom "Integer")+      RBool -> pure (plainAtom "Bool")+      RNatural -> pure (plainAtom "Natural")+      RTime -> pure (plainAtom "UTCTime")+      RJson -> pure (plainAtom "Value")+      ROptional value -> application "Maybe" <$> render value+      RList value -> listType <$> render value+      RMap value -> do+        renderedValue <- render value+        pure+          renderedValue+            { rendered = "Map Text " <> argument renderedValue,+              precedence = ApplicationType+            }+      RRef key -> case Map.lookup key (tgDeclarations graph) of+        Nothing -> Left (ConsumerTypePlanUnknownDeclaration key)+        Just declaration ->+          let source = mappedSource declaration+           in atom (hsType source) (reference (hsModule source) (hsType source))++    atom _ ref = plainAtom <$> plannedReference ref+    plainAtom value = RenderedType value AtomicType Set.empty Set.empty+    application constructor value = value {rendered = constructor <> " " <> argument value, precedence = ApplicationType}+    listType value = value {rendered = "[" <> rendered value <> "]", precedence = AtomicType}+    argument value = case precedence value of+      AtomicType -> rendered value+      ApplicationType -> "(" <> rendered value <> ")"+    reference moduleName occurrence = HaskellReference moduleName occurrence TypeNamespace PreferUnqualified+    plannedReference = either (Left . ConsumerTypePlanImportError) Right . renderPlannedReference importPlan

+ src/Keiro/Dsl/CoordinationImpact.hs view

@@ -0,0 +1,334 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++-- | Reviewable coordination consequences for router selection evolution.+--+-- The aggregate replay report deliberately remains separate. Declarative+-- selection metadata describes drain/redelivery coordination around the frozen+-- target-keyed command identity; custom resolvers are reported honestly as+-- unverified rather than assigned invented semantic metadata.+module Keiro.Dsl.CoordinationImpact+  ( SelectionVerification (..),+    CoordinationSeverity (..),+    CoordinationReason (..),+    RouterSelectionSnapshot (..),+    RouterSelectionDrift (..),+    CoordinationImpact (..),+    routerSelectionSnapshots,+    routerSelectionDrift,+    renderRouterSelectionDrift,+    coordinationImpact,+    renderCoordinationImpact,+  )+where++import Control.Monad (unless)+import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=))+import Data.List (sortOn)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import Keiro.Dsl.Grammar+import Keiro.Dsl.RouterSelection+import Keiro.Dsl.SemanticContract (CheckedService, checkedLanguageContract, checkedSpec, checkedTypeGraph)+import Keiro.Dsl.SemanticImpact (MappedConsumer (..), MappedImpactDelta (..))+import Keiro.Dsl.TypeGraph (UsePath (..), UseSite, renderUsePath)+import Numeric.Natural (Natural)++data SelectionVerification = DeclarativeVerified | CustomUnverified+  deriving stock (Eq, Ord, Show, Generic)++data CoordinationSeverity = CoordinationAdvisory | CoordinationBreaking+  deriving stock (Eq, Ord, Show, Generic)++data CoordinationReason+  = SelectionIdentityChanged+  | SelectionVersionDecreased+  | SelectionFingerprintChangedWithoutVersionBump+  | SelectionFingerprintChangedWithVersionBump+  | SelectionVersionMetadataOnly+  | SelectionVerificationBoundaryChanged+  | SelectionMappedDependencyChanged+  deriving stock (Eq, Ord, Show, Generic)++-- | Durable selection ownership metadata. Locations and query files are absent;+-- the ledger owns only the verification boundary and checked semantic identity.+data RouterSelectionSnapshot = RouterSelectionSnapshot+  { selectionRouter :: !Name,+    selectionVerification :: !SelectionVerification,+    selectionIdentity :: !(Maybe Text),+    selectionVersion :: !(Maybe Natural),+    selectionFingerprint :: !(Maybe Text)+  }+  deriving stock (Eq, Ord, Show, Generic)++data CoordinationImpact = CoordinationImpact+  { coordinationRouter :: !Name,+    coordinationSeverity :: !CoordinationSeverity,+    coordinationReason :: !CoordinationReason,+    previousVerification :: !SelectionVerification,+    currentVerification :: !SelectionVerification,+    previousIdentity :: !(Maybe Text),+    currentIdentity :: !(Maybe Text),+    previousVersion :: !(Maybe Natural),+    currentVersion :: !(Maybe Natural),+    previousFingerprint :: !(Maybe Text),+    currentFingerprint :: !(Maybe Text),+    affectedUseSites :: ![UseSite]+  }+  deriving stock (Eq, Show, Generic)++data RouterSelectionDrift = RouterSelectionDrift+  { driftRouter :: !Name,+    driftPreviousSelection :: !(Maybe RouterSelectionSnapshot),+    driftCurrentSelection :: !(Maybe RouterSelectionSnapshot)+  }+  deriving stock (Eq, Show, Generic)++instance ToJSON SelectionVerification where+  toJSON = toJSON . verificationIdentity++instance FromJSON SelectionVerification where+  parseJSON value = do+    identity <- parseJSON value+    case (identity :: Text) of+      "declarative-verified" -> pure DeclarativeVerified+      "custom-unverified" -> pure CustomUnverified+      _ -> fail "unknown router selection verification"++instance ToJSON RouterSelectionSnapshot where+  toJSON snapshot =+    object+      [ "router" .= selectionRouter snapshot,+        "verification" .= selectionVerification snapshot,+        "identity" .= selectionIdentity snapshot,+        "version" .= selectionVersion snapshot,+        "fingerprint" .= selectionFingerprint snapshot+      ]++instance FromJSON RouterSelectionSnapshot where+  parseJSON = withObject "RouterSelectionSnapshot" $ \fields -> do+    snapshot <-+      RouterSelectionSnapshot+        <$> fields .: "router"+        <*> fields .: "verification"+        <*> fields .:? "identity"+        <*> fields .:? "version"+        <*> fields .:? "fingerprint"+    unless (snapshotValid snapshot) (fail "router selection metadata does not match its verification boundary")+    pure snapshot++instance ToJSON CoordinationImpact where+  toJSON impact =+    object+      [ "router" .= coordinationRouter impact,+        "severity" .= severityIdentity (coordinationSeverity impact),+        "reason" .= reasonIdentity (coordinationReason impact),+        "previousVerification" .= previousVerification impact,+        "currentVerification" .= currentVerification impact,+        "previousIdentity" .= previousIdentity impact,+        "currentIdentity" .= currentIdentity impact,+        "previousVersion" .= previousVersion impact,+        "currentVersion" .= currentVersion impact,+        "previousFingerprint" .= previousFingerprint impact,+        "currentFingerprint" .= currentFingerprint impact,+        "affectedUseSites" .= map (renderUsePath . (`UsePath` [])) (affectedUseSites impact)+      ]++-- | Freeze every router's checked coordination metadata in canonical name order.+routerSelectionSnapshots :: CheckedService -> [RouterSelectionSnapshot]+routerSelectionSnapshots = sortOn selectionRouter . map stateSnapshot . routerSelectionStates++routerSelectionDrift :: [RouterSelectionSnapshot] -> [RouterSelectionSnapshot] -> [RouterSelectionDrift]+routerSelectionDrift previous current =+  [ RouterSelectionDrift router old new+  | router <- Set.toAscList (Map.keysSet oldByRouter <> Map.keysSet newByRouter),+    let old = Map.lookup router oldByRouter,+    let new = Map.lookup router newByRouter,+    old /= new+  ]+  where+    oldByRouter = Map.fromList [(selectionRouter snapshot, snapshot) | snapshot <- previous]+    newByRouter = Map.fromList [(selectionRouter snapshot, snapshot) | snapshot <- current]++renderRouterSelectionDrift :: [RouterSelectionDrift] -> [Text]+renderRouterSelectionDrift [] = []+renderRouterSelectionDrift drifts = "router selection coordination metadata:" : concatMap renderDrift drifts+  where+    renderDrift drift =+      [ "  " <> driftRouter drift,+        "    previous: " <> maybe "(none)" renderSnapshot (driftPreviousSelection drift),+        "    current:  " <> maybe "(none)" renderSnapshot (driftCurrentSelection drift)+      ]+    renderSnapshot snapshot =+      verificationIdentity (selectionVerification snapshot)+        <> maybe "" (" identity=" <>) (selectionIdentity snapshot)+        <> maybe "" ((" version=" <>) . T.pack . show) (selectionVersion snapshot)+        <> maybe "" (" fingerprint=" <>) (selectionFingerprint snapshot)++coordinationImpact :: CheckedService -> CheckedService -> [MappedImpactDelta] -> [CoordinationImpact]+coordinationImpact previous current mappedDeltas =+  sortOn impactOrder (directImpacts <> mappedImpacts)+  where+    previousStates = stateMap previous+    currentStates = stateMap current+    matchedRouters = Set.toAscList (Map.keysSet previousStates `Set.intersection` Map.keysSet currentStates)+    directImpacts =+      mapMaybe+        (\router -> directImpact (previousStates Map.! router) (currentStates Map.! router))+        matchedRouters+    affectedRouters =+      Set.toAscList . Set.fromList $+        [ router+        | delta <- mappedDeltas,+          consumer <- Set.toList (impactPreviousConsumers delta <> impactCurrentConsumers delta),+          RouterSelectionConsumer router _ <- [consumer]+        ]+    mappedImpacts =+      [ mkImpact+          CoordinationAdvisory+          SelectionMappedDependencyChanged+          oldState+          newState+          (stateUseSites oldState <> stateUseSites newState)+      | router <- affectedRouters,+        Just oldState <- [Map.lookup router previousStates],+        Just newState <- [Map.lookup router currentStates]+      ]+    impactOrder impact = (coordinationRouter impact, coordinationReason impact)++data RouterSelectionState = RouterSelectionState+  { stateSnapshot :: !RouterSelectionSnapshot,+    stateUseSites :: ![UseSite]+  }++stateMap :: CheckedService -> Map Name RouterSelectionState+stateMap = Map.fromList . map (\state -> (selectionRouter (stateSnapshot state), state)) . routerSelectionStates++routerSelectionStates :: CheckedService -> [RouterSelectionState]+routerSelectionStates service = case checkedTypeGraph service of+  Left failures -> error ("checked service type graph did not resolve for router coordination: " <> show failures)+  Right graph -> map (routerState graph) routers+  where+    spec = checkedSpec service+    routers = [router | NRouter router <- specNodes spec]+    routerState graph router = case rvSource (rtResolve router) of+      ResolveDeclarative {} -> case checkRouterSelection (checkedLanguageContract service) graph spec router of+        Left failures -> error ("validated declarative router selection did not check for coordination: " <> show failures)+        Right selection ->+          RouterSelectionState+            { stateSnapshot =+                RouterSelectionSnapshot+                  { selectionRouter = rtId router,+                    selectionVerification = DeclarativeVerified,+                    selectionIdentity = Just (checkedIdentity selection),+                    selectionVersion = Just (checkedVersion selection),+                    selectionFingerprint = Just (checkedFingerprint selection)+                  },+              stateUseSites = checkedUseSites selection+            }+      ResolveReadModel {} -> customState router+      ResolveHole -> customState router+    customState router =+      RouterSelectionState+        { stateSnapshot =+            RouterSelectionSnapshot+              { selectionRouter = rtId router,+                selectionVerification = CustomUnverified,+                selectionIdentity = Nothing,+                selectionVersion = Nothing,+                selectionFingerprint = Nothing+              },+          stateUseSites = []+        }++directImpact :: RouterSelectionState -> RouterSelectionState -> Maybe CoordinationImpact+directImpact oldState newState+  | oldVerification /= newVerification = advisory SelectionVerificationBoundaryChanged+  | oldVerification == CustomUnverified = Nothing+  | oldIdentity /= newIdentity = breaking SelectionIdentityChanged+  | newVersion < oldVersion = breaking SelectionVersionDecreased+  | oldFingerprint /= newFingerprint && newVersion == oldVersion = breaking SelectionFingerprintChangedWithoutVersionBump+  | oldFingerprint /= newFingerprint && newVersion > oldVersion = advisory SelectionFingerprintChangedWithVersionBump+  | oldFingerprint == newFingerprint && newVersion > oldVersion = advisory SelectionVersionMetadataOnly+  | otherwise = Nothing+  where+    old = stateSnapshot oldState+    new = stateSnapshot newState+    oldVerification = selectionVerification old+    newVerification = selectionVerification new+    oldIdentity = selectionIdentity old+    newIdentity = selectionIdentity new+    oldVersion = selectionVersion old+    newVersion = selectionVersion new+    oldFingerprint = selectionFingerprint old+    newFingerprint = selectionFingerprint new+    useSites = stateUseSites oldState <> stateUseSites newState+    advisory reason = Just (mkImpact CoordinationAdvisory reason oldState newState useSites)+    breaking reason = Just (mkImpact CoordinationBreaking reason oldState newState useSites)++mkImpact :: CoordinationSeverity -> CoordinationReason -> RouterSelectionState -> RouterSelectionState -> [UseSite] -> CoordinationImpact+mkImpact severity reason oldState newState useSites =+  CoordinationImpact+    { coordinationRouter = selectionRouter new,+      coordinationSeverity = severity,+      coordinationReason = reason,+      previousVerification = selectionVerification old,+      currentVerification = selectionVerification new,+      previousIdentity = selectionIdentity old,+      currentIdentity = selectionIdentity new,+      previousVersion = selectionVersion old,+      currentVersion = selectionVersion new,+      previousFingerprint = selectionFingerprint old,+      currentFingerprint = selectionFingerprint new,+      affectedUseSites = Set.toAscList (Set.fromList useSites)+    }+  where+    old = stateSnapshot oldState+    new = stateSnapshot newState++renderCoordinationImpact :: [CoordinationImpact] -> [Text]+renderCoordinationImpact [] = []+renderCoordinationImpact impacts = "coordination impact:" : concatMap renderImpact impacts+  where+    renderImpact impact =+      [ "  " <> coordinationRouter impact <> ": " <> severityIdentity (coordinationSeverity impact) <> " (" <> reasonIdentity (coordinationReason impact) <> ")",+        "    verification: " <> verificationIdentity (previousVerification impact) <> " -> " <> verificationIdentity (currentVerification impact),+        "    identity: " <> renderMaybe (previousIdentity impact) <> " -> " <> renderMaybe (currentIdentity impact),+        "    version: " <> renderMaybeShow (previousVersion impact) <> " -> " <> renderMaybeShow (currentVersion impact),+        "    fingerprint: " <> renderMaybe (previousFingerprint impact) <> " -> " <> renderMaybe (currentFingerprint impact),+        "    affected use sites: " <> renderUseSites (affectedUseSites impact)+      ]+    renderMaybe = maybe "(unverified)" id+    renderMaybeShow = maybe "(unverified)" (T.pack . show)+    renderUseSites [] = "(none)"+    renderUseSites values = T.intercalate ", " (map (renderUsePath . (`UsePath` [])) values)++snapshotValid :: RouterSelectionSnapshot -> Bool+snapshotValid snapshot = case selectionVerification snapshot of+  DeclarativeVerified -> allPresent+  CustomUnverified -> allAbsent+  where+    fields = [() <$ selectionIdentity snapshot, () <$ selectionVersion snapshot, () <$ selectionFingerprint snapshot]+    allPresent = all (/= Nothing) fields+    allAbsent = all (== Nothing) fields++verificationIdentity :: SelectionVerification -> Text+verificationIdentity DeclarativeVerified = "declarative-verified"+verificationIdentity CustomUnverified = "custom-unverified"++severityIdentity :: CoordinationSeverity -> Text+severityIdentity CoordinationAdvisory = "advisory"+severityIdentity CoordinationBreaking = "breaking"++reasonIdentity :: CoordinationReason -> Text+reasonIdentity SelectionIdentityChanged = "selection-identity-changed"+reasonIdentity SelectionVersionDecreased = "selection-version-decreased"+reasonIdentity SelectionFingerprintChangedWithoutVersionBump = "selection-fingerprint-changed-without-version-bump"+reasonIdentity SelectionFingerprintChangedWithVersionBump = "selection-fingerprint-changed-with-version-bump"+reasonIdentity SelectionVersionMetadataOnly = "selection-version-metadata-only"+reasonIdentity SelectionVerificationBoundaryChanged = "selection-verification-boundary-changed"+reasonIdentity SelectionMappedDependencyChanged = "selection-mapped-dependency-changed"

src/Keiro/Dsl/Coverage.hs view

@@ -3,8 +3,8 @@ -- | Reporting-only structural coverage over the checked mapped-type graph. -- -- The report intentionally has no aggregate percentage. Private persisted event--- payloads and mapped register cache boundaries have different authorities, and--- queue/public-contract payloads are not represented by this graph at all.+-- payloads, mapped register cache boundaries, and queued-job history have+-- different authorities. Public contracts remain separately owned. module Keiro.Dsl.Coverage   ( CoverageSurface (..),     CoverageMode (..),@@ -21,6 +21,7 @@     CoverageDelta (..),     CoverageReport (..),     coverageReport,+    coverageReportForService,     coverageDiffReport,     failOnOpaque,     failOnOpaqueIncrease,@@ -41,12 +42,21 @@ import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.Grammar+import Keiro.Dsl.SemanticContract (CheckedService, checkedSpec, checkedTypeGraph, legacyCheckedService)+import Keiro.Dsl.SemanticImpact import Keiro.Dsl.TypeGraph import Keiro.Dsl.Validate (DiagnosticCode (..), Severity (..)) import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) -data CoverageSurface = PrivateEventPayload | SnapshotRegister+data CoverageSurface+  = AggregateCommandPayload+  | PrivateEventPayload+  | SnapshotRegister+  | WorkqueuePayload+  | ReadModelQueryInput+  | ReadModelQueryResult+  | ProjectionTypedConsumer   deriving stock (Eq, Ord, Show)  data CoverageMode = StructuralCoverage | OpaqueCoverage@@ -54,6 +64,7 @@  data CoverageRoot = CoverageRoot   { rootSurface :: !CoverageSurface,+    rootConsumer :: !Text,     rootPath :: !Text,     rootMappedType :: !Text,     rootMode :: !CoverageMode,@@ -83,7 +94,8 @@   deriving stock (Eq, Ord, Show)  data JsonBoundary = JsonBoundary-  { jsonRoot :: !Text,+  { jsonSurface :: !CoverageSurface,+    jsonRoot :: !Text,     jsonPath :: !Text   }   deriving stock (Eq, Ord, Show)@@ -117,8 +129,13 @@   deriving stock (Eq, Show)  data CoverageSummary = CoverageSummary-  { privateEventPayloads :: !CoverageCounts,-    snapshotRegisters :: !CoverageCounts+  { aggregateCommandPayloads :: !CoverageCounts,+    privateEventPayloads :: !CoverageCounts,+    snapshotRegisters :: !CoverageCounts,+    workqueuePayloads :: !CoverageCounts,+    readModelQueryInputs :: !CoverageCounts,+    readModelQueryResults :: !CoverageCounts,+    projectionTypedConsumers :: !CoverageCounts   }   deriving stock (Eq, Show) @@ -138,8 +155,13 @@   deriving stock (Eq, Show)  data CoverageDelta = CoverageDelta-  { privateEventRootDelta :: !Int,+  { aggregateCommandRootDelta :: !Int,+    privateEventRootDelta :: !Int,     snapshotRegisterRootDelta :: !Int,+    workqueuePayloadRootDelta :: !Int,+    readModelQueryInputRootDelta :: !Int,+    readModelQueryResultRootDelta :: !Int,+    projectionTypedConsumerRootDelta :: !Int,     opaqueBoundaryDelta :: !Int,     addedOpaqueBoundaries :: ![OpaqueBoundary],     removedOpaqueBoundaries :: ![OpaqueBoundary]@@ -162,12 +184,17 @@   deriving stock (Eq, Show)  coverageReport :: FilePath -> Spec -> Either (NonEmpty TypeGraphError) CoverageReport-coverageReport specPath spec = do-  graph <- resolveTypeGraph spec-  let roots = sortOn rootPath (map (coverageRoot graph) (persistedSites graph))+coverageReport specPath = coverageReportForService specPath . legacyCheckedService++coverageReportForService :: FilePath -> CheckedService -> Either (NonEmpty TypeGraphError) CoverageReport+coverageReportForService specPath service = do+  graph <- checkedTypeGraph service+  let spec = checkedSpec service+  let impact = semanticImpact graph+      roots = sortOn (\root -> (rootPath root, rootConsumer root, rootSurface root)) (map (coverageRoot graph) (impactRoots impact))       structural = structuralBoundaryInventory graph       opaque = opaqueBoundaryInventory graph-      json = jsonBoundaryInventory graph+      json = sortOn jsonPath (jsonBoundaryInventory graph <> queueExplicitJsonBoundaries spec)       snapshots = snapshotBoundaryInventory spec graph       summary = summarize roots json       findings = opaqueSurfaceFindings opaque@@ -179,7 +206,7 @@         coverageOpaqueBoundaries = opaque,         coverageJsonBoundaries = json,         coverageSnapshotBoundaries = snapshots,-        coverageUnsupportedSurfaces = unsupportedInventory,+        coverageUnsupportedSurfaces = unsupportedInventory graph,         coverageSummary = summary,         coverageFindings = findings,         coveragePrevious = Nothing,@@ -198,8 +225,13 @@       newSummary = coverageSummary newReport       delta =         CoverageDelta-          { privateEventRootDelta = totalRoots (privateEventPayloads newSummary) - totalRoots (privateEventPayloads oldSummary),+          { aggregateCommandRootDelta = totalRoots (aggregateCommandPayloads newSummary) - totalRoots (aggregateCommandPayloads oldSummary),+            privateEventRootDelta = totalRoots (privateEventPayloads newSummary) - totalRoots (privateEventPayloads oldSummary),             snapshotRegisterRootDelta = totalRoots (snapshotRegisters newSummary) - totalRoots (snapshotRegisters oldSummary),+            workqueuePayloadRootDelta = totalRoots (workqueuePayloads newSummary) - totalRoots (workqueuePayloads oldSummary),+            readModelQueryInputRootDelta = totalRoots (readModelQueryInputs newSummary) - totalRoots (readModelQueryInputs oldSummary),+            readModelQueryResultRootDelta = totalRoots (readModelQueryResults newSummary) - totalRoots (readModelQueryResults oldSummary),+            projectionTypedConsumerRootDelta = totalRoots (projectionTypedConsumers newSummary) - totalRoots (projectionTypedConsumers oldSummary),             opaqueBoundaryDelta = length added - length removed,             addedOpaqueBoundaries = added,             removedOpaqueBoundaries = removed@@ -251,9 +283,13 @@ renderCoverageSummary report =   T.unlines     [ "structural/opaque boundaries (reporting only):",+      "  aggregate-command-payloads: " <> renderCounts (aggregateCommandPayloads summary) <> "; encoding=consumer-build-only",       "  private-event-payloads: " <> renderCounts (privateEventPayloads summary),       "  snapshot-registers: " <> renderCounts (snapshotRegisters summary) <> "; encoding=consumer-json-cache; invalidation=tracked",-      "  queue-payloads: unsupported",+      "  queue-payloads: " <> renderCounts (workqueuePayloads summary) <> "; encoding=queue-envelope-v1; migration=drain-or-transitional-codec",+      "  read-model-query-inputs: " <> renderCounts (readModelQueryInputs summary) <> "; encoding=generated-haskell-api",+      "  read-model-query-results: " <> renderCounts (readModelQueryResults summary) <> "; encoding=generated-haskell-api",+      "  projection-typed-consumers: " <> renderCounts (projectionTypedConsumers summary) <> "; encoding=inherited-event-source",       "  public-contracts: not-applicable (separately owned grammar)"     ]   where@@ -301,16 +337,21 @@     isPersisted RootEventField {} = True     isPersisted RootRegister {} = True     isPersisted RootCommandField {} = False+    isPersisted RootWorkqueueField {} = True+    isPersisted RootReadModelQueryInput {} = False+    isPersisted RootReadModelQueryResult {} = False -coverageRoot :: TypeGraph -> UseSite -> CoverageRoot-coverageRoot graph site =-  let key = useSiteKey site-      path = renderUsePath (UsePath site [])+coverageRoot :: TypeGraph -> MappedRoot -> CoverageRoot+coverageRoot graph mappedRoot =+  let site = mappedRootUseSite mappedRoot+      key = mappedRootDeclaration mappedRoot+      path = renderUsePath (UsePath site (useSiteSegments graph site))       fingerprint = wireFingerprint graph (unMappedKey key)    in case Map.lookup key (tgDeclarations graph) of         Just (ResolvedStructural declaration _) ->           CoverageRoot-            { rootSurface = useSiteSurface site,+            { rootSurface = rootKindSurface (mappedRootKind mappedRoot),+              rootConsumer = mappedConsumerIdentity (mappedRootConsumer mappedRoot),               rootPath = path,               rootMappedType = unMappedKey key,               rootMode = StructuralCoverage,@@ -321,7 +362,8 @@             }         Just (ResolvedOpaque declaration) ->           CoverageRoot-            { rootSurface = useSiteSurface site,+            { rootSurface = rootKindSurface (mappedRootKind mappedRoot),+              rootConsumer = mappedConsumerIdentity (mappedRootConsumer mappedRoot),               rootPath = path,               rootMappedType = unMappedKey key,               rootMode = OpaqueCoverage,@@ -345,7 +387,7 @@         }     | ResolvedStructural declaration _ <- Map.elems (tgDeclarations graph),       path <- usePaths graph (sdName declaration),-      isEventSite (upRoot path)+      isWireSite (upRoot path)     ]  opaqueBoundaryInventory :: TypeGraph -> [OpaqueBoundary]@@ -361,22 +403,56 @@         }     | ResolvedOpaque declaration <- Map.elems (tgDeclarations graph),       path <- usePaths graph (odName declaration),-      isEventSite (upRoot path)+      isWireSite (upRoot path)     ]  jsonBoundaryInventory :: TypeGraph -> [JsonBoundary] jsonBoundaryInventory graph =   sortOn     jsonPath-    [ JsonBoundary-        { jsonRoot = rootText site,-          jsonPath = renderUsePath (UsePath site segments)-        }+    [ boundary site completeSegments     | site <- persistedSites graph,-      isEventSite site,-      segments <- jsonPathsFromDecl graph Set.empty (useSiteKey site)+      isWireSite site,+      segments <- jsonPathsFromDecl graph Set.empty (useSiteKey site),+      let completeSegments = useSiteSegments graph site <> segments     ]+  where+    boundary site segments =+      JsonBoundary+        { jsonSurface = useSiteSurface site,+          jsonRoot = rootText site,+          jsonPath = renderUsePath (UsePath site segments)+        } +queueExplicitJsonBoundaries :: Spec -> [JsonBoundary]+queueExplicitJsonBoundaries spec =+  [ JsonBoundary+      { jsonSurface = WorkqueuePayload,+        jsonRoot = root,+        jsonPath = root <> renderSegments segments+      }+  | NWorkqueue workqueue <- specNodes spec,+    field <- wqPayload workqueue,+    TypedQueueExpression expression <- [wqfType field],+    segments <- explicitJsonPaths expression,+    let root = "workqueue " <> wqName workqueue <> " payload ." <> wqfName field+  ]+  where+    explicitJsonPaths TJson = [[]]+    explicitJsonPaths (TOptional value) = map (SegOptional :) (explicitJsonPaths value)+    explicitJsonPaths (TList value) = map (SegElem :) (explicitJsonPaths value)+    explicitJsonPaths (TMap value) = map (SegMapValue :) (explicitJsonPaths value)+    explicitJsonPaths _ = []+    renderSegments = T.concat . map renderSegment+    renderSegment SegOptional = " optional"+    renderSegment SegElem = " []"+    renderSegment SegMapValue = " {}"+    renderSegment (SegField name key)+      | name == key = " ." <> name+      | otherwise = " ." <> name <> " as " <> T.pack (show key)+    renderSegment (SegArm _ tag) = " arm " <> T.pack (show tag)+    renderSegment (SegDecl name) = " : " <> name+ snapshotBoundaryInventory :: Spec -> TypeGraph -> [SnapshotBoundary] snapshotBoundaryInventory spec graph =   sortOn@@ -451,15 +527,18 @@ summarize :: [CoverageRoot] -> [JsonBoundary] -> CoverageSummary summarize roots json =   CoverageSummary-    { privateEventPayloads = countsFor PrivateEventPayload,-      snapshotRegisters = countsFor SnapshotRegister+    { aggregateCommandPayloads = countsFor AggregateCommandPayload,+      privateEventPayloads = countsFor PrivateEventPayload,+      snapshotRegisters = countsFor SnapshotRegister,+      workqueuePayloads = countsFor WorkqueuePayload,+      readModelQueryInputs = countsFor ReadModelQueryInput,+      readModelQueryResults = countsFor ReadModelQueryResult,+      projectionTypedConsumers = countsFor ProjectionTypedConsumer     }   where     countsFor surface =       let matching = filter ((== surface) . rootSurface) roots-          jsonCount = case surface of-            PrivateEventPayload -> length json-            SnapshotRegister -> 0+          jsonCount = length (filter ((== surface) . jsonSurface) json)        in CoverageCounts             { totalRoots = length matching,               structuralRoots = length (filter ((== StructuralCoverage) . rootMode) matching),@@ -473,7 +552,7 @@       { findingSeverity = Warning,         findingCode = CoverageOpaqueSurface,         findingRoots = [root],-        findingMessage = "persisted private-event root contains opaque mapped boundaries"+        findingMessage = "persisted mapped root contains opaque mapped boundaries"       }   | root <- Set.toAscList (Set.fromList (map opaqueRoot boundaries))   ]@@ -487,35 +566,62 @@       findingMessage = message     } -unsupportedInventory :: [UnsupportedSurface]-unsupportedInventory =+unsupportedInventory :: TypeGraph -> [UnsupportedSurface]+unsupportedInventory graph =   [ UnsupportedSurface-      { unsupportedSurface = "queue-payloads",-        unsupportedSupport = "unsupported",-        unsupportedReason = "queue payloads are not roots in the mapped-type graph"-      },-    UnsupportedSurface       { unsupportedSurface = "public-contracts",         unsupportedSupport = "not-applicable",         unsupportedReason = "public contracts have a separately owned grammar and compatibility surface"       }   ]+    <> [ UnsupportedSurface+           { unsupportedSurface = unsupportedProjectionIdentity boundary,+             unsupportedSupport = "operational-only",+             unsupportedReason = "heterogeneous projection sources have no single generated event type or mapped declaration root"+           }+       | boundary <- tgUnsupportedProjectionSources graph+       ]+  where+    unsupportedProjectionIdentity (UnsupportedCatalogCategory owner categoryName) = "projection-category:" <> owner <> ":" <> categoryName+    unsupportedProjectionIdentity (UnsupportedCatalogAll owner) = "projection-all:" <> owner  useSiteKey :: UseSite -> MappedKey useSiteKey (RootCommandField _ _ _ key) = key useSiteKey (RootEventField _ _ _ key) = key useSiteKey (RootRegister _ _ key) = key+useSiteKey (RootWorkqueueField _ _ key) = key+useSiteKey (RootReadModelQueryInput _ key) = key+useSiteKey (RootReadModelQueryResult _ key) = key  useSiteSurface :: UseSite -> CoverageSurface+useSiteSurface RootCommandField {} = AggregateCommandPayload useSiteSurface RootEventField {} = PrivateEventPayload useSiteSurface RootRegister {} = SnapshotRegister-useSiteSurface RootCommandField {} = error "command fields are not persisted coverage roots"+useSiteSurface RootWorkqueueField {} = WorkqueuePayload+useSiteSurface RootReadModelQueryInput {} = ReadModelQueryInput+useSiteSurface RootReadModelQueryResult {} = ReadModelQueryResult -isEventSite :: UseSite -> Bool-isEventSite RootEventField {} = True-isEventSite RootRegister {} = False-isEventSite RootCommandField {} = False+rootKindSurface :: MappedRootKind -> CoverageSurface+rootKindSurface MappedCommandFieldRoot = AggregateCommandPayload+rootKindSurface MappedEventFieldRoot = PrivateEventPayload+rootKindSurface MappedRegisterRoot = SnapshotRegister+rootKindSurface MappedWorkqueueFieldRoot = WorkqueuePayload+rootKindSurface MappedReadModelQueryInputRoot = ReadModelQueryInput+rootKindSurface MappedReadModelQueryResultRoot = ReadModelQueryResult+rootKindSurface MappedRouterSelectionQueryInputRoot = ReadModelQueryInput+rootKindSurface MappedRouterSelectionPredicateRoot = ReadModelQueryResult+rootKindSurface MappedRouterSelectionRecipientRoot = ReadModelQueryResult+rootKindSurface MappedRouterSelectionCommandFieldRoot = ReadModelQueryResult+rootKindSurface MappedProjectionEventRoot = ProjectionTypedConsumer +isWireSite :: UseSite -> Bool+isWireSite RootEventField {} = True+isWireSite RootWorkqueueField {} = True+isWireSite RootRegister {} = False+isWireSite RootCommandField {} = False+isWireSite RootReadModelQueryInput {} = False+isWireSite RootReadModelQueryResult {} = False+ rootText :: UseSite -> Text rootText site = renderUsePath (UsePath site []) @@ -528,8 +634,13 @@       }  instance ToJSON CoverageSurface where+  toJSON AggregateCommandPayload = toJSON ("aggregate-command-payload" :: Text)   toJSON PrivateEventPayload = toJSON ("private-event-payload" :: Text)   toJSON SnapshotRegister = toJSON ("snapshot-register" :: Text)+  toJSON WorkqueuePayload = toJSON ("workqueue-payload" :: Text)+  toJSON ReadModelQueryInput = toJSON ("read-model-query-input" :: Text)+  toJSON ReadModelQueryResult = toJSON ("read-model-query-result" :: Text)+  toJSON ProjectionTypedConsumer = toJSON ("projection-typed-consumer" :: Text)  instance ToJSON CoverageMode where   toJSON StructuralCoverage = toJSON ("structural" :: Text)@@ -539,6 +650,7 @@   toJSON root =     object       [ "surface" .= rootSurface root,+        "consumer" .= rootConsumer root,         "path" .= rootPath root,         "mappedType" .= rootMappedType root,         "mode" .= rootMode root,@@ -569,7 +681,7 @@       ]  instance ToJSON JsonBoundary where-  toJSON boundary = object ["root" .= jsonRoot boundary, "path" .= jsonPath boundary]+  toJSON boundary = object ["surface" .= jsonSurface boundary, "root" .= jsonRoot boundary, "path" .= jsonPath boundary]  instance ToJSON SnapshotBoundary where   toJSON boundary =@@ -605,8 +717,13 @@ instance ToJSON CoverageSummary where   toJSON summary =     object-      [ "privateEventPayloads" .= privateEventPayloads summary,-        "snapshotRegisters" .= snapshotRegisters summary+      [ "aggregateCommandPayloads" .= aggregateCommandPayloads summary,+        "privateEventPayloads" .= privateEventPayloads summary,+        "snapshotRegisters" .= snapshotRegisters summary,+        "workqueuePayloads" .= workqueuePayloads summary,+        "readModelQueryInputs" .= readModelQueryInputs summary,+        "readModelQueryResults" .= readModelQueryResults summary,+        "projectionTypedConsumers" .= projectionTypedConsumers summary       ]  instance ToJSON CoverageFinding where@@ -635,8 +752,13 @@ instance ToJSON CoverageDelta where   toJSON delta =     object-      [ "privateEventRootDelta" .= privateEventRootDelta delta,+      [ "aggregateCommandRootDelta" .= aggregateCommandRootDelta delta,+        "privateEventRootDelta" .= privateEventRootDelta delta,         "snapshotRegisterRootDelta" .= snapshotRegisterRootDelta delta,+        "workqueuePayloadRootDelta" .= workqueuePayloadRootDelta delta,+        "readModelQueryInputRootDelta" .= readModelQueryInputRootDelta delta,+        "readModelQueryResultRootDelta" .= readModelQueryResultRootDelta delta,+        "projectionTypedConsumerRootDelta" .= projectionTypedConsumerRootDelta delta,         "opaqueBoundaryDelta" .= opaqueBoundaryDelta delta,         "addedOpaqueBoundaries" .= addedOpaqueBoundaries delta,         "removedOpaqueBoundaries" .= removedOpaqueBoundaries delta

src/Keiro/Dsl/Diff.hs view

@@ -19,6 +19,8 @@     SurfaceVerdict (..),     RolloutConstraint (..),     CompatibilityVector (..),+    MappedPersistedSurface (..),+    MappedPersistedImpact (..),     ChangeContext,     privateEventContext,     privateEventAdditionContext,@@ -41,6 +43,8 @@     diffSources,     sourceLanguageChange,     diffServices,+    mappedSemanticImpact,+    mappedSemanticImpactForServices,     DiffEnv (..),     NodeFamily (..),     familyOf,@@ -55,13 +59,15 @@  import Data.Char (toUpper) import Data.Foldable (traverse_)-import Data.List (find, (\\))-import Data.Maybe (isJust, isNothing, mapMaybe)+import Data.List (find, sort, (\\))+import Data.Map.Strict qualified as Map+import Data.Maybe (isJust, isNothing, mapMaybe, maybeToList) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.AggregateType (typeExprCanonicalName)+import Keiro.Dsl.CanonicalEncoding (canonicalDomainOutcomeTypes, canonicalTransition, canonicalTransitionOutcome) import Keiro.Dsl.FieldIdentity   ( ResolvedFieldIdentity (..),     resolveAggregateFieldIdentity,@@ -79,10 +85,14 @@     renderRouterDispatchSurface,     renderTimerPayloadSurface,     renderTransition,+    renderTypeExpr,   )+import Keiro.Dsl.ProjectionMappedImpact qualified as ProjectionImpact+import Keiro.Dsl.ProjectionSupply import Keiro.Dsl.ReadModelShape (registryNameFor, subscriptionNameFor)-import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, checkedSource, effectiveLanguageContract, effectiveRuntimeSemantics, legacyCheckedService)-import Keiro.Dsl.TypeGraph (UsePath (..), UseSite (..))+import Keiro.Dsl.SemanticContract (CheckedService, EffectiveLanguageContract, checkedLanguageContract, checkedSource, checkedSpec, effectiveLanguageContract, effectiveRuntimeSemantics, legacyCheckedService)+import Keiro.Dsl.SemanticImpact (MappedConsequence (..), MappedConsumer (..), MappedImpactDelta (..), MappedQueryPosition (..), diffSemanticImpact, mappedConsumerIdentity, mappedImpactForDeclarations, semanticImpact, semanticImpactForService, semanticImpactSnapshot)+import Keiro.Dsl.TypeGraph (DerivedMappedConsumer (..), MappedKey (..), UsePath (..), UseSite (..), renderUsePath, resolveTypeGraph) import Keiro.Dsl.Validate (DiagnosticCode (..))  -- | A classified spec change.@@ -131,6 +141,20 @@   }   deriving stock (Eq, Show) +-- | Persisted mapped payloads that must not be conflated merely because the+-- compatibility vector predates first-class queue history.+data MappedPersistedSurface+  = PrivateEventHistory+  | SnapshotCache+  | WorkqueueHistory !Name+  deriving stock (Eq, Ord, Show)++data MappedPersistedImpact = MappedPersistedImpact+  { mappedPersistedSurface :: !MappedPersistedSurface,+    mappedPersistedVerdict :: !SurfaceVerdict+  }+  deriving stock (Eq, Show)+ data ContextKind   = ContextGeneral   | ContextPrivateEvent@@ -159,6 +183,8 @@     ckCode :: !DiagnosticCode,     ckContext :: !ChangeContext,     ckVector :: !CompatibilityVector,+    ckMappedPersistedImpact :: !(Maybe MappedPersistedImpact),+    ckMappedConsequences :: !(Set MappedConsequence),     ckPaths :: ![Text],     ckDetail :: !Text   }@@ -243,14 +269,25 @@ queueBreakingVector :: CompatibilityVector queueBreakingVector =   CompatibilityVector-    VBreaking-    VBreaking     VNotApplicable     VNotApplicable-    VAdvisory     VNotApplicable-    (Set.singleton RolloutWorkersFirst)+    VNotApplicable+    VNotApplicable+    VBreaking+    (Set.fromList [RolloutWorkersFirst, RolloutDrainRequired]) +catalogCheckpointPolicyVector :: CompatibilityVector+catalogCheckpointPolicyVector =+  CompatibilityVector+    VCompatible+    VCompatible+    VNotApplicable+    VNotApplicable+    VCompatible+    VBreaking+    (Set.singleton RolloutStopTheWorld)+ advisoryVector :: CompatibilitySurface -> Set RolloutConstraint -> CompatibilityVector advisoryVector surface rollout =   compatibleVector@@ -275,6 +312,8 @@   | code == SourceLanguageDeclarationChanged = sourceProvenanceVector   | code == GeneratedHaskellNameChanged = sourceProvenanceVector {cvConsumerBuild = VAdvisory}   | code `elem` [OwnershipMoved, WorkspaceAuthorityChanged] = mappedBuildVector+  | code `elem` [ReadModelQueryInputChanged, ReadModelQueryResultChanged] =+      compatibleVector {cvConsumerBuild = VBreaking}   | code == MappedFieldAddedWithDefault = mappedFieldAdditionVector context   | code `elem` [MappedArmAdded, MappedEnumValueAdded] = mappedDirectionalAdditionVector context   | code `elem` mappedWireBreakingCodes = mappedWireBreakingVector context@@ -295,6 +334,12 @@   | code `elem` publicBreakingCodes = publicBreakingVector   | code `elem` queueBreakingCodes = queueBreakingVector   | code `elem` readModelBreakingCodes = persistedIdentityBreakingVector+  | code `elem` catalogIdentityCodes = persistedIdentityBreakingVector+  | code `elem` catalogReplayCodes = privateDecodeBreakingVector+  | code == CatalogCheckpointPolicyChanged = catalogCheckpointPolicyVector+  | code `elem` [ProjectionDeliveryChanged, QueryFreshnessChanged] = persistedIdentityBreakingVector+  | code == CatalogHandlerOrderChanged =+      (advisoryVector PrivateHistoryRead Set.empty) {cvConsumerBuild = VAdvisory}   | code == ContractSchemaVersionBumped = advisoryVector PublicConsumer (Set.singleton RolloutProducerLast)   | code == AggFoldSurfaceChanged =       (advisoryVector PrivateHistoryRead Set.empty) {cvSnapshotHydration = VAdvisory}@@ -365,6 +410,18 @@         ReadModelFeedChanged,         ReadModelConsistencyWeakened       ]+    catalogIdentityCodes =+      [ CatalogTargetRemoved,+        CatalogTargetLocationChanged,+        CatalogTargetDependencyChanged,+        CatalogGroupChanged,+        CatalogOwnerRemoved,+        CatalogFeedIdentityChanged,+        CatalogQueryBindingChanged,+        ProjectionDeliveryChanged,+        QueryFreshnessChanged+      ]+    catalogReplayCodes = [CatalogSourceChanged, CatalogReplayPolicyChanged]     additiveCodes =       [ DeclarationAdded,         VersionBumped,@@ -431,6 +488,7 @@       oldBinaryVerdict = if rejectsUnknown then VBreaking else VCompatible       rollout = if rejectsUnknown then Set.singleton RolloutProducerLast else Set.empty   ContextSnapshot -> mappedSnapshotVector+  ContextQueue -> queueBreakingVector   ContextConsumerBuild -> mappedBuildVector   _ -> compatibleVector @@ -442,6 +500,7 @@         cvRollout = Set.singleton RolloutProducerLast       }   ContextSnapshot -> mappedSnapshotVector+  ContextQueue -> queueBreakingVector   ContextConsumerBuild -> mappedBuildVector   _ -> compatibleVector @@ -457,6 +516,7 @@       VNotApplicable       (Set.singleton RolloutStopTheWorld)   ContextSnapshot -> mappedSnapshotVector+  ContextQueue -> queueBreakingVector   ContextConsumerBuild -> mappedBuildVector   _ -> mappedBuildVector @@ -495,6 +555,7 @@       Set.empty   ContextSnapshot ->     mappedSnapshotVector {cvConsumerBuild = VAdvisory}+  ContextQueue -> queueBreakingVector   _ -> mappedBuildVector  mappedSnapshotBuildVector :: ChangeContext -> CompatibilityVector@@ -581,6 +642,11 @@   | FamWorkqueue   | FamPgmqDispatch   | FamReadModel+  | FamProjectionTarget+  | FamRebuildGroup+  | FamProjectionRevision+  | FamExternalRead+  | FamProjectionOwner   | FamWorkflow   | FamOperation   deriving stock (Eq, Ord, Show, Enum, Bounded)@@ -597,6 +663,11 @@ familyOf (NWorkqueue _) = FamWorkqueue familyOf (NPgmqDispatch _) = FamPgmqDispatch familyOf (NReadModel _) = FamReadModel+familyOf (NProjectionTarget _) = FamProjectionTarget+familyOf (NRebuildGroup _) = FamRebuildGroup+familyOf (NProjectionRevision _) = FamProjectionRevision+familyOf (NExternalRead _) = FamExternalRead+familyOf (NProjectionOwner _) = FamProjectionOwner familyOf (NWorkflow _) = FamWorkflow familyOf (NOperation _) = FamOperation @@ -651,6 +722,11 @@     (FamWorkqueue, DiffFamily workqueueDiff),     (FamPgmqDispatch, DiffFamily pgmqDispatchDiff),     (FamReadModel, DiffFamily readModelDiff),+    (FamProjectionTarget, DiffFamily projectionTargetDiff),+    (FamRebuildGroup, DiffFamily rebuildGroupDiff),+    (FamProjectionRevision, DiffFamily projectionRevisionDiff),+    (FamExternalRead, DiffFamily externalReadDiff),+    (FamProjectionOwner, DiffFamily projectionOwnerDiff),     (FamWorkflow, DiffFamily workflowDiff),     (FamOperation, OutOfDiffScope "operations own no persisted decode or identity surface; their references and workflow signal/await pairing are single-spec validation concerns")   ]@@ -817,8 +893,110 @@ sharedDeclarationDiff env = enumDiff env ++ idDiff env ++ nominalScalarDiff env ++ mappedDeclarationDiff env  mappedDeclarationDiff :: DiffEnv -> [Change]-mappedDeclarationDiff env = concatMap mappedFindingChanges (diffMapped (deOld env) (deNew env))+mappedDeclarationDiff env =+  concatMap+    (\finding -> mappedFindingChanges finding <> mappedProjectionFindingChanges env finding)+    (diffMapped (deOld env) (deNew env)) +-- | A mapped event finding retains its existing private-history change and+-- gains one build/review finding per real inline/catalog aggregate consumer.+-- Category/all owners never appear because they have no single mapped event+-- authority. Operational targets and observers are evidence, not SQL claims.+mappedProjectionFindingChanges :: DiffEnv -> MappedFinding -> [Change]+mappedProjectionFindingChanges env finding = case (projectionImpactFor (deOld env), projectionImpactFor (deNew env)) of+  (Nothing, Nothing) -> []+  (oldImpact, newImpact) ->+    let derivedConsumers =+          maybe Set.empty (`ProjectionImpact.projectionConsumersFor` declarationKey) oldImpact+            <> maybe Set.empty (`ProjectionImpact.projectionConsumersFor` declarationKey) newImpact+     in [ withMappedConsequences (projectionConsequences derived oldOperation newOperation) $+            appendChangeDetail (operationDetail oldOperation newOperation) $+              mappedChange+                (consumerBuildContext root inheritedPaths)+                root+                "mapped-projection"+                subject+                finding+        | derived <- Set.toAscList derivedConsumers,+          let oldOperation = oldImpact >>= operationFor declarationKey derived,+          let newOperation = newImpact >>= operationFor declarationKey derived,+          let inheritedPaths =+                Set.toAscList . Set.fromList $+                  projectionPaths declarationKey derived oldImpact+                    <> projectionPaths declarationKey derived newImpact,+          let root = projectionConsumerRoot derived,+          let subject = mappedConsumerIdentity (DerivedProjectionConsumer derived) <> " inherits " <> unMappedKey declarationKey+        ]+  where+    declarationKey = MappedKey (mfDeclaration finding)+    projectionImpactFor spec = case resolveTypeGraph spec of+      Left _ -> Nothing+      Right graph -> Just (ProjectionImpact.projectionMappedImpact (legacyCheckedService spec) (semanticImpact graph))+    operationFor key derived impact =+      find+        (\(ProjectionImpact.ProjectionOperationalImpact candidate _ _ _ _ _) -> candidate == derived)+        (ProjectionImpact.projectionOperationsFor impact key)+    projectionPaths key derived = maybe [] $ \impact ->+      sort . Set.toList . Set.fromList $+        [ renderUsePath inheritedPath+        | ProjectionImpact.ProjectionMappedRoot candidate declaration inheritedPath <- ProjectionImpact.roots impact,+          candidate == derived,+          declaration == key+        ]+    operationDetail oldOperation newOperation =+      "; derived projection impact: "+        <> renderOperation "previous" oldOperation+        <> "; "+        <> renderOperation "current" newOperation+    renderOperation label Nothing = label <> "=(absent)"+    renderOperation label (Just (ProjectionImpact.ProjectionOperationalImpact _ groupName targetNames observerNames canReplay fingerprint)) =+      label+        <> "=(group="+        <> maybe "(inline)" id groupName+        <> ", targets=["+        <> T.intercalate "," (Set.toAscList targetNames)+        <> "], read-models=["+        <> T.intercalate "," (Set.toAscList observerNames)+        <> "], replayable="+        <> (if canReplay then "yes" else "no")+        <> ", source-fingerprint="+        <> fingerprint+        <> ")"+    appendChangeDetail suffix = \case+      Additive kind -> Additive kind {ckDetail = ckDetail kind <> suffix}+      Advisory kind -> Advisory kind {ckDetail = ckDetail kind <> suffix}+      Breaking kind -> Breaking kind {ckDetail = ckDetail kind <> suffix}+    projectionConsequences derived oldOperation newOperation =+      Set.fromList+        ( [MappedConsumerBuild (DerivedProjectionConsumer derived), MappedProjectionHandlerReview derived]+            <> [ MappedProjectionRebuild derived groupName+               | ProjectionImpact.ProjectionOperationalImpact _ (Just groupName) _ _ True _ <- maybeToList oldOperation <> maybeToList newOperation+               ]+        )+    projectionConsumerRoot (AggregateInlineProjectionConsumer aggregate _) = aggregate+    projectionConsumerRoot (CatalogProjectionConsumer owner _) = owner++-- | Explain only declarations for which the authoritative mapped differ emits+-- a finding. The compatibility findings remain unchanged; this projection adds+-- the checked before/after aggregate consumer sets and service-conformance role.+mappedSemanticImpact :: Spec -> Spec -> [MappedImpactDelta]+mappedSemanticImpact oldSpec newSpec = mappedSemanticImpactForServices (legacyCheckedService oldSpec) (legacyCheckedService newSpec)++-- | Service-aware mapped impact adds checked declarative selection consumers;+-- the legacy Spec-only entry point retains its historical language contract.+mappedSemanticImpactForServices :: CheckedService -> CheckedService -> [MappedImpactDelta]+mappedSemanticImpactForServices oldService newService = case (resolveTypeGraph oldSpec, resolveTypeGraph newSpec) of+  (Right oldGraph, Right newGraph) ->+    let oldSnapshot = semanticImpactSnapshot (semanticImpactForService oldService oldGraph)+        newSnapshot = semanticImpactSnapshot (semanticImpactForService newService newGraph)+        declarationChanges = [MappedKey (mfDeclaration finding) | finding <- diffMapped oldSpec newSpec]+        relationChanges = map impactDeclaration (diffSemanticImpact oldSnapshot newSnapshot)+     in mappedImpactForDeclarations (declarationChanges <> relationChanges) oldSnapshot newSnapshot+  _ -> []+  where+    oldSpec = checkedSpec oldService+    newSpec = checkedSpec newService+ mappedFindingChanges :: MappedFinding -> [Change] mappedFindingChanges finding   | mfCode finding == MappedDeclAdded = [mappedDeclarationChange LabelAdditive finding]@@ -848,18 +1026,37 @@  mappedUseChange :: MappedFinding -> UsePath -> Change mappedUseChange finding path =-  mappedChange context root facet subject finding+  withMappedConsequences (mappedUseConsequences path) (mappedChange context root facet subject finding)   where     subject = renderMappedSubject path (mfLeaf finding)     (root, facet, kind) = case upRoot path of       RootCommandField aggregate _ _ _ -> (aggregate, "mapped-command", ContextConsumerBuild)       RootEventField aggregate _ _ _ -> (aggregate, "mapped-event", ContextPrivateEvent)       RootRegister aggregate _ _ -> (aggregate, "mapped-register", ContextSnapshot)+      RootWorkqueueField workqueue _ _ -> (workqueue, "mapped-workqueue", ContextQueue)+      RootReadModelQueryInput readModel _ -> (readModel, "mapped-query-input", ContextConsumerBuild)+      RootReadModelQueryResult readModel _ -> (readModel, "mapped-query-result", ContextConsumerBuild)     context = ChangeContext root [subject] kind (mappedContextHint finding kind) +mappedUseConsequences :: UsePath -> Set MappedConsequence+mappedUseConsequences path = Set.fromList $ case upRoot path of+  RootCommandField aggregate _ _ _ -> [MappedConsumerBuild (AggregateConsumer aggregate)]+  RootEventField aggregate _ _ _ -> [MappedConsumerBuild (AggregateConsumer aggregate), MappedPrivateEventHistory aggregate]+  RootRegister aggregate _ _ -> [MappedConsumerBuild (AggregateConsumer aggregate), MappedSnapshotHydration aggregate]+  RootWorkqueueField workqueue _ _ -> [MappedConsumerBuild (WorkqueueConsumer workqueue), MappedWorkqueueHistory workqueue]+  RootReadModelQueryInput readModel _ -> [MappedConsumerBuild (ReadModelQueryConsumer readModel MappedQueryInput), MappedQueryApi readModel MappedQueryInput]+  RootReadModelQueryResult readModel _ -> [MappedConsumerBuild (ReadModelQueryConsumer readModel MappedQueryResult), MappedQueryApi readModel MappedQueryResult]++withMappedConsequences :: Set MappedConsequence -> Change -> Change+withMappedConsequences consequences = \case+  Additive kind -> Additive kind {ckMappedConsequences = consequences}+  Advisory kind -> Advisory kind {ckMappedConsequences = consequences}+  Breaking kind -> Breaking kind {ckMappedConsequences = consequences}+ mappedContextHint :: MappedFinding -> ContextKind -> Label mappedContextHint finding kind = case kind of   ContextSnapshot -> LabelAdvisory+  ContextQueue -> LabelBreaking   ContextConsumerBuild -> LabelAdvisory   ContextPrivateEvent     | mfCode finding == MappedFieldAddedWithDefault -> case mfOldUnknownFields finding of@@ -872,9 +1069,14 @@  mappedChange :: ChangeContext -> Name -> Text -> Text -> MappedFinding -> Change mappedChange context node facet subject finding =-  mkChange label context node facet subject (mfCode finding) (mfDetail finding)+  mkChange label context node facet subject (mfCode finding) detail   where     label = deriveLabel defaultGate (classifyCompatibility context (mfCode finding))+    detail = case contextKind context of+      ContextQueue ->+        mfDetail finding+          <> "; queued jobs remain schema-version-1 history; drain the queue or supply an application-owned transitional codec before deployment"+      _ -> mfDetail finding  declarationSubject :: MappedFinding -> Text declarationSubject finding =@@ -920,6 +1122,26 @@ nodeReadModel (NReadModel readModel) = Just readModel nodeReadModel _ = Nothing +nodeProjectionTarget :: Node -> Maybe ProjectionTargetNode+nodeProjectionTarget (NProjectionTarget target) = Just target+nodeProjectionTarget _ = Nothing++nodeRebuildGroup :: Node -> Maybe RebuildGroupNode+nodeRebuildGroup (NRebuildGroup groupNode) = Just groupNode+nodeRebuildGroup _ = Nothing++nodeProjectionRevision :: Node -> Maybe ProjectionRevisionNode+nodeProjectionRevision (NProjectionRevision revision) = Just revision+nodeProjectionRevision _ = Nothing++nodeExternalRead :: Node -> Maybe ExternalReadNode+nodeExternalRead (NExternalRead externalRead) = Just externalRead+nodeExternalRead _ = Nothing++nodeProjectionOwner :: Node -> Maybe ProjectionOwnerNode+nodeProjectionOwner (NProjectionOwner owner) = Just owner+nodeProjectionOwner _ = Nothing+ nodeWorkflow :: Node -> Maybe WorkflowNode nodeWorkflow (NWorkflow workflow) = Just workflow nodeWorkflow _ = Nothing@@ -978,20 +1200,22 @@  readModelDiff :: DiffEnv -> [Change] readModelDiff env =-  concatMap (uncurry (readModelPairDiff env)) (prMatched paired)+  concatMap (uncurry (readModelPairDiff env oldSupplies newSupplies)) (prMatched paired)     ++ concatMap addedReadModelDiff (prAdded paired)     ++ concatMap removedReadModelDiff (prRemoved paired)   where     paired = pairByName nodeReadModel rmName env+    oldSupplies = analyzeProjectionSupplies (deOld env)+    newSupplies = analyzeProjectionSupplies (deNew env) -readModelPairDiff :: DiffEnv -> ReadModelNode -> ReadModelNode -> [Change]-readModelPairDiff env oldReadModel newReadModel =+readModelPairDiff :: DiffEnv -> ProjectionSupplyAnalysis -> ProjectionSupplyAnalysis -> ReadModelNode -> ReadModelNode -> [Change]+readModelPairDiff env oldSupplies newSupplies oldReadModel newReadModel =   versionChanges     ++ shapeChanges     ++ identityChanges-    ++ feedChanges-    ++ consistencyChanges-    ++ scopeChanges+    ++ policyChanges+    ++ bindingChanges+    ++ queryContractChanges   where     nodeName = rmName newReadModel     versionChanges@@ -1023,25 +1247,318 @@         ++ [ breaking nodeName "read-model-subscription" nodeName DerivedIdentityChanged ("subscription changed '" <> oldSubscription <> "' -> '" <> newSubscription <> "'; the worker cursor remains under the old identity")            | oldSubscription /= newSubscription            ]-    feedChanges =-      [ breaking nodeName "read-model-feed" nodeName ReadModelFeedChanged ("feed changed " <> renderFeed (rmFeed oldReadModel) <> " -> " <> renderFeed (rmFeed newReadModel) <> "; projection wiring and rebuild identities changed")-      | rmFeed oldReadModel /= rmFeed newReadModel+    -- There are three policy comparison shapes: catalog-owned on both sides,+    -- legacy on both sides, or a migration between them. The mixed case uses+    -- the normalized freshness matrix in docs/plans/250-report-legacy-strong-consistency-weakening-across-the-language-4-to-5-migration-in-diff.md;+    -- unlike two catalog-owned revisions, a migration strengthening is additive.+    policyChanges = case (rmSupply oldReadModel, rmSupply newReadModel) of+      (OwnerDerivedSupply, OwnerDerivedSupply) ->+        [ breaking nodeName "query-freshness" nodeName QueryFreshnessChanged ("query freshness changed " <> renderFreshness (rmFreshness oldReadModel) <> " -> " <> renderFreshness (rmFreshness newReadModel) <> "; catalog and owning-group query policy identity changed")+        | rmFreshness oldReadModel /= rmFreshness newReadModel+        ]+      (LegacyReadModelSupply {}, LegacyReadModelSupply {}) ->+        legacyFeedChanges <> legacyConsistencyChanges <> legacyScopeChanges+      _ -> migrationFreshnessChanges+    migrationFreshnessChanges = case (rmFreshness oldReadModel, rmFreshness newReadModel) of+      (oldFreshness, newFreshness)+        | oldFreshness == newFreshness -> []+      (FreshnessWaitForHead _, FreshnessImmediate) ->+        [ breaking nodeName "query-freshness" nodeName QueryFreshnessChanged ("query freshness weakened " <> renderFreshness (rmFreshness oldReadModel) <> " -> immediate across the legacy consistency migration; callers lose the cursor-wait guarantee")+        ]+      (FreshnessImmediate, FreshnessWaitForHead _) ->+        [ additive nodeName "query-freshness" nodeName CompatibilityStrengthened ("query freshness strengthened immediate -> " <> renderFreshness (rmFreshness newReadModel) <> " across the legacy consistency migration; callers gain a cursor-wait guarantee")+        ]+      (FreshnessWaitForHead oldWaitScope, FreshnessWaitForHead newWaitScope)+        | scopeStrengthened oldWaitScope newWaitScope ->+            [ additive nodeName "query-freshness" nodeName CompatibilityStrengthened ("query freshness head scope widened " <> renderScope oldWaitScope <> " -> " <> renderScope newWaitScope <> " across the legacy consistency migration")+            ]+        | otherwise ->+            [ breaking nodeName "query-freshness" nodeName QueryFreshnessChanged ("query freshness head scope changed " <> renderScope oldWaitScope <> " -> " <> renderScope newWaitScope <> " across the legacy consistency migration; callers no longer wait on the same event surface")+            ]+      (FreshnessImmediate, FreshnessImmediate) -> []+    legacyFeedChanges =+      [ breaking nodeName "read-model-feed" nodeName ReadModelFeedChanged ("feed changed " <> renderFeed oldFeed <> " -> " <> renderFeed newFeed <> "; projection wiring and rebuild identities changed")+      | Just oldFeed <- [legacyReadModelFeed oldReadModel],+        Just newFeed <- [legacyReadModelFeed newReadModel],+        oldFeed /= newFeed       ]-    consistencyChanges = case (rmConsistency oldReadModel, rmConsistency newReadModel) of-      (Strong, Eventual) ->+    legacyConsistencyChanges = case (legacyReadModelConsistency oldReadModel, legacyReadModelConsistency newReadModel) of+      (Just Strong, Just Eventual) ->         [breaking nodeName "read-model-consistency" nodeName ReadModelConsistencyWeakened "default consistency changed Strong -> Eventual; callers lose the cursor-wait guarantee"]-      (Eventual, Strong) ->+      (Just Eventual, Just Strong) ->         [additive nodeName "read-model-consistency" nodeName CompatibilityStrengthened "default consistency changed Eventual -> Strong; callers gain a cursor-wait guarantee"]       _ -> []-    oldScope = effectiveScope (rmScope oldReadModel)-    newScope = effectiveScope (rmScope newReadModel)-    scopeChanges+    oldScope = effectiveScope (legacyReadModelScope oldReadModel)+    newScope = effectiveScope (legacyReadModelScope newReadModel)+    legacyScopeChanges       | oldScope == newScope = []       | scopeStrengthened oldScope newScope =           [additive nodeName "read-model-scope" nodeName CompatibilityStrengthened ("Strong scope widened " <> renderScope oldScope <> " -> " <> renderScope newScope)]       | otherwise =           [breaking nodeName "read-model-scope" nodeName ReadModelConsistencyWeakened ("Strong scope changed " <> renderScope oldScope <> " -> " <> renderScope newScope <> "; callers no longer wait on the same event surface")]+    bindingChanges =+      [ breaking nodeName "read-model-catalog-binding" nodeName CatalogQueryBindingChanged "query-model rebuild group, observed target set, resolved projection supplier, or backing target changed; persisted lifecycle identity and rebuild completeness changed"+      | bindingIdentity oldSupplies oldReadModel /= bindingIdentity newSupplies newReadModel+      ]+    bindingIdentity supplyAnalysis readModel =+      ( rmGroup readModel,+        Set.fromList (rmObservedTargets readModel),+        resolvedSupplier supplyAnalysis readModel,+        effectiveBacking readModel+      )+    resolvedSupplier supplyAnalysis readModel =+      case [ supplyProjectionOwner supply+           | supply <- resolvedProjectionSupplies supplyAnalysis,+             supplyQueryModel supply == rmName readModel+           ] of+        [ownerName] -> Just ownerName+        _ -> Nothing+    effectiveBacking readModel = case rmBackingTarget readModel of+      Just target -> Just target+      Nothing -> case rmObservedTargets readModel of+        [single] -> Just single+        _ -> Nothing+    queryContractChanges =+      queryPositionChange+        "input"+        MappedQueryInput+        ReadModelQueryInputChanged+        (input <$> queryTypes oldReadModel)+        (input <$> queryTypes newReadModel)+        "callers"+        <> queryPositionChange+          "result"+          MappedQueryResult+          ReadModelQueryResultChanged+          (result <$> queryTypes oldReadModel)+          (result <$> queryTypes newReadModel)+          "result consumers"+    queryPositionChange position mappedPosition code oldExpression newExpression owner =+      [ withMappedConsequences+          (Set.fromList [MappedConsumerBuild consumer, MappedQueryApi nodeName mappedPosition])+          ( advisoryAt+              (consumerBuildContext nodeName [nodeName <> " query " <> position])+              nodeName+              ("read-model-query-" <> position)+              (nodeName <> " query " <> position)+              code+              ( "query "+                  <> position+                  <> " changed "+                  <> renderMaybeType oldExpression+                  <> " -> "+                  <> renderMaybeType newExpression+                  <> "; recompile "+                  <> owner+                  <> " against the generated QueryContract. SQL columns, projection replay, and persisted history are unaffected"+              )+          )+      | oldExpression /= newExpression+      ]+      where+        consumer = ReadModelQueryConsumer nodeName mappedPosition+    renderMaybeType = maybe "(absent)" renderTypeExpr +projectionTargetDiff :: DiffEnv -> [Change]+projectionTargetDiff env =+  concatMap (uncurry projectionTargetPairDiff) (prMatched paired)+    <> [additive (ptName target) "projection-target" (ptName target) CatalogTargetAdded "new application-owned target; consumer DDL is still required" | target <- prAdded paired]+    <> [breaking (ptName target) "projection-target" (ptName target) CatalogTargetRemoved "target declaration removed while table data and rebuild evidence may remain" | target <- prRemoved paired]+  where+    paired = pairByName nodeProjectionTarget ptName env++projectionTargetPairDiff :: ProjectionTargetNode -> ProjectionTargetNode -> [Change]+projectionTargetPairDiff oldTarget newTarget = locationChange <> resetChange <> dependencyChange+  where+    targetName = ptName newTarget+    locationChange =+      [ breaking targetName "projection-target-location" targetName CatalogTargetLocationChanged $+          "qualified target changed " <> ptSchema oldTarget <> "." <> ptTable oldTarget <> " -> " <> ptSchema newTarget <> "." <> ptTable newTarget <> "; Keiro does not move application data"+      | (ptSchema oldTarget, ptTable oldTarget) /= (ptSchema newTarget, ptTable newTarget)+      ]+    resetChange = case (ptReset oldTarget, ptReset newTarget) of+      (TargetPreserve, TargetClear) -> [breaking targetName "projection-target-reset" targetName CatalogTargetResetPolicyChanged "reset changed preserve -> clear; a rebuild can now delete retained brownfield data"]+      (TargetClear, TargetPreserve) -> [advisory targetName "projection-target-reset" targetName CatalogTargetResetPolicyChanged "reset changed clear -> preserve; application reconciliation must now prove retained rows"]+      _ -> []+    dependencyChange =+      [ breaking targetName "projection-target-dependencies" targetName CatalogTargetDependencyChanged "target dependency order changed; abandon any active fingerprint and start a fresh group rebuild"+      | ptDependsOn oldTarget /= ptDependsOn newTarget+      ]++rebuildGroupDiff :: DiffEnv -> [Change]+rebuildGroupDiff env =+  concatMap (uncurry rebuildGroupPairDiff) (prMatched paired)+    <> [additive (rgName groupNode) "rebuild-group" (rgName groupNode) DeclarationAdded "new rebuild group" | groupNode <- prAdded paired]+    <> [breaking (rgName groupNode) "rebuild-group" (rgName groupNode) CatalogGroupChanged "rebuild group removed while lifecycle and run evidence may remain" | groupNode <- prRemoved paired]+  where+    paired = pairByName nodeRebuildGroup rgName env++rebuildGroupPairDiff :: RebuildGroupNode -> RebuildGroupNode -> [Change]+rebuildGroupPairDiff oldGroup newGroup =+  [ breaking (rgName newGroup) "rebuild-group-membership-order" (rgName newGroup) CatalogGroupChanged "target membership or deterministic preparation order changed; abandon any active fingerprint and start a fresh rebuild"+  | (rgTargets oldGroup, rgOrder oldGroup) /= (rgTargets newGroup, rgOrder newGroup)+  ]++projectionRevisionDiff :: DiffEnv -> [Change]+projectionRevisionDiff env =+  concatMap (uncurry projectionRevisionPairDiff) (prMatched paired)+    <> [additive (prvName revision) "projection-revision" (prvName revision) DeclarationAdded "new projection revision and target-schema contract" | revision <- prAdded paired]+    <> [breaking (prvName revision) "projection-revision" (prvName revision) CatalogProjectionRevisionRemoved "projection revision removed while serving, rebuild, or read-contract evidence may still refer to it" | revision <- prRemoved paired]+  where+    paired = pairByName nodeProjectionRevision prvName env++projectionRevisionPairDiff :: ProjectionRevisionNode -> ProjectionRevisionNode -> [Change]+projectionRevisionPairDiff oldRevision newRevision = groupChange <> schemaChanges <> contractChanges+  where+    revisionName = prvName newRevision+    oldTargets = Map.fromList [(prtTarget target, target) | target <- prvTargets oldRevision]+    newTargets = Map.fromList [(prtTarget target, target) | target <- prvTargets newRevision]+    groupChange =+      [ breaking revisionName "projection-revision-group" revisionName CatalogProjectionRevisionChanged "revision rebuild group changed; persisted revision and generation identity no longer matches"+      | prvGroup oldRevision /= prvGroup newRevision+      ]+    schemaChanges =+      [ breaking revisionName "target-schema" targetName CatalogTargetSchemaChanged $+          "target schema version changed " <> prtSchemaVersion oldTarget <> " -> " <> prtSchemaVersion newTarget <> "; declare a new projection revision instead of mutating a registered one"+      | (targetName, oldTarget) <- Map.toAscList oldTargets,+        Just newTarget <- [Map.lookup targetName newTargets],+        prtSchemaVersion oldTarget /= prtSchemaVersion newTarget+      ]+    contractChanges =+      [ breaking revisionName "projection-revision-contract" revisionName CatalogProjectionRevisionChanged "target membership, provisioner, expected-shape, validator, or ordered promotion-name contract changed; declare a new revision identity"+      | Map.keysSet oldTargets /= Map.keysSet newTargets+          || any targetContractChanged (Map.toAscList oldTargets)+      ]+    targetContractChanged (targetName, oldTarget) = case Map.lookup targetName newTargets of+      Nothing -> True+      Just newTarget ->+        ( prtProvisioner oldTarget,+          prtProvisionerVersion oldTarget,+          prtExpectedShape oldTarget,+          prtValidator oldTarget,+          prtValidatorVersion oldTarget,+          prtPromotionObjects oldTarget+        )+          /= ( prtProvisioner newTarget,+               prtProvisionerVersion newTarget,+               prtExpectedShape newTarget,+               prtValidator newTarget,+               prtValidatorVersion newTarget,+               prtPromotionObjects newTarget+             )++externalReadDiff :: DiffEnv -> [Change]+externalReadDiff env =+  concatMap (uncurry (externalReadPairDiff env)) (prMatched paired)+    <> [ additive+           (externalReadNodeIdentity externalRead)+           "external-read-version"+           (erName externalRead)+           CatalogExternalReadVersionAdded+           "new external read-contract version; grant execute only after its result type and wrapper are deployed"+       | externalRead <- prAdded paired+       ]+    <> [ breaking+           (externalReadNodeIdentity externalRead)+           "external-read-retirement"+           (erName externalRead)+           CatalogExternalReadRetired+           "external read-contract version removed; preview dependencies and retire it explicitly before removing the declaration"+       | externalRead <- prRemoved paired+       ]+  where+    paired = pairByName nodeExternalRead externalReadNodeIdentity env++externalReadPairDiff :: DiffEnv -> ExternalReadNode -> ExternalReadNode -> [Change]+externalReadPairDiff env oldExternalRead newExternalRead =+  immutableChanges <> compatibilityChanges <> shapeChanges <> generationChanges+  where+    subject = externalReadNodeIdentity newExternalRead+    immutableChanges =+      [ breaking subject "external-read-contract" (erName newExternalRead) CatalogExternalReadContractChanged "query binding or public result type changed for an existing contract version; publish a new version"+      | ( erQueryModel oldExternalRead,+          erResultSchema oldExternalRead,+          erResultType oldExternalRead+        )+          /= ( erQueryModel newExternalRead,+               erResultSchema newExternalRead,+               erResultType newExternalRead+             )+      ]+    oldCompatibility = Set.fromList (erCompatibleRevisions oldExternalRead)+    newCompatibility = Set.fromList (erCompatibleRevisions newExternalRead)+    compatibilityChanges+      | oldCompatibility == newCompatibility = []+      | oldCompatibility `Set.isSubsetOf` newCompatibility =+          [ additive subject "external-read-compatibility" (erName newExternalRead) CatalogExternalReadCompatibilityChanged "compatible projection-revision set widened; deploy the higher surface generation before promoting the added revision"+          ]+      | otherwise =+          [ breaking subject "external-read-compatibility" (erName newExternalRead) CatalogExternalReadCompatibilityChanged "compatible projection-revision set narrowed or replaced for an existing contract version"+          ]+    shapeChanges =+      [ breaking subject "external-read-result-shape" (erName newExternalRead) CatalogExternalReadResultShapeChanged "checked query result shape changed for an existing contract version; restore compatibility or publish a new version"+      | externalReadShape (deOld env) oldExternalRead /= externalReadShape (deNew env) newExternalRead+      ]+    generationChanges+      | erSurfaceGeneration oldExternalRead == erSurfaceGeneration newExternalRead = []+      | erSurfaceGeneration oldExternalRead < erSurfaceGeneration newExternalRead =+          [ advisory subject "external-read-surface-generation" (erName newExternalRead) CatalogExternalReadContractChanged "surface generation increased; roll out the newer declaration before older processes can reconcile"+          ]+      | otherwise =+          [ breaking subject "external-read-surface-generation" (erName newExternalRead) CatalogExternalReadContractChanged "surface generation decreased; runtime reconciliation refuses this downgrade"+          ]+    externalReadShape spec externalRead = case [rmShape readModel | NReadModel readModel <- specNodes spec, rmName readModel == erQueryModel externalRead] of+      shape : _ -> Just shape+      [] -> Nothing++projectionOwnerDiff :: DiffEnv -> [Change]+projectionOwnerDiff env =+  concatMap (uncurry projectionOwnerPairDiff) (prMatched paired)+    <> [additive (poName owner) "projection-owner" (poName owner) DeclarationAdded "new projection owner" | owner <- prAdded paired]+    <> [breaking (poName owner) "projection-owner" (poName owner) CatalogOwnerRemoved "projection owner removed while targets and replay evidence remain" | owner <- prRemoved paired]+  where+    paired = pairByName nodeProjectionOwner poName env++projectionOwnerPairDiff :: ProjectionOwnerNode -> ProjectionOwnerNode -> [Change]+projectionOwnerPairDiff oldOwner newOwner = groupAndTargets <> orderChange <> sourceChange <> feedIdentityChange <> checkpointPolicyChange <> replayChange+  where+    ownerName = poName newOwner+    groupAndTargets =+      [ breaking ownerName "projection-owner-group-targets" ownerName CatalogOwnerChanged "rebuild group or owned target set changed"+      | (poGroup oldOwner, Set.fromList (poTargets oldOwner)) /= (poGroup newOwner, Set.fromList (poTargets newOwner))+      ]+    orderChange =+      [ advisory ownerName "projection-owner-order" ownerName CatalogHandlerOrderChanged "handler order changed; replay materialization and resume fingerprint change"+      | poOrder oldOwner /= poOrder newOwner+      ]+    sourceChange =+      [ breaking ownerName "projection-owner-sources" ownerName CatalogSourceChanged "source selection changed; historical coverage and active resume fingerprint change"+      | poSources oldOwner /= poSources newOwner+      ]+    feedIdentityChange =+      [ breaking ownerName "projection-delivery" ownerName ProjectionDeliveryChanged "projection delivery changed; handler lifecycle, cursor, and dedup identity require coordinated review"+      | poDelivery oldOwner /= poDelivery newOwner+      ]+        <> [ breaking ownerName "projection-owner-delivery-identity" ownerName CatalogFeedIdentityChanged "subscription or dedup identity changed; cursors or dedup evidence remain under the old identity"+           | (poSubscription oldOwner, poDedup oldOwner) /= (poSubscription newOwner, poDedup newOwner)+           ]+    checkpointPolicyChange =+      [ breaking ownerName "projection-owner-checkpoint-on-missing" ownerName CatalogCheckpointPolicyChanged $+          "checkpoint-on-missing changed " <> renderCheckpointOnMissing oldPolicy <> " -> " <> renderCheckpointOnMissing newPolicy <> "; the generated catalog and next absent-row startup behavior change, while persisted subscription identity and existing checkpoint rows remain unchanged"+      | [oldPolicy] <- [poCheckpointOnMissing oldOwner],+        [newPolicy] <- [poCheckpointOnMissing newOwner],+        oldPolicy /= newPolicy+      ]+    replayChange =+      [ breaking ownerName "projection-owner-replay-policy" ownerName CatalogReplayPolicyChanged "replay policy changed; abandon any active run before rebuilding under the new contract"+      | poReplay oldOwner /= poReplay newOwner+      ]++renderCheckpointOnMissing :: CheckpointOnMissingNode -> Text+renderCheckpointOnMissing CheckpointFromBeginning = "from-beginning"+renderCheckpointOnMissing CheckpointFromCurrentHead = "from-current-head"+renderCheckpointOnMissing CheckpointFail = "fail"+ addedReadModelDiff :: ReadModelNode -> [Change] addedReadModelDiff readModel =   [additive (rmName readModel) "read-model" (rmName readModel) DeclarationAdded "new read model"]@@ -1057,6 +1574,10 @@ renderFeed RmInline = "inline" renderFeed RmSubscription = "subscription" +renderFreshness :: QueryFreshnessNode -> Text+renderFreshness FreshnessImmediate = "immediate"+renderFreshness (FreshnessWaitForHead scope) = "wait-for-head " <> renderScope scope+ effectiveScope :: Maybe RmScope -> RmScope effectiveScope Nothing = RmEntireLog effectiveScope (Just scope) = scope@@ -1087,8 +1608,52 @@     ++ wireDiff oldAgg newAgg     ++ projectionDiff oldAgg newAgg     ++ guardTighteningDiff oldAgg newAgg+    ++ domainOutcomeDiff oldAgg newAgg     ++ transitionSurfaceDiff oldSpec newSpec oldAgg newAgg +-- | Typed outcomes are forward command behavior, not persisted fold behavior.+-- Pair transitions by their frozen fold canonical form so a reason-only change+-- reports precisely without also claiming replay or snapshot impact.+domainOutcomeDiff :: Aggregate -> Aggregate -> [Change]+domainOutcomeDiff oldAggregate newAggregate = declarationChange ++ transitionChanges+  where+    declarationChange =+      [ advisory+          (aggName newAggregate)+          "domain-outcome-types"+          (aggName newAggregate)+          DomainOutcomeTypesChanged+          ( "domain outcome types changed from '"+              <> renderDeclaration (aggDomainOutcomeTypes oldAggregate)+              <> "' to '"+              <> renderDeclaration (aggDomainOutcomeTypes newAggregate)+              <> "'; generated command result types and callers must be updated, while event history and snapshots remain compatible"+          )+      | canonicalDomainOutcomeTypes (aggDomainOutcomeTypes oldAggregate)+          /= canonicalDomainOutcomeTypes (aggDomainOutcomeTypes newAggregate)+      ]+    transitionChanges =+      [ advisory+          (aggName newAggregate)+          "transition-domain-outcome"+          (transitionSubject ordinal newTransition)+          DomainTransitionOutcomeChanged+          ( "domain outcome changed from '"+              <> canonicalTransitionOutcome (tOutcome oldTransition)+              <> "' to '"+              <> canonicalTransitionOutcome (tOutcome newTransition)+              <> "'; forward command behavior changes, while the selected edge, emitted events, fold, replay, and snapshots remain unchanged"+          )+      | (ordinal, newTransition) <- zip [0 :: Int ..] (aggTransitions newAggregate),+        Just oldTransition <- [find ((== canonicalTransition newTransition) . canonicalTransition) (aggTransitions oldAggregate)],+        canonicalTransitionOutcome (tOutcome oldTransition) /= canonicalTransitionOutcome (tOutcome newTransition)+      ]+    renderDeclaration declaration = case canonicalDomainOutcomeTypes declaration of+      "" -> "(disabled)"+      value -> value+    transitionSubject ordinal transition =+      tSource transition <> " -- " <> tCommand transition <> " [edge " <> T.pack (show ordinal) <> "]"+ -- | Report replay-fold evolution. Regenerated scaffold code carries the new -- fingerprint and invalidates old snapshots, so this remains advisory. transitionSurfaceDiff :: Spec -> Spec -> Aggregate -> Aggregate -> [Change]@@ -1894,13 +2459,20 @@     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)]+      | wqfType oldField /= wqfType newField = [payloadBreaking newField ("type changed " <> renderQueuePayloadType (wqfType oldField) <> " -> " <> renderQueuePayloadType (wqfType newField))]       | otherwise = []+    renderQueuePayloadType (LegacyQueueScalar scalar) = queueScalarName scalar+    renderQueuePayloadType (TypedQueueExpression expression) = typeExprCanonicalName expression     -- 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+    payloadBreaking field detail =+      withMappedConsequences+        (Set.fromList [MappedConsumerBuild consumer, MappedWorkqueueHistory (wqName newQueue)])+        (breaking (wqName newQueue) "payload-field" (wqfName field) WqPayloadFieldChanged detail)+      where+        consumer = WorkqueueConsumer (wqName newQueue)  addedWorkqueueDiff :: WorkqueueNode -> [Change] addedWorkqueueDiff queue =@@ -2440,6 +3012,10 @@         ckCode = code,         ckContext = context,         ckVector = classifyCompatibility context code,+        ckMappedPersistedImpact = case contextKind context of+          ContextQueue -> Just (MappedPersistedImpact (WorkqueueHistory (changeContextRoot context)) VBreaking)+          _ -> Nothing,+        ckMappedConsequences = Set.empty,         ckPaths = changeContextPaths context,         ckDetail = detail       }@@ -2485,7 +3061,9 @@         ReadModelVersionDecreased,         ReadModelShapeChangedWithoutBump,         ReadModelFeedChanged,-        ReadModelConsistencyWeakened+        ReadModelConsistencyWeakened,+        ProjectionDeliveryChanged,+        QueryFreshnessChanged       ]     privateCodes =       [ EvtFieldAddedWithoutBump,

src/Keiro/Dsl/DiffReport.hs view

@@ -10,16 +10,24 @@   ( Remedy (..),     DiffReport,     diffReport,+    diffReportWithSemanticImpact,+    diffReportWithCoordinationImpact,+    diffReportWithImpacts,     OwnedSite (..),     WorkspaceChange (..),     WorkspaceMeta (..),     WorkspaceDiffReport,     workspaceDiffReport,+    workspaceDiffReportWithSemanticImpact,+    workspaceDiffReportWithCoordinationImpact,+    workspaceDiffReportWithImpacts,     remediationFor,     renderRemedy,     renderFinding,     renderVectorLine,     renderExplainBlock,+    renderSemanticImpact,+    renderCoordinationImpact,     surfaceName,     parseSurfaceName,     verdictName,@@ -35,7 +43,10 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T+import Keiro.Dsl.CoordinationImpact (CoordinationImpact (..), CoordinationSeverity (..), renderCoordinationImpact) import Keiro.Dsl.Diff+import Keiro.Dsl.SemanticImpact (MappedImpactDelta (..), MappedRootEvidence (..), mappedConsequenceIdentity, mappedConsumerIdentity, mappedRootKindIdentity)+import Keiro.Dsl.TypeGraph (MappedKey (..)) import Keiro.Dsl.Validate (DiagnosticCode (..))  data Remedy@@ -55,17 +66,32 @@   | RemedyDrainLegacyInvalidContractMessages   | RemedyRescaffoldContractConsumers   | RemedyRunContractConformance+  | RemedyDrainWorkqueue+  | RemedyTransitionalQueueCodec   deriving stock (Eq, Show)  data DiffReport = DiffReport   { reportGate :: !(Set CompatibilitySurface),-    reportFindings :: ![Change]+    reportFindings :: ![Change],+    reportSemanticImpact :: !(Maybe [MappedImpactDelta]),+    reportCoordinationImpact :: !(Maybe [CoordinationImpact])   }   deriving stock (Eq, Show)  diffReport :: Set CompatibilitySurface -> [Change] -> DiffReport-diffReport = DiffReport+diffReport gate findings = DiffReport gate findings Nothing Nothing +-- | Add the append-only semantic-impact object used by current CLI reports.+-- The older smart constructor intentionally omits it for source compatibility.+diffReportWithSemanticImpact :: Set CompatibilitySurface -> [Change] -> [MappedImpactDelta] -> DiffReport+diffReportWithSemanticImpact gate findings impact = DiffReport gate findings (Just impact) Nothing++diffReportWithCoordinationImpact :: Set CompatibilitySurface -> [Change] -> [CoordinationImpact] -> DiffReport+diffReportWithCoordinationImpact gate findings impact = DiffReport gate findings Nothing (Just impact)++diffReportWithImpacts :: Set CompatibilitySurface -> [Change] -> [MappedImpactDelta] -> [CoordinationImpact] -> DiffReport+diffReportWithImpacts gate findings semantic coordination = DiffReport gate findings (Just semantic) (Just coordination)+ -- | One source location from a composed workspace's ownership index. data OwnedSite = OwnedSite   { osFile :: !FilePath,@@ -95,32 +121,84 @@ data WorkspaceDiffReport = WorkspaceDiffReport   { workspaceReportMeta :: !WorkspaceMeta,     workspaceReportGate :: !(Set CompatibilitySurface),-    workspaceReportFindings :: ![WorkspaceChange]+    workspaceReportFindings :: ![WorkspaceChange],+    workspaceReportSemanticImpact :: !(Maybe [MappedImpactDelta]),+    workspaceReportCoordinationImpact :: !(Maybe [CoordinationImpact])   }   deriving stock (Eq, Show)  workspaceDiffReport :: WorkspaceMeta -> Set CompatibilitySurface -> [WorkspaceChange] -> WorkspaceDiffReport-workspaceDiffReport = WorkspaceDiffReport+workspaceDiffReport meta gate findings = WorkspaceDiffReport meta gate findings Nothing Nothing +workspaceDiffReportWithSemanticImpact :: WorkspaceMeta -> Set CompatibilitySurface -> [WorkspaceChange] -> [MappedImpactDelta] -> WorkspaceDiffReport+workspaceDiffReportWithSemanticImpact meta gate findings impact = WorkspaceDiffReport meta gate findings (Just impact) Nothing++workspaceDiffReportWithCoordinationImpact :: WorkspaceMeta -> Set CompatibilitySurface -> [WorkspaceChange] -> [CoordinationImpact] -> WorkspaceDiffReport+workspaceDiffReportWithCoordinationImpact meta gate findings impact = WorkspaceDiffReport meta gate findings Nothing (Just impact)++workspaceDiffReportWithImpacts :: WorkspaceMeta -> Set CompatibilitySurface -> [WorkspaceChange] -> [MappedImpactDelta] -> [CoordinationImpact] -> WorkspaceDiffReport+workspaceDiffReportWithImpacts meta gate findings semantic coordination = WorkspaceDiffReport meta gate findings (Just semantic) (Just coordination)+ instance ToJSON DiffReport where   toJSON report =-    object+    object $       [ "schema" .= ("keiro-dsl/diff-report/1" :: Text),         "gate" .= map surfaceName (Set.toAscList (reportGate report)),-        "breaking" .= any (gatedBreaking (reportGate report)) (reportFindings report),+        "breaking" .= (any (gatedBreaking (reportGate report)) (reportFindings report) || coordinationBreaking (reportCoordinationImpact report)),         "findings" .= map (findingValue (reportGate report)) (reportFindings report)       ]+        <> ["semanticImpact" .= semanticImpactValue impact | Just impact <- [reportSemanticImpact report]]+        <> ["coordinationImpact" .= impact | Just impact <- [reportCoordinationImpact report]]  instance ToJSON WorkspaceDiffReport where   toJSON report =-    object+    object $       [ "schema" .= ("keiro-dsl/diff-report/1" :: Text),         "gate" .= map surfaceName (Set.toAscList (workspaceReportGate report)),-        "breaking" .= any (gatedBreaking (workspaceReportGate report) . wcChange) (workspaceReportFindings report),+        "breaking" .= (any (gatedBreaking (workspaceReportGate report) . wcChange) (workspaceReportFindings report) || coordinationBreaking (workspaceReportCoordinationImpact report)),         "findings" .= map (workspaceFindingValue (workspaceReportGate report)) (workspaceReportFindings report),         "workspace" .= workspaceMetaValue (workspaceReportMeta report)       ]+        <> ["semanticImpact" .= semanticImpactValue impact | Just impact <- [workspaceReportSemanticImpact report]]+        <> ["coordinationImpact" .= impact | Just impact <- [workspaceReportCoordinationImpact report]] +semanticImpactValue :: [MappedImpactDelta] -> Value+semanticImpactValue impact = object ["declarations" .= impact]++coordinationBreaking :: Maybe [CoordinationImpact] -> Bool+coordinationBreaking = maybe False (any ((== CoordinationBreaking) . coordinationSeverity))++-- | Human-facing semantic dependency summary, kept separate from ordinary+-- compatibility findings and generated-file evidence.+renderSemanticImpact :: [MappedImpactDelta] -> [Text]+renderSemanticImpact [] = []+renderSemanticImpact impact = "semantic impact:" : concatMap renderDelta impact+  where+    renderDelta delta =+      [ "  " <> unMappedKey (impactDeclaration delta),+        "    previous aggregate consumers: " <> renderBaseline (impactPreviousEvidence delta) (renderConsumers (impactPreviousConsumers delta)),+        "    current aggregate consumers:  " <> renderConsumers (impactCurrentConsumers delta),+        "    previous roots: " <> maybe "baseline unavailable" renderEvidence (impactPreviousEvidence delta),+        "    current roots:  " <> maybe "baseline unavailable" renderEvidence (impactCurrentEvidence delta),+        "    previous consequences: " <> maybe "baseline unavailable" renderConsequences (impactPreviousConsequences delta),+        "    current consequences:  " <> maybe "baseline unavailable" renderConsequences (impactCurrentConsequences delta),+        "    service-conformance: " <> if impactServiceConformance delta then "impacted" else "unchanged"+      ]+    renderConsumers aggregateConsumers = case map consumerName (Set.toAscList aggregateConsumers) of+      [] -> "(none)"+      names -> T.intercalate ", " names+    consumerName = mappedConsumerIdentity+    renderBaseline Nothing _ = "baseline unavailable"+    renderBaseline (Just _) value = value+    renderEvidence values = renderSet renderRoot values+    renderRoot evidence =+      T.intercalate "|" [mappedRootKindIdentity (evidenceRootKind evidence), mappedConsumerIdentity (evidenceConsumer evidence), evidencePath evidence]+        <> maybe "" ("|" <>) (evidenceOperation evidence)+    renderConsequences = renderSet mappedConsequenceIdentity+    renderSet render values = case map render (Set.toAscList values) of+      [] -> "(none)"+      rendered -> T.intercalate ", " rendered+ findingValue :: Set CompatibilitySurface -> Change -> Value findingValue gate change = object (findingPairs gate change) @@ -144,6 +222,8 @@     "detail" .= ckDetail kind,     "remedies" .= map renderRemedy (NonEmpty.toList (remediationFor (ckContext kind) (ckCode kind)))   ]+    <> ["mappedPersistedSurface" .= mappedPersistedImpactValue impact | Just impact <- [ckMappedPersistedImpact kind]]+    <> ["mappedConsequences" .= map mappedConsequenceIdentity (Set.toAscList (ckMappedConsequences kind)) | not (Set.null (ckMappedConsequences kind))]   where     kind = changeKind change @@ -157,6 +237,18 @@         <> maybe [] (\owned -> ["file" .= osFile owned, "line" .= osLine owned]) site     ) +mappedPersistedImpactValue :: MappedPersistedImpact -> Value+mappedPersistedImpactValue impact =+  object+    [ "surface" .= persistedSurfaceName (mappedPersistedSurface impact),+      "verdict" .= verdictName (mappedPersistedVerdict impact)+    ]++persistedSurfaceName :: MappedPersistedSurface -> Text+persistedSurfaceName PrivateEventHistory = "private-event-history"+persistedSurfaceName SnapshotCache = "snapshot-cache"+persistedSurfaceName (WorkqueueHistory name) = "workqueue-history:" <> name+ workspaceMetaValue :: WorkspaceMeta -> Value workspaceMetaValue meta =   object@@ -196,6 +288,9 @@              RemedyRescaffoldContractConsumers,              RemedyRunContractConformance            ]+  | code == CatalogCheckpointPolicyChanged =+      RemedyDeploymentOrder RolloutStopTheWorld+        :| [RemedyRescaffoldGenerated, RemedyRecompileConsumers, RemedyRunConformance]   | code `elem` mappedWireCodes = mappedWireRemedy   | code `elem` [MappedFieldAddedWithDefault, MappedArmAdded, MappedEnumValueAdded] = mappedAdditionRemedy   | code `elem` [MappedHaskellSourceChanged, MappedRecordConstructorChanged] =@@ -210,7 +305,7 @@   | code `elem` contractCodes =       RemedyContractRevision :| [RemedyDeploymentOrder RolloutProducerLast]   | code `elem` queueCodes =-      RemedyDeploymentOrder RolloutWorkersFirst :| [RemedyRunConformance]+      RemedyDeploymentOrder RolloutWorkersFirst :| [RemedyDrainWorkqueue, RemedyTransitionalQueueCodec, RemedyRunConformance]   | code `elem` identityCodes =       RemedyDoNotDeploy "revert the re-keying change or perform an explicit operational identity migration" :| []   | code == EnumCtorAdded = case Set.toAscList (cvRollout vector) of@@ -230,17 +325,23 @@       | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump       | otherwise = RemedyRunConformance     mappedWireRemedy+      | Set.member RolloutDrainRequired (cvRollout vector) = queueMappedRemedy       | cvPrivateHistoryRead vector == VBreaking =           RemedyVersionBump :| [RemedyUpcaster, RemedyDeploymentOrder RolloutStopTheWorld]       | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance]       | otherwise = RemedyRecompileConsumers :| [RemedyRunConformance]     mappedAdditionRemedy       | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance]+      | Set.member RolloutDrainRequired (cvRollout vector) = queueMappedRemedy       | Just rollout <- firstRollout = RemedyDeploymentOrder rollout :| [RemedyRunConformance]       | otherwise = RemedyRunConformance :| []     mappedConformanceRemedy       | cvSnapshotHydration vector == VAdvisory = RemedyRunConformance :| [RemedyStateCodecBump]+      | Set.member RolloutDrainRequired (cvRollout vector) = queueMappedRemedy       | otherwise = RemedyRunConformance :| []+    queueMappedRemedy =+      RemedyDeploymentOrder RolloutWorkersFirst+        :| [RemedyDrainWorkqueue, RemedyTransitionalQueueCodec, RemedyRecompileConsumers, RemedyRunConformance]     mappedSnapshotConformanceRemedy       | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance]       | otherwise = RemedyRunConformance :| []@@ -322,13 +423,15 @@   RemedyDrainLegacyInvalidContractMessages -> "drain or remediate legacy-invalid in-flight messages"   RemedyRescaffoldContractConsumers -> "re-scaffold and recompile every affected consumer against the generated interface"   RemedyRunContractConformance -> "run contract conformance"+  RemedyDrainWorkqueue -> "drain incompatible queued jobs before deployment"+  RemedyTransitionalQueueCodec -> "supply an application-owned transitional queue codec when draining is impossible"  renderFinding :: Change -> Text renderFinding change =   headline-    <> if vectorIsUniform (ckVector kind)-      then ""-      else "\n" <> renderVectorLine (ckVector kind)+    <> vectorDetail+    <> persistedDetail+    <> consequenceDetail   where     kind = changeKind change     headline =@@ -342,6 +445,21 @@         <> ": "         <> ckDetail kind         <> codeSuffix change kind+    vectorDetail+      | vectorIsUniform (ckVector kind) = ""+      | otherwise = "\n" <> renderVectorLine (ckVector kind)+    persistedDetail = case ckMappedPersistedImpact kind of+      Nothing -> ""+      Just impact ->+        "\n    mapped-persisted-surface: "+          <> persistedSurfaceName (mappedPersistedSurface impact)+          <> "="+          <> verdictName (mappedPersistedVerdict impact)+    consequenceDetail+      | Set.null (ckMappedConsequences kind) = ""+      | otherwise =+          "\n    mapped-consequences: "+            <> T.intercalate ", " (map mappedConsequenceIdentity (Set.toAscList (ckMappedConsequences kind)))  renderVectorLine :: CompatibilityVector -> Text renderVectorLine vector =

src/Keiro/Dsl/EventOutput.hs view

@@ -13,16 +13,20 @@     EventOutputMapping (..),     EventOutputError (..),     eventOutputMapping,+    eventOutputMappingFromGraph,+    eventOutputMappingFromGraphResult,     eventOutputCanonical,   ) where  import Data.List (find)+import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.AggregateType import Keiro.Dsl.Grammar import Keiro.Dsl.PrettyPrint (renderExpr)+import Keiro.Dsl.TypeGraph (TypeGraph, TypeGraphError, resolveTypeGraph)  -- | One field in a checked identity copy.  The selector and current wire name -- are retained separately so a future aggregate-field alias can change the wire@@ -65,7 +69,13 @@ -- only for a transition consuming that exact command.  Explicit event fields -- remain hand-owned even when their names happen to match command fields. eventOutputMapping :: Spec -> Aggregate -> Transition -> Int -> Name -> Either EventOutputError EventOutputMapping-eventOutputMapping spec aggregate transition emitIndex eventName = do+eventOutputMapping spec = eventOutputMappingFromGraphResult (resolveTypeGraph spec) spec++eventOutputMappingFromGraph :: TypeGraph -> Spec -> Aggregate -> Transition -> Int -> Name -> Either EventOutputError EventOutputMapping+eventOutputMappingFromGraph graph = eventOutputMappingFromGraphResult (Right graph)++eventOutputMappingFromGraphResult :: Either (NonEmpty TypeGraphError) TypeGraph -> Spec -> Aggregate -> Transition -> Int -> Name -> Either EventOutputError EventOutputMapping+eventOutputMappingFromGraphResult typeGraphResult spec aggregate transition emitIndex eventName = do   event <- maybe (Left (OutputEventMissing eventName)) Right (find ((== eventName) . evName) (aggEvents aggregate))   case (tImplementation transition, evBody event) of     (LegacyHoleImplementation, _) -> pure handOwned@@ -87,7 +97,7 @@                 outputFields = fields               }   where-    symbols = aggregateSymbols spec+    symbols = aggregateSymbolsFromGraphResult typeGraphResult spec     handOwned =       HandOwnedEventOutput         { outputObligation =

src/Keiro/Dsl/ExplainBindings.hs view

@@ -26,9 +26,8 @@ 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-import Keiro.Dsl.SemanticContract (CheckedService (..), effectiveLanguageContract)+import Keiro.Dsl.SemanticContract (CheckedService, checkedLanguageContract, checkedSpec, checkedTypeGraph, legacyCheckedService) import Keiro.Dsl.TypeGraph  data BindingResolutionError@@ -137,11 +136,11 @@           <*> value .: "signature"  bindingObligations :: Spec -> Either (NonEmpty BindingResolutionError) [BindingObligation]-bindingObligations spec = bindingObligationsForService (CheckedService (effectiveLanguageContract LegacyUnversioned) spec)+bindingObligations = bindingObligationsForService . legacyCheckedService  bindingObligationsForService :: CheckedService -> Either (NonEmpty BindingResolutionError) [BindingObligation] bindingObligationsForService service = do-  graph <- first (fmap BindingTypeGraphError) (resolveTypeGraph spec)+  graph <- first (fmap BindingTypeGraphError) (checkedTypeGraph service)   nominalRegistry <- first (fmap BindingNominalTypeError) (resolveNominalTypes spec)   pure . sortOn obligationSortKey $     concat@@ -153,11 +152,11 @@     spec = checkedSpec service  bindingHoles :: Spec -> Either (NonEmpty BindingResolutionError) [BindingHole]-bindingHoles spec = bindingHolesForService (CheckedService (effectiveLanguageContract LegacyUnversioned) spec)+bindingHoles = bindingHolesForService . legacyCheckedService  bindingHolesForService :: CheckedService -> Either (NonEmpty BindingResolutionError) [BindingHole] bindingHolesForService service = do-  graph <- first (fmap BindingTypeGraphError) (resolveTypeGraph spec)+  graph <- first (fmap BindingTypeGraphError) (checkedTypeGraph service)   obligations <- bindingObligationsForService service   pure . sortOn holeSortKey $     concat@@ -175,8 +174,6 @@          | obligation <- obligations,            obligationCategory obligation /= "structural"          ]-  where-    spec = checkedSpec service  holesFor :: TypeGraph -> StructuralDecl -> ResolvedMappedShape -> [BindingObligation] -> [BindingHole] holesFor _graph declaration shape obligations = bindingEntries <> auxiliaryEntries

src/Keiro/Dsl/Expression.hs view

@@ -10,6 +10,9 @@ module Keiro.Dsl.Expression   ( ExpressionEnvironment,     expressionEnvironment,+    expressionEnvironmentFromGraph,+    expressionEnvironmentFromGraphResult,+    expressionEnvironmentWith,     ExpectedScalarType (..),     ScalarRootProvenance (..),     ResolvedScalarProjection (..),@@ -47,13 +50,28 @@   }  expressionEnvironment :: Spec -> Aggregate -> Transition -> ExpressionEnvironment-expressionEnvironment spec aggregate transition =+expressionEnvironment spec = expressionEnvironmentFromGraphResult (resolveTypeGraph spec) spec++expressionEnvironmentFromGraph :: TypeGraph -> Spec -> Aggregate -> Transition -> ExpressionEnvironment+expressionEnvironmentFromGraph graph = expressionEnvironmentFromGraphResult (Right graph)++expressionEnvironmentFromGraphResult :: Either (NonEmpty TypeGraphError) TypeGraph -> Spec -> Aggregate -> Transition -> ExpressionEnvironment+expressionEnvironmentFromGraphResult typeGraphResult spec aggregate transition =+  expressionEnvironmentWith+    (aggregateSymbolsFromGraphResult typeGraphResult spec)+    (either (const Nothing) Just typeGraphResult)+    spec+    aggregate+    transition++expressionEnvironmentWith :: AggregateSymbols -> Maybe TypeGraph -> Spec -> Aggregate -> Transition -> ExpressionEnvironment+expressionEnvironmentWith symbols graph spec aggregate transition =   ExpressionEnvironment     { environmentSpec = spec,       environmentAggregate = aggregate,       environmentTransition = transition,-      environmentSymbols = aggregateSymbols spec,-      environmentTypeGraph = either (const Nothing) Just (resolveTypeGraph spec)+      environmentSymbols = symbols,+      environmentTypeGraph = graph     }  data ExpectedScalarType

src/Keiro/Dsl/FoldFingerprint.hs view

@@ -24,7 +24,7 @@ import Keiro.Dsl.Grammar import Keiro.Dsl.LanguageVersion (RuntimeCapability (NominalEqualityV2), runtimeProfileHasCapability) import Keiro.Dsl.NominalType-import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveRuntimeProfile, runtimeSemanticsFingerprintSegments)+import Keiro.Dsl.SemanticContract (CheckedService, EffectiveLanguageContract, checkedLanguageContract, checkedSpec, checkedTypeGraph, effectiveRuntimeProfile, runtimeSemanticsFingerprintSegments) import Keiro.Dsl.TypeGraph  -- | A checked service can retain language provenance before semantic@@ -69,11 +69,12 @@ -- source declaration provenance and grammar-only versions never enter it. aggregateFoldSurfaceForService :: CheckedService -> Aggregate -> Either FoldSurfaceError Text aggregateFoldSurfaceForService service aggregate = do-  graph <- mapLeft (FoldTypeGraphResolutionFailed . showText) (resolveTypeGraph spec)+  graph <- mapLeft (FoldTypeGraphResolutionFailed . showText) (checkedTypeGraph service)+  let symbols = aggregateSymbolsFromGraph graph spec   nominalRegistry <- mapLeft (FoldNominalResolutionFailed . showText) (resolveNominalTypes spec)   registerSegments <- traverse (registerSegment symbols) (aggRegs aggregate)-  equalityUses <- nominalEqualityUses service aggregate-  transitionSegments <- traverse (transitionSegment spec aggregate) (aggTransitions aggregate)+  equalityUses <- nominalEqualityUses graph service aggregate+  transitionSegments <- traverse (transitionSegment graph spec aggregate) (aggTransitions aggregate)   pure     ( T.intercalate         "\n"@@ -89,7 +90,6 @@     )   where     spec = checkedSpec service-    symbols = aggregateSymbols spec     referencedRules =       [ rule       | rule <- specRules spec,@@ -112,8 +112,8 @@ -- actually compares that declaration. This keeps unrelated binding metadata out -- of replay compatibility while ensuring a witness/domain change cannot silently -- retain the old fold fingerprint.-nominalEqualityUses :: CheckedService -> Aggregate -> Either FoldSurfaceError (Set Text)-nominalEqualityUses service aggregate =+nominalEqualityUses :: TypeGraph -> CheckedService -> Aggregate -> Either FoldSurfaceError (Set Text)+nominalEqualityUses graph service aggregate =   if runtimeProfileHasCapability (effectiveRuntimeProfile (checkedLanguageContract service)) NominalEqualityV2     then fmap (Set.fromList . concat) (traverse transitionIdentities (aggTransitions aggregate))     else@@ -122,7 +122,7 @@             [ identity             | transition <- aggTransitions aggregate,               guardSyntax <- maybeToList (tGuard transition),-              Right guardExpression <- [resolveGuardExpr (expressionEnvironment spec aggregate transition) guardSyntax],+              Right guardExpression <- [resolveGuardExpr (expressionEnvironmentFromGraph graph spec aggregate transition) guardSyntax],               identity <- equalityIdentities (checkedLanguageContract service) guardExpression             ]         )@@ -134,7 +134,7 @@         guardExpression <-           mapLeft             (FoldGuardResolutionFailed (aggName aggregate) (tCommand transition) . showText)-            (resolveGuardExpr (expressionEnvironment spec aggregate transition) guardSyntax)+            (resolveGuardExpr (expressionEnvironmentFromGraph graph spec aggregate transition) guardSyntax)         pure (equalityIdentities (checkedLanguageContract service) guardExpression)  equalityIdentities :: EffectiveLanguageContract -> TypedScalarExpr -> [Text]@@ -248,8 +248,8 @@         <> registerInitialCanonicalName resolvedInitial     ) -transitionSegment :: Spec -> Aggregate -> Transition -> Either FoldSurfaceError Text-transitionSegment spec aggregate transition = do+transitionSegment :: TypeGraph -> Spec -> Aggregate -> Transition -> Either FoldSurfaceError Text+transitionSegment graph spec aggregate transition = do   outputOwnershipSegment <- case tImplementation transition of     LegacyHoleImplementation -> Right []     GeneratedImplementation -> fmap (pure . ("outputs=" <>) . T.intercalate ",") outputSegments@@ -277,7 +277,7 @@       mapping <-         mapLeft           (FoldEventOutputResolutionFailed (aggName aggregate) (tCommand transition) eventName . showText)-          (eventOutputMapping spec aggregate transition emitIndex eventName)+          (eventOutputMappingFromGraph graph spec aggregate transition emitIndex eventName)       pure (eventName <> "=" <> eventOutputCanonical mapping)     implementationSegment = case tImplementation transition of       LegacyHoleImplementation -> []

src/Keiro/Dsl/Frontend.hs view

@@ -34,6 +34,7 @@     renderLoweringFailure,     frontendFailureFromLowering,     parseSurfaceSource,+    lowerSurfaceDocument,     lowerSurfaceSource,   ) where

src/Keiro/Dsl/Frontend/Internal.hs view

@@ -18,6 +18,7 @@     LoweringFailureCode (..),     LoweringFailure (..),     renderLoweringFailure,+    lowerSurfaceDocument,     lowerSurfaceSource,   ) where@@ -46,6 +47,7 @@     sourceLanguageErrorCodeText,   ) import Keiro.Dsl.Source+import Keiro.Dsl.SourceIndex import Keiro.Dsl.Syntax import Prelude hiding (span) @@ -136,6 +138,7 @@   = InvalidSourceSpan   | SourceNameMismatch   | SurfaceOrderInvalid+  | SemanticSourceIndexInvalid !SourceIndexFailureCode   deriving stock (Eq, Ord, Show, Generic)  -- | A failure found while converting surface evidence to the semantic graph.@@ -175,8 +178,29 @@       compatibility = BodyGrammarFailure (renderLoweringFailure failure)     } --- | Remove document order and exact locations while projecting each top-level--- span's starting line into the compatibility 'Loc'.+-- | Lower semantic data and retain a checked exact source index beside it.+lowerSurfaceDocument :: SurfaceSource -> Either LoweringFailure ParsedSourceDocument+lowerSurfaceDocument surfaceSource@SurfaceSource {spec = locatedSpec} = do+  parsedSource <- lowerSurfaceSource surfaceSource+  let fallbackSpan = case locatedSpec of Located {span = sourceSpan} -> sourceSpan+  sourceIndex <-+    either+      (Left . sourceIndexLoweringFailure fallbackSpan)+      Right+      ( exactSemanticSourceIndex+          (case surfaceSource of SurfaceSource {source} -> source)+          (semanticSourceSubjects (parsedSpec parsedSource))+          (surfaceSourceEntries surfaceSource)+      )+  pure+    ParsedSourceDocument+      { documentParsedSource = parsedSource,+        documentSourceIndex = sourceIndex+      }++-- | Compatibility lowering for syntax-valid semantic graphs, including graphs+-- whose duplicate names make an exact semantic index ambiguous. Production+-- source-aware paths use 'lowerSurfaceDocument'. lowerSurfaceSource :: SurfaceSource -> Either LoweringFailure ParsedSource lowerSurfaceSource surfaceSource@SurfaceSource {language, spec = locatedSpec} = do   validateSurfaceSource surfaceSource@@ -186,6 +210,26 @@         parsedSpec = lowerSpec locatedSpec       } +surfaceSourceEntries :: SurfaceSource -> [(SourceSubject, SourceSpan)]+surfaceSourceEntries SurfaceSource {spec = Located {value = SurfaceSpec {elements}}} =+  concatMap sourceEntry elements+  where+    sourceEntry Located {span = sourceSpan, value = surfaceElement} = case surfaceElement of+      SurfaceAggregateState aggregateName stateName ->+        [(AggregateStateSubject aggregateName stateName, sourceSpan)]+      SurfaceAggregateTransition aggregateName ordinal ->+        [(AggregateTransitionSubject aggregateName (TransitionOrdinal ordinal), sourceSpan)]+      SurfaceField {} -> []+      SurfaceExpression {} -> []++sourceIndexLoweringFailure :: SourceSpan -> SourceIndexFailure -> LoweringFailure+sourceIndexLoweringFailure fallback SourceIndexFailure {failureCode = indexCode, failureSpan, failureMessage} =+  LoweringFailure+    { code = SemanticSourceIndexInvalid indexCode,+      span = maybe fallback id failureSpan,+      message = failureMessage+    }+ lowerSpec :: Located SurfaceSpec -> Spec lowerSpec   Located@@ -231,6 +275,11 @@   NWorkqueue value -> NWorkqueue value {wqLoc = loc}   NPgmqDispatch value -> NPgmqDispatch value {pdLoc = loc}   NReadModel value -> NReadModel value {rmLoc = loc}+  NProjectionTarget value -> NProjectionTarget value {ptLoc = loc}+  NRebuildGroup value -> NRebuildGroup value {rgLoc = loc}+  NProjectionRevision value -> NProjectionRevision value {prvLoc = loc}+  NExternalRead value -> NExternalRead value {erLoc = loc}+  NProjectionOwner value -> NProjectionOwner value {poLoc = loc}   NWorkflow     WorkflowNode       { wfId,

src/Keiro/Dsl/Grammar.hs view

@@ -52,6 +52,9 @@     Event (..),     EventBody (..),     Hole (..),+    DomainOutcomeTypes (..),+    TransitionOutcome (..),+    transitionOutcomeLoc,     Transition (..),     TransitionImplementation (..),     TransitionMode (..),@@ -83,6 +86,8 @@     ProcessNode (..),      -- * The router node (EP-108)+    RouterSelectionDecl (..),+    SelectionDispositionSyntax (..),     ResolveSource (..),     ResolveDecl (..),     RouterDispatchNode (..),@@ -111,6 +116,9 @@     PublisherNode (..),      -- * The pgmq workqueue/dispatch nodes (EP-5)+    QueueScalar (..),+    queueScalarName,+    QueuePayloadType (..),     WqField (..),     WqDispRow (..),     WqOrdering (..),@@ -123,8 +131,31 @@     RmColumn (..),     RmFeed (..),     RmScope (..),+    ProjectionDelivery (..),+    QueryFreshnessNode (..),+    ReadModelSupply (..),+    legacyReadModelConsistency,+    legacyReadModelScope,+    legacyReadModelFeed,+    legacyReadModelSubscription,+    ReadModelQueryTypes (..),     ReadModelNode (..), +    -- * Projection catalog nodes (language 5)+    TargetResetPolicy (..),+    ProjectionTargetNode (..),+    RebuildGroupNode (..),+    PromotionObjectKindNode (..),+    PromotionObjectNode (..),+    RevisionTargetNode (..),+    ProjectionRevisionNode (..),+    ExternalReadNode (..),+    externalReadNodeIdentity,+    CatalogSource (..),+    CheckpointOnMissingNode (..),+    ProjectionReplayPolicy (..),+    ProjectionOwnerNode (..),+     -- * The workflow/operation nodes (EP-6)     WfBodyItem (..),     WorkflowNode (..),@@ -140,7 +171,9 @@ where  import Data.Text (Text)+import Data.Text qualified as T import GHC.Generics (Generic)+import Numeric.Natural (Natural)  -- | An identifier in the notation: a type name, register name, command/event -- name, state name, enum constructor, etc. Always a non-empty 'Text'.@@ -525,6 +558,29 @@ data Hole = Hole | Filled !Text   deriving stock (Eq, Show, Generic) +-- | The aggregate-wide result types used by typed domain decisions. The+-- declaration is opt-in so published sources without it retain their existing+-- command surface.+data DomainOutcomeTypes = DomainOutcomeTypes+  { rejectionType :: !Name,+    noOpType :: !Name,+    outcomeTypesLoc :: !Loc+  }+  deriving stock (Eq, Show, Generic)++-- | The result attached to one live transition. Rejection and no-op reasons+-- use the same typed scalar expression language as guards and register writes.+data TransitionOutcome+  = OutcomeAccepted !Loc+  | OutcomeRejected !Expr !Loc+  | OutcomeNoOp !Expr !Loc+  deriving stock (Eq, Show, Generic)++transitionOutcomeLoc :: TransitionOutcome -> Loc+transitionOutcomeLoc (OutcomeAccepted loc) = loc+transitionOutcomeLoc (OutcomeRejected _ loc) = loc+transitionOutcomeLoc (OutcomeNoOp _ loc) = loc+ -- | A transition @Src -- Command --> clauses@. Clauses may be written -- indentation-stacked or @;@-separated on one line. data Transition = Transition@@ -534,6 +590,10 @@     tGuard :: !(Maybe Expr),     tWrites :: ![(Name, Expr)],     tEmits :: ![Name],+    tOutcome :: !(Maybe TransitionOutcome),+    -- | Locations of clauses after the first. Invalid syntax is retained long+    -- enough for semantic validation to emit stable located diagnostics.+    tOutcomeDuplicateLocs :: ![Loc],     tGoto :: !Name,     tMode :: !TransitionMode,     tLoc :: !Loc@@ -606,6 +666,10 @@     aggCommands :: ![Command],     aggEvents :: ![Event],     aggTransitions :: ![Transition],+    aggDomainOutcomeTypes :: !(Maybe DomainOutcomeTypes),+    -- | Locations of declarations after the first; see+    -- 'tOutcomeDuplicateLocs'.+    aggDomainOutcomeDuplicateLocs :: ![Loc],     aggWire :: !(Maybe WireSpec),     aggProjection :: !(Maybe ProjectionSpec),     aggSnapshot :: !(Maybe SnapshotSpec),@@ -628,7 +692,9 @@ -- event shape (one field must be a @:Time@ field used by the timer deadline). data InputDecl = InputDecl   { inName :: !Name,-    inFields :: ![Field]+    inFields :: ![Field],+    inType :: !(Maybe TypeExpr),+    inLoc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -775,9 +841,50 @@  -- EP-108: stateless, effectful content-based routing. -data ResolveSource = ResolveReadModel !Name | ResolveHole+data SelectionDispositionSyntax+  = SelectionAck+  | SelectionRetry+  | SelectionDeadLetter+  | SelectionHalt+  deriving stock (Eq, Ord, Show, Generic)++-- | Candidate language-5 syntax for a bounded, generated router selection.+-- Policy spellings that are not yet admitted remain raw names so validation,+-- rather than parsing, owns stable diagnostics for future-looking values.+data RouterSelectionDecl = RouterSelectionDecl+  { rsIdentity :: !Text,+    rsIdentityLoc :: !Loc,+    rsVersion :: !Natural,+    rsVersionLoc :: !Loc,+    rsQuery :: !Name,+    rsQueryLoc :: !Loc,+    rsQueryInput :: !Name,+    rsQueryInputLoc :: !Loc,+    rsPredicate :: !Expr,+    rsRecipient :: !Expr,+    rsLimit :: !(Maybe (Natural, Loc)),+    rsOrder :: !Name,+    rsOrderLoc :: !Loc,+    rsDedupe :: !Name,+    rsDedupeLoc :: !Loc,+    rsEmptyPolicy :: !SelectionDispositionSyntax,+    rsEmptyPolicyLoc :: !Loc,+    rsFailurePolicy :: !SelectionDispositionSyntax,+    rsFailurePolicyLoc :: !Loc,+    rsRedelivery :: !Name,+    rsRedeliveryLoc :: !Loc,+    rsPartial :: !Name,+    rsPartialLoc :: !Loc,+    rsLoc :: !Loc+  }   deriving stock (Eq, Show, Generic) +data ResolveSource+  = ResolveReadModel !Name+  | ResolveHole+  | ResolveDeclarative !RouterSelectionDecl+  deriving stock (Eq, Show, Generic)+ data ResolveDecl = ResolveDecl   { rvSource :: !ResolveSource,     rvRow :: ![Name],@@ -972,11 +1079,34 @@  -- EP-5: the pgmq @workqueue@ + @dispatch@ nodes. +-- | The legacy lower-case workqueue scalar vocabulary. These constructors+-- retain the released generated JSON meaning of @text@, @int@, and @bool@.+data QueueScalar+  = QueueText+  | QueueInt+  | QueueBool+  | QueueOther !Name+  deriving stock (Eq, Show, Generic)++queueScalarName :: QueueScalar -> Name+queueScalarName QueueText = "text"+queueScalarName QueueInt = "int"+queueScalarName QueueBool = "bool"+queueScalarName (QueueOther name) = name++-- | A workqueue field either retains its released scalar spelling or owns a+-- complete candidate-language mapped type expression.+data QueuePayloadType+  = LegacyQueueScalar !QueueScalar+  | TypedQueueExpression !TypeExpr+  deriving stock (Eq, Show, Generic)+ -- | One @field -> \"wire_name\" type required@ row of a workqueue payload. data WqField = WqField   { wqfName :: !Name,     wqfWire :: !Text,-    wqfType :: !Name+    wqfType :: !QueuePayloadType,+    wqfLoc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -1065,6 +1195,41 @@ data RmScope = RmEntireLog | RmCategory !Text   deriving stock (Eq, Show, Generic) +-- | When a projection owner applies events to its targets.+data ProjectionDelivery+  = DeliveryInline+  | DeliverySubscription+  deriving stock (Eq, Ord, Show, Generic)++-- | What, if anything, a query waits for before reading its target.+data QueryFreshnessNode+  = FreshnessImmediate+  | FreshnessWaitForHead !RmScope+  deriving stock (Eq, Show, Generic)++-- | How a read model finds its projection supply. Released Languages 1-4 keep+-- their original clauses here as source provenance; candidate Language 5+-- derives delivery and cursor identity from the validated projection owner.+data ReadModelSupply+  = LegacyReadModelSupply+      { legacyConsistency :: !Consistency,+        legacyScope :: !(Maybe RmScope),+        legacyFeed :: !RmFeed,+        legacySubscription :: !(Maybe Text)+      }+  | OwnerDerivedSupply+  deriving stock (Eq, Show, Generic)++-- | The two type parameters of the generated @ReadModel q r@ API. The pair is+-- atomic because accepting only one side could not be lowered completely.+data ReadModelQueryTypes = ReadModelQueryTypes+  { input :: !TypeExpr,+    result :: !TypeExpr,+    inputLoc :: !Loc,+    resultLoc :: !Loc+  }+  deriving stock (Eq, Show, Generic)+ -- | A registered, versioned SQL read model. Columns define its shape identity; -- the runtime table remains owned by codd migrations rather than the DSL. data ReadModelNode = ReadModelNode@@ -1074,14 +1239,156 @@     rmColumns :: ![RmColumn],     rmVersion :: !Int,     rmShape :: !Text,-    rmConsistency :: !Consistency,-    rmScope :: !(Maybe RmScope),-    rmFeed :: !RmFeed,-    rmSubscription :: !(Maybe Text),+    rmFreshness :: !QueryFreshnessNode,+    rmSupply :: !ReadModelSupply,+    rmGroup :: !(Maybe Name),+    rmObservedTargets :: ![Name],+    rmBackingTarget :: !(Maybe Name),+    queryTypes :: !(Maybe ReadModelQueryTypes),     rmLoc :: !Loc   }   deriving stock (Eq, Show, Generic) +legacyReadModelConsistency :: ReadModelNode -> Maybe Consistency+legacyReadModelConsistency readModel = case rmSupply readModel of+  LegacyReadModelSupply {legacyConsistency} -> Just legacyConsistency+  OwnerDerivedSupply -> Nothing++legacyReadModelScope :: ReadModelNode -> Maybe RmScope+legacyReadModelScope readModel = case rmSupply readModel of+  LegacyReadModelSupply {legacyScope} -> legacyScope+  OwnerDerivedSupply -> Nothing++legacyReadModelFeed :: ReadModelNode -> Maybe RmFeed+legacyReadModelFeed readModel = case rmSupply readModel of+  LegacyReadModelSupply {legacyFeed} -> Just legacyFeed+  OwnerDerivedSupply -> Nothing++legacyReadModelSubscription :: ReadModelNode -> Maybe Text+legacyReadModelSubscription readModel = case rmSupply readModel of+  LegacyReadModelSupply {legacySubscription} -> legacySubscription+  OwnerDerivedSupply -> Nothing++-- | Destructive preparation clears a target; preserve retains brownfield rows+-- for an application-owned reconciliation adapter.+data TargetResetPolicy = TargetClear | TargetPreserve+  deriving stock (Eq, Show, Generic)++-- | One physical PostgreSQL target owned by exactly one catalog group.+data ProjectionTargetNode = ProjectionTargetNode+  { ptName :: !Name,+    ptSchema :: !Text,+    ptTable :: !Text,+    ptReset :: !TargetResetPolicy,+    ptDependsOn :: ![Name],+    ptLoc :: !Loc+  }+  deriving stock (Eq, Show, Generic)++-- | One atomic lifecycle group and its deterministic target preparation order.+data RebuildGroupNode = RebuildGroupNode+  { rgName :: !Name,+    rgTargets :: ![Name],+    rgOrder :: ![Name],+    rgLoc :: !Loc+  }+  deriving stock (Eq, Show, Generic)++data PromotionObjectKindNode+  = PromotionIndexNode+  | PromotionConstraintNode+  | PromotionOwnedSequenceNode+  deriving stock (Eq, Ord, Show, Generic)++data PromotionObjectNode = PromotionObjectNode+  { rpoKind :: !PromotionObjectKindNode,+    rpoGenerationName :: !Text,+    rpoCanonicalName :: !Text+  }+  deriving stock (Eq, Show, Generic)++-- | Application-owned schema contract for one target in a projection+-- revision. The DSL carries stable identities, never raw DDL.+data RevisionTargetNode = RevisionTargetNode+  { prtTarget :: !Name,+    prtSchemaVersion :: !Text,+    prtProvisioner :: !Text,+    prtProvisionerVersion :: !Int,+    prtExpectedShape :: !Text,+    prtValidator :: !Text,+    prtValidatorVersion :: !Int,+    prtPromotionObjects :: ![PromotionObjectNode]+  }+  deriving stock (Eq, Show, Generic)++data ProjectionRevisionNode = ProjectionRevisionNode+  { prvName :: !Name,+    prvGroup :: !Name,+    prvTargets :: ![RevisionTargetNode],+    prvLoc :: !Loc+  }+  deriving stock (Eq, Show, Generic)++-- | Candidate language-5 declaration for one bounded all-row external SQL+-- contract. The result shape is deliberately absent: lowering obtains it from+-- the checked read-model binding so source and runtime identity cannot drift.+data ExternalReadNode = ExternalReadNode+  { erName :: !Name,+    erVersion :: !Int,+    erQueryModel :: !Name,+    erResultSchema :: !Text,+    erResultType :: !Text,+    erCompatibleRevisions :: ![Name],+    erSurfaceGeneration :: !Int,+    erLoc :: !Loc+  }+  deriving stock (Eq, Show, Generic)++-- | Top-level declaration identity. Several contract versions may coexist,+-- so source-level duplicate detection keys by contract and version together.+externalReadNodeIdentity :: ExternalReadNode -> Name+externalReadNodeIdentity externalRead =+  erName externalRead <> "_v" <> T.pack (show (erVersion externalRead))++-- | A replay source selected by a projection owner.+data CatalogSource+  = CatalogAggregate !Name+  | CatalogCategory !Text+  | CatalogAll+  deriving stock (Eq, Show, Generic)++-- | What a subscription feed does when its exact durable checkpoint is absent.+-- The parser retains a list so validation can diagnose omission and duplication+-- precisely; a validated subscription owner has exactly one value.+data CheckpointOnMissingNode+  = CheckpointFromBeginning+  | CheckpointFromCurrentHead+  | CheckpointFail+  deriving stock (Eq, Show, Generic)++-- | Whether a projection has an application-owned replay adapter or is+-- intentionally live-only for the recorded reason.+data ProjectionReplayPolicy+  = ProjectionReplayExplicit+  | ProjectionLiveOnly !Text+  deriving stock (Eq, Show, Generic)++-- | One ordered live/replay handler declaration in the service catalog.+data ProjectionOwnerNode = ProjectionOwnerNode+  { poName :: !Name,+    poSources :: ![CatalogSource],+    poDelivery :: !ProjectionDelivery,+    poGroup :: !Name,+    poTargets :: ![Name],+    poOrder :: !Int,+    poSubscription :: !(Maybe Text),+    poDedup :: !(Maybe Text),+    poCheckpointOnMissing :: ![CheckpointOnMissingNode],+    poReplay :: !ProjectionReplayPolicy,+    poLoc :: !Loc+  }+  deriving stock (Eq, Show, Generic)+ -- EP-6: the durable @workflow@ + @operation@ nodes.  -- | One ordered item of a workflow body. Replay matches on the label, not the@@ -1155,6 +1462,11 @@   | NWorkqueue WorkqueueNode   | NPgmqDispatch PgmqDispatchNode   | NReadModel ReadModelNode+  | NProjectionTarget ProjectionTargetNode+  | NRebuildGroup RebuildGroupNode+  | NProjectionRevision ProjectionRevisionNode+  | NExternalRead ExternalReadNode+  | NProjectionOwner ProjectionOwnerNode   | NWorkflow WorkflowNode   | NOperation OperationNode   deriving stock (Eq, Show, Generic)

src/Keiro/Dsl/Harness.hs view

@@ -28,15 +28,19 @@     harnessForWithGoldens,     harnessProcess,     harnessRouter,+    harnessRouterForService,     harnessReadModel,+    harnessReadModelForService,     harnessWorkflow,     processHarnessFactValues,     routerHarnessFactValues,+    routerHarnessFactValuesForService,     workflowHarnessFactValues,   ) where -import Data.List (find)+import Data.List (find, sortOn)+import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Set qualified as Set@@ -49,10 +53,15 @@ import Keiro.Dsl.Goldens (GoldenPayload (..)) import Keiro.Dsl.Grammar import Keiro.Dsl.HaskellImport+import Keiro.Dsl.HaskellName qualified as HaskellName import Keiro.Dsl.IdDomain (idDomainContractFor, idDomainSampleText) import Keiro.Dsl.NominalType+import Keiro.Dsl.ProjectionSupply+import Keiro.Dsl.ReadModelShape (registryNameFor)+import Keiro.Dsl.RouterSelection import Keiro.Dsl.Scaffold-import Keiro.Dsl.SemanticContract (CheckedService (..), legacyCheckedService)+import Keiro.Dsl.SemanticContract (CheckedService, checkedLanguageContract, checkedProjectionSupplies, checkedSpec, checkedTypeGraph, legacyCheckedService)+import Keiro.Dsl.SemanticImpact (aggregateMappedClosure, semanticImpact) import Keiro.Dsl.TypeGraph  -- | Emit the aggregate harness after selecting the service's effective@@ -131,8 +140,27 @@   where     genPrefix = genPrefixFor ctx (rtId router) +-- | Add checked declarative-selection evidence without changing any legacy+-- custom-router harness bytes.+harnessRouterForService :: Context -> CheckedService -> RouterNode -> [ScaffoldModule]+harnessRouterForService ctx service router = case rvSource (rtResolve router) of+  ResolveDeclarative {} ->+    [ ScaffoldModule+        { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/RouterHarness.hs"),+          moduleText = emitRouterHarnessWithFacts genPrefix (routerHarnessFactValuesForService service router),+          kind = Generated,+          origin = "router " <> rtId router <> locSuffix (rtLoc router)+        }+    ]+  _ -> harnessRouter ctx router+  where+    genPrefix = genPrefixFor ctx (rtId router)+ emitRouterHarness :: Text -> RouterNode -> Text-emitRouterHarness genPrefix router =+emitRouterHarness genPrefix router = emitRouterHarnessWithFacts genPrefix (routerHarnessFactValues router)++emitRouterHarnessWithFacts :: Text -> [(Text, Text)] -> Text+emitRouterHarnessWithFacts genPrefix facts =   nl $     [ generatedBanner,       "module " <> genPrefix <> ".RouterHarness (routerHarnessValues) where",@@ -140,7 +168,7 @@       "routerHarnessValues :: [(String, String)]",       "routerHarnessValues ="     ]-      <> renderFactValues (routerHarnessFactValues router)+      <> renderFactValues facts  routerHarnessFactValues :: RouterNode -> [(Text, Text)] routerHarnessFactValues router =@@ -161,16 +189,53 @@     resolveSource = case rvSource (rtResolve router) of       ResolveReadModel name -> "read-model " <> name       ResolveHole -> "hole"+      ResolveDeclarative selection -> "declarative " <> rsIdentity selection +routerHarnessFactValuesForService :: CheckedService -> RouterNode -> [(Text, Text)]+routerHarnessFactValuesForService service router = case rvSource (rtResolve router) of+  ResolveDeclarative {} ->+    routerHarnessFactValues router+      <> [ ("resolverOwnership", "generated-declarative"),+           ("queryIdentity", checkedQueryName (checkedQuery selection)),+           ("selectionIdentity", checkedIdentity selection),+           ("selectionVersion", T.pack (show (checkedVersion selection))),+           ("selectionFingerprint", checkedFingerprint selection),+           ("maxRecipients", T.pack (show (checkedLimit selection))),+           ("selectionOrder", "target-stream"),+           ("selectionDedupe", "target-stream"),+           ("emptyPolicy", checkedEmptyPolicyText (checkedEmptyPolicy selection)),+           ("failurePolicy", checkedFailurePolicyText (checkedFailurePolicy selection)),+           ("redeliveryPolicy", "stable-union"),+           ("partialPolicy", "retain-successes")+         ]+  _ -> routerHarnessFactValues router+  where+    graph = case checkedTypeGraph service of+      Left errors -> error ("checked declarative router harness type graph failed: " <> show errors)+      Right value -> value+    selection = case checkRouterSelection (checkedLanguageContract service) graph (checkedSpec service) router of+      Left diagnostics -> error ("checked declarative router harness selection failed: " <> show diagnostics)+      Right value -> value+    checkedEmptyPolicyText CheckedEmptyAck = "ack"+    checkedEmptyPolicyText CheckedEmptyRetry = "retry"+    checkedEmptyPolicyText CheckedEmptyDeadLetter = "deadLetter"+    checkedEmptyPolicyText CheckedEmptyHalt = "halt"+    checkedFailurePolicyText CheckedFailureRetry = "retry"+    checkedFailurePolicyText CheckedFailureDeadLetter = "deadLetter"+    checkedFailurePolicyText CheckedFailureHalt = "halt"+ -- | Emit runtime-free facts for a read-model node. Each row records the value -- expected directly from the notation next to the value produced by the shared -- derivation helpers. Committed conformance expectations pin the lowered values, -- while a shape-fixture drift makes the generated harness itself fail.-harnessReadModel :: Context -> ReadModelNode -> [ScaffoldModule]-harnessReadModel ctx readModel =+harnessReadModel :: Context -> Spec -> ReadModelNode -> [ScaffoldModule]+harnessReadModel ctx spec = harnessReadModelForService ctx (legacyCheckedService spec)++harnessReadModelForService :: Context -> CheckedService -> ReadModelNode -> [ScaffoldModule]+harnessReadModelForService ctx service readModel =   [ ScaffoldModule       { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/ReadModelHarness.hs"),-        moduleText = emitReadModelHarness genPrefix ctx readModel,+        moduleText = emitReadModelHarness genPrefix ctx (checkedSpec service) (checkedProjectionSupplies service) readModel,         kind = Generated,         origin = "readmodel " <> rmName readModel <> locSuffix (rmLoc readModel)       }@@ -178,34 +243,32 @@   where     genPrefix = genPrefixFor ctx (pascal (rmName readModel)) -emitReadModelHarness :: Text -> Context -> ReadModelNode -> Text-emitReadModelHarness genPrefix ctx readModel =+emitReadModelHarness :: Text -> Context -> Spec -> ProjectionSupplyAnalysis -> ReadModelNode -> Text+emitReadModelHarness genPrefix ctx spec supplyAnalysis readModel =   nl $     renderGeneratedLanguagePragmas [ExtOverloadedRecordDot]       <> [ generatedBanner,-           "module " <> genPrefix <> ".ReadModelHarness (readModelFacts, readModelFactResults, runReadModelFacts) where",+           "module " <> genPrefix <> ".ReadModelHarness (" <> T.intercalate ", " moduleExports <> ") where",            "",            "import " <> genPrefix <> ".ReadModel (" <> T.intercalate ", " readModelImports <> ")",-           "import Data.Text qualified as T",-           "import Keiro.ReadModel (ReadModel (..), StrongScope (..))"+           "import Data.Text qualified as T"          ]-      <> ["import Keiro.Projection (AsyncProjection (..))" | rmFeed readModel == RmSubscription]+      <> catalogImports+      <> ["import Keiro.ReadModel (" <> runtimeImports <> ")"]+      <> ["import Keiro.Projection (AsyncProjection (..))" | emitsLegacyAsync]       <> [ "",            "-- | (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",-           "",+           "readModelFacts ="+         ]+      <> baseFactRows+      <> [asyncFactRow | not catalogManaged]+      <> policyFactRows+      <> ["  ]"]+      <> ["    <> catalogFactsAgainst ProjectionCatalog.projectionCatalogRegistrations ProjectionCatalog.projectionCatalogAsyncRegistrations ProjectionCatalog.projectionCatalogQuerySupplies" | catalogManaged]+      <> policyHelpers+      <> catalogHelpers+      <> [ "",            "readModelFactResults :: [(String, Bool)]",            "readModelFactResults =",            "  [(fact, expected == actual) | (fact, expected, actual) <- readModelFacts]",@@ -220,21 +283,176 @@     stem = lowerFirst (pascal (rmName readModel))     readModelName = stem <> "ReadModel"     asyncProjectionName = stem <> "AsyncProjection"-    readModelImports = readModelName : [asyncProjectionName | rmFeed readModel == RmSubscription]-    expectedRegistry = contextName ctx <> "-" <> T.replace "_" "-" (rmName readModel)-    expectedSubscription = case rmSubscription readModel of+    readModelImports = readModelName : [asyncProjectionName | emitsLegacyAsync]+    moduleExports = ["readModelFacts", "readModelFactResults", "runReadModelFacts"] <> ["catalogFactsAgainst" | catalogManaged]+    expectedRegistry = registryNameFor (contextName ctx) readModel+    ownerDerived = rmSupply readModel == OwnerDerivedSupply+    expectedSubscription = case legacyReadModelSubscription readModel of       Just name -> name       Nothing -> expectedRegistry <> "-sub"-    expectedAsync = case rmFeed readModel of-      RmInline -> "none"-      RmSubscription -> expectedRegistry <> "-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"-    scope = case rmScope readModel of+    expectedAsync = case legacyReadModelFeed readModel of+      Just RmSubscription -> expectedRegistry <> "-async"+      _ -> "none"+    asyncFactRow = case legacyReadModelFeed readModel of+      Just RmSubscription -> "  , (\"asyncProjectionName\", " <> tshow expectedAsync <> ", T.unpack " <> asyncProjectionName <> ".name)"+      _ -> "  , (\"asyncProjectionName\", \"none\", \"none\") -- Definitionally inert: inline feeds have no AsyncProjection value."+    catalogManaged = rmGroup readModel /= Nothing+    emitsLegacyAsync = not ownerDerived && not catalogManaged && legacyReadModelFeed readModel == Just RmSubscription+    runtimeImports+      | ownerDerived = "ReadModel (..), readModelCursorAuthority, readModelDefaultFreshness"+      | otherwise = "ReadModel (..), StrongScope (..)"+    baseFactRows+      | ownerDerived =+          [ "  [ (\"registryName\", " <> tshow expectedRegistry <> ", T.unpack " <> readModelName <> ".name)",+            "  , (\"shapeHash\", " <> tshow (rmShape readModel) <> ", T.unpack " <> readModelName <> ".shapeHash)"+          ]+      | otherwise =+          [ "  [ (\"registryName\", " <> tshow expectedRegistry <> ", T.unpack " <> readModelName <> ".name)",+            "  , (\"subscriptionName\", " <> tshow expectedSubscription <> ", T.unpack " <> readModelName <> ".subscriptionName)",+            "  , (\"shapeHash\", " <> tshow (rmShape readModel) <> ", T.unpack " <> readModelName <> ".shapeHash)"+          ]+    policyFactRows+      | ownerDerived =+          [ "  , (\"freshness\", " <> tshow expectedFreshness <> ", show (readModelDefaultFreshness " <> readModelName <> "))",+            "  , (\"cursorAuthority\", " <> tshow expectedCursor <> ", show (readModelCursorAuthority " <> readModelName <> "))"+          ]+      | otherwise =+          [ "  , (\"consistency\", " <> tshow consistency <> ", show " <> readModelName <> ".defaultConsistency)",+            "  , (\"strongScope\", " <> tshow scope <> ", renderStrongScope " <> readModelName <> ".strongScope)"+          ]+    policyHelpers+      | ownerDerived = []+      | otherwise =+          [ "",+            "renderStrongScope :: StrongScope -> String",+            "renderStrongScope EntireLog = \"EntireLog\"",+            "renderStrongScope (CategoryHead categoryName) = \"CategoryHead \" <> T.unpack categoryName"+          ]+    catalogImports+      | catalogManaged =+          [ "import Data.List.NonEmpty qualified as NE",+            "import " <> contextGeneratedPrefix ctx <> ".ProjectionCatalog qualified as ProjectionCatalog",+            "import Keiro.Projection.Catalog qualified as Catalog"+          ]+      | otherwise = []+    supply =+      find+        ((== rmName readModel) . supplyQueryModel)+        (resolvedProjectionSupplies supplyAnalysis)+    resolvedOwner = do+      resolved <- supply+      find+        ((== supplyProjectionOwner resolved) . poName)+        [owner | NProjectionOwner owner <- specNodes spec]+    expectedCursor = case resolvedOwner of+      Just owner+        | poDelivery owner == DeliverySubscription,+          Just subscription <- poSubscription owner ->+            "DurableQueryCursor " <> T.pack (show subscription)+      _ -> "NoQueryCursor"+    expectedFreshness = case rmFreshness readModel of+      FreshnessImmediate -> "Immediate"+      FreshnessWaitForHead RmEntireLog -> "WaitForHead EntireVisibleLog"+      FreshnessWaitForHead (RmCategory categoryName) -> "WaitForHead (CategoryVisibleHead " <> T.pack (show categoryName) <> ")"+    feedingOwners =+      sortOn+        poOrder+        [ owner+        | Just resolved <- [supply],+          NProjectionOwner owner <- specNodes spec,+          poName owner == supplyProjectionOwner resolved,+          poDelivery owner == DeliverySubscription+        ]+    expectedCatalogRegistration =+      T.intercalate+        "|"+        [ expectedRegistry,+          T.pack (show (rmVersion readModel)),+          rmShape readModel,+          fromMaybe "" (rmGroup readModel)+        ]+    expectedCatalogSupply = case supply of+      Nothing -> "missing"+      Just resolved ->+        T.intercalate+          "|"+          [ supplyProjectionOwner resolved,+            supplyRebuildGroup resolved,+            T.intercalate "," (NE.toList (supplyObservedTargets resolved))+          ]+    catalogHelpers+      | not catalogManaged = []+      | otherwise =+          [ "",+            "catalogFactsAgainst :: [Catalog.CatalogRegistration] -> [Catalog.AsyncProjectionRegistration] -> [Catalog.ResolvedQuerySupply] -> [(String, String, String)]",+            "catalogFactsAgainst registrations " <> asyncParameter <> " supplies ="+          ]+            <> catalogFactRows+            <> [ "",+                 "renderRegistration :: [Catalog.CatalogRegistration] -> String",+                 "renderRegistration [entry] = T.unpack entry.registryName <> \"|\" <> show entry.version <> \"|\" <> T.unpack entry.shapeHash <> \"|\" <> T.unpack (Catalog.rebuildGroupIdText entry.rebuildGroupId)",+                 "renderRegistration _ = \"missing\"",+                 "",+                 "renderSupply :: [Catalog.ResolvedQuerySupply] -> String",+                 "renderSupply [entry] = T.unpack (Catalog.projectionIdText entry.resolvedProjectionId) <> \"|\" <> T.unpack (Catalog.rebuildGroupIdText entry.resolvedRebuildGroupId) <> \"|\" <> T.unpack (T.intercalate \",\" (map Catalog.targetIdText (NE.toList entry.resolvedObservedTargets)))",+                 "renderSupply _ = \"missing\"",+                 "",+                 "renderDelivery :: [Catalog.ResolvedQuerySupply] -> String",+                 "renderDelivery [entry] = T.unpack (T.intercalate \",\" (map renderCapability (NE.toList entry.resolvedHandlerCapabilities)))",+                 "renderDelivery _ = \"missing\"",+                 "",+                 "renderCapability :: Catalog.ProjectionHandlerCapability -> T.Text",+                 "renderCapability Catalog.InlineCapability {} = \"inline\"",+                 "renderCapability Catalog.SubscriptionCapability {} = \"subscription\""+               ]+            <> asyncRenderHelper+    asyncRenderHelper+      | null feedingOwners = []+      | otherwise =+          [ "",+            "renderAsync :: [Catalog.AsyncProjectionRegistration] -> String",+            "renderAsync [entry] = T.unpack entry.subscriptionName <> \"|\" <> T.unpack entry.dedupName",+            "renderAsync _ = \"missing\""+          ]+    asyncParameter+      | null feedingOwners = "_asyncRegistrations"+      | otherwise = "asyncRegistrations"+    catalogFactRows =+      [ "  [ (\"catalogRegistration\", "+          <> tshow expectedCatalogRegistration+          <> ", renderRegistration [entry | entry <- registrations, Catalog.queryModelIdText entry.queryModelId == "+          <> tshow (rmName readModel)+          <> "])",+        "  , (\"querySupply\", "+          <> tshow expectedCatalogSupply+          <> ", renderSupply [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "+          <> tshow (rmName readModel)+          <> "])",+        "  , (\"projectionDelivery\", "+          <> tshow expectedDelivery+          <> ", renderDelivery [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "+          <> tshow (rmName readModel)+          <> "])"+      ]+        <> [ "  , (\"asyncRegistration:"+               <> poName owner+               <> "\", "+               <> tshow (T.intercalate "|" [fromMaybe "" (poSubscription owner), fromMaybe "" (poDedup owner)])+               <> ", renderAsync [entry | entry <- asyncRegistrations, Catalog.projectionIdText entry.projectionId == "+               <> tshow (poName owner)+               <> "])"+           | owner <- feedingOwners+           ]+        <> ["  ]"]+    expectedDelivery = case resolvedOwner of+      Just owner -> case poDelivery owner of+        DeliveryInline -> "inline"+        DeliverySubscription -> "subscription"+      Nothing -> "missing"+    consistency = case legacyReadModelConsistency readModel of+      Just Strong -> "Strong"+      _ -> "Eventual"+    scope = case legacyReadModelScope readModel of       Nothing -> "EntireLog"       Just RmEntireLog -> "EntireLog"       Just (RmCategory categoryName) -> "CategoryHead " <> categoryName@@ -400,55 +618,96 @@   ]     <> ["  ]"] --- | Emit the workflow's deterministic id derivation compiled against the LIVE--- @Keiro.Workflow@: the 'WorkflowName' and the awakeable-id function (the actual--- 'deterministicAwakeableId'). A signal operation deriving the SAME (name, id,--- label) lands on the same 'AwakeableId' — so this module compiling + the--- conformance comparing the two sides proves the await↔signal coupling holds over--- the real runtime function, not just by label-string equality.+-- | Emit the workflow's live runtime support. Each declared await becomes an+-- opaque binding whose allocation delegates to @awakeableNamed@ and therefore+-- returns the only id that can signal the fresh row. emitWorkflowRuntime :: Text -> WorkflowNode -> Text emitWorkflowRuntime genPrefix w =   nl $     [ generatedBanner,       "module " <> genPrefix <> ".WorkflowRuntime",       "  ( workflowName",-      "  , awaitAwakeableId",-      "  , awaitLabels",-      "  , declaredPatches",-      "  , declaredPatchStepNames",-      "  , withDeclaredPatches",-      "  ) where",-      "",-      "import Data.Set (Set)",-      "import Data.Set qualified as Set",-      "import Data.Text (Text)",-      "import Keiro.Workflow (WorkflowRunOptions (..))",-      "import Keiro.Workflow.Awakeable (AwakeableId, deterministicAwakeableId)",-      "import Keiro.Workflow.Types (PatchId (..), WorkflowId, WorkflowName (..), patchStepName)",-      "",-      "workflowName :: WorkflowName",-      "workflowName = WorkflowName " <> tshow (wfStable w),-      "",-      "-- The awakeable id an await allocates — the real deterministicAwakeableId.",-      "-- A signal op deriving the same (name, id, label) gets the same id.",-      "awaitAwakeableId :: WorkflowId -> Text -> AwakeableId",-      "awaitAwakeableId wid label = deterministicAwakeableId workflowName wid label",-      "",-      "awaitLabels :: [Text]",-      "awaitLabels = [" <> T.intercalate ", " (map tshow (workflowAwaitLabels (wfBody w))) <> "]",-      "",-      "declaredPatches :: Set PatchId",-      "declaredPatches = Set.fromList [" <> T.intercalate ", " ["PatchId " <> tshow patchId | patchId <- workflowPatchIds (wfBody w)] <> "]",-      "",-      "-- The journal keys the runtime records patch decisions under.",-      "declaredPatchStepNames :: [Text]",-      "declaredPatchStepNames = map patchStepName (Set.toList declaredPatches)",-      "",-      "-- Activate exactly the patches declared by this spec for a workflow run.",-      "withDeclaredPatches :: WorkflowRunOptions -> WorkflowRunOptions",-      "withDeclaredPatches opts = opts{activePatches = declaredPatches}"+      "  , AwaitBinding",+      "  , allocateDeclaredAwait"     ]+      ++ ["  , " <> bindingName | (bindingName, _) <- awaitBindings]+      ++ [ "  , awaitLabels",+           "  , declaredPatches",+           "  , declaredPatchStepNames",+           "  , withDeclaredPatches",+           "  ) where",+           "",+           "import Data.Aeson (FromJSON)",+           "import Data.Set (Set)",+           "import Data.Set qualified as Set",+           "import Data.Text (Text)",+           "import Effectful (Eff, IOE, (:>))",+           "import Keiro.Workflow (StepName (..), Workflow, WorkflowRunOptions (..))",+           "import Keiro.Workflow.Awakeable (AwakeableId, awakeableNamed)",+           "import Keiro.Workflow.Types (PatchId (..), WorkflowName (..), patchStepName)",+           "import Kiroku.Store.Effect (Store)",+           "",+           "workflowName :: WorkflowName",+           "workflowName = WorkflowName " <> tshow (wfStable w),+           "",+           "-- | A declared await label. The constructor stays private so consumers",+           "-- can allocate only labels that exist in the source workflow.",+           "data AwaitBinding = AwaitBinding StepName",+           "",+           "allocateDeclaredAwait",+           "  :: (Workflow :> es, Store :> es, IOE :> es, FromJSON a)",+           "  => AwaitBinding",+           "  -> Eff es (AwakeableId, Eff es a)",+           "allocateDeclaredAwait (AwaitBinding label) = awakeableNamed label",+           ""+         ]+      ++ concatMap emitBinding awaitBindings+      ++ [ "awaitLabels :: [Text]",+           "awaitLabels = [" <> T.intercalate ", " (map tshow (workflowAwaitLabels (wfBody w))) <> "]",+           "",+           "declaredPatches :: Set PatchId",+           "declaredPatches = Set.fromList [" <> T.intercalate ", " ["PatchId " <> tshow patchId | patchId <- workflowPatchIds (wfBody w)] <> "]",+           "",+           "-- The journal keys the runtime records patch decisions under.",+           "declaredPatchStepNames :: [Text]",+           "declaredPatchStepNames = map patchStepName (Set.toList declaredPatches)",+           "",+           "-- Activate exactly the patches declared by this spec for a workflow run.",+           "withDeclaredPatches :: WorkflowRunOptions -> WorkflowRunOptions",+           "withDeclaredPatches opts = opts{activePatches = declaredPatches}"+         ]+  where+    awaitBindings =+      [ (workflowAwaitBindingName w label loc, label)+      | (label, loc) <- workflowAwaits (wfBody w)+      ]+    emitBinding (bindingName, label) =+      [ bindingName <> " :: AwaitBinding",+        bindingName <> " = AwaitBinding (StepName " <> tshow label <> ")",+        ""+      ] +workflowAwaitBindingName :: WorkflowNode -> Name -> Loc -> Text+workflowAwaitBindingName workflow label loc =+  case HaskellName.deriveLowerHelperName HaskellName.LogicalWireWord "Await" site of+    Right name -> HaskellName.renderLowerCamelName name+    Left nameError -> error ("keiro-dsl workflow await binding invariant failed: " <> show nameError)+  where+    site =+      HaskellName.NameSite+        { HaskellName.siteKind = HaskellName.GeneratedValueSite,+          HaskellName.siteLogicalName = label,+          HaskellName.siteOwner = "workflow:" <> wfId workflow <> ":await:" <> label,+          HaskellName.siteLine = unLoc loc+        }++workflowAwaits :: [WfBodyItem] -> [(Name, Loc)]+workflowAwaits = concatMap go+  where+    go (WfAwait label _ loc) = [(label, loc)]+    go (WfPatch _ items _) = workflowAwaits items+    go _ = []+ workflowAwaitLabels :: [WfBodyItem] -> [Name] workflowAwaitLabels = concatMap go   where@@ -527,7 +786,7 @@     coreImports =       ["applyEventsEither" | not (null replayTransitions)]         ++ ["defaultValidationOptions", "step", "validateTransducer"]-        ++ ["fieldWitnessAgrees" | not (null (mappedProjectionSpecs a)) || not (null (nominalScalarHarnessTypes a)) || not (null (enforcedConsumerNominalIdHarnessTypes a))]+        ++ ["fieldWitnessAgrees" | not (null (nominalScalarHarnessTypes a)) || not (null (enforcedConsumerNominalIdHarnessTypes a))]         ++ ["(!)" | not (null replayTransitions) && not (null (aRegs a))]     upcastAssertions =       [ "(" <> tshow (upcastLabel e m) <> ", upcasts" <> rcName e <> ")"@@ -999,34 +1258,19 @@ mappedHarnessImports aggregate   | null declarations = []   | otherwise =-      ["import Data.Aeson qualified as Aeson" | not (null opaque) || not (null structuralWire)]+      ["import Data.Aeson qualified as Aeson" | 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))]+        ++ ["import Data.List.NonEmpty qualified as NonEmpty"]+        ++ ["import Data.Text qualified as T" | hasMappedConformanceAssertions aggregate]+        ++ [renderImport "Keiro.Codec.Structural" ["FixtureCases (..)"]]   where     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 =@@ -1083,32 +1327,15 @@         | declaration <- mappedHarnessDeclarationsResolved aggregate,           reference <- case declaration of             ResolvedStructural structural _ ->-              harnessTypeReference (sdHaskell structural)-                : map-                  harnessQualifiedValueReference-                  (sdBinding structural : sdFixtures structural : maybeToListHarness (sdInitial structural))+              map+                harnessQualifiedValueReference+                (sdFixtures structural : maybeToListHarness (sdInitial structural))             ResolvedOpaque opaque ->               map                 harnessQualifiedValueReference                 (odFixtures opaque : maybeToListHarness (odInitial opaque))         ]-    shapeReferences =-      Set.fromList-        [ reference-        | ResolvedStructural declaration shape <- mappedHarnessDeclarationsResolved aggregate,-          reference <- structuralShapeHarnessReferences (aContext aggregate) declaration shape-        ]-    projectionReferences =-      Set.fromList-        [ HaskellReference shapeModule selector ValueNamespace RequireQualified-        | projection <- mappedProjectionSpecs aggregate,-          (shapeModule, selector) <- spSelectors projection-        ]-    references = consumerNominalReferences <> mappedReferences <> shapeReferences <> projectionReferences--harnessTypeReference :: HaskellSource -> HaskellReference-harnessTypeReference source =-  HaskellReference (hsModule source) (hsType source) TypeNamespace PreferUnqualified+    references = consumerNominalReferences <> mappedReferences  harnessQualifiedValueReference :: QualifiedValueName -> HaskellReference harnessQualifiedValueReference qualified =@@ -1116,19 +1343,6 @@   where     (moduleName, valueName) = splitQualifiedHarness (unQualifiedValueName qualified) -structuralShapeHarnessReferences :: Context -> StructuralDecl -> ResolvedMappedShape -> [HaskellReference]-structuralShapeHarnessReferences context declaration =-  foldMappedShape-    MappedShapeAlgebra-      { onRecord = \constructor _ fields -> constructorRef constructor : map (valueRef . rwfHaskell) fields,-        onEnum = map (constructorRef . weCtor),-        onUnion = \_ -> map (constructorRef . rwaCtor)-      }-  where-    moduleName = structuralShapeModuleName context (sdName declaration)-    constructorRef constructor = HaskellReference moduleName constructor ConstructorNamespace RequireQualified-    valueRef value = HaskellReference moduleName value ValueNamespace RequireQualified- renderHarnessReference :: Agg -> HaskellReference -> Text renderHarnessReference aggregate reference =   either@@ -1146,7 +1360,6 @@       "Map",       "NominalProjections",       "NonEmpty",-      "StructuralProjections",       "T"     ] @@ -1154,84 +1367,55 @@ unique = foldr (\value values -> if value `elem` values then values else value : values) []  hasMappedHarness :: Agg -> Bool-hasMappedHarness = not . null . mappedHarnessDeclarationsResolved+hasMappedHarness = hasMappedConformanceAssertions +hasMappedConformanceAssertions :: Agg -> Bool+hasMappedConformanceAssertions aggregate =+  not (null (mappedEventFields aggregate)) || not (null (structuralWireDeclarations aggregate))+ mappedHarnessDeclarationsResolved :: Agg -> [ResolvedMappedDecl] mappedHarnessDeclarationsResolved aggregate = case aTypeGraph aggregate of   Nothing -> []-  Just graph -> Map.elems (tgDeclarations graph)--mappedProjectionSpecs :: Agg -> [StructuralProjection]-mappedProjectionSpecs aggregate = case aTypeGraph aggregate of-  Nothing -> []-  Just graph -> map (resolveProjectionModules (aContext aggregate)) (projectionSpecs graph)+  Just graph ->+    [ declaration+    | key <- aggregateMappedClosure (semanticImpact graph) (aName aggregate),+      Just declaration <- [Map.lookup key (tgDeclarations graph)]+    ] -structuralShapeModuleName :: Context -> Name -> Text-structuralShapeModuleName context name = case placement context of-  GeneratedPrefix -> root <> "Generated." <> contextSegment <> ".Structural.Shape." <> name-  CollocatedLeaf -> root <> contextSegment <> ".Generated.Structural.Shape." <> name-  where-    root = if T.null (moduleRoot context) then "" else moduleRoot context <> "."-    contextSegment = pascalFromKebab (contextName context)+mappedEventFields :: Agg -> [(ResolvedCtor, Text, ResolvedAggregateType, ResolvedMappedDecl)]+mappedEventFields aggregate =+  [ (event, fieldDslName identity, fieldType, declaration)+  | event <- aEvents aggregate,+    (identity, fieldType) <- rcFields event,+    declaration <- maybeToListHarness (mappedDeclaration aggregate fieldType)+  ] -structuralProjectionModuleName :: Context -> Text-structuralProjectionModuleName context = case placement context of-  GeneratedPrefix -> root <> "Generated." <> contextSegment <> ".StructuralProjections"-  CollocatedLeaf -> root <> contextSegment <> ".Generated.StructuralProjections"-  where-    root = if T.null (moduleRoot context) then "" else moduleRoot context <> "."-    contextSegment = pascalFromKebab (contextName context)+structuralWireDeclarations :: Agg -> [(StructuralDecl, ResolvedMappedShape)]+structuralWireDeclarations aggregate =+  [(declaration, shape) | ResolvedStructural declaration shape <- codecMappedDeclarations aggregate]  mappedHarnessDeclarations :: Agg -> [Text] mappedHarnessDeclarations aggregate-  | not (hasMappedHarness aggregate) = []+  | not (hasMappedConformanceAssertions aggregate) = []   | otherwise =       [ "",         "mappedConformanceAssertions :: [(String, Bool)]",         "mappedConformanceAssertions =",         "  concat",         "    [ " <> T.intercalate "\n    , " assertionLists,-        "    ]",-        "",-        "validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool",-        "validFixtureLabels cases =",-        "  all (not . T.null) labels && length labels == length (nub labels)",-        "  where",-        "    labels = map fst (NonEmpty.toList cases)"+        "    ]"       ]-        ++ concatMap (bindingAssertionDecl aggregate) structural-        ++ concatMap (opaqueAssertionDecl aggregate) opaque-        ++ concatMap (coverageDecl aggregate) structural-        ++ concatMap (mappedEventAssertionDecl aggregate) mappedEventFields+        ++ concatMap (mappedEventAssertionDecl aggregate) eventFields         ++ wirePolicyAssertionDecls aggregate structuralWire-        ++ projectionAssertionDecls aggregate structural         ++ wirePolicyHelpers structuralWire   where-    declarations = mappedHarnessDeclarationsResolved aggregate-    structural = [(declaration, shape) | ResolvedStructural declaration shape <- declarations]-    opaque = [declaration | ResolvedOpaque declaration <- declarations]-    structuralWire = [(declaration, shape) | ResolvedStructural declaration shape <- codecMappedDeclarations aggregate]-    mappedEventFields =-      [ (event, fieldDslName identity, fieldType, declaration)-      | event <- aEvents aggregate,-        (identity, fieldType) <- rcFields event,-        declaration <- maybeToListHarness (mappedDeclaration aggregate fieldType)-      ]+    structuralWire = structuralWireDeclarations aggregate+    eventFields = mappedEventFields aggregate     assertionLists =-      [lowerFirst (sdName declaration) <> "BindingAssertions" | (declaration, _) <- structural]-        <> [lowerFirst (odName declaration) <> "OpaqueAssertions" | declaration <- opaque]-        <> [ "[(\"fixture coverage: "-               <> unCanonicalTypeId (sdCanonical declaration)-               <> "\", coverage"-               <> sdName declaration-               <> ")]"-           | (declaration, _) <- structural-           ]-        <> [ mappedEventAssertionName event fieldName <> "Assertions"-           | (event, fieldName, _, _) <- mappedEventFields-           ]+      [ mappedEventAssertionName event fieldName <> "Assertions"+      | (event, fieldName, _, _) <- eventFields+      ]         <> ["structuralWirePolicyAssertions" | not (null structuralWire)]-        <> ["structuralProjectionAssertions" | not (null (mappedProjectionSpecs aggregate))]  mappedDeclaration :: Agg -> ResolvedAggregateType -> Maybe ResolvedMappedDecl mappedDeclaration aggregate resolvedType = do@@ -1241,92 +1425,6 @@   graph <- aTypeGraph aggregate   Map.lookup key (tgDeclarations graph) -bindingAssertionDecl :: Agg -> (StructuralDecl, ResolvedMappedShape) -> [Text]-bindingAssertionDecl aggregate (declaration, _shape) =-  [ "",-    valueName <> " :: [(String, Bool)]",-    valueName <> " =",-    "  (\"fixture labels: " <> canonical <> "\", validFixtureLabels cases) :",-    "  (\"canonical identity: " <> canonical <> "\", canonicalTypeName (Proxy @" <> consumerType <> ") == " <> tshow canonical <> ") :",-    "  concat",-    "    [ [ (\"binding domain round-trip: " <> canonical <> "/\" <> T.unpack label, bindingDomainRoundTrip " <> binding <> " value)",-    "      , (\"binding shape round-trip: " <> canonical <> "/\" <> T.unpack label, bindingShapeRoundTrip " <> binding <> " (bindingToShape " <> binding <> " value))",-    "      ]",-    "    | (label, value) <- NonEmpty.toList cases",-    "    ]",-    "  where",-    "    cases = fixtureCases " <> fixtures-  ]-  where-    valueName = lowerFirst (sdName declaration) <> "BindingAssertions"-    canonical = unCanonicalTypeId (sdCanonical declaration)-    consumerType = renderHarnessReference aggregate (harnessTypeReference (sdHaskell declaration))-    binding = renderHarnessReference aggregate (harnessQualifiedValueReference (sdBinding declaration))-    fixtures = renderHarnessReference aggregate (harnessQualifiedValueReference (sdFixtures declaration))--opaqueAssertionDecl :: Agg -> OpaqueDecl -> [Text]-opaqueAssertionDecl aggregate declaration =-  [ "",-    valueName <> " :: [(String, Bool)]",-    valueName <> " =",-    "  (\"opaque boundary fixtures: " <> label <> "\", validFixtureLabels cases) :",-    "  [ (\"opaque codec round-trip: " <> label <> "/\" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False)",-    "  | (caseLabel, value) <- NonEmpty.toList cases",-    "  ]",-    "  where",-    "    cases = fixtureCases " <> fixtures-  ]-  where-    valueName = lowerFirst (odName declaration) <> "OpaqueAssertions"-    label = unCodecIdentity (odCodecIdentity declaration) <> "@" <> unCodecVersion (odCodecVersion declaration)-    fixtures = renderHarnessReference aggregate (harnessQualifiedValueReference (odFixtures declaration))--coverageDecl :: Agg -> (StructuralDecl, ResolvedMappedShape) -> [Text]-coverageDecl aggregate (declaration, shape) =-  [ "",-    "coverage" <> sdName declaration <> " :: Bool",-    "coverage" <> sdName declaration <> " = " <> coverageExpression aggregate declaration shape-  ]--coverageExpression :: Agg -> StructuralDecl -> ResolvedMappedShape -> Text-coverageExpression aggregate declaration shape = case obligations of-  [] -> "True"-  _ -> T.intercalate " && " obligations <> "\n  where\n    shapes = map (bindingToShape " <> binding <> " . snd) (NonEmpty.toList (fixtureCases " <> fixtures <> "))"-  where-    shapeModule = structuralShapeModuleName (aContext aggregate) (sdName declaration)-    binding = renderHarnessReference aggregate (harnessQualifiedValueReference (sdBinding declaration))-    fixtures = renderHarnessReference aggregate (harnessQualifiedValueReference (sdFixtures declaration))-    obligations = case shape of-      RRecord _ _ fields -> concatMap (recordFieldObligation aggregate shapeModule) fields-      REnum entries ->-        [ "any (\\case " <> renderHarnessReference aggregate (HaskellReference shapeModule (weCtor entry) ConstructorNamespace RequireQualified) <> " -> True; _ -> False) shapes"-        | entry <- entries-        ]-      RUnion _ arms -> concatMap (unionArmObligations aggregate shapeModule) arms--recordFieldObligation :: Agg -> Text -> ResolvedWireField -> [Text]-recordFieldObligation aggregate shapeModule field = case rwfType field of-  ROptional _ ->-    [ "any (isNothing . " <> selector <> ") shapes",-      "any (isJust . " <> selector <> ") shapes"-    ]-  _ -> []-  where-    selector = renderHarnessReference aggregate (HaskellReference shapeModule (rwfHaskell field) ValueNamespace RequireQualified)--unionArmObligations :: Agg -> Text -> ResolvedWireArm -> [Text]-unionArmObligations aggregate shapeModule arm =-  ["any (\\case " <> patternText <> " -> True; _ -> False) shapes"] <> optionalPayload-  where-    constructor = renderHarnessReference aggregate (HaskellReference shapeModule (rwaCtor arm) ConstructorNamespace RequireQualified)-    patternText = constructor <> maybe "" (const "{}") (rwaPayload arm)-    optionalPayload = case rwaPayload arm of-      Just (ROptional _) ->-        [ "any (\\case " <> constructor <> " Nothing -> True; _ -> False) shapes",-          "any (\\case " <> constructor <> " (Just _) -> True; _ -> False) shapes"-        ]-      _ -> []- mappedEventAssertionDecl :: Agg -> (ResolvedCtor, Text, ResolvedAggregateType, ResolvedMappedDecl) -> [Text] mappedEventAssertionDecl aggregate (event, fieldName, _fieldType, declaration) =   [ "",@@ -1557,45 +1655,6 @@         [ " " <> if fieldDslName identity == target then replacement else sampleValue aggregate (fieldDslName identity) fieldType         | (identity, fieldType) <- rcFields constructor         ]--projectionAssertionDecls :: Agg -> [(StructuralDecl, ResolvedMappedShape)] -> [Text]-projectionAssertionDecls aggregate structural-  | null specs = []-  | otherwise =-      [ "",-        "structuralProjectionAssertions :: [(String, Bool)]",-        "structuralProjectionAssertions =",-        "  [ " <> T.intercalate "\n  , " (map assertion specs),-        "  ]"-      ]-  where-    specs = mappedProjectionSpecs aggregate-    assertion spec =-      "(\"projection witness agreement: "-        <> unCanonicalTypeId (spCanonical spec)-        <> spPointer spec-        <> "\", all (\\(_, owner) -> fieldWitnessAgrees StructuralProjections."-        <> spWitness spec-        <> " (\\referenceOwner -> "-        <> projectionGetter aggregate "referenceOwner" spec-        <> ") owner) (NonEmpty.toList (fixtureCases "-        <> ownerFixtures spec-        <> ")))"-    ownerFixtures spec = case find (\(declaration, _) -> sdCanonical declaration == spCanonical spec) structural of-      Just (declaration, _) -> renderHarnessReference aggregate (harnessQualifiedValueReference (sdFixtures declaration))-      Nothing -> "error \"projection owner fixtures missing\""--projectionGetter :: Agg -> Text -> StructuralProjection -> Text-projectionGetter aggregate owner spec =-  foldl-    ( \value (shapeModule, selector) ->-        renderHarnessReference aggregate (HaskellReference shapeModule selector ValueNamespace RequireQualified)-          <> " ("-          <> value-          <> ")"-    )-    ("bindingToShape " <> renderHarnessReference aggregate (harnessQualifiedValueReference (spBinding spec)) <> " " <> owner)-    (spSelectors spec)  maybeToListHarness :: Maybe value -> [value] maybeToListHarness = maybe [] pure

src/Keiro/Dsl/HaskellName.hs view

@@ -21,6 +21,7 @@     renderGeneratedHaskellNamingEdition,     parseGeneratedHaskellNamingEdition,     deriveHaskellName,+    deriveLowerHelperName,     checkedModuleSegment,     checkedModuleName,     checkedUpperOccurrence,@@ -172,6 +173,15 @@           upperName <- checkedUpperOccurrence site upper           lowerName <- checkedLowerOccurrence site lower           pure DerivedHaskellName {upperCamel = upperName, lowerCamel = lowerName}++-- | Derive a lower-camel helper name from a logical name and append one checked+-- UpperCamel suffix. Generator emission and collision planning use this same+-- function so the occurrence registered before a scaffold write is exactly the+-- occurrence later emitted.+deriveLowerHelperName :: NameSourceKind -> Text -> NameSite -> Either HaskellNameError LowerCamelName+deriveLowerHelperName source suffix site = do+  derived <- deriveHaskellName source site+  checkedLowerOccurrence site (renderLowerCamelName (lowerCamel derived) <> suffix)  checkedModuleSegment :: NameSite -> Text -> Either HaskellNameError HaskellModuleSegment checkedModuleSegment site candidate

src/Keiro/Dsl/IdDomain.hs view

@@ -20,7 +20,7 @@ import Keiro.Codec.IdDomain import Keiro.Dsl.Grammar (ContractEvent (..), ContractField (..), ContractNode (..), ContractType (..), IdDecl (..), Node (..), Spec (..)) import Keiro.Dsl.LanguageVersion (RuntimeCapability (..), runtimeProfileHasCapability)-import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveRuntimeProfile)+import Keiro.Dsl.SemanticContract (CheckedService, EffectiveLanguageContract, checkedLanguageContract, checkedSpec, effectiveRuntimeProfile)  -- | Versions 1 and 2 intentionally return 'Nothing': their generated IDs -- admitted arbitrary text. Runtime-semantics generation 2 is the first

src/Keiro/Dsl/LanguageVersion.hs view

@@ -26,12 +26,14 @@     RuntimeCapability (..),     capabilityFoldSegment,     LanguageSupport (..),+    LanguageMaturity (..),     languageSupportText,     LanguageDefinition (..),     definitionRuntimeSemantics,     languageRegistry,     supportedLanguageVersions,     currentStableLanguageVersion,+    currentAuthoringLanguageVersion,     languageSupportForVersion,     lookupLanguageDefinition,     LanguageFeature (..),@@ -61,7 +63,7 @@ import Keiro.Dsl.Grammar (Loc (..), Spec, noLoc) import Numeric.Natural (Natural) --- | A positive released Keiro DSL language version.+-- | A positive registered Keiro DSL language version. newtype LanguageVersion = LanguageVersion Natural   deriving stock (Eq, Ord) @@ -126,8 +128,9 @@ syntaxProfileSupportsFeature :: SyntaxProfile -> LanguageFeature -> Bool syntaxProfileSupportsFeature SyntaxProfile {profileFeatures} feature = Set.member feature profileFeatures --- | One independently selectable runtime behavior in a released language--- contract.  Constructors are append-only: registry profiles are monotone, and+-- | One independently selectable runtime behavior in a registered language+-- contract. Constructors shipped in a release are append-only; the active+-- pre-release candidate may be corrected in place before that boundary. -- 'capabilityFoldSegment' must make an explicit fingerprint decision for every -- new constructor. data RuntimeCapability@@ -135,6 +138,9 @@   | NominalEqualityV2   | ContractIdDomainTypeIdV7   | StrictSpecSurfaceValidation+  | ProjectionCatalogRuntime+  | TypedDomainCommandOutcomes+  | SeparatedProjectionQueryPolicy   deriving stock (Eq, Ord, Show, Enum, Bounded)  -- | An immutable, explicitly named set of runtime capabilities.  The@@ -161,6 +167,9 @@ capabilityFoldSegment NominalEqualityV2 = Just "semantic-contract:keiro-dsl/runtime-semantics/2" capabilityFoldSegment ContractIdDomainTypeIdV7 = Nothing capabilityFoldSegment StrictSpecSurfaceValidation = Nothing+capabilityFoldSegment ProjectionCatalogRuntime = Just "semantic-contract:keiro-dsl/projection-catalog/1"+capabilityFoldSegment TypedDomainCommandOutcomes = Nothing+capabilityFoldSegment SeparatedProjectionQueryPolicy = Nothing  runtimeProfileFoldSegments :: RuntimeSemanticsProfile -> [Text] runtimeProfileFoldSegments RuntimeSemanticsProfile {runtimeSemanticsCapabilities} =@@ -177,13 +186,24 @@ data LanguageSupport   = CompatibilityOnly   | Stable+  | Candidate   deriving stock (Eq, Ord, Show, Enum, Bounded)  languageSupportText :: LanguageSupport -> Text languageSupportText CompatibilityOnly = "compatibility-only" languageSupportText Stable = "stable"+languageSupportText Candidate = "candidate" --- | One append-only released-language registry entry.+-- | Whether a recognized contract has crossed the external compatibility+-- boundary. The active candidate is accepted for development and authoring,+-- but may still be corrected in place until it is published.+data LanguageMaturity+  = PublishedLanguage+  | CandidateLanguage+  deriving stock (Eq, Ord, Show)++-- | One language-registry entry. Published entries are immutable; an active+-- pre-release candidate is not a published compatibility contract yet. data LanguageDefinition = LanguageDefinition   { definitionVersion :: !LanguageVersion,     definitionPredecessor :: !(Maybe LanguageVersion),@@ -192,7 +212,8 @@     definitionBodyParser :: !LanguageBodyParser,     definitionSyntaxProfile :: !SyntaxProfile,     definitionRuntimeSemanticsProfile :: !RuntimeSemanticsProfile,-    definitionSupport :: !LanguageSupport+    definitionSupport :: !LanguageSupport,+    definitionMaturity :: !LanguageMaturity   }   deriving stock (Eq, Show, Generic) @@ -213,13 +234,18 @@ version4 :: LanguageVersion version4 = LanguageVersion 4 --- | The authoritative, append-only registry of released language contracts.+version5 :: LanguageVersion+version5 = LanguageVersion 5++-- | The authoritative registry of recognized language contracts. Published+-- entries are append-only; any future pre-release candidate is amended in place. languageRegistry :: NonEmpty LanguageDefinition languageRegistry =-  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 profileV3 runtimeProfileV3 Stable+  LanguageDefinition version1 Nothing LanguageBodyParserV1 profileV1 runtimeProfileV1 CompatibilityOnly PublishedLanguage+    :| [ LanguageDefinition version2 (Just version1) LanguageBodyParserV2 profileV2 runtimeProfileV1 CompatibilityOnly PublishedLanguage,+         LanguageDefinition version3 (Just version2) LanguageBodyParserV2 profileV2 runtimeProfileV2 CompatibilityOnly PublishedLanguage,+         LanguageDefinition version4 (Just version3) LanguageBodyParserV2 profileV3 runtimeProfileV3 CompatibilityOnly PublishedLanguage,+         LanguageDefinition version5 (Just version4) LanguageBodyParserV2 profileV4 runtimeProfileV4 Stable PublishedLanguage        ]  profileV1 :: SyntaxProfile@@ -246,6 +272,24 @@         (profileFeatures profileV2)     ) +profileV4 :: SyntaxProfile+profileV4 =+  SyntaxProfile+    "keiro-dsl/syntax-profile/4"+    ( Set.insert+        SeparatedProjectionQueryPolicySyntax+        ( Set.insert+            DeclarativeRouterSelectionSyntax+            ( Set.insert+                DomainCommandOutcomeSyntax+                ( Set.insert+                    MappedConsumerSurfaceSyntax+                    (Set.insert ExternalReadContractSyntax (Set.insert ProjectionCatalogSyntax (profileFeatures profileV3)))+                )+            )+        )+    )+ runtimeProfileV1 :: RuntimeSemanticsProfile runtimeProfileV1 =   RuntimeSemanticsProfile@@ -270,17 +314,36 @@         ]     ) +runtimeProfileV4 :: RuntimeSemanticsProfile+runtimeProfileV4 =+  RuntimeSemanticsProfile+    "keiro-dsl/runtime-semantics/4"+    ( Set.insert+        SeparatedProjectionQueryPolicy+        (Set.insert TypedDomainCommandOutcomes (Set.insert ProjectionCatalogRuntime (runtimeSemanticsCapabilities runtimeProfileV3)))+    )+ -- | Supported versions, derived from 'languageRegistry'. supportedLanguageVersions :: NonEmpty LanguageVersion supportedLanguageVersions = definitionVersion <$> languageRegistry --- | The one registry entry recommended for newly-authored sources.+-- | The one published registry entry recommended for stable sources. currentStableLanguageVersion :: LanguageVersion currentStableLanguageVersion =   case [definitionVersion definition | definition <- NE.toList languageRegistry, definitionSupport definition == Stable] of     [version] -> version     _ -> error "keiro-dsl internal invariant: language registry must contain exactly one stable version" +-- | The language selected for newly-authored sources on this development+-- branch. One active candidate takes precedence without pretending it has been+-- published; otherwise authoring falls back to the published stable contract.+currentAuthoringLanguageVersion :: LanguageVersion+currentAuthoringLanguageVersion =+  case [definitionVersion definition | definition <- NE.toList languageRegistry, definitionMaturity definition == CandidateLanguage] of+    [] -> currentStableLanguageVersion+    [version] -> version+    _ -> error "keiro-dsl internal invariant: language registry must contain at most one candidate version"+ languageSupportForVersion :: LanguageVersion -> Maybe LanguageSupport languageSupportForVersion version = definitionSupport <$> lookupLanguageDefinition version @@ -297,6 +360,12 @@   | TypedAggregateExpressionSyntax   | ExplicitTransitionImplementationSyntax   | FieldAliasSyntax+  | ProjectionCatalogSyntax+  | ExternalReadContractSyntax+  | MappedConsumerSurfaceSyntax+  | DomainCommandOutcomeSyntax+  | DeclarativeRouterSelectionSyntax+  | SeparatedProjectionQueryPolicySyntax   deriving stock (Eq, Ord, Show)  -- | The first released contract that owns each grammar feature.@@ -403,9 +472,31 @@         "misplaced language preamble; it must be the first significant clause before `context`"       LanguageFeatureRequiresVersion ->         "selected syntax requires keiro-dsl language version "-          <> languageVersionText (NE.last (sourceLanguageSupportedVersions diagnostic))+          <> languageVersionText requiredVersion           <> "; selected version "           <> maybe token languageVersionText (sourceLanguageDeclaredVersion diagnostic)+        where+          requiredVersion =+            case reverse publishedCompatibilityVersions of+              latestCompatibility : _ -> latestCompatibility+              [] -> case reverse publishedVersions of+                latestPublished : _ -> latestPublished+                [] -> NE.last (sourceLanguageSupportedVersions diagnostic)+          supportedDefinitions =+            [ (version, definition)+            | version <- NE.toList (sourceLanguageSupportedVersions diagnostic),+              Just definition <- [lookupLanguageDefinition version]+            ]+          publishedVersions =+            [version | (version, definition) <- supportedDefinitions, definitionMaturity definition == PublishedLanguage]+          -- Released compatibility diagnostics are byte-stable. Publishing a+          -- successor must not rewrite the predecessor version they recommend.+          publishedCompatibilityVersions =+            [ version+            | (version, definition) <- supportedDefinitions,+              definitionMaturity definition == PublishedLanguage,+              definitionSupport definition == CompatibilityOnly+            ]  -- | A parsed document with its source declaration preserved beside its graph. data ParsedSource = ParsedSource

src/Keiro/Dsl/Manifest.hs view

@@ -17,7 +17,8 @@ --   * intake/emit/publisher (full integration path) --                         => effectful-core, hasql-transaction, keiro, kiroku-store --                                                          (…-intake-full)---   * workqueue           => aeson, keiro-core, keiro-pgmq, text+--   * workqueue           => aeson, keiro-core, keiro-pgmq, text, plus containers/time+--                            when candidate payload expressions use Map/Time --                                                          (…-queue, …-queue-runtime) --   * dispatch            => aeson, effectful-core, keiro-pgmq, text --                                                          (…-dispatch-full)@@ -44,10 +45,10 @@ import Keiro.Dsl.GeneratedHaskellLanguage (generatedHaskellDefaultExtensions, generatedHaskellDefaultLanguage) import Keiro.Dsl.Grammar import Keiro.Dsl.IdDomain (contractIdDomainContractFor)-import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), consumerPlan)+import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), consumerPlanForService) import Keiro.Dsl.NominalType import Keiro.Dsl.Scaffold (ScaffoldModule (..))-import Keiro.Dsl.SemanticContract (CheckedService (..), legacyCheckedService)+import Keiro.Dsl.SemanticContract (CheckedService, checkedLanguageContract, checkedSpec, checkedTypeGraph, legacyCheckedService)  -- | Render a Cabal-pasteable manifest from the modules a scaffold run produced -- plus the node kinds present (which imply the dependency set). The first argument@@ -87,8 +88,7 @@       ++ map ("    , " <>) (manifestDependenciesForService service)       ++ consumerBlocks   where-    spec = checkedSpec service-    plan = consumerPlan spec+    plan = consumerPlanForService service     moduleNames = sort (map (moduleNameOf . modulePath) mods)     otherModules = case facadeModule of       Nothing -> moduleNames@@ -120,23 +120,28 @@  manifestDependenciesForService :: CheckedService -> [Text] manifestDependenciesForService service =-  sort (nub ("base" : consumerPackages (consumerPlan spec) <> concatMap (depsForNode service spec) (specNodes spec)))+  sort (nub ("base" : consumerPackages (consumerPlanForService service) <> concatMap (depsForNode service) (specNodes spec)))   where     spec = checkedSpec service  -- | The dependencies a single node kind implies (see the module header table).-depsForNode :: CheckedService -> Spec -> Node -> [Text]-depsForNode service spec n = case n of-  NAggregate aggregate -> ["aeson", "keiki", "keiro", "text"] <> aggregateDependencies spec aggregate+depsForNode :: CheckedService -> Node -> [Text]+depsForNode service n = case n of+  NAggregate aggregate -> ["aeson", "keiki", "keiro", "text"] <> aggregateDependencies service aggregate   NProcess {} -> ["aeson", "keiki", "keiro", "shibuya-core", "text", "time", "uuid"]   NRouter {} -> ["effectful-core", "keiro", "shibuya-core", "text"]   NContract contract -> ["aeson", "text"] <> [dependency | hasTypedContractId contract, dependency <- ["keiro-core", "mmzk-typeid"]]   NIntake {} -> integration   NEmit {} -> integration   NPublisher {} -> integration-  NWorkqueue {} -> ["aeson", "keiro-core", "keiro-pgmq", "text"]+  NWorkqueue workqueue -> ["aeson", "keiro-core", "keiro-pgmq", "text"] <> workqueueDependencies workqueue   NPgmqDispatch {} -> ["aeson", "effectful-core", "keiro-pgmq", "text"]-  NReadModel {} -> ["effectful-core", "hasql-transaction", "keiro", "kiroku-store", "text"]+  NReadModel readModel -> ["effectful-core", "hasql-transaction", "keiro", "kiroku-store", "text"] <> readModelDependencies readModel+  NProjectionTarget {} -> ["keiro", "kiroku-store", "text"]+  NRebuildGroup {} -> ["keiro", "kiroku-store", "text"]+  NProjectionRevision {} -> ["containers", "hasql-transaction", "keiro", "kiroku-store", "text"]+  NExternalRead {} -> ["keiro"]+  NProjectionOwner {} -> ["keiro", "kiroku-store", "text"]   NWorkflow {} -> ["containers", "effectful-core", "keiro", "text"]   NOperation {} -> ["effectful-core", "keiro", "text"]   where@@ -149,8 +154,49 @@           CTypeId prefix <- [cfType field]         ] -aggregateDependencies :: Spec -> Aggregate -> [Text]-aggregateDependencies spec aggregate =+workqueueDependencies :: WorkqueueNode -> [Text]+workqueueDependencies workqueue =+  ["containers" | any (typeExprUses isMap) expressions]+    <> ["time" | any (typeExprUses isTime) expressions]+  where+    expressions = [expression | field <- wqPayload workqueue, TypedQueueExpression expression <- [wqfType field]]+    isMap (TMap _) = True+    isMap _ = False+    isTime TTime = True+    isTime _ = False+    typeExprUses predicate expression =+      predicate expression+        || case expression of+          TOptional value -> typeExprUses predicate value+          TList value -> typeExprUses predicate value+          TMap value -> typeExprUses predicate value+          _ -> False++readModelDependencies :: ReadModelNode -> [Text]+readModelDependencies readModel =+  ["aeson" | any (typeExprUses isJson) expressions]+    <> ["containers" | any (typeExprUses isMap) expressions]+    <> ["time" | any (typeExprUses isTime) expressions]+  where+    expressions = case queryTypes readModel of+      Nothing -> []+      Just queryPair -> [input queryPair, result queryPair]+    isJson TJson = True+    isJson _ = False+    isMap TMap {} = True+    isMap _ = False+    isTime TTime = True+    isTime _ = False+    typeExprUses predicate expression =+      predicate expression+        || case expression of+          TOptional value -> typeExprUses predicate value+          TList value -> typeExprUses predicate value+          TMap value -> typeExprUses predicate value+          _ -> False++aggregateDependencies :: CheckedService -> Aggregate -> [Text]+aggregateDependencies service aggregate =   Set.toAscList     ( Set.unions         [ aggregatePackages symbols resolvedType@@ -164,7 +210,8 @@           ]     )   where-    symbols = aggregateSymbols spec+    spec = checkedSpec service+    symbols = aggregateSymbolsFromGraphResult (checkedTypeGraph service) spec     resolvedTypes =       [ resolvedType       | register <- aggRegs aggregate,

+ src/Keiro/Dsl/MappedCodecPlan.hs view

@@ -0,0 +1,136 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++-- | Pure lowering plan shared by persisted mapped consumers. The graph is the+-- only schema authority; this module merely plans a consumer type and renders+-- Aeson expressions for either consumer values or generated structural shapes.+module Keiro.Dsl.MappedCodecPlan+  ( MappedAuthorityMode (..),+    MappedReferenceBoundary (..),+    MappedCodecPlan (..),+    MappedCodecPlanError (..),+    planMappedCodec,+    renderMappedEncode,+    renderMappedParse,+  )+where++import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Keiro.Dsl.ConsumerTypePlan+import Keiro.Dsl.TypeGraph++data MappedAuthorityMode+  = PrimitiveAuthority+  | ExplicitJsonAuthority+  | StructuralAuthority !MappedKey+  | OpaqueAuthority !MappedKey+  deriving stock (Eq, Ord, Show)++-- | A consumer root crosses a declared total binding for structural+-- references. A structural-shape field is already on the generated side of+-- that binding and therefore calls the nested shape codec directly.+data MappedReferenceBoundary+  = ConsumerValueBoundary+  | StructuralShapeBoundary+  deriving stock (Eq, Ord, Show)++data MappedCodecPlan = MappedCodecPlan+  { consumerType :: !ConsumerTypePlan,+    resolvedExpression :: !ResolvedTypeExpr,+    authority :: !(Set MappedAuthorityMode)+  }+  deriving stock (Eq, Show)++newtype MappedCodecPlanError+  = MappedCodecConsumerTypeError ConsumerTypePlanError+  deriving stock (Eq, Show)++planMappedCodec :: TypeGraph -> ResolvedTypeExpr -> Either MappedCodecPlanError MappedCodecPlan+planMappedCodec graph expression = do+  plannedType <- either (Left . MappedCodecConsumerTypeError) Right (planConsumerType graph expression)+  pure+    MappedCodecPlan+      { consumerType = plannedType,+        resolvedExpression = expression,+        authority = foldTypeExpr authorityAlgebra expression+      }+  where+    authorityAlgebra =+      TypeExprAlgebra+        { onText = Set.singleton PrimitiveAuthority,+          onInt = Set.singleton PrimitiveAuthority,+          onInteger = Set.singleton PrimitiveAuthority,+          onBool = Set.singleton PrimitiveAuthority,+          onNatural = Set.singleton PrimitiveAuthority,+          onTime = Set.singleton PrimitiveAuthority,+          onJson = Set.singleton ExplicitJsonAuthority,+          onOptional = id,+          onList = id,+          onMap = id,+          onRef = \key -> case Map.lookup key (tgDeclarations graph) of+            Just ResolvedStructural {} -> Set.singleton (StructuralAuthority key)+            Just ResolvedOpaque {} -> Set.singleton (OpaqueAuthority key)+            Nothing -> Set.empty+        }++renderMappedEncode :: TypeGraph -> MappedReferenceBoundary -> MappedCodecPlan -> Text -> Text+renderMappedEncode graph boundary plan value =+  foldTypeExpr+    TypeExprAlgebra+      { onText = primitive,+        onInt = primitive,+        onInteger = primitive,+        onBool = primitive,+        onNatural = primitive,+        onTime = primitive,+        onJson = id,+        onOptional = \encode candidate -> "maybe Null (\\item -> " <> encode "item" <> ") (" <> candidate <> ")",+        onList = \encode candidate -> "toJSON (map (\\item -> " <> encode "item" <> ") (" <> candidate <> "))",+        onMap = \encode candidate -> "toJSON (Map.map (\\item -> " <> encode "item" <> ") (" <> candidate <> "))",+        onRef = encodeReference+      }+    (resolvedExpression plan)+    value+  where+    primitive candidate = "toJSON (" <> candidate <> ")"+    encodeReference key candidate = case Map.lookup key (tgDeclarations graph) of+      Just (ResolvedStructural declaration _) ->+        "encode" <> sdName declaration <> suffix <> argument candidate+      Just ResolvedOpaque {} -> case boundary of+        ConsumerValueBoundary -> "toJSON " <> candidate+        StructuralShapeBoundary -> primitive candidate+      Nothing -> primitive candidate+    argument candidate = case boundary of+      ConsumerValueBoundary -> " " <> candidate+      StructuralShapeBoundary -> " (" <> candidate <> ")"+    suffix = case boundary of+      ConsumerValueBoundary -> "Mapped"+      StructuralShapeBoundary -> "Shape"++renderMappedParse :: TypeGraph -> MappedReferenceBoundary -> MappedCodecPlan -> Text+renderMappedParse graph boundary plan =+  foldTypeExpr+    TypeExprAlgebra+      { onText = "parseJSON",+        onInt = "parseJSON",+        onInteger = "parseJSON",+        onBool = "parseJSON",+        onNatural = "parseJSON",+        onTime = "parseJSON",+        onJson = "pure",+        onOptional = \decode -> "\\value -> case value of Null -> pure Nothing; other -> Just <$> " <> decode <> " other",+        onList = \decode -> "\\value -> (parseJSON value :: Parser [Value]) >>= traverse (" <> decode <> ")",+        onMap = \decode -> "\\value -> (parseJSON value :: Parser (Map Text Value)) >>= traverse (" <> decode <> ")",+        onRef = parseReference+      }+    (resolvedExpression plan)+  where+    parseReference key = case Map.lookup key (tgDeclarations graph) of+      Just (ResolvedStructural declaration _) -> "parse" <> sdName declaration <> suffix+      Just ResolvedOpaque {} -> "parseJSON"+      Nothing -> "parseJSON"+    suffix = case boundary of+      ConsumerValueBoundary -> "Mapped"+      StructuralShapeBoundary -> "Shape"

src/Keiro/Dsl/MappedConsumer.hs view

@@ -6,6 +6,7 @@   ( ConsumerPlan (..),     MappingIdentity (..),     consumerPlan,+    consumerPlanForService,   ) where @@ -17,6 +18,7 @@ import Data.Text qualified as T import Keiro.Dsl.Grammar (HaskellSource (..), Spec) import Keiro.Dsl.NominalType+import Keiro.Dsl.SemanticContract (CheckedService, checkedSpec, checkedTypeGraph, legacyCheckedService) import Keiro.Dsl.TypeGraph  data ConsumerPlan = ConsumerPlan@@ -141,7 +143,10 @@           _ -> fail "unknown mapping identity mode"  consumerPlan :: Spec -> ConsumerPlan-consumerPlan spec = case (resolveTypeGraph spec, resolveNominalTypes spec) of+consumerPlan = consumerPlanForService . legacyCheckedService++consumerPlanForService :: CheckedService -> ConsumerPlan+consumerPlanForService service = case (checkedTypeGraph service, resolveNominalTypes spec) of   (Right graph, Right nominalRegistry) ->     ConsumerPlan       { consumerPackages = uniqueSorted ([hsPackage (mappedSource declaration) | declaration <- declarations] <> map nominalPackage nominalBindings),@@ -156,6 +161,8 @@           ConsumerNominal binding <- [resolvedNominalOwnership nominal]         ]   _ -> ConsumerPlan [] [] []+  where+    spec = checkedSpec service  mappedSource :: ResolvedMappedDecl -> HaskellSource mappedSource (ResolvedStructural declaration _) = sdHaskell declaration

src/Keiro/Dsl/NominalType.hs view

@@ -41,7 +41,7 @@ import Keiro.Dsl.HaskellName (haskellKeywords) import Keiro.Dsl.IdDomain (enforcedIdDomainVersion) import Keiro.Dsl.LanguageVersion (RuntimeCapability (..), runtimeProfileHasCapability)-import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveRuntimeProfile)+import Keiro.Dsl.SemanticContract (CheckedService, EffectiveLanguageContract, checkedLanguageContract, checkedSpec, effectiveRuntimeProfile) import Keiro.Dsl.TypeGraph  data NominalScalarRepresentation@@ -383,6 +383,11 @@   NWorkqueue value -> ("workqueue", wqName value, wqLoc value)   NPgmqDispatch value -> ("dispatch", pdName value, pdLoc value)   NReadModel value -> ("readmodel", rmName value, rmLoc value)+  NProjectionTarget value -> ("target", ptName value, ptLoc value)+  NRebuildGroup value -> ("rebuild-group", rgName value, rgLoc value)+  NProjectionRevision value -> ("projection-revision", prvName value, prvLoc value)+  NExternalRead value -> ("external-read", externalReadNodeIdentity value, erLoc value)+  NProjectionOwner value -> ("projection-owner", poName value, poLoc value)   NWorkflow value -> ("workflow", wfId value, workflowNodeLoc value)   NOperation value -> ("operation", opName value, opLoc value)

src/Keiro/Dsl/Parser.hs view

@@ -3,6 +3,8 @@   ( ParseError,     ParseFailure (..),     ParsedSource (..),+    ParsedSourceDocument (..),+    parseSourceDocument,     parseSource,     parseSpec,     parseSpecText,@@ -12,13 +14,14 @@  import Data.Bifunctor (first) import Data.Text (Text)-import Keiro.Dsl.Frontend (lowerSurfaceSource, parseSurfaceSource)+import Keiro.Dsl.Frontend (lowerSurfaceDocument, lowerSurfaceSource, parseSurfaceSource) import Keiro.Dsl.Frontend.Internal   ( frontendCompatibilityFailure,     frontendFailureFromLowering,   ) import Keiro.Dsl.Grammar (Spec) import Keiro.Dsl.LanguageVersion+import Keiro.Dsl.SourceIndex (ParsedSourceDocument (..))  -- | A rendered, line-numbered parse error, ready to print to the user. type ParseError = Text@@ -37,3 +40,10 @@ parseSource sourceName input = do   surface <- first frontendCompatibilityFailure (parseSurfaceSource sourceName input)   first (frontendCompatibilityFailure . frontendFailureFromLowering) (lowerSurfaceSource surface)++-- | Parse a source once, retaining both semantic data and exact source+-- provenance.+parseSourceDocument :: FilePath -> Text -> Either ParseFailure ParsedSourceDocument+parseSourceDocument sourceName input = do+  surface <- first frontendCompatibilityFailure (parseSurfaceSource sourceName input)+  first (frontendCompatibilityFailure . frontendFailureFromLowering) (lowerSurfaceDocument surface)

src/Keiro/Dsl/Parser/Aggregate.hs view

@@ -24,17 +24,27 @@   | BIWire WireSpec   | BIProjection ProjectionSpec   | BISnapshot SnapshotSpec-  | BITransition Transition [Located SurfaceElement]+  | BITransition (Located Transition) [Located SurfaceElement]  pAggregate :: FrontendContext -> P (Aggregate, [Located SurfaceElement]) pAggregate context = do   loc <- getLoc   keyword "aggregate"   name <- ident+  outcomeDeclarations <- many (pDomainOutcomeTypes context)   regs <- pRegsBlock context-  states <- pStatesLine+  locatedStates <- pStatesLine   positionedItems <- many ((,) <$> getOffset <*> pBodyItem context)   let items = map snd positionedItems+      transitions = [transition | BITransition transition _ <- items]+      stateElements =+        [ mapLocated (SurfaceAggregateState name . stName) locatedState+        | locatedState <- locatedStates+        ]+      transitionElements =+        [ mapLocated (const (SurfaceAggregateTransition name ordinal)) transition+        | (ordinal, transition) <- zip [0 ..] transitions+        ]       wireOffsets = [offset | (offset, BIWire _) <- positionedItems]       projectionOffsets = [offset | (offset, BIProjection _) <- positionedItems]       snapshotOffsets = [offset | (offset, BISnapshot _) <- positionedItems]@@ -54,16 +64,20 @@     ( Aggregate         { aggName = name,           aggRegs = regs,-          aggStates = states,+          aggStates = map locatedValue locatedStates,           aggCommands = [c | BICommand c _ <- items],           aggEvents = [e | BIEvent e _ <- items],-          aggTransitions = [t | BITransition t _ <- items],+          aggTransitions = map locatedValue transitions,+          aggDomainOutcomeTypes = case outcomeDeclarations of+            declaration : _ -> Just declaration+            [] -> Nothing,+          aggDomainOutcomeDuplicateLocs = map outcomeTypesLoc (drop 1 outcomeDeclarations),           aggWire = listToMaybe [w | BIWire w <- items],           aggProjection = listToMaybe [p | BIProjection p <- items],           aggSnapshot = listToMaybe [s | BISnapshot s <- items],           aggLoc = loc         },-      concatMap bodyElements items+      stateElements <> transitionElements <> concatMap bodyElements items     )   where     listToMaybe xs = case xs of (x : _) -> Just x; [] -> Nothing@@ -75,6 +89,22 @@       BIProjection _ -> []       BISnapshot _ -> [] +pDomainOutcomeTypes :: FrontendContext -> P DomainOutcomeTypes+pDomainOutcomeTypes context = do+  loc <- getLoc+  marker <- withOwnedSpan (keyword "domain-outcomes")+  requireLanguageFeatureAt context DomainCommandOutcomeSyntax (spanOf marker)+  _ <- symbol "rejection" *> symbol "="+  rejection <- ident+  _ <- symbol "no-op" *> symbol "="+  noOp <- ident+  pure+    DomainOutcomeTypes+      { rejectionType = rejection,+        noOpType = noOp,+        outcomeTypesLoc = loc+      }+ pRegsBlock :: FrontendContext -> P [RegDecl] pRegsBlock context = do   keyword "regs"@@ -89,10 +119,10 @@   initial <- (RegInitText <$> stringLit) <|> (RegInitBare <$> (ident <|> signedDecimalText))   pure RegDecl {regName = name, regType = ty, regInitial = initial, regLoc = loc} -pStatesLine :: P [StateDecl]+pStatesLine :: P [Located StateDecl] pStatesLine = do   keyword "states"-  many pStateDecl+  many (withOwnedSpan pStateDecl)   where     -- A state decl is an identifier with an optional terminal @!@. The     -- @notFollowedBy@ lookahead stops the list before a transition whose source@@ -117,9 +147,12 @@     [ uncurry BICommand <$> pCommand context,       uncurry BIEvent <$> pEvent context,       BIWire <$> pWire,-      BIProjection <$> pProjection,+      BIProjection <$> pProjection context,       BISnapshot <$> pSnapshot,-      uncurry BITransition <$> pTransition context+      do+        located <- withOwnedSpan (pTransition context)+        let (_, elements) = locatedValue located+        pure (BITransition (mapLocated fst located) elements)     ]  pSnapshot :: P SnapshotSpec@@ -225,12 +258,20 @@   v <- boundedDecimal   pure WireSpec {wireKind = k, wireFields = f, wireSchemaVersion = v} -pProjection :: P ProjectionSpec-pProjection = do+pProjection :: FrontendContext -> P ProjectionSpec+pProjection context = do   loc <- getLoc   keyword "projection"   table <- ident-  cons <- optional (symbol "consistency" *> symbol "=" *> pConsistency)+  cons <-+    if frontendSupportsFeature context SeparatedProjectionQueryPolicySyntax+      then do+        startOffset <- getOffset+        legacyConsistency <- optional (lookAhead (keyword "consistency"))+        case legacyConsistency of+          Just _ -> failAt startOffset "Language 5 aggregate projections do not declare consistency; put `freshness` on the referenced readmodel"+          Nothing -> pure Nothing+      else optional (symbol "consistency" *> symbol "=" *> pConsistency)   _ <- symbol "key"   _ <- symbol "="   k <- ident@@ -268,6 +309,7 @@   = CGuard Expr   | CWrite Name Expr   | CEmit Name+  | COutcome TransitionOutcome   | CGoto Name   | CImplementationHole @@ -287,6 +329,7 @@       elements = concatMap (snd . snd) positionedClauses       gotos = [(offset, target) | (offset, (CGoto target, _)) <- positionedClauses]       holeOffsets = [offset | (offset, (CImplementationHole, _)) <- positionedClauses]+      outcomes = [(offset, outcome) | (offset, (COutcome outcome, _)) <- positionedClauses]       transitionName = T.unpack src <> " -- " <> T.unpack cmd   gt <- case gotos of     [] -> failAt startOffset ("transition " <> transitionName <> " is missing a goto clause")@@ -310,6 +353,10 @@           tGuard = case guards of [] -> Nothing; es -> Just (foldr1 EAnd es),           tWrites = [(r, e) | CWrite r e <- clauses],           tEmits = [n | CEmit n <- clauses],+          tOutcome = case outcomes of+            (_, outcome) : _ -> Just outcome+            [] -> Nothing,+          tOutcomeDuplicateLocs = map (transitionOutcomeLoc . snd) (drop 1 outcomes),           tGoto = gt,           tMode = mode,           tLoc = loc@@ -321,6 +368,36 @@ pClause context =   choice     [ do+        loc <- getLoc+        let outcomeSelectors :: [(T.Text, P (Clause, [Located SurfaceElement]))]+            outcomeSelectors =+              [ ("accepted", pure (COutcome (OutcomeAccepted loc), [])),+                ( "rejected",+                  do+                    expression <- withOwnedSpan (pExpr context)+                    pure (COutcome (OutcomeRejected (locatedValue expression) loc), [mapLocated SurfaceExpression expression])+                ),+                ( "no-op",+                  do+                    expression <- withOwnedSpan (pExpr context)+                    pure (COutcome (OutcomeNoOp (locatedValue expression) loc), [mapLocated SurfaceExpression expression])+                )+              ]+        -- @outcome@ is a contextual keyword, never reserved (plan 233, completing+        -- plan 232's decision for accepted/rejected/no-op): claim it only when one+        -- of the three selectors follows, so @outcome@ stays a legal identifier in+        -- every language -- including a transition source named @outcome@, whose+        -- next token is @--@.+        marker <-+          withOwnedSpan+            ( try+                ( keyword "outcome"+                    <* lookAhead (choice [keyword name | (name, _) <- outcomeSelectors])+                )+            )+        requireLanguageFeatureAt context DomainCommandOutcomeSyntax (spanOf marker)+        choice [keyword name *> handler | (name, handler) <- outcomeSelectors],+      do         marker <- withOwnedSpan (keyword "implementation" *> keyword "hole")         requireLanguageFeatureAt context ExplicitTransitionImplementationSyntax (spanOf marker)         pure (CImplementationHole, []),

src/Keiro/Dsl/Parser/Coordination.hs view

@@ -8,8 +8,13 @@ import Data.List (intersperse) import Data.Text (Text) import Data.Text qualified as T+import Keiro.Dsl.Frontend.Internal (FrontendContext) import Keiro.Dsl.Grammar+import Keiro.Dsl.LanguageVersion (LanguageFeature (DeclarativeRouterSelectionSyntax)) import Keiro.Dsl.Parser.Core+import Keiro.Dsl.Parser.Expression (pExpr)+import Keiro.Dsl.Parser.Mapped (pMappedTypeExpr)+import Keiro.Dsl.Source (SourceSpan) import Text.Megaparsec import Text.Megaparsec.Char (char) @@ -50,16 +55,22 @@         procLoc = loc       } -pRouter :: P RouterNode-pRouter = do+pRouter :: FrontendContext -> P RouterNode+pRouter context = do   loc <- getLoc   keyword "router"   rid <- ident   keyword "name"   nm <- stringLit-  inp <- pInputDecl-  key <- pRouterKey-  resolved <- pResolveDecl+  (inp, typedInputSpan) <- pRouterInputDecl context+  key <- pRouterKey (maybe False (const True) typedInputSpan)+  resolved <- pResolveDecl context+  case (typedInputSpan, rvSource resolved) of+    (Just _, ResolveDeclarative {}) -> pure ()+    (Nothing, ResolveReadModel {}) -> pure ()+    (Nothing, ResolveHole) -> pure ()+    (Just _, _) -> fail "typed router input requires declarative selection"+    (Nothing, ResolveDeclarative {}) -> fail "declarative selection requires a typed router input"   keyword "target"   target <- ident   projections <- keyword "projections" *> brackets (many ident)@@ -82,19 +93,22 @@         rtLoc = loc       } -pRouterKey :: P CorrelateDecl-pRouterKey = do+pRouterKey :: Bool -> P CorrelateDecl+pRouterKey declarative = do   keyword "key"   _ <- keyword "input" *> symbol "."   field <- ident-  keyword "via"-  via <- ident+  via <- if declarative then pure "idText" else keyword "via" *> ident   pure CorrelateDecl {corrField = field, corrVia = via} -pResolveDecl :: P ResolveDecl-pResolveDecl = do+pResolveDecl :: FrontendContext -> P ResolveDecl+pResolveDecl context = do   loc <- getLoc   keyword "resolve"+  choice [pDeclarativeResolve context loc, pCustomResolve loc]++pCustomResolve :: Loc -> P ResolveDecl+pCustomResolve loc = do   keyword "stable"   keyword "via"   source <- choice [ResolveReadModel <$> (keyword "read-model" *> ident), ResolveHole <$ keyword "hole"]@@ -102,6 +116,93 @@   row <- braces (many ident)   pure ResolveDecl {rvSource = source, rvRow = row, rvLoc = loc} +pDeclarativeResolve :: FrontendContext -> Loc -> P ResolveDecl+pDeclarativeResolve context loc = do+  marker <- withOwnedSpan (keyword "declarative")+  requireLanguageFeatureAt context DeclarativeRouterSelectionSyntax (spanOf marker)+  selection <- braces (pRouterSelection context loc)+  pure ResolveDecl {rvSource = ResolveDeclarative selection, rvRow = [], rvLoc = loc}++pRouterSelection :: FrontendContext -> Loc -> P RouterSelectionDecl+pRouterSelection context loc = do+  (identity, identityLoc) <- locatedClause "identity" stringLit+  (version, versionLoc) <- locatedClause "version" (fromIntegral <$> boundedDecimal)+  queryLoc <- getLoc+  keyword "query"+  _ <- symbol "=" *> keyword "read-model"+  query <- ident+  keyword "with"+  queryInputLoc <- getLoc+  queryInput <- ident+  keyword "where"+  _ <- symbol "="+  predicate <- pExpr context+  keyword "recipient"+  _ <- symbol "="+  recipient <- pExpr context+  (order, orderLoc) <- locatedClause "order" pSelectionPolicyName+  (dedupe, dedupeLoc) <- locatedClause "dedupe" pSelectionPolicyName+  recipientLimit <- optional $ try $ do+    (limit, limitLoc) <- locatedClause "max-recipients" (fromIntegral <$> boundedDecimal)+    pure (limit, limitLoc)+  emptyPolicyLoc <- getLoc+  keyword "empty"+  _ <- symbol "=>"+  emptyPolicy <- pSelectionDisposition+  failurePolicyLoc <- getLoc+  keyword "failure"+  _ <- symbol "=>"+  failurePolicy <- pSelectionDisposition+  (redelivery, redeliveryLoc) <- locatedClause "redelivery" pSelectionPolicyName+  (partial, partialLoc) <- locatedClause "partial" pSelectionPolicyName+  pure+    RouterSelectionDecl+      { rsIdentity = identity,+        rsIdentityLoc = identityLoc,+        rsVersion = version,+        rsVersionLoc = versionLoc,+        rsQuery = query,+        rsQueryLoc = queryLoc,+        rsQueryInput = queryInput,+        rsQueryInputLoc = queryInputLoc,+        rsPredicate = predicate,+        rsRecipient = recipient,+        rsLimit = recipientLimit,+        rsOrder = order,+        rsOrderLoc = orderLoc,+        rsDedupe = dedupe,+        rsDedupeLoc = dedupeLoc,+        rsEmptyPolicy = emptyPolicy,+        rsEmptyPolicyLoc = emptyPolicyLoc,+        rsFailurePolicy = failurePolicy,+        rsFailurePolicyLoc = failurePolicyLoc,+        rsRedelivery = redelivery,+        rsRedeliveryLoc = redeliveryLoc,+        rsPartial = partial,+        rsPartialLoc = partialLoc,+        rsLoc = loc+      }++locatedClause :: Text -> P a -> P (a, Loc)+locatedClause clause parser = do+  clauseLoc <- getLoc+  keyword clause+  _ <- symbol "="+  value <- parser+  pure (value, clauseLoc)++pSelectionDisposition :: P SelectionDispositionSyntax+pSelectionDisposition =+  choice+    [ SelectionAck <$ keyword "ack",+      SelectionRetry <$ keyword "retry",+      SelectionDeadLetter <$ keyword "deadLetter",+      SelectionHalt <$ keyword "halt"+    ]++pSelectionPolicyName :: P Name+pSelectionPolicyName = T.intercalate "-" <$> ((:) <$> ident <*> many (symbol "-" *> ident))+ pRouterDispatch :: P RouterDispatchNode pRouterDispatch = do   loc <- getLoc@@ -145,10 +246,26 @@  pInputDecl :: P InputDecl pInputDecl = do+  loc <- getLoc   keyword "input"   nm <- ident   fs <- braces (many pField)-  pure InputDecl {inName = nm, inFields = fs}+  pure InputDecl {inName = nm, inFields = fs, inType = Nothing, inLoc = loc}++pRouterInputDecl :: FrontendContext -> P (InputDecl, Maybe SourceSpan)+pRouterInputDecl context = do+  loc <- getLoc+  keyword "input"+  name <- ident+  choice+    [ do+        marker <- withOwnedSpan (symbol ":")+        inputType <- pMappedTypeExpr context+        pure (InputDecl {inName = name, inFields = [], inType = Just inputType, inLoc = loc}, Just (spanOf marker)),+      do+        fields <- braces (many pField)+        pure (InputDecl {inName = name, inFields = fields, inType = Nothing, inLoc = loc}, Nothing)+    ]  pCorrelate :: P CorrelateDecl pCorrelate = do

src/Keiro/Dsl/Parser/Core.hs view

@@ -304,11 +304,8 @@   startOffset <- getOffset   startPosition <- getSourcePos   startState <- getParserState-  inputBefore <- getInput-  value <- parser-  inputAfter <- getInput-  let consumedLength = T.length inputBefore - T.length inputAfter-      ownedLength = ownedSyntaxLength (T.take consumedLength inputBefore)+  (consumed, value) <- match parser+  let ownedLength = ownedSyntaxLength consumed       endOffset = startOffset + ownedLength       endPosition = pstateSourcePos (reachOffsetNoLine endOffset (statePosState startState))       span =

src/Keiro/Dsl/Parser/Document.hs view

@@ -16,6 +16,7 @@ import Keiro.Dsl.Parser.Integration (pContract, pEmit, pIntake, pPublisher) import Keiro.Dsl.Parser.Mapped (pMappedTopItem) import Keiro.Dsl.Parser.Preamble+import Keiro.Dsl.Parser.ProjectionCatalog (pExternalRead, pProjectionOwner, pProjectionRevision, pProjectionTarget, pRebuildGroup) import Keiro.Dsl.Parser.Queue (pPgmqDispatch, pWorkqueue) import Keiro.Dsl.Parser.ReadModel (pReadModel) import Keiro.Dsl.Parser.Workflow (pOperation, pWorkflow)@@ -125,15 +126,20 @@           pure (ParsedTopItem (SurfaceRule rule) elements),         plain (pMappedTopItem context)       ]-        ++ [ plain (SurfaceNode . NRouter <$> pRouter),+        ++ [ plain (SurfaceNode . NRouter <$> pRouter context),              plain (SurfaceNode . NProcess <$> pProcess),              plain (SurfaceNode . NContract <$> pContract context),              plain (SurfaceNode . NIntake <$> pIntake),              plain (SurfaceNode . NEmit <$> pEmit),              plain (SurfaceNode . NPublisher <$> pPublisher),-             plain (SurfaceNode . NWorkqueue <$> pWorkqueue),+             plain (SurfaceNode . NWorkqueue <$> pWorkqueue context),              plain (SurfaceNode . NPgmqDispatch <$> pPgmqDispatch),-             plain (SurfaceNode . NReadModel <$> pReadModel),+             plain (SurfaceNode . NReadModel <$> pReadModel context),+             plain (SurfaceNode . NProjectionTarget <$> pProjectionTarget context),+             plain (SurfaceNode . NRebuildGroup <$> pRebuildGroup context),+             plain (SurfaceNode . NProjectionRevision <$> pProjectionRevision context),+             plain (SurfaceNode . NExternalRead <$> pExternalRead context),+             plain (SurfaceNode . NProjectionOwner <$> pProjectionOwner context),              plain (SurfaceNode . NWorkflow <$> pWorkflow),              plain (SurfaceNode . NOperation <$> pOperation),              do

src/Keiro/Dsl/Parser/Preamble.hs view

@@ -7,6 +7,7 @@ where  import Data.Char (isAscii, isDigit)+import Data.List.NonEmpty qualified as NE import Data.Text (Text) import Data.Text qualified as T import Data.Text.Read qualified as TR@@ -31,7 +32,11 @@       sourceLanguageDeclaredVersion = case code of         LanguageFeatureRequiresVersion -> Just effectiveVersion         _ -> Nothing,-      sourceLanguageSupportedVersions = supportedLanguageVersions+      sourceLanguageSupportedVersions = case contextualFailureFeature contextual of+        Nothing -> supportedLanguageVersions+        Just feature -> case NE.nonEmpty (languageVersionsSupportingFeature feature) of+          Just versions -> versions+          Nothing -> supportedLanguageVersions     }   where     code = contextualFailureCode contextual

+ src/Keiro/Dsl/Parser/ProjectionCatalog.hs view

@@ -0,0 +1,171 @@+-- | Language-5 projection catalog syntax.+module Keiro.Dsl.Parser.ProjectionCatalog+  ( pProjectionTarget,+    pRebuildGroup,+    pProjectionRevision,+    pExternalRead,+    pProjectionOwner,+  )+where++import Keiro.Dsl.Frontend.Internal (FrontendContext, frontendSupportsFeature)+import Keiro.Dsl.Grammar+import Keiro.Dsl.LanguageVersion (LanguageFeature (ExternalReadContractSyntax, ProjectionCatalogSyntax, SeparatedProjectionQueryPolicySyntax))+import Keiro.Dsl.Parser.Core+import Text.Megaparsec++pProjectionTarget :: FrontendContext -> P ProjectionTargetNode+pProjectionTarget context = do+  loc <- getLoc+  marker <- withOwnedSpan (keyword "target")+  requireLanguageFeatureAt context ProjectionCatalogSyntax (spanOf marker)+  name <- ident+  _ <- symbol "{"+  schema <- symbol "schema" *> symbol "=" *> stringLit+  table <- symbol "table" *> symbol "=" *> stringLit+  reset <- symbol "reset" *> symbol "=" *> pReset+  dependsOn <- option [] (try (symbol "depends-on" *> symbol "=" *> brackets (many ident)))+  _ <- symbol "}"+  pure ProjectionTargetNode {ptName = name, ptSchema = schema, ptTable = table, ptReset = reset, ptDependsOn = dependsOn, ptLoc = loc}+  where+    pReset = choice [TargetClear <$ keyword "clear", TargetPreserve <$ keyword "preserve"]++pRebuildGroup :: FrontendContext -> P RebuildGroupNode+pRebuildGroup context = do+  loc <- getLoc+  marker <- withOwnedSpan (keyword "rebuild-group")+  requireLanguageFeatureAt context ProjectionCatalogSyntax (spanOf marker)+  name <- ident+  _ <- symbol "{"+  targets <- symbol "targets" *> symbol "=" *> brackets (many ident)+  order <- symbol "order" *> symbol "=" *> brackets (many ident)+  _ <- symbol "}"+  pure RebuildGroupNode {rgName = name, rgTargets = targets, rgOrder = order, rgLoc = loc}++pProjectionRevision :: FrontendContext -> P ProjectionRevisionNode+pProjectionRevision context = do+  loc <- getLoc+  marker <- withOwnedSpan (keyword "projection-revision")+  requireLanguageFeatureAt context ProjectionCatalogSyntax (spanOf marker)+  name <- ident+  _ <- symbol "{"+  group <- symbol "group" *> symbol "=" *> ident+  revisionTargets <- many pRevisionTarget+  _ <- symbol "}"+  pure ProjectionRevisionNode {prvName = name, prvGroup = group, prvTargets = revisionTargets, prvLoc = loc}+  where+    pRevisionTarget = do+      _ <- keyword "target"+      targetName <- ident+      _ <- symbol "{"+      schemaVersion <- symbol "schema-version" *> symbol "=" *> stringLit+      provisioner <- symbol "provisioner" *> symbol "=" *> stringLit+      provisionerVersion <- symbol "provisioner-version" *> symbol "=" *> boundedDecimal+      expectedShape <- symbol "expected-shape" *> symbol "=" *> stringLit+      validator <- symbol "validator" *> symbol "=" *> stringLit+      validatorVersion <- symbol "validator-version" *> symbol "=" *> boundedDecimal+      promotionObjects <- many pPromotionObject+      _ <- symbol "}"+      pure+        RevisionTargetNode+          { prtTarget = targetName,+            prtSchemaVersion = schemaVersion,+            prtProvisioner = provisioner,+            prtProvisionerVersion = provisionerVersion,+            prtExpectedShape = expectedShape,+            prtValidator = validator,+            prtValidatorVersion = validatorVersion,+            prtPromotionObjects = promotionObjects+          }+    pPromotionObject = do+      _ <- keyword "promotion"+      objectKind <-+        choice+          [ PromotionIndexNode <$ keyword "index",+            PromotionConstraintNode <$ keyword "constraint",+            PromotionOwnedSequenceNode <$ keyword "owned-sequence"+          ]+      generationName <- stringLit+      _ <- symbol "->"+      canonicalName <- stringLit+      pure (PromotionObjectNode objectKind generationName canonicalName)++pExternalRead :: FrontendContext -> P ExternalReadNode+pExternalRead context = do+  loc <- getLoc+  marker <- withOwnedSpan (keyword "external-read")+  requireLanguageFeatureAt context ExternalReadContractSyntax (spanOf marker)+  name <- ident+  _ <- symbol "{"+  version <- symbol "version" *> symbol "=" *> boundedDecimal+  queryModel <- symbol "query" *> symbol "=" *> ident+  resultSchema <- symbol "result-schema" *> symbol "=" *> stringLit+  resultType <- symbol "result-type" *> symbol "=" *> stringLit+  compatibleRevisions <- symbol "compatible-revisions" *> symbol "=" *> brackets (many ident)+  surfaceGeneration <- symbol "surface-generation" *> symbol "=" *> boundedDecimal+  _ <- symbol "}"+  pure+    ExternalReadNode+      { erName = name,+        erVersion = version,+        erQueryModel = queryModel,+        erResultSchema = resultSchema,+        erResultType = resultType,+        erCompatibleRevisions = compatibleRevisions,+        erSurfaceGeneration = surfaceGeneration,+        erLoc = loc+      }++pProjectionOwner :: FrontendContext -> P ProjectionOwnerNode+pProjectionOwner context = do+  loc <- getLoc+  marker <- withOwnedSpan (keyword "projection-owner")+  requireLanguageFeatureAt context ProjectionCatalogSyntax (spanOf marker)+  name <- ident+  _ <- symbol "{"+  sources <- some pSource+  delivery <- pDeliveryClause+  group <- symbol "group" *> symbol "=" *> ident+  targets <- symbol "targets" *> symbol "=" *> brackets (many ident)+  ownerOrder <- symbol "order" *> symbol "=" *> boundedDecimal+  subscription <- optional (try (symbol "subscription" *> symbol "=" *> stringLit))+  dedup <- optional (try (symbol "dedup" *> symbol "=" *> stringLit))+  checkpointOnMissing <- many (try (symbol "checkpoint-on-missing") *> symbol "=" *> pCheckpointOnMissing)+  replay <- symbol "replay" *> symbol "=" *> pReplay+  _ <- symbol "}"+  pure+    ProjectionOwnerNode+      { poName = name,+        poSources = sources,+        poDelivery = delivery,+        poGroup = group,+        poTargets = targets,+        poOrder = ownerOrder,+        poSubscription = subscription,+        poDedup = dedup,+        poCheckpointOnMissing = checkpointOnMissing,+        poReplay = replay,+        poLoc = loc+      }+  where+    pSource = symbol "source" *> symbol "=" *> choice [CatalogAggregate <$> (keyword "aggregate" *> ident), CatalogCategory <$> (keyword "category" *> stringLit), CatalogAll <$ keyword "all"]+    pDeliveryClause+      | frontendSupportsFeature context SeparatedProjectionQueryPolicySyntax = do+          startOffset <- getOffset+          legacyFeed <- optional (lookAhead (keyword "feed"))+          case legacyFeed of+            Just _ -> failAt startOffset "Language 5 projection owners use `delivery = inline | subscription`; replace legacy `feed`"+            Nothing -> symbol "delivery" *> symbol "=" *> pDelivery+      | otherwise = do+          _ <- symbol "feed" *> symbol "="+          choice [DeliveryInline <$ keyword "inline", DeliverySubscription <$ keyword "subscription"]+    pDelivery = choice [DeliveryInline <$ keyword "inline", DeliverySubscription <$ keyword "subscription"]+    pCheckpointOnMissing = do+      startOffset <- getOffset+      choice+        [ CheckpointFromBeginning <$ keyword "from-beginning",+          CheckpointFromCurrentHead <$ keyword "from-current-head",+          CheckpointFail <$ keyword "fail",+          failAt startOffset "unknown checkpoint-on-missing policy; expected from-beginning, from-current-head, or fail"+        ]+    pReplay = choice [ProjectionReplayExplicit <$ keyword "explicit", ProjectionLiveOnly <$> (keyword "live-only" *> stringLit)]

src/Keiro/Dsl/Parser/Queue.hs view

@@ -5,12 +5,15 @@   ) where +import Keiro.Dsl.Frontend.Internal (FrontendContext) import Keiro.Dsl.Grammar+import Keiro.Dsl.LanguageVersion (LanguageFeature (MappedConsumerSurfaceSyntax)) import Keiro.Dsl.Parser.Core+import Keiro.Dsl.Parser.Mapped (pMappedTypeExpr) import Text.Megaparsec -pWorkqueue :: P WorkqueueNode-pWorkqueue = do+pWorkqueue :: FrontendContext -> P WorkqueueNode+pWorkqueue context = do   loc <- getLoc   keyword "workqueue"   nm <- ident@@ -89,15 +92,28 @@             pure (WqPartitioned interval retention)         ]     pWqField = do+      loc <- getLoc       n <- ident       _ <- symbol "->"       w <- stringLit-      ty <- ident+      ty <- pTypedPayload <|> pLegacyPayload       -- 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}+      pure WqField {wqfName = n, wqfWire = w, wqfType = ty, wqfLoc = loc}+    pTypedPayload = do+      marker <- withOwnedSpan (symbol ":")+      requireLanguageFeatureAt context MappedConsumerSurfaceSyntax (spanOf marker)+      TypedQueueExpression <$> pMappedTypeExpr context+    pLegacyPayload =+      LegacyQueueScalar+        <$> choice+          [ QueueText <$ keyword "text",+            QueueInt <$ keyword "int",+            QueueBool <$ keyword "bool",+            QueueOther <$> ident+          ]     pWqDispRow = do       loc <- getLoc       o <- ident

src/Keiro/Dsl/Parser/ReadModel.hs view

@@ -4,32 +4,51 @@   ) where +import Keiro.Dsl.Frontend.Internal (FrontendContext, frontendSupportsFeature) import Keiro.Dsl.Grammar+import Keiro.Dsl.LanguageVersion (LanguageFeature (MappedConsumerSurfaceSyntax, ProjectionCatalogSyntax, SeparatedProjectionQueryPolicySyntax)) import Keiro.Dsl.Parser.Core+import Keiro.Dsl.Parser.Mapped (pMappedTypeExpr) import Text.Megaparsec -pReadModel :: P ReadModelNode-pReadModel = do+pReadModel :: FrontendContext -> P ReadModelNode+pReadModel context = do   loc <- getLoc   keyword "readmodel"   name <- ident   _ <- symbol "{"-  _ <- symbol "table" *> symbol "="-  table <- stringLit-  _ <- symbol "schema" *> symbol "="-  schema <- stringLit+  (table, schema) <-+    if frontendSupportsFeature context ProjectionCatalogSyntax+      then option ("", "") $ try $ do+        _ <- symbol "table" *> symbol "="+        table <- stringLit+        _ <- symbol "schema" *> symbol "="+        schema <- stringLit+        pure (table, schema)+      else do+        _ <- symbol "table" *> symbol "="+        table <- stringLit+        _ <- symbol "schema" *> symbol "="+        schema <- stringLit+        pure (table, schema)   _ <- symbol "columns"   columns <- braces (many pColumn)+  queryTypes <- optionalLanguageFeature context MappedConsumerSurfaceSyntax "query" pQueryTypes   _ <- symbol "version" *> symbol "="   version <- boundedDecimal   _ <- symbol "shape" *> symbol "="   shape <- stringLit-  _ <- symbol "consistency" *> symbol "="-  consistency <- pConsistency-  scope <- optional (symbol "scope" *> symbol "=" *> pScope)-  _ <- symbol "feed" *> symbol "="-  feed <- pFeed-  subscription <- optional (symbol "subscription" *> symbol "=" *> stringLit)+  (freshness, supply) <-+    if frontendSupportsFeature context SeparatedProjectionQueryPolicySyntax+      then pSeparatedPolicy+      else pLegacyPolicy+  group <- optionalLanguageFeature context ProjectionCatalogSyntax "group" (try (symbol "group" *> symbol "=" *> ident))+  observedTargets <- case group of+    Nothing -> pure []+    Just _ -> symbol "targets" *> symbol "=" *> brackets (many ident)+  backingTarget <- case group of+    Nothing -> pure Nothing+    Just _ -> optional (symbol "backing" *> symbol "=" *> ident)   _ <- symbol "}"   pure     ReadModelNode@@ -39,10 +58,12 @@         rmColumns = columns,         rmVersion = version,         rmShape = shape,-        rmConsistency = consistency,-        rmScope = scope,-        rmFeed = feed,-        rmSubscription = subscription,+        rmFreshness = freshness,+        rmSupply = supply,+        rmGroup = group,+        rmObservedTargets = observedTargets,+        rmBackingTarget = backingTarget,+        queryTypes,         rmLoc = loc       }   where@@ -58,3 +79,68 @@           RmCategory <$> (keyword "category" *> stringLit)         ]     pFeed = choice [RmInline <$ keyword "inline", RmSubscription <$ keyword "subscription"]+    pLegacyPolicy = do+      separatedMarker <- optional (try (withOwnedSpan (keyword "freshness")))+      case separatedMarker of+        Just marker -> requireLanguageFeatureAt context SeparatedProjectionQueryPolicySyntax (spanOf marker)+        Nothing -> pure ()+      _ <- symbol "consistency" *> symbol "="+      consistency <- pConsistency+      scope <- optional (symbol "scope" *> symbol "=" *> pScope)+      _ <- symbol "feed" *> symbol "="+      feed <- pFeed+      subscription <- optional (symbol "subscription" *> symbol "=" *> stringLit)+      let freshness = case consistency of+            Eventual -> FreshnessImmediate+            Strong -> FreshnessWaitForHead (maybe RmEntireLog id scope)+      pure+        ( freshness,+          LegacyReadModelSupply+            { legacyConsistency = consistency,+              legacyScope = scope,+              legacyFeed = feed,+              legacySubscription = subscription+            }+        )+    pSeparatedPolicy = do+      rejectLegacyPolicyClause+      _ <- symbol "freshness" *> symbol "="+      freshness <-+        choice+          [ FreshnessImmediate <$ keyword "immediate",+            FreshnessWaitForHead <$> (keyword "wait-for-head" *> pScope)+          ]+      rejectLegacyPolicyClause+      pure (freshness, OwnerDerivedSupply)+    rejectLegacyPolicyClause = do+      startOffset <- getOffset+      legacyClause <-+        optional+          ( lookAhead+              ( choice+                  [ "consistency" <$ keyword "consistency",+                    "scope" <$ keyword "scope",+                    "feed" <$ keyword "feed",+                    "subscription" <$ keyword "subscription"+                  ]+              )+          )+      case legacyClause of+        Nothing -> pure ()+        Just clauseName ->+          failAt+            startOffset+            ( "Language 5 readmodel policy is `freshness = immediate | wait-for-head ...`; remove legacy `"+                <> clauseName+                <> "` and derive delivery/subscription from its projection-owner"+            )+    pQueryTypes = do+      inputLoc <- getLoc+      keyword "query"+      _ <- symbol "input" *> symbol "="+      input <- pMappedTypeExpr context+      resultLoc <- getLoc+      keyword "query"+      _ <- symbol "result" *> symbol "="+      result <- pMappedTypeExpr context+      pure ReadModelQueryTypes {input, result, inputLoc, resultLoc}

src/Keiro/Dsl/PrettyPrint.hs view

@@ -10,6 +10,7 @@     renderSpec,     renderTransition,     renderExpr,+    renderTypeExpr,     renderHandleSurface,     renderResolveSurface,     renderRouterDispatchSurface,@@ -49,6 +50,9 @@ renderTimerPayloadSurface timer =   renderDoc ("payload" <+> braced (map docFieldBinding (tmPayload timer))) +renderTypeExpr :: TypeExpr -> Text+renderTypeExpr = renderDoc . docTypeExpr+ renderDoc :: Doc ann -> Text renderDoc = renderStrict . layoutPretty LayoutOptions {layoutPageWidth = Unbounded} @@ -257,6 +261,11 @@ docNode (NWorkqueue w) = docWorkqueue w docNode (NPgmqDispatch d) = docPgmqDispatch d docNode (NReadModel r) = docReadModel r+docNode (NProjectionTarget target) = docProjectionTarget target+docNode (NRebuildGroup groupNode) = docRebuildGroup groupNode+docNode (NProjectionRevision revision) = docProjectionRevision revision+docNode (NExternalRead externalRead) = docExternalRead externalRead+docNode (NProjectionOwner owner) = docProjectionOwner owner docNode (NWorkflow w) = docWorkflow w docNode (NOperation o) = docOperation o @@ -351,7 +360,12 @@         [indent 2 ("provision partitioned(interval=" <> dquoted interval <> ", retention=" <> dquoted retention <> ")")]     -- 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"+    field f = pretty (wqfName f) <+> "->" <+> dquoted (wqfWire f) <+> docQueuePayloadType (wqfType f) <> " required"+    docQueuePayloadType (LegacyQueueScalar QueueText) = "text"+    docQueuePayloadType (LegacyQueueScalar QueueInt) = "int"+    docQueuePayloadType (LegacyQueueScalar QueueBool) = "bool"+    docQueuePayloadType (LegacyQueueScalar (QueueOther name)) = pretty name+    docQueuePayloadType (TypedQueueExpression expression) = ":" <+> docTypeExpr expression     dispRow r = pretty (wqdOutcome r) <+> "->" <+> act (wqdAction r)     act IAckOk = "ackOk"     act (IRetry win) = "retry" <+> pretty win@@ -374,20 +388,25 @@ docReadModel :: ReadModelNode -> Doc ann docReadModel readModel =   vsep $-    [ "readmodel" <+> pretty (rmName readModel) <+> "{",-      indent 2 ("table =" <+> dquoted (rmTable readModel)),-      indent 2 ("schema =" <+> dquoted (rmSchema readModel)),-      indent 2 "columns {"-    ]+    ["readmodel" <+> pretty (rmName readModel) <+> "{"]+      ++ ( if not (T.null (rmTable readModel)) || not (T.null (rmSchema readModel))+             then+               [ indent 2 ("table =" <+> dquoted (rmTable readModel)),+                 indent 2 ("schema =" <+> dquoted (rmSchema readModel))+               ]+             else []+         )+      ++ [indent 2 "columns {"]       ++ map (indent 4 . docColumn) (rmColumns readModel)-      ++ [ indent 2 "}",-           indent 2 ("version =" <+> pretty (rmVersion readModel)),-           indent 2 ("shape =" <+> dquoted (rmShape readModel)),-           indent 2 ("consistency =" <+> docConsistency (rmConsistency readModel))+      ++ [indent 2 "}"]+      ++ maybe [] docQueryTypes (queryTypes readModel)+      ++ [ indent 2 ("version =" <+> pretty (rmVersion readModel)),+           indent 2 ("shape =" <+> dquoted (rmShape readModel))          ]-      ++ maybe [] (pure . indent 2 . ("scope =" <+>) . docScope) (rmScope readModel)-      ++ [indent 2 ("feed =" <+> docFeed (rmFeed readModel))]-      ++ maybe [] (pure . indent 2 . ("subscription =" <+>) . dquoted) (rmSubscription readModel)+      ++ policyLines+      ++ maybe [] (pure . indent 2 . ("group =" <+>) . pretty) (rmGroup readModel)+      ++ [indent 2 ("targets =" <+> bracketed (map pretty (rmObservedTargets readModel))) | rmGroup readModel /= Nothing]+      ++ maybe [] (pure . indent 2 . ("backing =" <+>) . pretty) (rmBackingTarget readModel)       ++ ["}"]   where     docColumn columnDecl =@@ -398,7 +417,110 @@     docScope (RmCategory categoryName) = "category" <+> dquoted categoryName     docFeed RmInline = "inline"     docFeed RmSubscription = "subscription"+    policyLines = case rmSupply readModel of+      LegacyReadModelSupply {legacyConsistency, legacyScope, legacyFeed, legacySubscription} ->+        [indent 2 ("consistency =" <+> docConsistency legacyConsistency)]+          ++ maybe [] (pure . indent 2 . ("scope =" <+>) . docScope) legacyScope+          ++ [indent 2 ("feed =" <+> docFeed legacyFeed)]+          ++ maybe [] (pure . indent 2 . ("subscription =" <+>) . dquoted) legacySubscription+      OwnerDerivedSupply ->+        [indent 2 ("freshness =" <+> docFreshness (rmFreshness readModel))]+    docFreshness FreshnessImmediate = "immediate"+    docFreshness (FreshnessWaitForHead scope) = "wait-for-head" <+> docScope scope+    docQueryTypes ReadModelQueryTypes {input, result} =+      [ indent 2 ("query input =" <+> docTypeExpr input),+        indent 2 ("query result =" <+> docTypeExpr result)+      ] +docProjectionTarget :: ProjectionTargetNode -> Doc ann+docProjectionTarget target =+  vsep $+    [ "target" <+> pretty (ptName target) <+> "{",+      indent 2 ("schema =" <+> dquoted (ptSchema target)),+      indent 2 ("table =" <+> dquoted (ptTable target)),+      indent 2 ("reset =" <+> case ptReset target of TargetClear -> "clear"; TargetPreserve -> "preserve")+    ]+      ++ [indent 2 ("depends-on =" <+> bracketed (map pretty (ptDependsOn target))) | not (null (ptDependsOn target))]+      ++ ["}"]++docRebuildGroup :: RebuildGroupNode -> Doc ann+docRebuildGroup groupNode =+  vsep+    [ "rebuild-group" <+> pretty (rgName groupNode) <+> "{",+      indent 2 ("targets =" <+> bracketed (map pretty (rgTargets groupNode))),+      indent 2 ("order =" <+> bracketed (map pretty (rgOrder groupNode))),+      "}"+    ]++docProjectionRevision :: ProjectionRevisionNode -> Doc ann+docProjectionRevision revision =+  vsep $+    [ "projection-revision" <+> pretty (prvName revision) <+> "{",+      indent 2 ("group =" <+> pretty (prvGroup revision))+    ]+      <> concatMap (pure . indent 2 . docRevisionTarget) (prvTargets revision)+      <> ["}"]+  where+    docRevisionTarget target =+      vsep $+        [ "target" <+> pretty (prtTarget target) <+> "{",+          indent 2 ("schema-version =" <+> dquoted (prtSchemaVersion target)),+          indent 2 ("provisioner =" <+> dquoted (prtProvisioner target)),+          indent 2 ("provisioner-version =" <+> pretty (prtProvisionerVersion target)),+          indent 2 ("expected-shape =" <+> dquoted (prtExpectedShape target)),+          indent 2 ("validator =" <+> dquoted (prtValidator target)),+          indent 2 ("validator-version =" <+> pretty (prtValidatorVersion target))+        ]+          <> map (indent 2 . docPromotionObject) (prtPromotionObjects target)+          <> ["}"]+    docPromotionObject promotionObject =+      "promotion"+        <+> ( case rpoKind promotionObject of+                PromotionIndexNode -> "index"+                PromotionConstraintNode -> "constraint"+                PromotionOwnedSequenceNode -> "owned-sequence"+            )+        <+> dquoted (rpoGenerationName promotionObject)+        <+> "->"+        <+> dquoted (rpoCanonicalName promotionObject)++docExternalRead :: ExternalReadNode -> Doc ann+docExternalRead externalRead =+  vsep+    [ "external-read" <+> pretty (erName externalRead) <+> "{",+      indent 2 ("version =" <+> pretty (erVersion externalRead)),+      indent 2 ("query =" <+> pretty (erQueryModel externalRead)),+      indent 2 ("result-schema =" <+> dquoted (erResultSchema externalRead)),+      indent 2 ("result-type =" <+> dquoted (erResultType externalRead)),+      indent 2 ("compatible-revisions =" <+> bracketed (map pretty (erCompatibleRevisions externalRead))),+      indent 2 ("surface-generation =" <+> pretty (erSurfaceGeneration externalRead)),+      "}"+    ]++docProjectionOwner :: ProjectionOwnerNode -> Doc ann+docProjectionOwner owner =+  vsep $+    ["projection-owner" <+> pretty (poName owner) <+> "{"]+      ++ map (indent 2 . ("source =" <+>) . docSource) (poSources owner)+      ++ [ indent 2 ("delivery =" <+> case poDelivery owner of DeliveryInline -> "inline"; DeliverySubscription -> "subscription"),+           indent 2 ("group =" <+> pretty (poGroup owner)),+           indent 2 ("targets =" <+> bracketed (map pretty (poTargets owner))),+           indent 2 ("order =" <+> pretty (poOrder owner))+         ]+      ++ maybe [] (pure . indent 2 . ("subscription =" <+>) . dquoted) (poSubscription owner)+      ++ maybe [] (pure . indent 2 . ("dedup =" <+>) . dquoted) (poDedup owner)+      ++ map (indent 2 . ("checkpoint-on-missing =" <+>) . docCheckpointOnMissing) (poCheckpointOnMissing owner)+      ++ [indent 2 ("replay =" <+> docReplay (poReplay owner)), "}"]+  where+    docSource (CatalogAggregate aggregateName) = "aggregate" <+> pretty aggregateName+    docSource (CatalogCategory categoryName) = "category" <+> dquoted categoryName+    docSource CatalogAll = "all"+    docCheckpointOnMissing CheckpointFromBeginning = "from-beginning"+    docCheckpointOnMissing CheckpointFromCurrentHead = "from-current-head"+    docCheckpointOnMissing CheckpointFail = "fail"+    docReplay ProjectionReplayExplicit = "explicit"+    docReplay (ProjectionLiveOnly reason) = "live-only" <+> dquoted reason+ docEmit :: EmitNode -> Doc ann docEmit e =   vsep $@@ -537,7 +659,7 @@     [ "router" <+> pretty (rtId r),       indent 2 ("name" <+> dquoted (rtName r)),       indent 2 (docInput (rtInput r)),-      indent 2 (docRouterKey (rtKey r)),+      indent 2 (docRouterKey (isDeclarativeResolve (rtResolve r)) (rtKey r)),       indent 2 (docResolve (rtResolve r)),       indent 2 ("target" <+> pretty (rtTarget r)),       indent 2 ("projections" <+> bracketed (map pretty (rtProjections r))),@@ -547,20 +669,48 @@       indent 2 ("poison =>" <+> docPolicyChoice (rtPoison r))     ] -docRouterKey :: CorrelateDecl -> Doc ann-docRouterKey key = "key" <+> ("input." <> pretty (corrField key)) <+> "via" <+> pretty (corrVia key)+docRouterKey :: Bool -> CorrelateDecl -> Doc ann+docRouterKey declarative key+  | declarative = "key" <+> ("input." <> pretty (corrField key))+  | otherwise = "key" <+> ("input." <> pretty (corrField key)) <+> "via" <+> pretty (corrVia key) +isDeclarativeResolve :: ResolveDecl -> Bool+isDeclarativeResolve resolve = case rvSource resolve of+  ResolveDeclarative {} -> True+  _ -> False+ docResolve :: ResolveDecl -> Doc ann-docResolve resolve =-  "resolve stable via"-    <+> source-    <+> "row"-    <+> braced (map pretty (rvRow resolve))+docResolve resolve = case rvSource resolve of+  ResolveReadModel name -> custom ("read-model" <+> pretty name)+  ResolveHole -> custom "hole"+  ResolveDeclarative selection ->+    vsep+      ( [ "resolve declarative {",+          indent 2 ("identity =" <+> dquoted (rsIdentity selection)),+          indent 2 ("version =" <+> pretty (rsVersion selection)),+          indent 2 ("query = read-model" <+> pretty (rsQuery selection) <+> "with" <+> pretty (rsQueryInput selection)),+          indent 2 ("where =" <+> docExpr 0 (rsPredicate selection)),+          indent 2 ("recipient =" <+> docExpr 0 (rsRecipient selection)),+          indent 2 ("order =" <+> pretty (rsOrder selection)),+          indent 2 ("dedupe =" <+> pretty (rsDedupe selection))+        ]+          ++ maybe [] (\(recipientLimit, _) -> [indent 2 ("max-recipients =" <+> pretty recipientLimit)]) (rsLimit selection)+          ++ [ indent 2 ("empty =>" <+> docSelectionDisposition (rsEmptyPolicy selection)),+               indent 2 ("failure =>" <+> docSelectionDisposition (rsFailurePolicy selection)),+               indent 2 ("redelivery =" <+> pretty (rsRedelivery selection)),+               indent 2 ("partial =" <+> pretty (rsPartial selection)),+               "}"+             ]+      )   where-    source = case rvSource resolve of-      ResolveReadModel name -> "read-model" <+> pretty name-      ResolveHole -> "hole"+    custom source = "resolve stable via" <+> source <+> "row" <+> braced (map pretty (rvRow resolve)) +docSelectionDisposition :: SelectionDispositionSyntax -> Doc ann+docSelectionDisposition SelectionAck = "ack"+docSelectionDisposition SelectionRetry = "retry"+docSelectionDisposition SelectionDeadLetter = "deadLetter"+docSelectionDisposition SelectionHalt = "halt"+ docRouterDispatch :: RouterDispatchNode -> Doc ann docRouterDispatch dispatch =   vsep@@ -574,7 +724,9 @@ docPolicyChoice PolSkip = "skip"  docInput :: InputDecl -> Doc ann-docInput i = "input" <+> pretty (inName i) <+> braced (map docField (inFields i))+docInput input = case inType input of+  Just inputType -> "input" <+> pretty (inName input) <+> ":" <+> docTypeExpr inputType+  Nothing -> "input" <+> pretty (inName input) <+> braced (map docField (inFields input))  docCorrelate :: CorrelateDecl -> Doc ann docCorrelate c = "correlate" <+> ("input." <> pretty (corrField c)) <+> "via" <+> pretty (corrVia c)@@ -683,6 +835,7 @@ docAggregate a =   vsep $     [ "aggregate" <+> pretty (aggName a),+      maybe mempty (indent 2 . docDomainOutcomeTypes) (aggDomainOutcomeTypes a),       indent 2 "regs",       indent 4 (vsep (map docReg (aggRegs a))),       indent 2 ("states" <+> hsep (map docState (aggStates a))),@@ -700,6 +853,12 @@   where     blank xs = if null xs then [] else [mempty] +docDomainOutcomeTypes :: DomainOutcomeTypes -> Doc ann+docDomainOutcomeTypes declaration =+  "domain-outcomes"+    <+> ("rejection=" <> pretty (rejectionType declaration))+    <+> ("no-op=" <> pretty (noOpType declaration))+ docSnapshot :: SnapshotSpec -> Doc ann docSnapshot snapshot =   vsep@@ -793,8 +952,14 @@       ["implementation hole" | tImplementation t == HoleImplementation]         ++ maybe [] (\g -> ["guard" <+> docExpr 0 g]) (tGuard t)         ++ map (\(r, e) -> "write" <+> pretty r <+> ":=" <+> docExpr 0 e) (tWrites t)+        ++ maybe [] (pure . docTransitionOutcome) (tOutcome t)         ++ map (\ev -> "emit" <+> pretty ev) (tEmits t)         ++ ["goto" <+> pretty (tGoto t)]++docTransitionOutcome :: TransitionOutcome -> Doc ann+docTransitionOutcome (OutcomeAccepted _) = "outcome accepted"+docTransitionOutcome (OutcomeRejected expression _) = "outcome rejected" <+> docExpr 0 expression+docTransitionOutcome (OutcomeNoOp expression _) = "outcome no-op" <+> docExpr 0 expression  docWire :: WireSpec -> Doc ann docWire w =

+ src/Keiro/Dsl/ProjectionMappedImpact.hs view

@@ -0,0 +1,300 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++-- | Projection dependencies inherited from authoritative aggregate event+-- roots. This module never invents a projection type expression: it projects+-- the checked mapped-event graph onto the existing inline/catalog ownership+-- graph and keeps SQL effects explicitly operational rather than typed.+module Keiro.Dsl.ProjectionMappedImpact+  ( ProjectionMappedRoot (..),+    ProjectionOperationalImpact (..),+    UnsupportedProjectionImpact (..),+    ProjectionMappedImpact (..),+    projectionMappedImpact,+    projectionMappedImpactForService,+    projectionConsumersFor,+    projectionOperationsFor,+    projectionAggregateSourceFingerprint,+    projectionAggregateSourceFingerprintForService,+    renderProjectionMappedImpact,+  )+where++import Data.List (find, nub, sort)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import Keiro.Dsl.Grammar+import Keiro.Dsl.ReadModelShape (fnv1a64)+import Keiro.Dsl.SemanticContract (CheckedService, checkedSpec, checkedTypeGraph)+import Keiro.Dsl.SemanticImpact+import Keiro.Dsl.TypeGraph++-- | One complete inherited event path for one derived projection consumer and+-- one declaration in the event root's transitive mapped closure.+data ProjectionMappedRoot = ProjectionMappedRoot+  { consumer :: !DerivedMappedConsumer,+    declaration :: !MappedKey,+    path :: !UsePath+  }+  deriving stock (Eq, Ord, Show, Generic)++-- | Operational effects related to a typed projection consumer. Targets and+-- observing query models do not become Haskell type consumers: unrestricted+-- handler SQL prevents that stronger claim.+data ProjectionOperationalImpact = ProjectionOperationalImpact+  { consumer :: !DerivedMappedConsumer,+    group :: !(Maybe Name),+    targets :: !(Set Name),+    readModels :: !(Set Name),+    replayable :: !Bool,+    sourceFingerprint :: !Text+  }+  deriving stock (Eq, Ord, Show, Generic)++-- | A category/all-history owner participates in catalog operations but has+-- no single mapped event type. Keeping the whole operational relation makes+-- that unsupported typed boundary visible without attaching a fake key.+data UnsupportedProjectionImpact = UnsupportedProjectionImpact+  { source :: !UnsupportedProjectionSource,+    group :: !Name,+    targets :: !(Set Name),+    readModels :: !(Set Name),+    replayable :: !Bool+  }+  deriving stock (Eq, Ord, Show, Generic)++data ProjectionMappedImpact = ProjectionMappedImpact+  { roots :: ![ProjectionMappedRoot],+    consumers :: !(Map MappedKey (Set DerivedMappedConsumer)),+    operations :: !(Map DerivedMappedConsumer ProjectionOperationalImpact),+    unsupported :: ![UnsupportedProjectionImpact]+  }+  deriving stock (Eq, Show, Generic)++-- | Join checked mapped-event paths to inline/catalog projection ownership.+-- Command, register, queue, and query roots are excluded by construction.+projectionMappedImpact :: CheckedService -> SemanticImpact -> ProjectionMappedImpact+projectionMappedImpact service semantic =+  ProjectionMappedImpact+    { roots = mappedRoots,+      consumers =+        Map.fromListWith+          Set.union+          [ (declarationKey, Set.singleton derived)+          | ProjectionMappedRoot derived declarationKey _ <- mappedRoots+          ],+      operations = Map.fromList [(derived, operation) | operation@(ProjectionOperationalImpact derived _ _ _ _ _) <- operational],+      unsupported = sort (mapMaybeUnsupported unsupportedSources)+    }+  where+    spec = checkedSpec service+    graph = either (const Nothing) Just (checkedTypeGraph service)+    derivedConsumers =+      Set.fromList+        [ derived+        | mappedConsumers <- Map.elems (impactDeclarationConsumers semantic),+          DerivedProjectionConsumer derived <- Set.toList mappedConsumers+        ]+    mappedRoots =+      sort . nub $+        [ ProjectionMappedRoot derived declarationKey usePath+        | (declarationKey, usePathValues) <- Map.toAscList (impactUsePaths semantic),+          usePath <- usePathValues,+          aggregate <- maybeToList (eventAuthority usePath),+          derived <- Set.toAscList derivedConsumers,+          derivedAuthority derived == aggregate+        ]+    operational =+      mapMaybeOperation+        (Set.toAscList (Set.fromList [derived | ProjectionMappedRoot derived _ _ <- mappedRoots]))+    unsupportedSources = impactUnsupportedProjectionSources semantic++    mapMaybeOperation = foldr (maybe id (:) . operationFor graph spec) []+    mapMaybeUnsupported = foldr (maybe id (:) . unsupportedFor spec) []++-- | Resolve and project a checked service without making callers reconstruct+-- the shared type graph. A failed resolution remains explicit even though the+-- scaffold admission gate normally prevents it from reaching report creation.+projectionMappedImpactForService :: CheckedService -> Maybe ProjectionMappedImpact+projectionMappedImpactForService service = case checkedTypeGraph service of+  Left _ -> Nothing+  Right graph -> Just (projectionMappedImpact service (semanticImpact graph))++projectionConsumersFor :: ProjectionMappedImpact -> MappedKey -> Set DerivedMappedConsumer+projectionConsumersFor impact declarationKey = Map.findWithDefault Set.empty declarationKey (consumers impact)++projectionOperationsFor :: ProjectionMappedImpact -> MappedKey -> [ProjectionOperationalImpact]+projectionOperationsFor impact declarationKey =+  [ operation+  | derived <- Set.toAscList (projectionConsumersFor impact declarationKey),+    operation <- maybeToList (Map.lookup derived (operations impact))+  ]++-- | Stable source metadata for generated aggregate codecs. Existing aggregate+-- sources with no mapped event roots keep their historical byte exactly. A+-- mapped event root adds a digest over its complete root spelling and+-- transitive wire authority; command/register/query-only mappings are absent.+projectionAggregateSourceFingerprint :: Spec -> Name -> Text+projectionAggregateSourceFingerprint spec aggregate =+  projectionAggregateSourceFingerprintWithGraph+    (either (const Nothing) Just (resolveTypeGraph spec))+    aggregate++projectionAggregateSourceFingerprintForService :: CheckedService -> Name -> Text+projectionAggregateSourceFingerprintForService service =+  projectionAggregateSourceFingerprintWithGraph+    (either (const Nothing) Just (checkedTypeGraph service))++projectionAggregateSourceFingerprintWithGraph :: Maybe TypeGraph -> Name -> Text+projectionAggregateSourceFingerprintWithGraph maybeGraph aggregate =+  case maybeGraph of+    Nothing -> base+    Just graph -> case eventRows graph of+      [] -> base+      rows -> base <> "/mapped-" <> fnv1a64 (T.intercalate "\n" rows)+  where+    base = "aggregate:" <> aggregate <> "/generated-codec/v1"+    eventRows graph =+      sort+        [ renderUsePath (UsePath site (useSiteSegments graph site))+            <> "|wire="+            <> wireFingerprint graph (unMappedKey declarationKey)+        | site@(RootEventField authority _ _ declarationKey) <- tgUseSites graph,+          authority == aggregate+        ]++-- | Human-readable typed and operational projection evidence. Complete event+-- roots are shown independently from groups, targets, observing read models,+-- replay policy, and source fingerprints so SQL is never presented as a type+-- dependency. Category/all boundaries remain explicit and untyped.+renderProjectionMappedImpact :: ProjectionMappedImpact -> [Text]+renderProjectionMappedImpact impact+  | Map.null (consumers impact) && null (unsupported impact) = []+  | otherwise =+      ["projection mapped impact:"]+        <> concatMap renderDeclaration (Map.toAscList (consumers impact))+        <> renderUnsupported (unsupported impact)+  where+    renderDeclaration (declarationKey, derivedConsumers) =+      ["  " <> unMappedKey declarationKey]+        <> concatMap (renderConsumer declarationKey) (Set.toAscList derivedConsumers)+    renderConsumer declarationKey derived =+      [ "    " <> mappedConsumerIdentity (DerivedProjectionConsumer derived),+        "      inherited event roots: " <> renderSet (Set.fromList (pathsFor declarationKey derived))+      ]+        <> maybe [] (pure . ("      operation: " <>) . renderOperation) (Map.lookup derived (operations impact))+    pathsFor declarationKey derived =+      [ renderUsePath inheritedPath+      | ProjectionMappedRoot candidate declaration inheritedPath <- roots impact,+        candidate == derived,+        declaration == declarationKey+      ]+    renderOperation (ProjectionOperationalImpact _ groupName targetNames observerNames canReplay fingerprint) =+      "group="+        <> maybe "(inline)" id groupName+        <> "; targets="+        <> renderSet targetNames+        <> "; read-models="+        <> renderSet observerNames+        <> "; replayable="+        <> yesNo canReplay+        <> "; source-fingerprint="+        <> fingerprint+    renderUnsupported [] = []+    renderUnsupported boundaries =+      ["  unsupported typed sources:"] <> concatMap renderBoundary boundaries+    renderBoundary (UnsupportedProjectionImpact boundary groupName targetNames observerNames canReplay) =+      [ "    " <> renderBoundaryName boundary,+        "      operation: group="+          <> groupName+          <> "; targets="+          <> renderSet targetNames+          <> "; read-models="+          <> renderSet observerNames+          <> "; replayable="+          <> yesNo canReplay+          <> "; mapped-key=(unsupported heterogeneous source)"+      ]+    renderBoundaryName (UnsupportedCatalogCategory owner categoryName) =+      "catalog-category:" <> owner <> ":" <> categoryName+    renderBoundaryName (UnsupportedCatalogAll owner) = "catalog-all:" <> owner+    renderSet values = case Set.toAscList values of+      [] -> "(none)"+      names -> T.intercalate ", " names+    yesNo True = "yes"+    yesNo False = "no"++operationFor :: Maybe TypeGraph -> Spec -> DerivedMappedConsumer -> Maybe ProjectionOperationalImpact+operationFor graph spec derived = case derived of+  AggregateInlineProjectionConsumer aggregate projection ->+    Just+      ProjectionOperationalImpact+        { consumer = derived,+          group = Nothing,+          targets = Set.singleton projection,+          readModels = Set.fromList [rmName readModel | readModel <- readModelNodes spec, rmName readModel == projection],+          replayable = False,+          sourceFingerprint = projectionAggregateSourceFingerprintWithGraph graph aggregate+        }+  CatalogProjectionConsumer ownerName aggregate -> do+    owner <- find ((== ownerName) . poName) (projectionOwners spec)+    pure+      ProjectionOperationalImpact+        { consumer = derived,+          group = Just (poGroup owner),+          targets = Set.fromList (poTargets owner),+          readModels = observingReadModels spec owner,+          replayable = isReplayable owner,+          sourceFingerprint = projectionAggregateSourceFingerprintWithGraph graph aggregate+        }++unsupportedFor :: Spec -> UnsupportedProjectionSource -> Maybe UnsupportedProjectionImpact+unsupportedFor spec boundary = do+  owner <- find ((== unsupportedOwner boundary) . poName) (projectionOwners spec)+  pure+    UnsupportedProjectionImpact+      { source = boundary,+        group = poGroup owner,+        targets = Set.fromList (poTargets owner),+        readModels = observingReadModels spec owner,+        replayable = isReplayable owner+      }++observingReadModels :: Spec -> ProjectionOwnerNode -> Set Name+observingReadModels spec owner =+  Set.fromList+    [ rmName readModel+    | readModel <- readModelNodes spec,+      rmGroup readModel == Just (poGroup owner),+      not (Set.disjoint (Set.fromList (rmObservedTargets readModel)) (Set.fromList (poTargets owner)))+    ]++eventAuthority :: UsePath -> Maybe Name+eventAuthority UsePath {upRoot = RootEventField aggregate _ _ _} = Just aggregate+eventAuthority _ = Nothing++derivedAuthority :: DerivedMappedConsumer -> Name+derivedAuthority (AggregateInlineProjectionConsumer aggregate _) = aggregate+derivedAuthority (CatalogProjectionConsumer _ aggregate) = aggregate++unsupportedOwner :: UnsupportedProjectionSource -> Name+unsupportedOwner (UnsupportedCatalogCategory owner _) = owner+unsupportedOwner (UnsupportedCatalogAll owner) = owner++projectionOwners :: Spec -> [ProjectionOwnerNode]+projectionOwners spec = [owner | NProjectionOwner owner <- specNodes spec]++readModelNodes :: Spec -> [ReadModelNode]+readModelNodes spec = [readModel | NReadModel readModel <- specNodes spec]++isReplayable :: ProjectionOwnerNode -> Bool+isReplayable owner = case poReplay owner of+  ProjectionReplayExplicit -> True+  ProjectionLiveOnly _ -> False++maybeToList :: Maybe value -> [value]+maybeToList = maybe [] pure

+ src/Keiro/Dsl/ProjectionSupply.hs view

@@ -0,0 +1,163 @@+-- | Order-independent projection-owner resolution for catalog-bound query+-- models. Validation and generated consumers share this analysis so target+-- ownership never acquires a second, list-order-sensitive interpretation.+module Keiro.Dsl.ProjectionSupply+  ( ResolvedProjectionSupply (..),+    ProjectionSupplyIssue (..),+    ProjectionSupplyAnalysis (..),+    analyzeProjectionSupplies,+  )+where++import Data.List (nub, sort, sortOn)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as Map+import Keiro.Dsl.Grammar++-- | One successfully resolved catalog-bound query model. Observed targets are+-- normalized by identity; source locations remain available for structured+-- diagnostics and generated evidence.+data ResolvedProjectionSupply = ResolvedProjectionSupply+  { supplyQueryModel :: !Name,+    supplyProjectionOwner :: !Name,+    supplyRebuildGroup :: !Name,+    supplyObservedTargets :: !(NonEmpty Name),+    supplyQueryLoc :: !Loc,+    supplyOwnerLoc :: !Loc+  }+  deriving stock (Eq, Show)++-- | Structural failures found while deriving the relation. The public DSL+-- diagnostic layer decides which issue owns a user-facing diagnostic and which+-- is already covered by an earlier target/group declaration error.+data ProjectionSupplyIssue+  = SupplyObservedTargetsEmpty !ReadModelNode+  | SupplyObservedTargetUnknown !ReadModelNode !Name+  | SupplyObservedTargetOutsideGroup !ReadModelNode !Name+  | SupplyObservedTargetWithoutOwner !ReadModelNode !Name+  | SupplyObservedTargetWithMultipleOwners !ReadModelNode !Name ![ProjectionOwnerNode]+  | SupplyOwnerGroupMismatch !ReadModelNode !Name !ProjectionOwnerNode+  | SupplyQueryWithoutOwner !ReadModelNode+  | SupplyQueryWithMultipleOwners !ReadModelNode ![ProjectionOwnerNode]+  | SupplyLegacyProjectionConflict !ReadModelNode !Aggregate !ProjectionSpec+  deriving stock (Eq, Show)++data ProjectionSupplyAnalysis = ProjectionSupplyAnalysis+  { resolvedProjectionSupplies :: ![ResolvedProjectionSupply],+    projectionSupplyIssues :: ![ProjectionSupplyIssue]+  }+  deriving stock (Eq, Show)++analyzeProjectionSupplies :: Spec -> ProjectionSupplyAnalysis+analyzeProjectionSupplies spec =+  ProjectionSupplyAnalysis+    { resolvedProjectionSupplies = concatMap (fst . analyzeReadModel) catalogReadModels,+      projectionSupplyIssues = concatMap (snd . analyzeReadModel) catalogReadModels+    }+  where+    catalogReadModels =+      sortOn+        rmName+        [ readModel+        | NReadModel readModel <- specNodes spec,+          rmGroup readModel /= Nothing+        ]+    targetsByName =+      Map.fromList+        [ (ptName target, target)+        | NProjectionTarget target <- specNodes spec+        ]+    groupsByTarget =+      Map.fromListWith+        (<>)+        [ (targetName, [rgName groupNode])+        | NRebuildGroup groupNode <- specNodes spec,+          targetName <- rgTargets groupNode+        ]+    ownersByTarget =+      Map.fromListWith+        (<>)+        [ (targetName, [owner])+        | NProjectionOwner owner <- specNodes spec,+          targetName <- poTargets owner+        ]+    legacyProjections =+      [ (aggregate, projection)+      | NAggregate aggregate <- specNodes spec,+        Just projection <- [aggProjection aggregate]+      ]++    analyzeReadModel readModel =+      (resolved, sortOn issueSortKey (legacyIssues <> structuralIssues))+      where+        observedTargets = sort (nub (rmObservedTargets readModel))+        queryGroup = maybe (error "catalog read model lost its group") id (rmGroup readModel)+        legacyIssues =+          [ SupplyLegacyProjectionConflict readModel aggregate projection+          | (aggregate, projection) <- legacyProjections,+            projTable projection == rmName readModel+          ]+        targetIssues = concatMap (issuesForTarget readModel queryGroup) observedTargets+        structuralIssues+          | null observedTargets = [SupplyObservedTargetsEmpty readModel]+          | not (null targetIssues) = targetIssues+          | otherwise = case supplierOwners of+              [] -> [SupplyQueryWithoutOwner readModel]+              [owner] ->+                [ SupplyOwnerGroupMismatch readModel targetName owner+                | targetName <- observedTargets,+                  poGroup owner /= queryGroup+                ]+              owners -> [SupplyQueryWithMultipleOwners readModel owners]+        supplierOwners =+          sortOn poName+            . nubByOwner+            $ [ owner+              | targetName <- observedTargets,+                [owner] <- [Map.findWithDefault [] targetName ownersByTarget]+              ]+        resolved = case structuralIssues of+          [] -> case supplierOwners of+            [owner] ->+              [ ResolvedProjectionSupply+                  { supplyQueryModel = rmName readModel,+                    supplyProjectionOwner = poName owner,+                    supplyRebuildGroup = queryGroup,+                    supplyObservedTargets = case observedTargets of+                      target : rest -> target :| rest+                      [] -> error "resolved projection supply lost observed targets",+                    supplyQueryLoc = rmLoc readModel,+                    supplyOwnerLoc = poLoc owner+                  }+              ]+            _ -> []+          _ -> []++    issuesForTarget readModel queryGroup targetName =+      case Map.lookup targetName targetsByName of+        Nothing -> [SupplyObservedTargetUnknown readModel targetName]+        Just _ ->+          groupIssues <> ownerIssues+      where+        groupIssues =+          [ SupplyObservedTargetOutsideGroup readModel targetName+          | Map.findWithDefault [] targetName groupsByTarget /= [queryGroup]+          ]+        ownerIssues = case sortOn poName (Map.findWithDefault [] targetName ownersByTarget) of+          [] -> [SupplyObservedTargetWithoutOwner readModel targetName]+          [_] -> []+          owners -> [SupplyObservedTargetWithMultipleOwners readModel targetName owners]++    nubByOwner = Map.elems . Map.fromList . map (\owner -> (poName owner, owner))++issueSortKey :: ProjectionSupplyIssue -> (Name, Int, Name)+issueSortKey = \case+  SupplyObservedTargetsEmpty readModel -> (rmName readModel, 0, "")+  SupplyObservedTargetUnknown readModel targetName -> (rmName readModel, 1, targetName)+  SupplyObservedTargetOutsideGroup readModel targetName -> (rmName readModel, 2, targetName)+  SupplyObservedTargetWithoutOwner readModel targetName -> (rmName readModel, 3, targetName)+  SupplyObservedTargetWithMultipleOwners readModel targetName _ -> (rmName readModel, 4, targetName)+  SupplyOwnerGroupMismatch readModel targetName _ -> (rmName readModel, 5, targetName)+  SupplyQueryWithoutOwner readModel -> (rmName readModel, 6, "")+  SupplyQueryWithMultipleOwners readModel _ -> (rmName readModel, 7, "")+  SupplyLegacyProjectionConflict readModel aggregate _ -> (rmName readModel, 8, aggName aggregate)

+ src/Keiro/Dsl/ReadModelQueryContract.hs view

@@ -0,0 +1,147 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++-- | Durable identity for the two compile-time query positions of a read model.+-- These rows deliberately exclude SQL columns, codecs, and projection runtime+-- identity: they describe only the generated Haskell API and its mapped closure.+module Keiro.Dsl.ReadModelQueryContract+  ( QueryContractPosition (..),+    QueryContractIdentity (..),+    QueryContractDrift (..),+    queryContractIdentities,+    queryContractIdentitiesForService,+    queryContractIdentityKey,+    queryContractDrift,+  )+where++import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=))+import Data.List (sortOn)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Keiro.Dsl.Grammar+import Keiro.Dsl.PrettyPrint (renderTypeExpr)+import Keiro.Dsl.SemanticContract (CheckedService, checkedSpec, checkedTypeGraph, legacyCheckedService)+import Keiro.Dsl.TypeGraph++data QueryContractPosition+  = QueryInputConsumer+  | QueryResultConsumer+  deriving stock (Eq, Ord, Show)++data QueryContractIdentity = QueryContractIdentity+  { qciReadModel :: !Name,+    qciPosition :: !QueryContractPosition,+    qciTypeExpression :: !Text,+    qciMappedDependencies :: ![Name]+  }+  deriving stock (Eq, Ord, Show)++data QueryContractDrift = QueryContractDrift+  { qcdKey :: !(Name, QueryContractPosition),+    qcdPrevious :: !(Maybe QueryContractIdentity),+    qcdCurrent :: !(Maybe QueryContractIdentity)+  }+  deriving stock (Eq, Show)++instance ToJSON QueryContractPosition where+  toJSON QueryInputConsumer = toJSON ("input" :: Text)+  toJSON QueryResultConsumer = toJSON ("result" :: Text)++instance FromJSON QueryContractPosition where+  parseJSON value = do+    label <- parseJSON value+    case (label :: Text) of+      "input" -> pure QueryInputConsumer+      "result" -> pure QueryResultConsumer+      other -> fail ("unknown read-model query contract position: " <> show other)++instance ToJSON QueryContractIdentity where+  toJSON identity =+    object+      [ "readModel" .= qciReadModel identity,+        "position" .= qciPosition identity,+        "typeExpression" .= qciTypeExpression identity,+        "mappedDependencies" .= qciMappedDependencies identity+      ]++instance FromJSON QueryContractIdentity where+  parseJSON = withObject "QueryContractIdentity" $ \fields ->+    QueryContractIdentity+      <$> fields .: "readModel"+      <*> fields .: "position"+      <*> fields .: "typeExpression"+      <*> fields .: "mappedDependencies"++queryContractIdentityKey :: QueryContractIdentity -> (Name, QueryContractPosition)+queryContractIdentityKey identity = (qciReadModel identity, qciPosition identity)++queryContractDrift :: [QueryContractIdentity] -> [QueryContractIdentity] -> [QueryContractDrift]+queryContractDrift current previous =+  [ QueryContractDrift key oldValue newValue+  | key <- Set.toAscList (Map.keysSet oldByKey <> Map.keysSet newByKey),+    let oldValue = Map.lookup key oldByKey,+    let newValue = Map.lookup key newByKey,+    oldValue /= newValue+  ]+  where+    oldByKey = Map.fromList [(queryContractIdentityKey identity, identity) | identity <- previous]+    newByKey = Map.fromList [(queryContractIdentityKey identity, identity) | identity <- current]++queryContractIdentities :: Spec -> Either (NonEmpty TypeGraphError) [QueryContractIdentity]+queryContractIdentities = queryContractIdentitiesForService . legacyCheckedService++queryContractIdentitiesForService :: CheckedService -> Either (NonEmpty TypeGraphError) [QueryContractIdentity]+queryContractIdentitiesForService service = do+  graph <- checkedTypeGraph service+  fmap (sortOn queryContractIdentityKey . concat) (traverse (identitiesFor graph) readModels)+  where+    spec = checkedSpec service+    readModels = [readModel | NReadModel readModel <- specNodes spec]++identitiesFor :: TypeGraph -> ReadModelNode -> Either (NonEmpty TypeGraphError) [QueryContractIdentity]+identitiesFor _ ReadModelNode {queryTypes = Nothing} = Right []+identitiesFor graph readModel@ReadModelNode {queryTypes = Just queryPair} = do+  inputExpression <- resolve QueryInputConsumer (inputLoc queryPair) (input queryPair)+  resultExpression <- resolve QueryResultConsumer (resultLoc queryPair) (result queryPair)+  pure+    [ identity QueryInputConsumer (input queryPair) inputExpression,+      identity QueryResultConsumer (result queryPair) resultExpression+    ]+  where+    resolve position location expression =+      case resolveTypeExpression graph owner location expression of+        Left failure -> Left (failure :| [])+        Right resolved -> Right resolved+      where+        owner = "readmodel '" <> rmName readModel <> "' query " <> positionLabel position+    identity position sourceExpression resolved =+      QueryContractIdentity+        { qciReadModel = rmName readModel,+          qciPosition = position,+          qciTypeExpression = renderTypeExpr sourceExpression,+          qciMappedDependencies = Set.toAscList (Set.map unMappedKey (mappedClosure graph resolved))+        }++mappedClosure :: TypeGraph -> ResolvedTypeExpr -> Set MappedKey+mappedClosure graph =+  foldTypeExpr+    TypeExprAlgebra+      { onText = Set.empty,+        onInt = Set.empty,+        onInteger = Set.empty,+        onBool = Set.empty,+        onNatural = Set.empty,+        onTime = Set.empty,+        onJson = Set.empty,+        onOptional = id,+        onList = id,+        onMap = id,+        onRef = \key -> Set.insert key (Map.findWithDefault Set.empty key (tgReachability graph))+      }++positionLabel :: QueryContractPosition -> Text+positionLabel QueryInputConsumer = "input"+positionLabel QueryResultConsumer = "result"

src/Keiro/Dsl/ReadModelShape.hs view

@@ -15,14 +15,19 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Word (Word64)-import Keiro.Dsl.Grammar (Name, ReadModelNode (..), RmColumn (..))+import Keiro.Dsl.Grammar (Name, ReadModelNode (..), RmColumn (..), legacyReadModelSubscription) import Numeric (showHex) --- | The ordered table-and-column identity hashed into 'deriveShapeHash'.+-- | The ordered query-row identity hashed into 'deriveShapeHash'. Legacy read+-- models include their table identity; catalog-bound query models deliberately+-- do not duplicate physical authority owned by their target declarations. canonicalShape :: ReadModelNode -> Text canonicalShape readModel =-  T.intercalate "|" (rmTable readModel : map columnSegment (rmColumns readModel))+  T.intercalate "|" (shapeRoot : map columnSegment (rmColumns readModel))   where+    shapeRoot = case rmGroup readModel of+      Nothing -> rmTable readModel+      Just _ -> "query-model"     columnSegment columnDecl =       T.intercalate         ":"@@ -52,7 +57,7 @@ -- | The explicit subscription override or its deterministic default. subscriptionNameFor :: Name -> ReadModelNode -> Text subscriptionNameFor contextName readModel =-  fromMaybe (registryNameFor contextName readModel <> "-sub") (rmSubscription readModel)+  fromMaybe (registryNameFor contextName readModel <> "-sub") (legacyReadModelSubscription readModel)  offsetBasis :: Word64 offsetBasis = 0xcbf29ce484222325

src/Keiro/Dsl/ReplayImpact.hs view

@@ -12,7 +12,9 @@ module Keiro.Dsl.ReplayImpact   ( AggregateImpact (..),     ReplayImpact (..),+    CatalogReplayImpact (..),     replayImpactServices,+    catalogReplayImpactServices,     renderReplayImpact,   ) where@@ -23,6 +25,7 @@ import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text)@@ -33,8 +36,10 @@ import Keiro.Dsl.FoldFingerprint (FoldSurfaceError, aggregateFoldSurfaceForService) import Keiro.Dsl.Grammar import Keiro.Dsl.NominalType-import Keiro.Dsl.SemanticContract (CheckedService (..))-import Keiro.Dsl.TypeGraph (BindingVersion (..), CanonicalTypeId (..), MappedKey (..), QualifiedValueName (..), TypeGraph (..), resolveTypeGraph, wireFingerprint)+import Keiro.Dsl.ProjectionMappedImpact qualified as ProjectionImpact+import Keiro.Dsl.SemanticContract (CheckedService, checkedSpec, checkedTypeGraph)+import Keiro.Dsl.SemanticImpact (semanticImpact)+import Keiro.Dsl.TypeGraph (BindingVersion (..), CanonicalTypeId (..), DerivedMappedConsumer (..), MappedKey (..), QualifiedValueName (..), TypeGraph (..), TypeGraphError, wireFingerprint)  -- | The smallest conservative audit input for one aggregate. data AggregateImpact = AggregateImpact@@ -49,6 +54,19 @@   | ReplayAffected !(Map Name AggregateImpact)   deriving stock (Eq, Show) +-- | Projection-catalog replay impact is reported beside aggregate-fold impact+-- so existing aggregate audit consumers retain their released JSON shape.+data CatalogReplayImpact+  = CatalogReplayNeutral+  | CatalogReplayAffected+      { affectedGroups :: !(Set Name),+        affectedTargets :: !(Set Name),+        affectedSources :: !(Set Text),+        affectedAdapters :: !(Set Name),+        invalidatesRunningFingerprint :: !Bool+      }+  deriving stock (Eq, Show)+ instance ToJSON AggregateImpact where   toJSON impact =     object@@ -64,6 +82,101 @@         "aggregates" .= aggregates       ] +instance ToJSON CatalogReplayImpact where+  toJSON CatalogReplayNeutral = object ["verdict" .= ("catalog-replay-neutral" :: Text)]+  toJSON impact@CatalogReplayAffected {} =+    object+      [ "verdict" .= ("catalog-replay-affected" :: Text),+        "groups" .= Set.toAscList (affectedGroups impact),+        "targets" .= Set.toAscList (affectedTargets impact),+        "sources" .= Set.toAscList (affectedSources impact),+        "adapters" .= Set.toAscList (affectedAdapters impact),+        "invalidatesRunningFingerprint" .= invalidatesRunningFingerprint impact+      ]++catalogReplayImpactServices :: CheckedService -> CheckedService -> CatalogReplayImpact+catalogReplayImpactServices oldService newService+  | Set.null groups && Set.null targets && Set.null sources && Set.null adapters = CatalogReplayNeutral+  | otherwise =+      CatalogReplayAffected+        { affectedGroups = groups,+          affectedTargets = targets,+          affectedSources = sources,+          affectedAdapters = adapters,+          invalidatesRunningFingerprint = True+        }+  where+    oldSpec = checkedSpec oldService+    newSpec = checkedSpec newService+    oldTargets = Map.fromList [(ptName target, target) | NProjectionTarget target <- specNodes oldSpec]+    newTargets = Map.fromList [(ptName target, target) | NProjectionTarget target <- specNodes newSpec]+    oldGroups = Map.fromList [(rgName groupNode, groupNode) | NRebuildGroup groupNode <- specNodes oldSpec]+    newGroups = Map.fromList [(rgName groupNode, groupNode) | NRebuildGroup groupNode <- specNodes newSpec]+    oldOwners = Map.fromList [(poName owner, owner) | NProjectionOwner owner <- specNodes oldSpec]+    newOwners = Map.fromList [(poName owner, owner) | NProjectionOwner owner <- specNodes newSpec]+    changedTargetNames = changedKeys oldTargets newTargets+    changedGroupNames = changedKeys oldGroups newGroups+    changedOwnerNames = changedKeys oldOwners newOwners+    changedOwners = mapMaybe (`Map.lookup` oldOwners) (Set.toList changedOwnerNames) <> mapMaybe (`Map.lookup` newOwners) (Set.toList changedOwnerNames)+    changedGroups = mapMaybe (`Map.lookup` oldGroups) (Set.toList changedGroupNames) <> mapMaybe (`Map.lookup` newGroups) (Set.toList changedGroupNames)+    groups = changedGroupNames <> Set.fromList (map poGroup changedOwners) <> groupsContainingChangedTargets <> inheritedGroups+    targets = changedTargetNames <> Set.fromList (concatMap poTargets changedOwners <> concatMap rgTargets changedGroups) <> inheritedTargets+    sources = Set.fromList (map renderSource (concatMap poSources changedOwners)) <> inheritedSources+    adapters = changedOwnerNames <> inheritedAdapters+    groupsContainingChangedTargets =+      Set.fromList+        [ rgName groupNode+        | groupNode <- Map.elems oldGroups <> Map.elems newGroups,+          any (`Set.member` changedTargetNames) (rgTargets groupNode)+        ]+    changedKeys oldMap newMap =+      Set.fromList+        [ key+        | key <- Set.toList (Map.keysSet oldMap <> Map.keysSet newMap),+          Map.lookup key oldMap /= Map.lookup key newMap+        ]+    renderSource CatalogAll = "all"+    renderSource (CatalogCategory categoryName) = "category:" <> categoryName+    renderSource (CatalogAggregate aggregateName) = "aggregate:" <> aggregateName++    -- A mapped wire change below an aggregate event changes the generated+    -- aggregate-source fingerprint even when the catalog declarations are+    -- byte-identical. Only explicitly replayable aggregate owners invalidate+    -- catalog replay state; live-only owners remain operationally visible in+    -- projection reporting but are excluded from this replay audit.+    (inheritedGroups, inheritedTargets, inheritedSources, inheritedAdapters) =+      foldMap mappedSourceImpact changedMappedCatalogConsumers+    changedMappedCatalogConsumers =+      [ (derived, oldOperation, newOperation)+      | derived@CatalogProjectionConsumer {} <- Set.toAscList (Map.keysSet oldMappedOperations <> Map.keysSet newMappedOperations),+        let oldOperation = Map.lookup derived oldMappedOperations,+        let newOperation = Map.lookup derived newMappedOperations,+        operationFingerprint oldOperation /= operationFingerprint newOperation,+        maybe False operationReplayable oldOperation || maybe False operationReplayable newOperation+      ]+    oldMappedOperations = maybe Map.empty ProjectionImpact.operations (projectionImpactFor oldService)+    newMappedOperations = maybe Map.empty ProjectionImpact.operations (projectionImpactFor newService)+    projectionImpactFor service = case checkedTypeGraph service of+      Left _ -> Nothing+      Right graph -> Just (ProjectionImpact.projectionMappedImpact service (semanticImpact graph))+    operationFingerprint = fmap (\(ProjectionImpact.ProjectionOperationalImpact _ _ _ _ _ fingerprint) -> fingerprint)+    operationReplayable (ProjectionImpact.ProjectionOperationalImpact _ _ _ _ canReplay _) = canReplay+    mappedSourceImpact+      ( CatalogProjectionConsumer owner aggregate,+        oldOperation,+        newOperation+        ) =+        ( groupsFor oldOperation <> groupsFor newOperation,+          targetsFor oldOperation <> targetsFor newOperation,+          Set.singleton ("aggregate:" <> aggregate),+          Set.singleton owner+        )+    mappedSourceImpact (AggregateInlineProjectionConsumer {}, _, _) = mempty+    groupsFor = maybe Set.empty (maybe Set.empty Set.singleton . operationGroup)+    targetsFor = maybe Set.empty operationTargets+    operationGroup (ProjectionImpact.ProjectionOperationalImpact _ groupName _ _ _ _) = groupName+    operationTargets (ProjectionImpact.ProjectionOperationalImpact _ _ targetNames _ _ _) = targetNames+ -- | Compute replay impact for every aggregate that existed under the old -- effective semantic contract. replayImpactServices :: CheckedService -> CheckedService -> Either FoldSurfaceError ReplayImpact@@ -72,7 +185,7 @@   traverse_ (aggregateFoldSurfaceForService newService . snd) (Map.toList newAggregates)   resolvedImpacts <-     traverse-      (\(name, oldAggregate) -> fmap ((,) name) (maybe (pure (removedAggregateImpact oldAggregate)) (matchedAggregateImpact oldService newService oldAggregate) (Map.lookup name newAggregates)))+      (\(name, oldAggregate) -> fmap ((,) name) (maybe (pure (removedAggregateImpact oldAggregate)) (matchedAggregateImpact oldService newService oldContext newContext oldAggregate) (Map.lookup name newAggregates)))       oldAggregates   pure $ case Map.filter hasImpact (Map.fromList resolvedImpacts) of     filtered@@ -81,9 +194,21 @@   where     oldSpec = checkedSpec oldService     newSpec = checkedSpec newService-    oldAggregates = [(aggName aggregate, aggregate) | NAggregate aggregate <- specNodes oldSpec]-    newAggregates = Map.fromList [(aggName aggregate, aggregate) | NAggregate aggregate <- specNodes newSpec]+    oldGraphResult = checkedTypeGraph oldService+    newGraphResult = checkedTypeGraph newService+    oldSymbols = aggregateSymbolsFromGraphResult oldGraphResult oldSpec+    newSymbols = aggregateSymbolsFromGraphResult newGraphResult newSpec+    oldContext = ReplaySurfaceContext oldSpec oldGraphResult oldSymbols+    newContext = ReplaySurfaceContext newSpec newGraphResult newSymbols+    oldAggregates = [(aggName aggregate, aggregate) | NAggregate aggregate <- specNodes (surfaceSpec oldContext)]+    newAggregates = Map.fromList [(aggName aggregate, aggregate) | NAggregate aggregate <- specNodes (surfaceSpec newContext)] +data ReplaySurfaceContext = ReplaySurfaceContext+  { surfaceSpec :: !Spec,+    surfaceGraphResult :: Either (NE.NonEmpty TypeGraphError) TypeGraph,+    surfaceSymbols :: AggregateSymbols+  }+ hasImpact :: AggregateImpact -> Bool hasImpact impact =   not (Set.null (eventTypes impact))@@ -96,8 +221,8 @@       includeSnapshotStreams = True     } -matchedAggregateImpact :: CheckedService -> CheckedService -> Aggregate -> Aggregate -> Either FoldSurfaceError AggregateImpact-matchedAggregateImpact oldService newService oldAggregate newAggregate = do+matchedAggregateImpact :: CheckedService -> CheckedService -> ReplaySurfaceContext -> ReplaySurfaceContext -> Aggregate -> Aggregate -> Either FoldSurfaceError AggregateImpact+matchedAggregateImpact oldService newService oldContext newContext oldAggregate newAggregate = do   oldSurface <- aggregateFoldSurfaceForService oldService oldAggregate   newNonTransitionSurface <-     aggregateFoldSurfaceForService@@ -113,18 +238,16 @@         includeSnapshotStreams = transitionFoldChanged || nonTransitionFoldChanged || mappedRegisterChanged       }   where-    oldSpec = checkedSpec oldService-    newSpec = checkedSpec newService     oldEventTypes = Set.fromList (evName <$> aggEvents oldAggregate)-    decodeAffected = decodeSurfaceAffected oldSpec newSpec oldAggregate newAggregate+    decodeAffected = decodeSurfaceAffected oldContext newContext oldAggregate newAggregate     mappedRegisterChanged =-      mappedRegisterSurface oldSpec oldAggregate-        /= mappedRegisterSurface newSpec newAggregate+      mappedRegisterSurface oldContext oldAggregate+        /= mappedRegisterSurface newContext newAggregate     (transitionAffected, transitionFoldChanged) =       changedTransitionEvents (aggTransitions oldAggregate) (aggTransitions newAggregate) -decodeSurfaceAffected :: Spec -> Spec -> Aggregate -> Aggregate -> Set Name-decodeSurfaceAffected oldSpec newSpec oldAggregate newAggregate =+decodeSurfaceAffected :: ReplaySurfaceContext -> ReplaySurfaceContext -> Aggregate -> Aggregate -> Set Name+decodeSurfaceAffected oldContext newContext oldAggregate newAggregate =   removedOrChanged <> wireAffected   where     newEvents = Map.fromList [(evName event, event) | event <- aggEvents newAggregate]@@ -132,7 +255,7 @@       Set.fromList         [ evName oldEvent         | oldEvent <- aggEvents oldAggregate,-          maybe True ((/= eventSurface oldSpec oldAggregate oldEvent) . eventSurface newSpec newAggregate) (Map.lookup (evName oldEvent) newEvents)+          maybe True ((/= eventSurface oldContext oldAggregate oldEvent) . eventSurface newContext newAggregate) (Map.lookup (evName oldEvent) newEvents)         ]     wireAffected       | aggWire oldAggregate == aggWire newAggregate = Set.empty@@ -148,14 +271,14 @@     ]   ) -eventSurface :: Spec -> Aggregate -> Event -> ((Int, Maybe (Int, Hole), [(Name, Text, Maybe TypeExpr)]), [(Name, Text)])-eventSurface spec aggregate event =-  (eventDecodeSurface aggregate event, mappedFieldSurface spec aggregate event)+eventSurface :: ReplaySurfaceContext -> Aggregate -> Event -> ((Int, Maybe (Int, Hole), [(Name, Text, Maybe TypeExpr)]), [(Name, Text)])+eventSurface context aggregate event =+  (eventDecodeSurface aggregate event, mappedFieldSurface context aggregate event) -mappedFieldSurface :: Spec -> Aggregate -> Event -> [(Name, Text)]-mappedFieldSurface spec aggregate event = mapped <> nominal+mappedFieldSurface :: ReplaySurfaceContext -> Aggregate -> Event -> [(Name, Text)]+mappedFieldSurface context aggregate event = mapped <> nominal   where-    mapped = case resolveTypeGraph spec of+    mapped = case surfaceGraphResult context of       Left _ -> []       Right graph ->         [ (aggregateFieldName field, wireFingerprint graph typeName)@@ -163,17 +286,17 @@           TRef typeName <- maybeToList (aggregateFieldType field),           Map.member (MappedKey typeName) (tgDeclarations graph)         ]-    symbols = aggregateSymbols spec+    symbols = surfaceSymbols context     nominal =       [ (aggregateFieldName field, nominalSurface resolved)       | field <- eventFields aggregate event,         Right (AggregateNominal resolved) <- [inferAggregateFieldType symbols aggregate EventFieldUse field]       ] -mappedRegisterSurface :: Spec -> Aggregate -> [(Name, Name, Text)]-mappedRegisterSurface spec aggregate = mapped <> nominal+mappedRegisterSurface :: ReplaySurfaceContext -> Aggregate -> [(Name, Name, Text)]+mappedRegisterSurface context aggregate = mapped <> nominal   where-    mapped = case resolveTypeGraph spec of+    mapped = case surfaceGraphResult context of       Left _ -> []       Right graph ->         [ (regName register, typeName, wireFingerprint graph typeName)@@ -181,7 +304,7 @@           TRef typeName <- [regType register],           Map.member (MappedKey typeName) (tgDeclarations graph)         ]-    symbols = aggregateSymbols spec+    symbols = surfaceSymbols context     nominal =       [ (regName register, resolvedNominalName resolved, nominalSurface resolved)       | register <- aggRegs aggregate,

+ src/Keiro/Dsl/RouterSelection.hs view

@@ -0,0 +1,584 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++-- | Checked language-5 router selection semantics.+--+-- The parser AST deliberately retains unsupported policy names and unresolved+-- expressions so check can produce stable, located diagnostics. Values exported+-- from this module have crossed the mapped-type boundary: every path is total,+-- every scalar has one type, command mappings are complete, and the recipient+-- set has a positive bound.+module Keiro.Dsl.RouterSelection+  ( CheckedReadModelQuery (..),+    CheckedMappedExpr (..),+    CheckedMappedType (..),+    SelectionScalarType (..),+    SelectionRoot (..),+    CheckedSelectionPathSegment (..),+    CheckedScalarExpr (..),+    CheckedScalarNode (..),+    CheckedSelectionOrder (..),+    CheckedSelectionDedupe (..),+    CheckedEmptySelectionPolicy (..),+    CheckedSelectionFailurePolicy (..),+    CheckedRedeliveryPolicy (..),+    CheckedPartialDispatchPolicy (..),+    CheckedRouterSelection (..),+    RouterSelectionDiagnosticCode (..),+    RouterSelectionDiagnostic (..),+    checkRouterSelection,+    routerSelectionFingerprint,+  )+where++import Crypto.Hash.SHA256 qualified as SHA256+import Data.ByteString qualified as BS+import Data.List (find, sort)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as Text+import GHC.Generics (Generic)+import Keiro.Dsl.AggregateType+import Keiro.Dsl.Grammar+import Keiro.Dsl.LanguageVersion (LanguageFeature (DeclarativeRouterSelectionSyntax), languageSupportsFeature)+import Keiro.Dsl.SemanticContract (EffectiveLanguageContract, effectiveContractLanguageVersion)+import Keiro.Dsl.TypeGraph+import Numeric (showHex)+import Numeric.Natural (Natural)++data CheckedReadModelQuery = CheckedReadModelQuery+  { checkedQueryName :: !Name,+    checkedQueryInputType :: !ResolvedTypeExpr,+    checkedQueryResultType :: !ResolvedTypeExpr+  }+  deriving stock (Eq, Show, Generic)++data CheckedMappedExpr = CheckedMappedExpr+  { checkedMappedExprRoot :: !SelectionRoot,+    checkedMappedExprType :: !ResolvedTypeExpr+  }+  deriving stock (Eq, Show, Generic)++data CheckedMappedType = CheckedMappedType+  { checkedMappedTypeKey :: !MappedKey,+    checkedMappedTypeConstructor :: !Name,+    checkedMappedTypeFields :: ![ResolvedWireField]+  }+  deriving stock (Eq, Show, Generic)++data SelectionScalarType+  = SelectionText+  | SelectionInt+  | SelectionInteger+  | SelectionBool+  | SelectionNatural+  | SelectionTime+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++data SelectionRoot = SelectionInput | SelectionRow+  deriving stock (Eq, Ord, Show, Generic)++data CheckedSelectionPathSegment = CheckedSelectionPathSegment+  { checkedPathField :: !Name,+    checkedPathWireKey :: !Text,+    checkedPathOwner :: !MappedKey+  }+  deriving stock (Eq, Ord, Show, Generic)++data CheckedScalarExpr = CheckedScalarExpr+  { checkedScalarType :: !SelectionScalarType,+    checkedScalarNode :: !CheckedScalarNode,+    checkedScalarLoc :: !Loc+  }+  deriving stock (Eq, Show, Generic)++data CheckedScalarNode+  = CheckedPath !SelectionRoot ![CheckedSelectionPathSegment]+  | CheckedTextLiteral !Text+  | CheckedIntegralLiteral !Integer+  | CheckedBoolLiteral !Bool+  | CheckedCompare !CmpOp !CheckedScalarExpr !CheckedScalarExpr+  | CheckedAnd !CheckedScalarExpr !CheckedScalarExpr+  | CheckedOr !CheckedScalarExpr !CheckedScalarExpr+  deriving stock (Eq, Show, Generic)++data CheckedSelectionOrder = CheckedOrderByTargetStream+  deriving stock (Eq, Ord, Show, Generic)++data CheckedSelectionDedupe = CheckedDedupeByTargetStream+  deriving stock (Eq, Ord, Show, Generic)++data CheckedEmptySelectionPolicy+  = CheckedEmptyAck+  | CheckedEmptyRetry+  | CheckedEmptyDeadLetter+  | CheckedEmptyHalt+  deriving stock (Eq, Ord, Show, Generic)++data CheckedSelectionFailurePolicy+  = CheckedFailureRetry+  | CheckedFailureDeadLetter+  | CheckedFailureHalt+  deriving stock (Eq, Ord, Show, Generic)++data CheckedRedeliveryPolicy = CheckedStableUnion+  deriving stock (Eq, Ord, Show, Generic)++data CheckedPartialDispatchPolicy = CheckedRetainSuccesses+  deriving stock (Eq, Ord, Show, Generic)++data CheckedRouterSelection = CheckedRouterSelection+  { checkedIdentity :: !Text,+    checkedVersion :: !Natural,+    checkedQuery :: !CheckedReadModelQuery,+    checkedInputBinding :: !CheckedMappedExpr,+    checkedRowBinding :: !CheckedMappedType,+    checkedKey :: !CheckedScalarExpr,+    checkedPredicate :: !CheckedScalarExpr,+    checkedRecipient :: !CheckedScalarExpr,+    checkedCommandFields :: !(Map Name CheckedScalarExpr),+    checkedTarget :: !Name,+    checkedCommand :: !Name,+    checkedLimit :: !Natural,+    checkedOrder :: !CheckedSelectionOrder,+    checkedDedupe :: !CheckedSelectionDedupe,+    checkedEmptyPolicy :: !CheckedEmptySelectionPolicy,+    checkedFailurePolicy :: !CheckedSelectionFailurePolicy,+    checkedRedeliveryPolicy :: !CheckedRedeliveryPolicy,+    checkedPartialPolicy :: !CheckedPartialDispatchPolicy,+    checkedFingerprint :: !Text,+    checkedUseSites :: ![UseSite]+  }+  deriving stock (Eq, Show, Generic)++data RouterSelectionDiagnosticCode+  = SelectionNotDeclarative+  | SelectionCapabilityUnavailable+  | SelectionIdentityEmpty+  | SelectionVersionInvalid+  | SelectionQueryUnknown+  | SelectionQueryContractMissing+  | SelectionQueryInputBindingInvalid+  | SelectionQueryInputTypeMismatch+  | SelectionQueryResultNotList+  | SelectionQueryRowNotStructural+  | SelectionExpressionRootUnknown+  | SelectionExpressionFieldUnknown+  | SelectionExpressionFieldOptional+  | SelectionExpressionTypeMismatch+  | SelectionPredicateNotBool+  | SelectionRecipientNotText+  | SelectionOperatorUnsupported+  | SelectionRecipientLimitMissing+  | SelectionRecipientLimitInvalid+  | SelectionOrderUnsupported+  | SelectionDedupeUnsupported+  | SelectionFailureAckForbidden+  | SelectionRedeliveryUnsupported+  | SelectionPartialDispatchUnsupported+  | SelectionTargetAmbiguous+  | SelectionCommandUnknown+  | SelectionCommandMappingDuplicate+  | SelectionCommandMappingIncomplete+  | SelectionCommandMappingTypeMismatch+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++data RouterSelectionDiagnostic = RouterSelectionDiagnostic+  { selectionDiagnosticLoc :: !Loc,+    selectionDiagnosticCode :: !RouterSelectionDiagnosticCode,+    selectionDiagnosticMessage :: !Text+  }+  deriving stock (Eq, Show, Generic)++checkRouterSelection :: EffectiveLanguageContract -> TypeGraph -> Spec -> RouterNode -> Either (NonEmpty RouterSelectionDiagnostic) CheckedRouterSelection+checkRouterSelection languageContract graph spec router = case rvSource (rtResolve router) of+  ResolveReadModel {} -> selectionFailure (rvLoc (rtResolve router)) SelectionNotDeclarative "custom-unverified router selection has no checked declarative contract"+  ResolveHole -> selectionFailure (rvLoc (rtResolve router)) SelectionNotDeclarative "custom-unverified router selection has no checked declarative contract"+  ResolveDeclarative declaration -> checkDeclaration declaration+  where+    symbols = aggregateSymbolsFromGraph graph spec++    checkDeclaration declaration = do+      requireFeature declaration+      identity <- requireIdentity declaration+      version <- requirePositive (rsVersionLoc declaration) SelectionVersionInvalid "selection version" (rsVersion declaration)+      recipientLimit <- case rsLimit declaration of+        Nothing -> selectionFailure (rsLoc declaration) SelectionRecipientLimitMissing "declarative router selection requires a positive max-recipients"+        Just (value, valueLoc) -> requirePositive valueLoc SelectionRecipientLimitInvalid "max-recipients" value+      order <- requireExact (rsOrderLoc declaration) SelectionOrderUnsupported "order" "target-stream" CheckedOrderByTargetStream (rsOrder declaration)+      dedupe <- requireExact (rsDedupeLoc declaration) SelectionDedupeUnsupported "dedupe" "target-stream" CheckedDedupeByTargetStream (rsDedupe declaration)+      emptyPolicy <- checkEmptyPolicy declaration+      failurePolicy <- checkFailurePolicy declaration+      redelivery <- requireExact (rsRedeliveryLoc declaration) SelectionRedeliveryUnsupported "redelivery" "stable-union" CheckedStableUnion (rsRedelivery declaration)+      partial <- requireExact (rsPartialLoc declaration) SelectionPartialDispatchUnsupported "partial" "retain-successes" CheckedRetainSuccesses (rsPartial declaration)+      (query, inputBinding, rowBinding) <- checkQuery declaration+      keyExpression <- resolveSelectionExpr graph (checkedMappedExprType inputBinding) rowBinding Nothing (EPath (inLoc (rtInput router)) UnqualifiedRoot ["input", corrField (rtKey router)])+      requireScalarType (inLoc (rtInput router)) SelectionQueryInputBindingInvalid "router key" SelectionText keyExpression+      predicate <- resolveSelectionExpr graph (checkedMappedExprType inputBinding) rowBinding Nothing (rsPredicate declaration)+      requireScalarType (exprLoc (rsPredicate declaration)) SelectionPredicateNotBool "where predicate" SelectionBool predicate+      recipient <- resolveSelectionExpr graph (checkedMappedExprType inputBinding) rowBinding Nothing (rsRecipient declaration)+      requireScalarType (exprLoc (rsRecipient declaration)) SelectionRecipientNotText "recipient expression" SelectionText recipient+      (targetAggregate, targetCommand) <- resolveTargetCommand+      commandFields <- checkCommandMappings graph inputBinding rowBinding targetAggregate targetCommand+      let initial =+            CheckedRouterSelection+              { checkedIdentity = identity,+                checkedVersion = version,+                checkedQuery = query,+                checkedInputBinding = inputBinding,+                checkedRowBinding = rowBinding,+                checkedKey = keyExpression,+                checkedPredicate = predicate,+                checkedRecipient = recipient,+                checkedCommandFields = commandFields,+                checkedTarget = rtTarget router,+                checkedCommand = rdCommand (rtDispatch router),+                checkedLimit = recipientLimit,+                checkedOrder = order,+                checkedDedupe = dedupe,+                checkedEmptyPolicy = emptyPolicy,+                checkedFailurePolicy = failurePolicy,+                checkedRedeliveryPolicy = redelivery,+                checkedPartialPolicy = partial,+                checkedFingerprint = "",+                checkedUseSites = queryUseSites (rsQuery declaration)+              }+      pure initial {checkedFingerprint = routerSelectionFingerprint initial}++    requireFeature declaration+      | languageSupportsFeature (effectiveContractLanguageVersion languageContract) DeclarativeRouterSelectionSyntax = Right ()+      | otherwise = selectionFailure (rsLoc declaration) SelectionCapabilityUnavailable "declarative router selection requires language keiro-dsl 5"++    requireIdentity declaration+      | T.null (T.strip (rsIdentity declaration)) = selectionFailure (rsIdentityLoc declaration) SelectionIdentityEmpty "selection identity must not be empty"+      | otherwise = Right (rsIdentity declaration)++    checkEmptyPolicy declaration = case rsEmptyPolicy declaration of+      SelectionAck -> Right CheckedEmptyAck+      SelectionRetry -> Right CheckedEmptyRetry+      SelectionDeadLetter -> Right CheckedEmptyDeadLetter+      SelectionHalt -> Right CheckedEmptyHalt++    checkFailurePolicy declaration = case rsFailurePolicy declaration of+      SelectionAck -> selectionFailure (rsFailurePolicyLoc declaration) SelectionFailureAckForbidden "selection failure cannot acknowledge the source message"+      SelectionRetry -> Right CheckedFailureRetry+      SelectionDeadLetter -> Right CheckedFailureDeadLetter+      SelectionHalt -> Right CheckedFailureHalt++    checkQuery declaration = do+      readModel <- case find ((== rsQuery declaration) . rmName) readModels of+        Nothing -> selectionFailure (rsQueryLoc declaration) SelectionQueryUnknown ("selection query names undeclared readmodel '" <> rsQuery declaration <> "'")+        Just value -> Right value+      queryTypesDeclaration <- maybe (selectionFailure (rsQueryLoc declaration) SelectionQueryContractMissing ("readmodel '" <> rmName readModel <> "' has no typed query input/result contract")) Right (queryTypes readModel)+      if rsQueryInput declaration == "input"+        then pure ()+        else selectionFailure (rsQueryInputLoc declaration) SelectionQueryInputBindingInvalid "selection query input must be the router input binding `input`"+      queryInput <- liftTypeGraph (rsQueryLoc declaration) (resolveTypeExpression graph ("readmodel " <> rmName readModel <> " query input") (inputLoc queryTypesDeclaration) (input queryTypesDeclaration))+      queryResult <- liftTypeGraph (rsQueryLoc declaration) (resolveTypeExpression graph ("readmodel " <> rmName readModel <> " query result") (resultLoc queryTypesDeclaration) (result queryTypesDeclaration))+      routerInputExpression <- maybe (selectionFailure (inLoc (rtInput router)) SelectionQueryInputBindingInvalid "declarative router input must name its mapped query-input type with `input Name : Type`") Right (inType (rtInput router))+      routerInput <- liftTypeGraph (inLoc (rtInput router)) (resolveTypeExpression graph ("router " <> rtId router <> " input") (inLoc (rtInput router)) routerInputExpression)+      if routerInput == queryInput+        then pure ()+        else selectionFailure (inLoc (rtInput router)) SelectionQueryInputTypeMismatch ("router input type does not match readmodel '" <> rmName readModel <> "' query input")+      _ <- structuralRecord (inLoc (rtInput router)) SelectionQueryInputBindingInvalid "router query input" routerInput+      rowBinding <- case queryResult of+        RList rowType -> structuralRecord (resultLoc queryTypesDeclaration) SelectionQueryRowNotStructural "query result row" rowType+        _ -> selectionFailure (resultLoc queryTypesDeclaration) SelectionQueryResultNotList "declarative router query result must be List Row"+      pure+        ( CheckedReadModelQuery (rmName readModel) queryInput queryResult,+          CheckedMappedExpr SelectionInput queryInput,+          rowBinding+        )++    structuralRecord diagnosticLoc diagnosticCode owner = \case+      RRef key -> case Map.lookup key (tgDeclarations graph) of+        Just (ResolvedStructural _ (RRecord constructor _ fields)) -> Right (CheckedMappedType key constructor fields)+        _ -> selectionFailure diagnosticLoc diagnosticCode (owner <> " must be a mapped structural record")+      _ -> selectionFailure diagnosticLoc diagnosticCode (owner <> " must be a mapped structural record")++    resolveTargetCommand = case [aggregate | NAggregate aggregate <- specNodes spec, aggName aggregate == rtTarget router] of+      [aggregate] -> case [command | command <- aggCommands aggregate, cmdName command == rdCommand (rtDispatch router)] of+        [command] -> Right (aggregate, command)+        _ -> selectionFailure (rdLoc (rtDispatch router)) SelectionCommandUnknown ("target aggregate '" <> rtTarget router <> "' has no unique command '" <> rdCommand (rtDispatch router) <> "'")+      _ -> selectionFailure (rtLoc router) SelectionTargetAmbiguous ("declarative router target '" <> rtTarget router <> "' does not identify exactly one aggregate")++    checkCommandMappings selectionGraph inputBinding rowBinding aggregate command = do+      let bindings = rdFields (rtDispatch router)+          duplicateNames = duplicates (map fbName bindings)+          expectedNames = sort (map aggregateFieldName (cmdFields command))+          actualNames = sort (map fbName bindings)+      case duplicateNames of+        duplicateName : _ -> selectionFailure (rdLoc (rtDispatch router)) SelectionCommandMappingDuplicate ("dispatch field '" <> duplicateName <> "' is mapped more than once")+        [] -> pure ()+      if expectedNames == actualNames+        then pure ()+        else selectionFailure (rdLoc (rtDispatch router)) SelectionCommandMappingIncomplete ("dispatch mapping must bind every field of command '" <> cmdName command <> "' exactly once")+      Map.fromList <$> traverse (checkBinding selectionGraph inputBinding rowBinding aggregate bindings) (cmdFields command)++    checkBinding selectionGraph inputBinding rowBinding aggregate bindings field = do+      binding <- case find ((== aggregateFieldName field) . fbName) bindings of+        Just value -> Right value+        Nothing -> selectionFailure (rdLoc (rtDispatch router)) SelectionCommandMappingIncomplete ("missing dispatch mapping for field '" <> aggregateFieldName field <> "'")+      expression <- resolveBinding selectionGraph inputBinding rowBinding (rdLoc (rtDispatch router)) binding+      expectedAggregateType <- case inferAggregateFieldType symbols aggregate CommandFieldUse field of+        Left _ -> selectionFailure (aggregateFieldLoc field) SelectionCommandMappingTypeMismatch ("command field '" <> aggregateFieldName field <> "' has no selection-compatible scalar type")+        Right value -> Right value+      expected <- maybe (selectionFailure (aggregateFieldLoc field) SelectionCommandMappingTypeMismatch ("command field '" <> aggregateFieldName field <> "' is not a supported scalar selection target")) Right (selectionTypeFromAggregate expectedAggregateType)+      requireScalarType (checkedScalarLoc expression) SelectionCommandMappingTypeMismatch ("command field '" <> aggregateFieldName field <> "'") expected expression+      pure (aggregateFieldName field, expression)++    queryUseSites queryName =+      [ useSite+      | useSite <- tgUseSites graph,+        case useSite of+          RootReadModelQueryInput name _ -> name == queryName+          RootReadModelQueryResult name _ -> name == queryName+          _ -> False+      ]++    readModels = [readModel | NReadModel readModel <- specNodes spec]++resolveBinding :: TypeGraph -> CheckedMappedExpr -> CheckedMappedType -> Loc -> FieldBinding -> Either (NonEmpty RouterSelectionDiagnostic) CheckedScalarExpr+resolveBinding graph inputBinding rowBinding diagnosticLoc binding =+  resolveSelectionExpr graph (checkedMappedExprType inputBinding) rowBinding Nothing expression+  where+    expression = case fbValue binding of+      Nothing -> EPath diagnosticLoc UnqualifiedRoot ["input", fbName binding]+      Just value+        | Just literal <- quotedValue value -> ELiteral diagnosticLoc (LiteralText literal)+        | otherwise -> EPath diagnosticLoc UnqualifiedRoot (T.splitOn "." value)+    quotedValue value+      | T.length value >= 2,+        T.head value == '"',+        T.last value == '"' =+          Just (T.init (T.tail value))+      | otherwise = Nothing++resolveSelectionExpr :: TypeGraph -> ResolvedTypeExpr -> CheckedMappedType -> Maybe SelectionScalarType -> Expr -> Either (NonEmpty RouterSelectionDiagnostic) CheckedScalarExpr+resolveSelectionExpr graph inputType rowType expected expression = case expression of+  EPath loc UnqualifiedRoot (rootName : fields) -> do+    (root, rootType) <- case rootName of+      "input" -> Right (SelectionInput, inputType)+      "row" -> Right (SelectionRow, RRef (checkedMappedTypeKey rowType))+      _ -> selectionFailure loc SelectionExpressionRootUnknown ("selection expression root must be input or row, found '" <> rootName <> "'")+    if null fields+      then selectionFailure loc SelectionExpressionTypeMismatch "a whole mapped value is not a scalar expression"+      else do+        (scalarType, path) <- resolvePath graph loc rootType fields+        requireExpected loc expected scalarType+        pure (CheckedScalarExpr scalarType (CheckedPath root path) loc)+  EPath loc _ _ -> selectionFailure loc SelectionExpressionRootUnknown "selection expressions do not admit aggregate reg/cmd roots"+  ELiteral loc (LiteralText value) -> literal loc SelectionText (CheckedTextLiteral value)+  ELiteral loc (LiteralIntegral value) -> case expected of+    Just SelectionNatural+      | value < 0 -> selectionFailure loc SelectionExpressionTypeMismatch "Natural selection literal must not be negative"+      | otherwise -> literal loc SelectionNatural (CheckedIntegralLiteral value)+    Just expectedType | expectedType `elem` [SelectionInt, SelectionInteger] -> literal loc expectedType (CheckedIntegralLiteral value)+    _ -> selectionFailure loc SelectionExpressionTypeMismatch "integral selection literal needs an Int, Integer, or Natural operand"+  ELiteral loc (LiteralBool value) -> literal loc SelectionBool (CheckedBoolLiteral value)+  ELiteral loc LiteralQualified {} -> selectionFailure loc SelectionOperatorUnsupported "qualified enum literals are not admitted in declarative router selection"+  ELiteral loc LiteralId {} -> selectionFailure loc SelectionOperatorUnsupported "nominal ID literals are not admitted in declarative router selection"+  EAtom (ABool value) -> literal noLoc SelectionBool (CheckedBoolLiteral value)+  EAtom (AName name) -> selectionFailure noLoc SelectionExpressionRootUnknown ("selection expression root must be input or row, found '" <> name <> "'")+  EAnd left right -> booleanNode CheckedAnd left right+  EOr left right -> booleanNode CheckedOr left right+  ECmp operator left right -> comparisonNode operator left right+  EAdd loc _ _ -> unsupportedArithmetic loc+  ESubtract loc _ _ -> unsupportedArithmetic loc+  EMultiply loc _ _ -> unsupportedArithmetic loc+  where+    literal loc scalarType node = do+      requireExpected loc expected scalarType+      pure (CheckedScalarExpr scalarType node loc)++    booleanNode constructor left right = do+      checkedLeft <- resolveSelectionExpr graph inputType rowType (Just SelectionBool) left+      checkedRight <- resolveSelectionExpr graph inputType rowType (Just SelectionBool) right+      let loc = exprLoc expression+      requireExpected loc expected SelectionBool+      pure (CheckedScalarExpr SelectionBool (constructor checkedLeft checkedRight) loc)++    comparisonNode operator left right = do+      (checkedLeft, checkedRight) <- case left of+        ELiteral _ LiteralIntegral {} -> do+          rightValue <- resolveSelectionExpr graph inputType rowType Nothing right+          leftValue <- resolveSelectionExpr graph inputType rowType (Just (checkedScalarType rightValue)) left+          pure (leftValue, rightValue)+        _ -> do+          leftValue <- resolveSelectionExpr graph inputType rowType Nothing left+          rightValue <- resolveSelectionExpr graph inputType rowType (Just (checkedScalarType leftValue)) right+          pure (leftValue, rightValue)+      if checkedScalarType checkedLeft == checkedScalarType checkedRight+        then pure ()+        else selectionFailure (exprLoc expression) SelectionExpressionTypeMismatch "comparison operands have different scalar types"+      if comparisonAdmitted operator (checkedScalarType checkedLeft)+        then pure ()+        else selectionFailure (exprLoc expression) SelectionOperatorUnsupported ("comparison operator is not admitted for " <> scalarTypeText (checkedScalarType checkedLeft))+      requireExpected (exprLoc expression) expected SelectionBool+      pure (CheckedScalarExpr SelectionBool (CheckedCompare operator checkedLeft checkedRight) (exprLoc expression))++    unsupportedArithmetic loc = selectionFailure loc SelectionOperatorUnsupported "arithmetic operators are not admitted in declarative router selection"++resolvePath :: TypeGraph -> Loc -> ResolvedTypeExpr -> [Name] -> Either (NonEmpty RouterSelectionDiagnostic) (SelectionScalarType, [CheckedSelectionPathSegment])+resolvePath graph diagnosticLoc = go []+  where+    go segments currentType remaining = case remaining of+      [] -> case selectionTypeFromResolved currentType of+        Just scalarType -> Right (scalarType, reverse segments)+        Nothing -> selectionFailure diagnosticLoc SelectionExpressionTypeMismatch "selection path does not end at a supported scalar"+      fieldName : rest -> case currentType of+        RRef owner -> case Map.lookup owner (tgDeclarations graph) of+          Just (ResolvedStructural _ (RRecord _ _ fields)) -> case find ((== fieldName) . rwfHaskell) fields of+            Nothing -> selectionFailure diagnosticLoc SelectionExpressionFieldUnknown ("mapped record '" <> unMappedKey owner <> "' has no field '" <> fieldName <> "'")+            Just field+              | rwfPresence field /= PRequired -> selectionFailure diagnosticLoc SelectionExpressionFieldOptional ("field '" <> fieldName <> "' is optional; selection paths must be total")+              | ROptional {} <- rwfType field -> selectionFailure diagnosticLoc SelectionExpressionFieldOptional ("field '" <> fieldName <> "' is nullable; selection paths must be total")+              | otherwise -> go (CheckedSelectionPathSegment fieldName (rwfKey field) owner : segments) (rwfType field) rest+          _ -> selectionFailure diagnosticLoc SelectionQueryRowNotStructural ("mapped type '" <> unMappedKey owner <> "' is not a structural record")+        _ -> selectionFailure diagnosticLoc SelectionExpressionFieldUnknown ("cannot project field '" <> fieldName <> "' through a scalar value")++requirePositive :: Loc -> RouterSelectionDiagnosticCode -> Text -> Natural -> Either (NonEmpty RouterSelectionDiagnostic) Natural+requirePositive diagnosticLoc diagnosticCode owner value+  | value > 0 = Right value+  | otherwise = selectionFailure diagnosticLoc diagnosticCode (owner <> " must be positive")++requireExact :: Loc -> RouterSelectionDiagnosticCode -> Text -> Name -> value -> Name -> Either (NonEmpty RouterSelectionDiagnostic) value+requireExact diagnosticLoc diagnosticCode owner admitted checked actual+  | actual == admitted = Right checked+  | otherwise = selectionFailure diagnosticLoc diagnosticCode (owner <> " must be " <> admitted <> ", found " <> actual)++requireExpected :: Loc -> Maybe SelectionScalarType -> SelectionScalarType -> Either (NonEmpty RouterSelectionDiagnostic) ()+requireExpected _ Nothing _ = Right ()+requireExpected diagnosticLoc (Just expected) actual+  | expected == actual = Right ()+  | otherwise = selectionFailure diagnosticLoc SelectionExpressionTypeMismatch ("expected " <> scalarTypeText expected <> ", found " <> scalarTypeText actual)++requireScalarType :: Loc -> RouterSelectionDiagnosticCode -> Text -> SelectionScalarType -> CheckedScalarExpr -> Either (NonEmpty RouterSelectionDiagnostic) ()+requireScalarType diagnosticLoc diagnosticCode owner expected expression+  | checkedScalarType expression == expected = Right ()+  | otherwise = selectionFailure diagnosticLoc diagnosticCode (owner <> " must have type " <> scalarTypeText expected <> ", found " <> scalarTypeText (checkedScalarType expression))++liftTypeGraph :: Loc -> Either TypeGraphError value -> Either (NonEmpty RouterSelectionDiagnostic) value+liftTypeGraph diagnosticLoc = either (\err -> selectionFailure diagnosticLoc SelectionExpressionTypeMismatch ("mapped type could not be resolved: " <> T.pack (show err))) Right++selectionTypeFromResolved :: ResolvedTypeExpr -> Maybe SelectionScalarType+selectionTypeFromResolved = \case+  RText -> Just SelectionText+  RInt -> Just SelectionInt+  RInteger -> Just SelectionInteger+  RBool -> Just SelectionBool+  RNatural -> Just SelectionNatural+  RTime -> Just SelectionTime+  RJson -> Nothing+  ROptional {} -> Nothing+  RList {} -> Nothing+  RMap {} -> Nothing+  RRef {} -> Nothing++selectionTypeFromAggregate :: ResolvedAggregateType -> Maybe SelectionScalarType+selectionTypeFromAggregate = \case+  AggregateText -> Just SelectionText+  AggregateInt -> Just SelectionInt+  AggregateInteger -> Just SelectionInteger+  AggregateBool -> Just SelectionBool+  AggregateTime -> Just SelectionTime+  AggregateNatural -> Just SelectionNatural+  AggregateNominal {} -> Nothing+  AggregateVertex {} -> Nothing+  AggregateMapped {} -> Nothing++comparisonAdmitted :: CmpOp -> SelectionScalarType -> Bool+comparisonAdmitted operator scalarType = case operator of+  OpEq -> True+  OpNeq -> True+  OpLt -> ordered+  OpLe -> ordered+  OpGt -> ordered+  OpGe -> ordered+  where+    ordered = scalarType `elem` [SelectionInt, SelectionInteger, SelectionNatural, SelectionTime]++scalarTypeText :: SelectionScalarType -> Text+scalarTypeText = \case+  SelectionText -> "Text"+  SelectionInt -> "Int"+  SelectionInteger -> "Integer"+  SelectionBool -> "Bool"+  SelectionNatural -> "Natural"+  SelectionTime -> "Time"++selectionFailure :: Loc -> RouterSelectionDiagnosticCode -> Text -> Either (NonEmpty RouterSelectionDiagnostic) value+selectionFailure diagnosticLoc diagnosticCode diagnosticMessage = Left (RouterSelectionDiagnostic diagnosticLoc diagnosticCode diagnosticMessage :| [])++duplicates :: (Ord value) => [value] -> [value]+duplicates values = Map.keys (Map.filter (> (1 :: Int)) (Map.fromListWith (+) [(value, 1 :: Int) | value <- values]))++-- | SHA-256 over a length-prefixed encoding of checked semantic evidence.+-- Locations, comments, formatting, identity, declared version, and the digest+-- field itself are intentionally absent.+routerSelectionFingerprint :: CheckedRouterSelection -> Text+routerSelectionFingerprint = hexDigest . SHA256.hash . Text.encodeUtf8 . canonicalSelection++canonicalSelection :: CheckedRouterSelection -> Text+canonicalSelection selection =+  tuple+    [ atom "keiro-dsl/router-selection/1",+      atom (checkedQueryName (checkedQuery selection)),+      canonicalResolvedType (checkedQueryInputType (checkedQuery selection)),+      canonicalResolvedType (checkedQueryResultType (checkedQuery selection)),+      canonicalScalar (checkedKey selection),+      canonicalScalar (checkedPredicate selection),+      canonicalScalar (checkedRecipient selection),+      tuple [tuple [atom fieldName, canonicalScalar expression] | (fieldName, expression) <- Map.toAscList (checkedCommandFields selection)],+      atom (checkedTarget selection),+      atom (checkedCommand selection),+      atom (T.pack (show (checkedLimit selection))),+      atom "order:target-stream",+      atom "dedupe:target-stream",+      atom ("empty:" <> T.pack (show (checkedEmptyPolicy selection))),+      atom ("failure:" <> T.pack (show (checkedFailurePolicy selection))),+      atom "redelivery:stable-union",+      atom "partial:retain-successes"+    ]++canonicalScalar :: CheckedScalarExpr -> Text+canonicalScalar expression = tuple [atom (scalarTypeText (checkedScalarType expression)), node (checkedScalarNode expression)]+  where+    node = \case+      CheckedPath root segments -> tuple (atom (T.pack (show root)) : map segment segments)+      CheckedTextLiteral value -> tuple [atom "text", atom value]+      CheckedIntegralLiteral value -> tuple [atom "integral", atom (T.pack (show value))]+      CheckedBoolLiteral value -> tuple [atom "bool", atom (if value then "true" else "false")]+      CheckedCompare operator left right -> tuple [atom (T.pack (show operator)), canonicalScalar left, canonicalScalar right]+      CheckedAnd left right -> tuple [atom "and", canonicalScalar left, canonicalScalar right]+      CheckedOr left right -> tuple [atom "or", canonicalScalar left, canonicalScalar right]+    segment value = tuple [atom (unMappedKey (checkedPathOwner value)), atom (checkedPathField value), atom (checkedPathWireKey value)]++canonicalResolvedType :: ResolvedTypeExpr -> Text+canonicalResolvedType = \case+  RText -> atom "Text"+  RInt -> atom "Int"+  RInteger -> atom "Integer"+  RBool -> atom "Bool"+  RNatural -> atom "Natural"+  RTime -> atom "Time"+  RJson -> atom "Json"+  ROptional value -> tuple [atom "Optional", canonicalResolvedType value]+  RList value -> tuple [atom "List", canonicalResolvedType value]+  RMap value -> tuple [atom "Map", canonicalResolvedType value]+  RRef key -> tuple [atom "Ref", atom (unMappedKey key)]++tuple :: [Text] -> Text+tuple values = "[" <> T.concat values <> "]"++atom :: Text -> Text+atom value = T.pack (show (T.length value)) <> ":" <> value++hexDigest :: BS.ByteString -> Text+hexDigest = T.pack . concatMap byteHex . BS.unpack+  where+    byteHex byte = case showHex byte "" of+      [digit] -> ['0', digit]+      digits -> digits

src/Keiro/Dsl/Scaffold.hs view

@@ -3,6778 +3,8707 @@ -- @-- \@generated@ modules plus create-if-absent Hole modules for the behavior -- that remains explicitly hand-owned. ----- The load-bearing invariant of this module is the __firewall__: only a--- generated aggregate @Transducer.hs@ may contain Keiki symbolic operators--- (@./=@, @.==@, @.||@, @lit@, @B.slot@, @B.requireGuard@). Hand-owned Hole--- modules remain the other intentional construction boundary. A generated-text--- scan enforces the exception by path.------ Version-2 generated-owned transition bodies are rendered authoritatively in--- that transducer. Explicit Hole-owned transitions keep only predicate/update--- ownership; the generated command/event/target envelope remains authoritative.--- Read-model SQL (the projection @apply@) is still a DB-coupled Hole delegated--- to @codd@/the agent; the @Generated@ Projection module emits deterministic--- @InlineProjection@ wiring and the pure event→status mapping. The decode emitted--- here is /strict/ (every field required); lenient\/optional decode is EP-4's--- concern.-module Keiro.Dsl.Scaffold-  ( ScaffoldModule (..),-    ModuleRole (..),-    moduleRole,-    ModuleKind (..),-    Context (..),-    Placement (..),-    defaultContext,-    genPrefixFor,-    contextGeneratedPrefix,-    holePrefixFor,-    generatedNominalModule,-    NominalUseSite (..),-    NominalGenerationOwner (..),-    planNominalGeneration,-    planNominalGenerationForService,-    generatedNominalsInTypes,-    generatedNominalTypeImports,-    generatedNominalTypeImportsForService,-    generatedIdSampleHaskell,-    scaffoldReplayAudit,-    scaffoldStructural,-    scaffoldStructuralForService,-    scaffoldStructuralOwners,-    scaffoldStructuralOwnersForService,-    codecComparisonModule,-    codecComparisonBanner,-    bindingSkeletonModules,-    bindingSkeletonOwners,-    scaffoldAggregateForService,-    scaffoldAggregate,-    obsoleteGeneratedOutputHooks,-    scaffoldProcess,-    scaffoldRouter,-    scaffoldContract,-    scaffoldContractForService,-    scaffoldIntake,-    scaffoldPublisher,-    scaffoldWorkqueue,-    scaffoldReadModel,-    scaffoldRefusals,-    windowSeconds,--    -- * Firewall self-check (M3)-    FirewallSurface (..),-    firewallSurface,-    firewallBreaches,--    -- * Internal resolution, shared with "Keiro.Dsl.Harness"-    Agg (..),-    aggregateCheckedService,-    ResolvedRegister (..),-    ResolvedCtor (..),-    StructuralProjection (..),-    resolveAggForService,-    resolveAgg,-    nominalEqualityUsedInGeneratedExpressions,-    projectionSpecs,-    resolveProjectionModules,-    nominalProjectionModule,-    codecMappedDeclarations,-    FieldCat (..),-    fieldCat,-    vertexCtor,-    initialVertex,-    firstEnumCtor,-    lowerFirst,-    pascal,-    pascalFromKebab,-    generatedBanner,-    generatedBannerFor,-    isGeneratedBannerLine,-    stampGeneratedModule,-    stampGeneratedModules,-  )-where--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, 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-import Keiro.Dsl.PrettyPrint (renderExpr)-import Keiro.Dsl.ReadModelShape (fnv1a64, registryNameFor, subscriptionNameFor)-import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveContractLanguageVersion, effectiveLanguageContract, legacyCheckedService)-import Keiro.Dsl.TypeGraph-import Keiro.Dsl.Validate (sagaCategoryError)-import Paths_keiro_dsl qualified as Package-import Text.Read (readMaybe)---- | One emitted module: its on-disk path (relative to the scaffold @--out@--- directory), its full text, and whether it is overwritten every run--- ('Generated') or written only when absent ('HoleStub').-data ScaffoldModule = ScaffoldModule-  { modulePath :: !FilePath,-    moduleText :: !Text,-    kind :: !ModuleKind,-    origin :: !Text-  }-  deriving stock (Eq, Show)---- | 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-  | -- | Hand-owned; created only when absent, never overwritten.-    HoleStub-  deriving stock (Eq, Show)---- | The threading context: the spec's @context@ name, the chosen output--- module-namespace root, and the placement style. Extended additively (never--- re-shaped) by later verticals.-data Context = Context-  { contextName :: !Text,-    -- | @""@ means no namespace prefix (the historical default).-    moduleRoot :: !Text,-    -- | 'GeneratedPrefix' is the historical default.-    placement :: !Placement-  }-  deriving stock (Eq, Show)---- | One aggregate-level reason a generated nominal declaration must be visible.--- The declaration itself is context-owned; these use sites determine the--- aggregate modules that import it.-data NominalUseSite = NominalUseSite-  { nominalUseAggregate :: !Name,-    nominalUseKind :: !AggregateUseSite-  }-  deriving stock (Eq, Ord, Show)---- | The checked generation owner for one unbound ID or enum. Every owner in a--- service points at the same context-level module, while retaining its source--- location through 'ResolvedNominalType' and all aggregate use sites explicitly.-data NominalGenerationOwner = NominalGenerationOwner-  { nominalDeclaration :: !ResolvedNominalType,-    nominalModule :: !Text,-    nominalUseSites :: !(Set.Set NominalUseSite),-    nominalEqualityUsed :: !Bool-  }-  deriving stock (Eq, Show)---- | A context with today's default placement ('GeneratedPrefix', no root prefix)--- for the given @context@ name. Callers that do not care about placement (the--- @parse@ path, tests) build their context with this.-defaultContext :: Text -> Context-defaultContext name = Context {contextName = name, moduleRoot = "", placement = GeneratedPrefix}---- | The generated-layer namespace for a node, honouring the root prefix and the--- placement style. The 'Text' argument is the already-pascalised node name (e.g.--- @Reservation@, @HospitalSurge@). For 'GeneratedPrefix' this is--- @\<root\>.Generated.\<Ctx\>.\<Node\>@ (identical to the historical layout); for--- 'CollocatedLeaf' it is @\<root\>.\<Ctx\>.\<Node\>.Generated@.-genPrefixFor :: Context -> Text -> Text-genPrefixFor ctx node = case placement ctx of-  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> "." <> node-  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> "." <> node <> ".Generated"---- | The generated-layer namespace shared by modules emitted once for a whole--- service context, such as Nominals, ReplayAudit, and Conformance.-contextGeneratedPrefix :: Context -> Text-contextGeneratedPrefix ctx = case placement ctx of-  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx-  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated"---- | The hand-owned (hole) namespace for a node: @\<root\>.\<Ctx\>.\<Node\>@ —--- the same for both placement styles (holes always sit beside the domain).-holePrefixFor :: Context -> Text -> Text-holePrefixFor ctx node = rootPrefix ctx <> ctxPascalOf ctx <> "." <> node---- | The one context-level Haskell owner for generated IDs and enums.-generatedNominalModule :: Context -> Text-generatedNominalModule ctx = contextGeneratedPrefix ctx <> ".Nominals"---- | The root namespace prefix, dot-terminated, or @""@ when no root is set.-rootPrefix :: Context -> Text-rootPrefix ctx = case moduleRoot ctx of r | T.null r -> ""; r -> r <> "."---- | The context name in PascalCase, e.g. @hospital-capacity@ -> @HospitalCapacity@.-ctxPascalOf :: Context -> Text-ctxPascalOf = pascalFromKebab . contextName------------------------------------------------------------------------------------- Firewall self-check (M3)------------------------------------------------------------------------------------- | The canonical keiki surface forbidden in generated modules. Symbolic--- operators are matched as maximal Haskell symbol tokens, identifiers as complete--- tokens, qualifiers by their leading module alias, and imports structurally.-data FirewallSurface = FirewallSurface-  { forbiddenSymbolic :: ![Text],-    forbiddenIdents :: ![Text],-    forbiddenQualifiers :: ![Text],-    forbiddenImports :: ![Text],-    restrictedImports :: ![(Text, [Text])]-  }-  deriving stock (Eq, Show)--firewallSurface :: FirewallSurface-firewallSurface =-  FirewallSurface-    { forbiddenSymbolic = [".==", "./=", ".<", ".<=", ".>", ".>=", ".&&", ".||", ".+", ".-", ".*", "=:", "*:"],-      forbiddenIdents = ["lit", "pnot", "tadd", "tsub", "tmul"],-      forbiddenQualifiers = ["B"],-      forbiddenImports = ["Keiki.Builder", "Keiki.Operators", "Keiki.Symbolic"],-      -- Generated aggregate modules use the first two names; generated-      -- harnesses validate, step, and replay filled holes register by register.-      restrictedImports =-        [ ( "Keiki.Core",-            [ "RegFile",-              "HsPred",-              "FieldProjection",-              "ExactFieldProjection",-              "FieldWitness",-              "fieldWitness",-              "exactFieldWitness",-              "fieldWitnessAgrees",-              "applyEventsEither",-              "defaultValidationOptions",-              "step",-              "validateTransducer",-              "EdgeMode",-              "EdgeRef",-              "StepSuccess",-              "StepFailure",-              "ReplayEventSpan",-              "ReplayAttribution",-              "ReplaySuccess",-              "applyEventsDetailedEither",-              "stepDetailedEither",-              "!"-            ]-          )-        ]-    }---- | Scan generated modules for firewall breaches, returning every offending--- @(module path, token, 1-based line number)@. Only modules whose 'kind' is--- 'Generated' are scanned. Strings and comments are skipped, symbol runs use--- maximal munch, and keiki imports are checked independently of token spelling.-firewallBreaches :: [ScaffoldModule] -> [(FilePath, Text, Int)]-firewallBreaches mods =-  [ (modulePath m, breach, n)-  | m <- mods,-    kind m == Generated,-    not (authoritativeScalarModule (modulePath m)),-    (n, line) <- zip [1 ..] (T.lines (moduleText m)),-    breach <- lineBreaches line-  ]---- The version-2 aggregate transducer is the narrow, intentional exception to--- the generated symbolic-operator firewall: it is precisely the generated--- authority that constructs Keiki terms. Every other generated module remains--- subject to the original firewall.-authoritativeScalarModule :: FilePath -> Bool-authoritativeScalarModule path = "/Transducer.hs" `isSuffixOf` path--lineBreaches :: Text -> [Text]-lineBreaches line = case importModule line of-  Just _ -> importBreaches line-  Nothing -> tokenBreaches (codeTokens line)-  where-    tokenBreaches = mapMaybe breachFor-    breachFor (IdentToken ident)-      | ident `elem` forbiddenIdents firewallSurface = Just ident-    breachFor (QualifiedToken qualifier)-      | qualifier `elem` forbiddenQualifiers firewallSurface = Just (qualifier <> ".*")-    breachFor (SymbolToken symbol)-      | symbol `elem` forbiddenSymbolic firewallSurface = Just symbol-    breachFor _ = Nothing--data CodeToken = IdentToken !Text | QualifiedToken !Text | SymbolToken !Text--codeTokens :: Text -> [CodeToken]-codeTokens = go . T.unpack-  where-    go [] = []-    go ('-' : '-' : _) = []-    go ('"' : rest) = go (dropString rest)-    go ('\'' : rest) = go (dropChar rest)-    go (c : rest)-      | isIdentStart c =-          let (identTail, afterIdent) = span isIdentContinue rest-              ident = T.pack (c : identTail)-           in case afterIdent of-                '.' : next : more-                  | isUpper c && isIdentStart next ->-                      let (_member, afterMember) = span isIdentContinue more-                       in QualifiedToken ident : go afterMember-                _ -> IdentToken ident : go afterIdent-      | isSymbolChar c =-          let (symbolTail, afterSymbol) = span isSymbolChar rest-           in SymbolToken (T.pack (c : symbolTail)) : go afterSymbol-      | otherwise = go rest-    isIdentStart c = isAlpha c || c == '_'-    isIdentContinue c = isAlphaNum c || c == '_' || c == '\''-    isSymbolChar c = c `elem` ("!#$%&*+./<=>?@\\^|-~:" :: String)-    dropString [] = []-    dropString ('\\' : _escaped : rest) = dropString rest-    dropString ('"' : rest) = rest-    dropString (_ : rest) = dropString rest-    dropChar [] = []-    dropChar ('\\' : _escaped : rest) = dropChar rest-    dropChar ('\'' : rest) = rest-    dropChar (_ : rest) = dropChar rest--importBreaches :: Text -> [Text]-importBreaches line = case importModule line of-  Nothing -> []-  Just imported-    | imported `elem` forbiddenImports firewallSurface -> ["import:" <> imported]-    | Just allowed <- lookup imported (restrictedImports firewallSurface),-      not (hasAllowedExplicitImportList allowed line) ->-        ["import:" <> imported]-    | otherwise -> []--importModule :: Text -> Maybe Text-importModule line = case T.words (T.strip line) of-  "import" : rest -> find (T.isPrefixOf "Keiki.") rest-  _ -> Nothing--hasAllowedExplicitImportList :: [Text] -> Text -> Bool-hasAllowedExplicitImportList allowed line =-  case (T.breakOn "(" line, T.breakOnEnd ")" line) of-    ((_, open), (close, _))-      | not (T.null open) && not (T.null close) ->-          let inside = T.takeWhile (/= ')') (T.drop 1 open)-              names = filter (not . T.null) (T.split (not . isAlphaNum) inside)-           in all (`elem` allowed) names-    _ -> False------------------------------------------------------------------------------------- Derived naming------------------------------------------------------------------------------------- | Resolved, denormalized view of an aggregate used by every emitter.-data Agg = Agg-  { aContext :: !Context,-    aLanguageContract :: !EffectiveLanguageContract,-    aSpec :: !Spec,-    aAggregate :: !Aggregate,-    aCtxPascal :: !Text,-    aName :: !Text,-    aLoc :: !Loc,-    aVertexType :: !Text,-    aIds :: ![IdDecl],-    aEnums :: ![EnumDecl],-    aRegs :: ![ResolvedRegister],-    aStates :: ![StateDecl],-    aCommands :: ![ResolvedCtor],-    aEvents :: ![ResolvedCtor],-    -- | Generated IDs and enums used by this aggregate, in stable name order.-    aGeneratedNominals :: ![ResolvedNominalType],-    aTransitions :: ![Transition],-    aOutputMappings :: !(Map.Map (Int, Int) EventOutputMapping),-    aWire :: !WireSpec,-    aProjection :: !(Maybe ProjectionSpec),-    aSnapshot :: !(Maybe SnapshotSpec),-    aFoldFingerprint :: !Text,-    aReadModels :: ![ReadModelNode],-    aTypeGraph :: !(Maybe TypeGraph),-    aSymbols :: !AggregateSymbols,-    -- | e.g. @Generated.HospitalCapacity.Reservation@-    aGenPrefix :: !Text,-    -- | e.g. @HospitalCapacity.Reservation@-    aHolePrefix :: !Text-  }--aggregateCheckedService :: Agg -> CheckedService-aggregateCheckedService aggregate =-  CheckedService-    { checkedLanguageContract = aLanguageContract aggregate,-      checkedSpec = aSpec aggregate-    }--data ResolvedRegister = ResolvedRegister-  { rrName :: !Name,-    rrType :: !ResolvedAggregateType,-    rrInitial :: !ResolvedRegisterInitial,-    rrLoc :: !Loc-  }-  deriving stock (Eq, Show)---- | A command or event constructor with its fully-resolved field identities and--- aggregate types.-data ResolvedCtor = ResolvedCtor-  { rcName :: !Text,-    -- | (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).-    rcUpcastFrom :: !(Maybe Int)-  }--defaultWire :: WireSpec-defaultWire = WireSpec {wireKind = "ctorName", wireFields = "camelCase", wireSchemaVersion = 1}--resolveAgg :: Context -> Spec -> Aggregate -> Agg-resolveAgg ctx spec = resolveAggForService ctx (legacyCheckedService spec)---- | Resolve one aggregate under the service's effective runtime semantics.-resolveAggForService :: Context -> CheckedService -> Aggregate -> Agg-resolveAggForService ctx service agg =-  Agg-    { aContext = ctx,-      aLanguageContract = checkedLanguageContract service,-      aSpec = spec,-      aAggregate = agg,-      aCtxPascal = ctxPascal,-      aName = nm,-      aLoc = aggLoc agg,-      aVertexType = vertexType,-      aIds = specIds spec,-      aEnums = specEnums spec,-      aRegs = map resolveRegister (aggRegs agg),-      aStates = aggStates agg,-      aCommands = map resolveCommand (aggCommands agg),-      aEvents = map resolveEvent (aggEvents agg),-      aGeneratedNominals = generatedNominalsInTypes aggregateResolvedTypes,-      aTransitions = aggTransitions agg,-      aOutputMappings =-        Map.fromList-          [ ( (transitionIndex, emitIndex),-              orDieOutput (eventOutputMapping spec agg transition emitIndex eventName)-            )-          | (transitionIndex, transition) <- zip [1 ..] (aggTransitions agg),-            (emitIndex, eventName) <- zip [1 ..] (tEmits transition)-          ],-      aWire = fromMaybe defaultWire (aggWire agg),-      aProjection = aggProjection agg,-      aSnapshot = aggSnapshot agg,-      aFoldFingerprint = either (error . T.unpack . renderFoldSurfaceError) id (aggregateFoldFingerprintForService service agg),-      aReadModels = [readModel | NReadModel readModel <- specNodes spec],-      aTypeGraph = either (const Nothing) Just (resolveTypeGraph spec),-      aSymbols = symbols,-      aGenPrefix = genPrefixFor ctx nm,-      aHolePrefix = holePrefixFor ctx nm-    }-  where-    spec = checkedSpec service-    nm = aggName agg-    symbols = aggregateSymbols spec-    ctxPascal = pascalFromKebab (contextName ctx)-    vertexType = nm <> "Vertex"-    commandFieldTypes = [(cmdName c, cmdFields c) | c <- aggCommands agg]-    resolveCommand c = (mkCtor CommandFieldUse (cmdName c) (cmdFields c)) {rcVersion = 1, rcUpcastFrom = Nothing}-    resolveEvent e =-      (mkCtor EventFieldUse (evName e) (eventFields e))-        { rcVersion = evVersion e,-          rcUpcastFrom = fst <$> evUpcastFrom e-        }-      where-        eventFields ev = case evBody ev of-          EventFields fs -> fs-          EventFromCommand cn -> fromMaybe [] (lookup cn commandFieldTypes)-    mkCtor useSite cn fs =-      ResolvedCtor-        { rcName = cn,-          rcFields = map (\field -> (resolveAggregateFieldIdentity field, orDie (inferAggregateFieldType symbols agg useSite field))) fs,-          rcVersion = 1,-          rcUpcastFrom = Nothing-        }-    aggregateResolvedTypes =-      map rrType (map resolveRegister (aggRegs agg))-        <> map snd (concatMap rcFields (map resolveCommand (aggCommands agg)))-        <> map snd (concatMap rcFields (map resolveEvent (aggEvents agg)))-    resolveRegister register =-      let resolvedType = orDie (resolveAggregateType symbols (regLoc register) RegisterUse (regType register))-          resolvedInitial = orDie (resolveRegisterInitial symbols (regLoc register) resolvedType (regInitial register))-       in ResolvedRegister-            { rrName = regName register,-              rrType = resolvedType,-              rrInitial = resolvedInitial,-              rrLoc = regLoc register-            }-    orDie = either (error . ("validated aggregate resolution failed: " <>) . show) id-    orDieOutput = either (error . ("validated aggregate output resolution failed: " <>) . show) id---- | Keep only generated nominal IDs/enums from a resolved aggregate type list.--- The map both deduplicates and makes declaration/import order independent of--- member and field order.-generatedNominalsInTypes :: [ResolvedAggregateType] -> [ResolvedNominalType]-generatedNominalsInTypes resolvedTypes =-  Map.elems . Map.fromList $-    [ (resolvedNominalName nominal, nominal)-    | AggregateNominal nominal <- resolvedTypes,-      GeneratedNominal <- [resolvedNominalOwnership nominal]-    ]---- | Plan declaration ownership and use closure without emitting text. Parsing--- and validation already reject malformed declarations; retaining the checked--- error here keeps this function total for direct library callers.-planNominalGeneration :: Context -> Spec -> Either (NonEmpty NominalTypeError) [NominalGenerationOwner]-planNominalGeneration ctx spec = planNominalGenerationForService ctx (legacyCheckedService spec)--planNominalGenerationForService :: Context -> CheckedService -> Either (NonEmpty NominalTypeError) [NominalGenerationOwner]-planNominalGenerationForService ctx service = do-  registry <- resolveNominalTypes spec-  let aggregates = [resolveAggForService ctx service aggregate | NAggregate aggregate <- specNodes spec]-      generated =-        [ nominal-        | nominal <- Map.elems (nominalTypes registry),-          GeneratedNominal <- [resolvedNominalOwnership nominal]-        ]-  pure-    [ NominalGenerationOwner-        { nominalDeclaration = nominal,-          nominalModule = generatedNominalModule ctx,-          nominalUseSites = Set.fromList (concatMap (usesFor nominal) aggregates),-          nominalEqualityUsed = any (nominalEqualityUsedInGeneratedExpressions nominal) aggregates-        }-    | nominal <- generated-    ]-  where-    spec = checkedSpec service-    usesFor nominal aggregate =-      [ NominalUseSite (aName aggregate) useKind-      | useKind <- aggregateUseKinds nominal aggregate-      ]--nominalEqualityUsedInGeneratedExpressions :: ResolvedNominalType -> Agg -> Bool-nominalEqualityUsedInGeneratedExpressions nominal aggregate =-  any (anyTypedExpression comparesNominal) (resolvedGeneratedExpressions aggregate)-  where-    comparesNominal expression = case typedScalarNode expression of-      TypedEqual left _ -> typedScalarType left == AggregateNominal nominal-      TypedNotEqual left _ -> typedScalarType left == AggregateNominal nominal-      _ -> False--aggregateUseKinds :: ResolvedNominalType -> Agg -> [AggregateUseSite]-aggregateUseKinds nominal aggregate =-  nub $-    [RegisterUse | nominal `elem` registerNominals]-      <> [CommandFieldUse | nominal `elem` commandNominals]-      <> [EventFieldUse | nominal `elem` eventNominals]-      <> [CodecUse | nominal `elem` eventNominals]-      <> [SnapshotUse | hasSnapshot aggregate && nominal `elem` registerNominals]-      <> [HarnessSampleUse | nominal `elem` commandNominals || nominal `elem` eventNominals]-      <> [HaskellLoweringUse | nominal `elem` aGeneratedNominals aggregate]-  where-    registerNominals = generatedNominalsInTypes (map rrType (aRegs aggregate))-    commandNominals = generatedNominalsInTypes (map snd (concatMap rcFields (aCommands aggregate)))-    eventNominals = generatedNominalsInTypes (map snd (concatMap rcFields (aEvents aggregate)))------------------------------------------------------------------------------------- Entry point------------------------------------------------------------------------------------- | Emit the context-level private structural stratum. Shape modules contain--- only generated wire representations. The projection facade contains only--- schema-derived Keiki field witnesses; neither layer owns consumer behavior.-scaffoldStructural :: Context -> Spec -> [ScaffoldModule]-scaffoldStructural ctx spec = scaffoldStructuralForService ctx (legacyCheckedService spec)--scaffoldStructuralForService :: Context -> CheckedService -> [ScaffoldModule]-scaffoldStructuralForService ctx service = map fst (scaffoldStructuralOwnersForService ctx service)---- | 'scaffoldStructural' paired with the mapped declarations each module was--- emitted for. A shape module names exactly one declaration; a binding skeleton--- names every declaration whose obligations it carries (several declarations may--- share one leaf binding module); the projection facade names __none__, because it--- is emitted once for the whole context from the complete resolved graph.------ This is the attribution seam whole-workspace scaffolding needs: a workspace--- emits from one merged spec, and this list says which declaration — and therefore--- which member file — produced each structural module, without parsing the--- human-readable 'origin' string.-scaffoldStructuralOwners :: Context -> Spec -> [(ScaffoldModule, [Name])]-scaffoldStructuralOwners ctx spec = scaffoldStructuralOwnersForService ctx (legacyCheckedService spec)--scaffoldStructuralOwnersForService :: Context -> CheckedService -> [(ScaffoldModule, [Name])]-scaffoldStructuralOwnersForService ctx service = case resolveTypeGraph (checkedSpec service) of-  Left _ -> []-  Right graph ->-    [(shapeModule ctx graph entry, [sdName (fst entry)]) | entry <- structural]-      <> projectionModules-      <> generatedNominalOwners ctx service-      <> nominalRepresentationOwners ctx spec-      <> nominalProjectionOwners ctx service-      <> bindingSkeletonOwners ctx spec graph-    where-      structural =-        [ (declaration, shape)-        | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph)-        ]-      projectionModules =-        [ ( ScaffoldModule-              { modulePath = T.unpack (T.replace "." "/" (structuralProjectionModule ctx) <> ".hs"),-                moduleText = emitStructuralProjections ctx graph,-                kind = Generated,-                origin = "context " <> specContext spec <> " mapped structural facade"-              },-            []-          )-        | not (null (projectionSpecs graph))-        ]-      spec = checkedSpec service---- | Plan one opt-in, non-production historical-codec comparison module.------ The module is intentionally absent from 'scaffoldStructural' and therefore--- from production manifests and scaffold records. It must be requested by name--- and is compiled only by consumer-owned test/tool components.-codecComparisonModule :: Context -> Spec -> Name -> Either Text ScaffoldModule-codecComparisonModule ctx spec requestedName = do-  graph <- either (Left . ("mapped type graph did not resolve: " <>) . T.pack . show) Right (resolveTypeGraph spec)-  (declaration, shape) <- case Map.lookup (MappedKey requestedName) (tgDeclarations graph) of-    Nothing -> Left ("codec comparison target is not a mapped declaration: " <> requestedName)-    Just (ResolvedOpaque _) ->-      Left-        ( "codec comparison target "-            <> requestedName-            <> " is opaque; finite evidence must never upgrade an opaque declaration to a structural claim"-        )-    Just (ResolvedStructural declaration shape) -> Right (declaration, shape)-  owner <- case sortOn aggName (comparisonOwners declaration) of-    [] ->-      Left-        ( "codec comparison target "-            <> requestedName-            <> " is not reachable from a persisted private event payload"-        )-    aggregate : _ -> Right aggregate-  let moduleName = structuralPrefix ctx <> ".CodecCompare." <> requestedName-  pure-    ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),-        moduleText = emitCodecComparison ctx moduleName graph declaration shape owner,-        kind = Generated,-        origin = "non-production codec comparison " <> requestedName-      }-  where-    comparisonOwners declaration =-      [ aggregate-      | NAggregate aggregate <- specNodes spec,-        let resolved = resolveAgg ctx spec aggregate,-        any ((== sdName declaration) . mappedName) (codecMappedDeclarations resolved)-      ]-      where-        mappedName (ResolvedStructural structural _) = sdName structural-        mappedName (ResolvedOpaque opaque) = odName opaque--codecComparisonBanner :: Text-codecComparisonBanner =-  "-- @generated by keiro-dsl codec comparison; non-production migration evidence; do not edit."--emitCodecComparison :: Context -> Text -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Aggregate -> Text-emitCodecComparison ctx moduleName graph declaration shape owner =-  nl-    [ "",-      codecComparisonBanner,-      "-- This module compares historical and generated codecs in consumer-owned tests only.",-      "-- It is never a runtime fallback and never changes the generated codec's authority.",-      "module " <> moduleName <> " (compareWithHistorical) where",-      "",-      "import Control.Monad (filterM)",-      "import Data.Aeson (Value)",-      "import Data.Aeson qualified as Aeson",-      "import Data.List (sort)",-      "import Data.List.NonEmpty qualified as NonEmpty",-      "import Data.Text (Text)",-      "import Data.Text qualified",-      "import " <> codecModule <> " qualified as GeneratedCodec",-      "import Keiro.Codec.Structural (FixtureCases (..))",-      "import Keiro.Dsl.CodecCompare",-      "import Keiro.Dsl.TypeGraph (BindingVersion (..), CanonicalTypeId (..), QualifiedValueName (..))",-      "import System.Directory (doesFileExist, listDirectory)",-      "import System.FilePath (takeExtension, (</>))",-      renderPlannedImports importPlan,-      "",-      "compareWithHistorical :: HistoricalCodec " <> domainType <> " -> FilePath -> IO CompareReport",-      "compareWithHistorical historicalCodec goldenDirectory = do",-      "  names <- sort . filter ((== \".json\") . takeExtension) <$> listDirectory goldenDirectory",-      "  files <- filterM doesFileExist [goldenDirectory </> name | name <- names]",-      "  loaded <- traverse (loadGolden historicalCodec) files",-      "  let inputIssues = [issue | Left issue <- loaded]",-      "      entries = [entry | Right entry <- loaded]",-      "      typedCases = NonEmpty.toList (fixtureCases " <> fixtureReference <> ")",-      "      encodeObservations =",-      "        [ EncodeObservation label (hcEncode historicalCodec value) (GeneratedCodec.encode" <> name <> "Mapped value)",-      "        | (label, value) <- typedCases",-      "        ]",-      "      decodeObservations = [observation | (observation, _) <- entries]",-      "      typedObserved =",-      "        concat",-      "          [ observedBranchesFor FromBinding branchSchema (GeneratedCodec.encode" <> name <> "Mapped value)",-      "          | (_, value) <- typedCases",-      "          ]",-      "      historicalObserved =",-      "        concat [observedBranchesFor HistoricalGolden branchSchema value | (_, values) <- entries, value <- values]",-      "      declared = declaredBranchesFor FromBinding branchSchema <> declaredBranchesFor HistoricalGolden branchSchema",-      "      provenance =",-      "        CompareProvenance",-      "          { cpHistoricalCodecIdentity = hcIdentity historicalCodec",-      "          , cpHistoricalCodecVersion = hcVersion historicalCodec",-      "          , cpCanonicalType = CanonicalTypeId " <> tshow (unCanonicalTypeId (sdCanonical declaration)),-      "          , cpBindingSymbol = QualifiedValueName " <> tshow (unQualifiedValueName (sdBinding declaration)),-      "          , cpBindingVersion = BindingVersion " <> tshow (unBindingVersion (sdBindingVersion declaration)),-      "          , cpWireFingerprint = " <> tshow (wireFingerprint graph name),-      "          }",-      "  pure (compareReport provenance inputIssues (encodeObservations <> decodeObservations) declared (typedObserved <> historicalObserved))",-      "",-      "loadGolden :: HistoricalCodec " <> domainType <> " -> FilePath -> IO (Either CompareInputIssue (CompareObservation, [Value]))",-      "loadGolden historicalCodec path = do",-      "  decoded <- Aeson.eitherDecodeFileStrict path",-      "  pure $ case decoded of",-      "    Left reason -> Left (HistoricalGoldenUnreadable path (fromString reason))",-      "    Right inputValue ->",-      "      let historicalDecoded = hcDecode historicalCodec inputValue",-      "          historicalOutcome = normalizeDecode historicalDecoded",-      "          generatedOutcome = normalizeDecode (GeneratedCodec.decode" <> name <> "Mapped inputValue)",-      "          observation = DecodeObservation path inputValue historicalOutcome generatedOutcome",-      "          coveredValues = case historicalDecoded of",-      "            Right value -> [inputValue, GeneratedCodec.encode" <> name <> "Mapped value]",-      "            Left _ -> []",-      "       in Right (observation, coveredValues)",-      "",-      "normalizeDecode :: Either Text " <> domainType <> " -> DecodeOutcome",-      "normalizeDecode = either DecodeFailed (DecodedShape . GeneratedCodec.encode" <> name <> "Mapped)",-      "",-      "fromString :: String -> Text",-      "fromString = Data.Text.pack",-      "",-      "branchSchema :: BranchSchema",-      "branchSchema = " <> renderBranchSchema (branchSchemaFor graph (ResolvedStructural declaration shape))-    ]-  where-    name = sdName declaration-    domainType = renderReferenceOrDie importPlan (haskellTypeReference (sdHaskell declaration))-    codecModule = genPrefixFor ctx (aggName owner) <> ".Codec"-    fixtureReference = renderReferenceOrDie importPlan (qualifiedValueReference (sdFixtures declaration))-    importPlan =-      planImportsOrDie-        moduleName-        Set.empty-        ( Set.fromList-            [ haskellTypeReference (sdHaskell declaration),-              qualifiedValueReference (sdFixtures declaration)-            ]-        )--branchSchemaFor :: TypeGraph -> ResolvedMappedDecl -> BranchSchema-branchSchemaFor graph =-  foldMappedDecl-    MappedDeclAlgebra-      { onStructuralDecl = \_ shape ->-          foldMappedShape-            MappedShapeAlgebra-              { onRecord = \_ _ fields ->-                  BranchRecord-                    [ BranchField-                        (rwfKey field)-                        (rwfPresence field == POptional)-                        (branchExpr graph (rwfType field))-                    | field <- fields-                    ],-                onEnum = const BranchScalar,-                onUnion = \encoding arms ->-                  BranchUnion-                    (ueTagField encoding)-                    (ueContentsField encoding)-                    [BranchArm (rwaTag arm) (branchExpr graph <$> rwaPayload arm) | arm <- arms]-              }-            shape,-        onOpaqueDecl = const BranchScalar-      }--branchExpr :: TypeGraph -> ResolvedTypeExpr -> BranchSchema-branchExpr graph =-  foldTypeExpr-    TypeExprAlgebra-      { onText = BranchScalar,-        onInt = BranchScalar,-        onInteger = BranchScalar,-        onBool = BranchScalar,-        onNatural = BranchScalar,-        onTime = BranchScalar,-        onJson = BranchScalar,-        onOptional = BranchOptional,-        onList = BranchList,-        onMap = BranchMap,-        onRef = \key -> maybe BranchScalar (branchSchemaFor graph) (Map.lookup key (tgDeclarations graph))-      }--renderBranchSchema :: BranchSchema -> Text-renderBranchSchema schema = case schema of-  BranchScalar -> "BranchScalar"-  BranchOptional nested -> "BranchOptional (" <> renderBranchSchema nested <> ")"-  BranchList nested -> "BranchList (" <> renderBranchSchema nested <> ")"-  BranchMap nested -> "BranchMap (" <> renderBranchSchema nested <> ")"-  BranchRecord fields ->-    "BranchRecord ["-      <> T.intercalate-        ", "-        [ "BranchField "-            <> tshow (bfWireKey field)-            <> " "-            <> (if bfPresenceOptional field then "True" else "False")-            <> " ("-            <> renderBranchSchema (bfSchema field)-            <> ")"-        | field <- fields-        ]-      <> "]"-  BranchUnion tagField contentsField arms ->-    "BranchUnion "-      <> tshow tagField-      <> " "-      <> tshow contentsField-      <> " ["-      <> T.intercalate-        ", "-        [ "BranchArm "-            <> tshow (baWireTag arm)-            <> " "-            <> maybe "Nothing" (\nested -> "(Just (" <> renderBranchSchema nested <> "))") (baPayloadSchema arm)-        | arm <- arms-        ]-      <> "]"---- | Emit one create-once consumer module per distinct qualified obligation--- owner. Multiple mapped declarations may intentionally share a leaf binding--- module, so grouping happens by module rather than by declaration.-bindingSkeletonModules :: Context -> Spec -> TypeGraph -> [ScaffoldModule]-bindingSkeletonModules ctx spec graph = map fst (bindingSkeletonOwners ctx spec graph)---- | 'bindingSkeletonModules' paired with the mapped declarations whose--- obligations each skeleton carries, in first-appearance order. A skeleton shared--- by declarations from different member files therefore names all of them, which--- is what lets whole-workspace scaffolding treat it as context-level rather than--- attributing it to an arbitrary member.-bindingSkeletonOwners :: Context -> Spec -> TypeGraph -> [(ScaffoldModule, [Name])]-bindingSkeletonOwners ctx spec graph = case bindingObligations spec of-  Left _ -> []-  Right obligations ->-    [ (emitBindingSkeleton ctx spec graph owner entries, nub (map obligationMappedName entries))-    | (owner, entries) <- Map.toAscList (Map.fromListWith (<>) [(obligationModule obligation, [obligation]) | obligation <- obligations])-    ]--emitBindingSkeleton :: Context -> Spec -> TypeGraph -> Text -> [BindingObligation] -> ScaffoldModule-emitBindingSkeleton ctx spec graph owner obligations =-  ScaffoldModule-    { modulePath = T.unpack (T.replace "." "/" owner <> ".hs"),-      moduleText =-        nl $-          [ "{-# LANGUAGE DataKinds #-}",-            "{-# LANGUAGE LambdaCase #-}",-            "",-            "-- This is a HAND-OWNED consumer binding skeleton. keiro-dsl creates it once",-            "-- and never overwrites it. Fill each HOLE and run the generated harness.",-            "module " <> owner <> " ("-          ]-            <> exportLines-            <> [") where", ""]-            <> importLines-            <> [""]-            <> intercalateBlank (map renderObligation obligations),-      kind = HoleStub,-      origin = "consumer binding skeleton " <> owner-    }-  where-    exportLines =-      [ (if index == (0 :: Int) then "    " else "  , ") <> obligationSymbol obligation-      | (index, obligation) <- zip [0 ..] obligations-      ]-    importPlan = bindingSkeletonImportPlan ctx spec graph owner obligations-    importLines =-      sort . nub $-        map ("import " <>) staticImports-          <> T.lines (renderPlannedImports importPlan)-    staticImports =-      sort . nub $-        [ "Keiro.Codec.Structural (FixtureCases, StructuralBinding (..))"-        | any (\obligation -> obligationCategory obligation == "structural" && obligationKind obligation `elem` [BindingValue, FixtureValue]) obligations-        ]-          <> [ "Keiro.Codec.Nominal (NominalBinding (..), NominalFixtureCases)"-             | any ((/= "structural") . obligationCategory) obligations-             ]-          <> [ "Data.KindID (KindID)"-             | obligation <- obligations,-               Just (nominal, _) <- [nominalFor obligation],-               IdRepresentation {} <- [resolvedNominalRepresentation nominal]-             ]-          <> [ "Data.Text (Text)"-             | obligation <- obligations,-               Just (nominal, _) <- [nominalFor obligation],-               ScalarRepresentation NominalText <- [resolvedNominalRepresentation nominal]-             ]-          <> [ "Data.Time (UTCTime)"-             | obligation <- obligations,-               Just (nominal, _) <- [nominalFor obligation],-               ScalarRepresentation NominalTime <- [resolvedNominalRepresentation nominal]-             ]-          <> [ "Numeric.Natural (Natural)"-             | obligation <- obligations,-               Just (nominal, _) <- [nominalFor obligation],-               ScalarRepresentation NominalNatural <- [resolvedNominalRepresentation nominal]-             ]-    renderObligation obligation = case structuralFor obligation of-      Nothing -> case nominalFor obligation of-        Just (nominal, binding) -> renderNominalObligation nominal binding obligation-        Nothing -> ["-- HOLE: declaration disappeared before skeleton rendering"]-      Just (declaration, shape) -> case obligationKind obligation of-        BindingValue -> renderBinding importPlan ctx declaration shape obligation-        FixtureValue ->-          [ "-- HOLE: provide deterministic labelled conformance fixtures for " <> sdName declaration,-            renderStructuralObligationSignature importPlan declaration obligation,-            obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> sdName declaration <> " fixtures")-          ]-        InitialValue ->-          [ "-- HOLE: provide the initial register value for " <> sdName declaration,-            renderStructuralObligationSignature importPlan declaration obligation,-            obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> sdName declaration <> " initial value")-          ]-    structuralFor obligation = case Map.lookup (MappedKey (obligationMappedName obligation)) (tgDeclarations graph) of-      Just (ResolvedStructural declaration shape) -> Just (declaration, shape)-      _ -> Nothing-    nominalFor obligation = do-      registry <- either (const Nothing) Just (resolveNominalTypes spec)-      nominal <- lookupNominalType (obligationMappedName obligation) registry-      binding <- case resolvedNominalOwnership nominal of-        ConsumerNominal value -> Just value-        GeneratedNominal -> Nothing-      pure (nominal, binding)-    renderNominalObligation nominal binding obligation = case obligationKind obligation of-      BindingValue ->-        [ "-- HOLE: complete both total directions; the generated codec remains wire authority.",-          renderNominalObligationSignature importPlan ctx nominal binding obligation,-          obligationSymbol obligation <> " =",-          "  NominalBinding",-          "    { nominalToRepresentation = \\_domainValue -> error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " nominalToRepresentation"),-          "    , nominalFromRepresentation = \\_representationValue -> error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " nominalFromRepresentation"),-          "    }"-        ]-      FixtureValue ->-        [ "-- HOLE: provide deterministic labelled expected-wire fixtures for " <> resolvedNominalName nominal,-          renderNominalObligationSignature importPlan ctx nominal binding obligation,-          obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " fixtures")-        ]-      InitialValue ->-        [ "-- HOLE: provide the initial register value for " <> resolvedNominalName nominal,-          renderNominalObligationSignature importPlan ctx nominal binding obligation,-          obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " initial value")-        ]-    intercalateBlank [] = []-    intercalateBlank (section : rest) = section <> concatMap ("" :) rest--renderBinding :: HaskellImportPlan -> Context -> StructuralDecl -> ResolvedMappedShape -> BindingObligation -> [Text]-renderBinding importPlan ctx declaration shape obligation =-  [ "-- HOLE: complete both total directions; wire policy remains in the generated codec.",-    obligationSymbol obligation <> " :: StructuralBinding " <> domainType <> " " <> shapeType,-    obligationSymbol obligation <> " =",-    "  StructuralBinding",-    "    { bindingToShape = \\case"-  ]-    <> indentCases (bindingCases True)-    <> ["    , bindingFromShape = \\case"]-    <> indentCases (bindingCases False)-    <> ["    }"]-  where-    domainType = renderReferenceOrDie importPlan (haskellTypeReference (sdHaskell declaration))-    shapeModuleName = structuralShapeModule ctx (sdName declaration)-    shapeType = renderReferenceOrDie importPlan (qualifiedTypeReference shapeModuleName (sdName declaration <> "Shape"))-    domainCtor constructor = renderReferenceOrDie importPlan (constructorReference (hsModule (sdHaskell declaration)) constructor)-    shapeCtor constructor = renderReferenceOrDie importPlan (constructorReference shapeModuleName constructor)-    indentCases = map ("      " <>)-    bindingCases toShapeDirection =-      foldMappedShape-        MappedShapeAlgebra-          { onRecord = \constructor _ fields -> [recordCase toShapeDirection constructor fields],-            onEnum = \entries -> map (enumCase toShapeDirection . weCtor) entries,-            onUnion = \_ arms -> map (unionCase toShapeDirection) arms-          }-        shape-    recordCase toShapeDirection constructor fields =-      sourceCtor-        <> arguments variables-        <> " -> "-        <> targetCtor-        <> arguments (map (holeFor toShapeDirection . rwfHaskell) fields)-      where-        variables = map (("_" <>) . (<> "Value") . rwfHaskell) fields-        sourceCtor = if toShapeDirection then domainCtor constructor else shapeCtor constructor-        targetCtor = if toShapeDirection then shapeCtor constructor else domainCtor constructor-    enumCase toShapeDirection constructor =-      sourceCtor <> " -> " <> holeFor toShapeDirection constructor-      where-        sourceCtor = if toShapeDirection then domainCtor constructor else shapeCtor constructor-    unionCase toShapeDirection arm =-      sourceCtor-        <> maybe "" (const " _payloadValue") (rwaPayload arm)-        <> " -> "-        <> case rwaPayload arm of-          Nothing -> holeFor toShapeDirection (rwaCtor arm)-          Just _ -> targetCtor <> " " <> holeFor toShapeDirection (rwaCtor arm <> ".payload")-      where-        sourceCtor = if toShapeDirection then domainCtor (rwaCtor arm) else shapeCtor (rwaCtor arm)-        targetCtor = if toShapeDirection then shapeCtor (rwaCtor arm) else domainCtor (rwaCtor arm)-    arguments [] = ""-    arguments values = " " <> T.unwords values-    holeFor toShapeDirection fieldName =-      "(error "-        <> tshow-          ( "HOLE: fill "-              <> sdName declaration-              <> (if toShapeDirection then " bindingToShape." else " bindingFromShape.")-              <> fieldName-          )-        <> ")"--bindingSkeletonImportPlan :: Context -> Spec -> TypeGraph -> Text -> [BindingObligation] -> HaskellImportPlan-bindingSkeletonImportPlan ctx spec graph owner obligations =-  planImportsOrDie owner (Set.fromList (map obligationSymbol obligations)) (Set.fromList (concatMap obligationReferences obligations))-  where-    obligationReferences obligation = case Map.lookup (MappedKey (obligationMappedName obligation)) (tgDeclarations graph) of-      Just (ResolvedStructural declaration shape) ->-        haskellTypeReference (sdHaskell declaration)-          : [ qualifiedTypeReference shapeModuleName (sdName declaration <> "Shape")-            | obligationKind obligation == BindingValue-            ]-            <> [ reference-               | obligationKind obligation == BindingValue,-                 constructor <- structuralConstructorNames shape,-                 reference <--                   [ constructorReference (hsModule (sdHaskell declaration)) constructor,-                     constructorReference shapeModuleName constructor-                   ]-               ]-        where-          shapeModuleName = structuralShapeModule ctx (sdName declaration)-      _ -> case nominalForName (obligationMappedName obligation) of-        Just (nominal, binding) ->-          haskellTypeReference (consumerNominalHaskell binding)-            : [ qualifiedTypeReference-                  (nominalRepresentationModule ctx (resolvedNominalName nominal))-                  (resolvedNominalName nominal <> "Representation")-              | obligationKind obligation == BindingValue,-                EnumRepresentation {} <- [resolvedNominalRepresentation nominal]-              ]-        Nothing -> []-    nominalForName name = do-      registry <- either (const Nothing) Just (resolveNominalTypes spec)-      nominal <- lookupNominalType name registry-      binding <- case resolvedNominalOwnership nominal of-        ConsumerNominal value -> Just value-        GeneratedNominal -> Nothing-      pure (nominal, binding)--structuralConstructorNames :: ResolvedMappedShape -> [Text]-structuralConstructorNames =-  foldMappedShape-    MappedShapeAlgebra-      { onRecord = \constructor _ _ -> [constructor],-        onEnum = map weCtor,-        onUnion = \_ -> map rwaCtor-      }--structuralShapeReferences :: Context -> StructuralDecl -> ResolvedMappedShape -> [HaskellReference]-structuralShapeReferences ctx declaration shape =-  qualifiedTypeReference moduleName (sdName declaration <> "Shape")-    : [constructorReference moduleName constructor | constructor <- structuralConstructorNames shape]-      <> [ HaskellReference moduleName selector ValueNamespace RequireQualified-         | selector <- structuralSelectorNames shape-         ]-  where-    moduleName = structuralShapeModule ctx (sdName declaration)--structuralSelectorNames :: ResolvedMappedShape -> [Text]-structuralSelectorNames =-  foldMappedShape-    MappedShapeAlgebra-      { onRecord = \_ _ -> map rwfHaskell,-        onEnum = const [],-        onUnion = \_ _ -> []-      }--nominalRepresentationEncoderReference :: Context -> ResolvedNominalType -> HaskellReference-nominalRepresentationEncoderReference ctx nominal =-  HaskellReference-    (nominalRepresentationModule ctx name)-    (lowerFirst name <> "RepresentationText")-    ValueNamespace-    RequireQualified-  where-    name = resolvedNominalName nominal--nominalRepresentationConstructorReference :: Context -> ResolvedNominalType -> Text -> HaskellReference-nominalRepresentationConstructorReference ctx nominal constructor =-  HaskellReference-    (nominalRepresentationModule ctx (resolvedNominalName nominal))-    constructor-    ConstructorNamespace-    RequireQualified--renderStructuralObligationSignature :: HaskellImportPlan -> StructuralDecl -> BindingObligation -> Text-renderStructuralObligationSignature importPlan declaration obligation =-  obligationSymbol obligation-    <> " :: "-    <> case obligationKind obligation of-      BindingValue -> error "structural binding signatures are rendered with renderBinding"-      FixtureValue -> "FixtureCases " <> domainType-      InitialValue -> domainType-  where-    domainType = renderReferenceOrDie importPlan (haskellTypeReference (sdHaskell declaration))--renderNominalObligationSignature :: HaskellImportPlan -> Context -> ResolvedNominalType -> ConsumerNominalBinding -> BindingObligation -> Text-renderNominalObligationSignature importPlan ctx nominal binding obligation =-  obligationSymbol obligation-    <> " :: "-    <> case obligationKind obligation of-      BindingValue -> "NominalBinding " <> domainType <> " " <> representationType-      FixtureValue -> "NominalFixtureCases " <> domainType-      InitialValue -> domainType-  where-    domainType = renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding))-    representationType = case resolvedNominalRepresentation nominal of-      IdRepresentation prefix -> "(KindID " <> tshow prefix <> ")"-      EnumRepresentation {} ->-        renderReferenceOrDie-          importPlan-          ( qualifiedTypeReference-              (nominalRepresentationModule ctx (resolvedNominalName nominal))-              (resolvedNominalName nominal <> "Representation")-          )-      ScalarRepresentation NominalText -> "Text"-      ScalarRepresentation NominalInt -> "Int"-      ScalarRepresentation NominalNatural -> "Natural"-      ScalarRepresentation NominalBool -> "Bool"-      ScalarRepresentation NominalTime -> "UTCTime"--qualifiedTypeReference :: Text -> Text -> HaskellReference-qualifiedTypeReference moduleName typeName =-  HaskellReference moduleName typeName TypeNamespace RequireQualified--constructorReference :: Text -> Text -> HaskellReference-constructorReference moduleName constructor =-  HaskellReference moduleName constructor ConstructorNamespace RequireQualified--shapeModule :: Context -> TypeGraph -> (StructuralDecl, ResolvedMappedShape) -> ScaffoldModule-shapeModule ctx graph (declaration, shape) =-  ScaffoldModule-    { modulePath = T.unpack (T.replace "." "/" (structuralShapeModule ctx (sdName declaration)) <> ".hs"),-      moduleText = emitShape ctx graph declaration shape,-      kind = Generated,-      origin = nodeOrigin "mapped structural" (sdName declaration) (sdLoc declaration)-    }--structuralPrefix :: Context -> Text-structuralPrefix ctx = case placement ctx of-  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".Structural"-  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.Structural"--structuralShapeModule :: Context -> Name -> Text-structuralShapeModule ctx name = structuralPrefix ctx <> ".Shape." <> name--nominalRepresentationModule :: Context -> Name -> Text-nominalRepresentationModule ctx name = case placement ctx of-  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".Nominal.Shape." <> name-  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Nominal.Shape." <> name <> ".Generated"---- | Emit the one generated nominal authority for the complete context. The--- empty declaration attribution is intentional: in a workspace this module is--- context-level even when all declarations currently happen to live in one--- member, so moving that member cannot move Haskell type ownership.-generatedNominalOwners :: Context -> CheckedService -> [(ScaffoldModule, [Name])]-generatedNominalOwners ctx service = case planNominalGenerationForService ctx service of-  Left _ -> []-  Right [] -> []-  Right owners ->-    [ ( ScaffoldModule-          { modulePath = T.unpack (T.replace "." "/" (generatedNominalModule ctx) <> ".hs"),-            moduleText = emitGeneratedNominals languageContract ctx owners,-            kind = Generated,-            origin = "context " <> specContext spec <> " generated nominal declarations"-          },-        []-      )-    ]-      <> [ ( ScaffoldModule-               { modulePath = T.unpack (T.replace "." "/" (generatedNominalInternalModule ctx) <> ".hs"),-                 moduleText = emitGeneratedNominalInternals ctx enforcingIds,-                 kind = Generated,-                 origin = "context " <> specContext spec <> " generated nominal ID internals"-               },-             []-           )-         | not (null enforcingIds)-         ]-    where-      enforcingIds =-        [ (nominal, contract)-        | owner <- owners,-          let nominal = nominalDeclaration owner,-          IdRepresentation prefix <- [resolvedNominalRepresentation nominal],-          Just contract <- [idDomainContractFor languageContract prefix]-        ]-  where-    spec = checkedSpec service-    languageContract = checkedLanguageContract service--generatedNominalInternalModule :: Context -> Text-generatedNominalInternalModule ctx = generatedNominalModule ctx <> ".Internal"--emitGeneratedNominals :: EffectiveLanguageContract -> Context -> [NominalGenerationOwner] -> Text-emitGeneratedNominals languageContract ctx owners =-  nl-    ( renderGeneratedLanguagePragmas localExtensions-        <> [ generatedBanner,-             moduleHeader,-             ""-           ]-        <> baseImports-        <> internalImports-        <> equalityImports-        <> if T.null declarations then [] else ["", declarations]-    )-  where-    usesEquality = any nominalEqualityUsed 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,-        let nominal = nominalDeclaration owner,-        IdRepresentation prefix <- [resolvedNominalRepresentation nominal],-        Just _ <- [idDomainContractFor languageContract prefix]-      ]-    moduleHeader-      | null enforcingIds = "module " <> generatedNominalModule ctx <> " where"-      | otherwise =-          nl-            [ "module " <> generatedNominalModule ctx,-              "  ( " <> T.intercalate "\n  , " (concatMap ownerExports owners),-              "  ) where"-            ]-    ownerExports owner =-      baseExports <> equalityExports-      where-        nominal = nominalDeclaration owner-        name = resolvedNominalName nominal-        baseExports = case resolvedNominalRepresentation nominal of-          IdRepresentation prefix-            | Just _ <- idDomainContractFor languageContract prefix ->-                [name, "parse" <> name, "mk" <> name, nominalTextName nominal]-          _ -> [name <> " (..)", nominalTextName nominal]-        equalityExports =-          if nominalEqualityUsed owner-            then [nominalEqualityTagName nominal, nominalEqualityWitnessName nominal]-            else []-    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 (" <> 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-          <> " ("-          <> T.intercalate-            ", "-            (concatMap (\nominal -> [resolvedNominalName nominal, "mk" <> resolvedNominalName nominal, "parse" <> resolvedNominalName nominal, nominalTextName nominal]) enforcingIds)-          <> ")"-      | 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-      IdRepresentation prefix -> isJust (idDomainContractFor languageContract prefix)-      ScalarRepresentation {} -> False-    nominalUsesDeriveAnyClass nominal = case resolvedNominalRepresentation nominal of-      IdRepresentation prefix -> not (isJust (idDomainContractFor languageContract prefix))-      EnumRepresentation {} -> True-      ScalarRepresentation {} -> False--emitGeneratedNominal :: EffectiveLanguageContract -> Bool -> ResolvedNominalType -> Text-emitGeneratedNominal languageContract equalityUsed nominal = case resolvedNominalRepresentation nominal of-  IdRepresentation prefix-    | Just _ <- idDomainContractFor languageContract prefix ->-        nl equalitySection-  IdRepresentation {} ->-    nl $-      [ "newtype " <> name <> " = " <> name <> " Text",-        "  deriving stock (Generic, Eq, Ord, Show)",-        "  deriving anyclass (ToJSON, FromJSON)",-        "",-        "instance CanonicalTypeName " <> name,-        "",-        nominalTextName nominal <> " :: " <> name <> " -> Text",-        nominalTextName nominal <> " (" <> name <> " value) = value"-      ]-        <> equalitySection-  EnumRepresentation constructors ->-    nl $-      [ "data " <> name <> " = " <> T.intercalate " | " (map fst (NE.toList constructors)),-        "  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)",-        "  deriving anyclass (ToJSON, FromJSON)",-        "",-        "instance CanonicalTypeName " <> name,-        "",-        nominalTextName nominal <> " :: " <> name <> " -> Text",-        nominalTextName nominal <> " = \\case",-        nl ["  " <> constructor <> " -> " <> tshow wire | (constructor, wire) <- NE.toList constructors]-      ]-        <> equalitySection-  ScalarRepresentation {} ->-    error "generated nominal scalar reached generated declaration emission"-  where-    name = resolvedNominalName nominal-    equalitySection = if equalityUsed then ["", emitGeneratedNominalEquality languageContract nominal] else []--emitGeneratedNominalEquality :: EffectiveLanguageContract -> ResolvedNominalType -> Text-emitGeneratedNominalEquality languageContract nominal =-  nl $-    [ "data " <> tagName,-      "",-      "instance FieldProjection " <> tagName <> " where",-      "  type FieldName " <> tagName <> " = " <> tshow name,-      "  type FieldOwner " <> tagName <> " = " <> name,-      "  type FieldResult " <> tagName <> " = Text",-      "  fieldShapeId _ = " <> tshow equalityIdentity,-      "  projectFieldValue _ = " <> nominalTextName nominal-    ]-      <> exactInstance-      <> [ "",-           witnessName <> " :: FieldWitness " <> tagName,-           witnessName <> " = " <> witnessConstructor <> " @" <> tagName-         ]-  where-    name = resolvedNominalName nominal-    tagName = nominalEqualityTagName nominal-    witnessName = nominalEqualityWitnessName nominal-    equalityIdentity = fromMaybe (error "generated nominal equality contract missing") (nominalEqualityIdentityForService languageContract nominal)-    (exactInstance, witnessConstructor) = case resolvedNominalRepresentation nominal of-      IdRepresentation prefix -> case idDomainContractFor languageContract prefix of-        Nothing -> ([], "fieldWitness")-        Just _ ->-          ( [ "",-              patternName <> " :: TextPattern",-              patternName <> " = either (error . show) id (idDomainTextPattern (typeIdV7Domain " <> tshow prefix <> "))",-              "",-              "instance ExactFieldProjection " <> tagName <> " where",-              "  fieldProjectionDomain _ = textProjectionDomain " <> patternName,-              "  reconstructFieldOwner _ = either (const Nothing) Just . parse" <> name-            ],-            "exactFieldWitness"-          )-      EnumRepresentation constructors ->-        ( [ "",-            "instance ExactFieldProjection " <> tagName <> " where",-            "  fieldProjectionDomain _ = finiteProjectionDomain (" <> renderNonEmpty (map (tshow . snd) (NE.toList constructors)) <> ")",-            "  reconstructFieldOwner _ = \\case"-          ]-            <> ["    " <> tshow wire <> " -> Just " <> constructor | (constructor, wire) <- NE.toList constructors]-            <> ["    _ -> Nothing"],-          "exactFieldWitness"-        )-      ScalarRepresentation {} -> error "generated nominal scalar equality emission"-    patternName = lowerFirst name <> "IdDomainPattern"--emitGeneratedNominalInternals :: Context -> [(ResolvedNominalType, IdDomainContract)] -> Text-emitGeneratedNominalInternals ctx nominals =-  nl-    [ generatedBanner,-      "module " <> generatedNominalInternalModule ctx,-      "  ( " <> T.intercalate "\n  , " (concatMap exportsFor nominals),-      "  ) where",-      "",-      "import Data.Aeson (FromJSON (..), ToJSON (..), withText)",-      "import Data.Text (Text)",-      "import Data.Text qualified as T",-      "import GHC.Generics (Generic)",-      "import Keiki.Shape (CanonicalTypeName)",-      "import Keiro.Codec.IdDomain (typeIdV7Domain, validateIdDomainText)",-      "",-      sectionsOf [map emitInternal nominals]-    ]-  where-    exportsFor (nominal, _) =-      [ resolvedNominalName nominal,-        "parse" <> resolvedNominalName nominal,-        "mk" <> resolvedNominalName nominal,-        nominalTextName nominal,-        legacyNominalConstructorName nominal-      ]-    emitInternal (nominal, contract) =-      nl-        [ "newtype " <> name <> " = " <> name <> " Text",-          "  deriving stock (Generic, Eq, Ord, Show)",-          "",-          "instance CanonicalTypeName " <> name,-          "",-          "instance ToJSON " <> name <> " where",-          "  toJSON = toJSON . " <> textName,-          "",-          "instance FromJSON " <> name <> " where",-          "  parseJSON = withText " <> tshow name <> " (either (fail . T.unpack) pure . parse" <> name <> ")",-          "",-          "parse" <> name <> " :: Text -> Either Text " <> name,-          "parse" <> name <> " input = case validateIdDomainText (typeIdV7Domain " <> tshow (idDomainPrefix contract) <> ") input of",-          "  Left reason -> Left (T.pack (show reason))",-          "  Right () -> Right (" <> name <> " input)",-          "",-          "mk" <> name <> " :: Text -> Either Text " <> name,-          "mk" <> name <> " = parse" <> name,-          "",-          textName <> " :: " <> name <> " -> Text",-          textName <> " (" <> name <> " value) = value",-          "",-          legacyNominalConstructorName nominal <> " :: Text -> " <> name,-          legacyNominalConstructorName nominal <> " = " <> name-        ]-      where-        name = resolvedNominalName nominal-        textName = nominalTextName nominal--nominalEqualityTagName :: ResolvedNominalType -> Text-nominalEqualityTagName nominal = resolvedNominalName nominal <> "EqualityProjection"--nominalEqualityWitnessName :: ResolvedNominalType -> Text-nominalEqualityWitnessName nominal = lowerFirst (resolvedNominalName nominal) <> "EqualityWitness"--renderNonEmpty :: [Text] -> Text-renderNonEmpty values = case values of-  [] -> error "cannot render an empty exact projection domain"-  firstValue : rest -> firstValue <> " :| [" <> T.intercalate ", " rest <> "]"--nominalTextName :: ResolvedNominalType -> Text-nominalTextName = (<> "Text") . lowerFirst . resolvedNominalName---- | Explicit type/constructor imports for exactly the generated declarations a--- generated aggregate module uses. Keeping an import list avoids making every--- aggregate depend on every service declaration merely because they share the--- one owner module.-generatedNominalTypeImports :: Context -> [ResolvedNominalType] -> [Text]-generatedNominalTypeImports _ [] = []-generatedNominalTypeImports ctx nominals =-  [ "import "-      <> generatedNominalModule ctx-      <> " ("-      <> T.intercalate ", " [resolvedNominalName nominal <> " (..)" | nominal <- stableNominals nominals]-      <> ")"-  ]--generatedNominalTypeImportsForService :: CheckedService -> Context -> [ResolvedNominalType] -> [Text]-generatedNominalTypeImportsForService 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-      <> " ("-      <> T.intercalate ", " (concatMap importsFor (stableNominals nominals))-      <> ")"-  ]-  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 `elem` parsingNames]-      _ -> [resolvedNominalName nominal <> " (..)"]--generatedNominalCodecImports :: CheckedService -> Context -> [ResolvedNominalType] -> [Text]-generatedNominalCodecImports _ _ [] = []-generatedNominalCodecImports service ctx nominals =-  [ "import "-      <> generatedNominalModule ctx-      <> " ("-      <> T.intercalate-        ", "-        ( concat-            [ publicImports nominal-            | nominal <- stableNominals nominals-            ]-        )-      <> ")"-  ]-    <> [ "import "-           <> generatedNominalInternalModule ctx-           <> " ("-           <> T.intercalate ", " [legacyNominalConstructorName nominal | nominal <- enforcingIds]-           <> ")"-       | not (null enforcingIds)-       ]-  where-    publicImports nominal = case resolvedNominalRepresentation nominal of-      IdRepresentation prefix-        | Just _ <- idDomainContractFor (checkedLanguageContract service) prefix -> [nominalTextName nominal]-      _ -> [resolvedNominalName nominal <> " (..)", nominalTextName nominal]-    enforcingIds =-      [ nominal-      | nominal <- stableNominals nominals,-        IdRepresentation prefix <- [resolvedNominalRepresentation nominal],-        Just _ <- [idDomainContractFor (checkedLanguageContract service) prefix]-      ]--legacyNominalConstructorName :: ResolvedNominalType -> Text-legacyNominalConstructorName nominal = "unsafe" <> resolvedNominalName nominal <> "FromLegacyText"--stableNominals :: [ResolvedNominalType] -> [ResolvedNominalType]-stableNominals = Map.elems . Map.fromList . map (\nominal -> (resolvedNominalName nominal, nominal))--nominalRepresentationOwners :: Context -> Spec -> [(ScaffoldModule, [Name])]-nominalRepresentationOwners ctx spec = case resolveNominalTypes spec of-  Left _ -> []-  Right registry ->-    [ (nominalRepresentationModuleValue ctx nominal constructors, [resolvedNominalName nominal])-    | nominal <- Map.elems (nominalTypes registry),-      ConsumerNominal {} <- [resolvedNominalOwnership nominal],-      EnumRepresentation constructors <- [resolvedNominalRepresentation nominal]-    ]--nominalRepresentationModuleValue :: Context -> ResolvedNominalType -> NonEmpty (Name, Text) -> ScaffoldModule-nominalRepresentationModuleValue ctx nominal constructors =-  ScaffoldModule-    { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),-      moduleText =-        nl-          [ generatedBanner,-            "module " <> moduleName <> " (" <> representationType <> " (..), " <> encoderName <> ") where",-            "",-            "import Data.Text (Text)",-            "import GHC.Generics (Generic)",-            "",-            "data " <> representationType <> " = " <> T.intercalate " | " (map fst (NE.toList constructors)),-            "  deriving stock (Eq, Generic, Ord, Show, Enum, Bounded)",-            "",-            encoderName <> " :: " <> representationType <> " -> Text",-            encoderName <> " = \\case",-            nl ["  " <> constructor <> " -> " <> tshow wire | (constructor, wire) <- NE.toList constructors]-          ],-      kind = Generated,-      origin = nodeOrigin "bound nominal enum representation" (resolvedNominalName nominal) (resolvedNominalLoc nominal)-    }-  where-    moduleName = nominalRepresentationModule ctx (resolvedNominalName nominal)-    representationType = resolvedNominalName nominal <> "Representation"-    encoderName = lowerFirst (resolvedNominalName nominal) <> "RepresentationText"--nominalProjectionModule :: Context -> Text-nominalProjectionModule ctx = case placement ctx of-  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".NominalProjections"-  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.NominalProjections"--nominalProjectionOwners :: Context -> CheckedService -> [(ScaffoldModule, [Name])]-nominalProjectionOwners ctx service = case nominalProjectionTypes spec of-  [] -> []-  nominals ->-    [ ( ScaffoldModule-          { modulePath = T.unpack (T.replace "." "/" (nominalProjectionModule ctx) <> ".hs"),-            moduleText = emitNominalProjections (checkedLanguageContract service) ctx nominals,-            kind = Generated,-            origin = "context " <> specContext spec <> " nominal scalar projection facade"-          },-        []-      )-    ]-  where-    spec = checkedSpec service--nominalProjectionTypes :: Spec -> [ResolvedNominalType]-nominalProjectionTypes spec =-  Map.elems . Map.fromList $-    [ (resolvedNominalName nominal, nominal)-    | aggregate <- [value | NAggregate value <- specNodes spec],-      resolved <- registerTypes aggregate <> commandTypes aggregate,-      AggregateNominal nominal <- [resolved],-      ConsumerNominal {} <- [resolvedNominalOwnership nominal]-    ]-  where-    symbols = aggregateSymbols spec-    registerTypes aggregate =-      [ resolved-      | register <- aggRegs aggregate,-        Right resolved <- [resolveAggregateType symbols (regLoc register) RegisterUse (regType register)]-      ]-    commandTypes aggregate =-      [ resolved-      | command <- aggCommands aggregate,-        field <- cmdFields command,-        Right resolved <- [inferAggregateFieldType symbols aggregate CommandFieldUse field]-      ]--emitNominalProjections :: EffectiveLanguageContract -> Context -> [ResolvedNominalType] -> Text-emitNominalProjections languageContract ctx nominals =-  nl $-    renderGeneratedLanguagePragmas [ExtTypeFamilies]-      <> [ generatedBanner,-           "module " <> moduleName <> " where",-           ""-         ]-      <> map ("import " <>) imports-      <> T.lines (renderPlannedImports importPlan)-      <> [""]-      <> [T.intercalate "\n\n" (map emitNominalProjection nominals)]-  where-    moduleName = nominalProjectionModule ctx-    imports =-      sort . nub $-        [ "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]-          -- 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 =-      planImportsOrDie-        moduleName-        ( Set.fromList-            [ tagName-            | nominal <- nominals,-              tagName <- case resolvedNominalRepresentation nominal of-                ScalarRepresentation {} -> [resolvedNominalName nominal <> "NominalProjection"]-                IdRepresentation {} -> [nominalEqualityTagName nominal]-                EnumRepresentation {} -> [nominalEqualityTagName nominal]-            ]-        )-        ( Set.fromList-            [ reference-            | nominal <- nominals,-              ConsumerNominal binding <- [resolvedNominalOwnership nominal],-              reference <--                [ haskellTypeReference (consumerNominalHaskell binding),-                  qualifiedValueReference (consumerNominalBinding binding)-                ]-                  <> case resolvedNominalRepresentation nominal of-                    EnumRepresentation constructors ->-                      HaskellReference representationModule (lowerFirst (resolvedNominalName nominal) <> "RepresentationText") ValueNamespace RequireQualified-                        : [ HaskellReference representationModule constructor ConstructorNamespace RequireQualified-                          | (constructor, _) <- NE.toList constructors-                          ]-                      where-                        representationModule = nominalRepresentationModule ctx (resolvedNominalName nominal)-                    _ -> []-            ]-        )-    emitNominalProjection nominal = case resolvedNominalOwnership nominal of-      GeneratedNominal -> ""-      ConsumerNominal binding -> case resolvedNominalRepresentation nominal of-        ScalarRepresentation {} -> emitScalarProjection nominal binding-        IdRepresentation prefix -> emitConsumerIdProjection nominal binding prefix-        EnumRepresentation constructors -> emitConsumerEnumProjection nominal binding constructors-    emitScalarProjection nominal binding =-      nl-        [ "data " <> tagName,-          "",-          "instance FieldProjection " <> tagName <> " where",-          "  type FieldName " <> tagName <> " = " <> tshow name,-          "  type FieldOwner " <> tagName <> " = " <> renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding)),-          "  type FieldResult " <> tagName <> " = " <> scalarHaskellType (resolvedNominalRepresentation nominal),-          "  fieldShapeId _ = " <> tshow (unCanonicalTypeId (consumerNominalCanonical binding)),-          "  projectFieldValue _ = nominalToRepresentation " <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)),-          "",-          witnessName <> " :: FieldWitness " <> tagName,-          witnessName <> " = fieldWitness @" <> tagName-        ]-      where-        name = resolvedNominalName nominal-        tagName = name <> "NominalProjection"-        witnessName = lowerFirst name <> "Witness"-    emitConsumerIdProjection nominal binding prefix =-      nl-        ( patternLines-            <> [ "",-                 "data " <> tagName,-                 "",-                 "instance FieldProjection " <> tagName <> " where",-                 "  type FieldName " <> tagName <> " = " <> tshow name,-                 "  type FieldOwner " <> tagName <> " = " <> ownerType,-                 "  type FieldResult " <> tagName <> " = Text",-                 "  fieldShapeId _ = " <> tshow equalityIdentity,-                 "  projectFieldValue _ = KindID.toText . nominalToRepresentation " <> bindingName,-                 "",-                 "instance ExactFieldProjection " <> tagName <> " where",-                 "  fieldProjectionDomain _ = textProjectionDomain " <> patternName,-                 "  reconstructFieldOwner _ value"-               ]-            <> validationGuard-            <> [ "    | not (matchesTextPattern " <> patternName <> " value) = Nothing",-                 "    | otherwise = case KindID.parseText @" <> tshow prefix <> " value of",-                 "        Left _ -> Nothing",-                 "        Right representation -> Just (nominalFromRepresentation " <> bindingName <> " representation)",-                 "",-                 witnessName <> " :: FieldWitness " <> tagName,-                 witnessName <> " = exactFieldWitness @" <> tagName-               ]-        )-      where-        name = resolvedNominalName nominal-        tagName = nominalEqualityTagName nominal-        witnessName = nominalEqualityWitnessName nominal-        patternName = lowerFirst name <> "EqualityPattern"-        ownerType = renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding))-        bindingName = renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding))-        equalityIdentity = fromMaybe (error "consumer ID equality contract missing") (nominalEqualityIdentityForService languageContract nominal)-        enforced = isJust (idDomainContractFor languageContract prefix)-        patternLines-          | enforced =-              [ patternName <> " :: TextPattern",-                patternName <> " = either (error . show) id (idDomainTextPattern (typeIdV7Domain " <> tshow prefix <> "))"-              ]-          | otherwise =-              [ patternName <> " :: TextPattern",-                patternName <> " = either (error . show) id $ do",-                "  prefix <- textLiteral " <> tshow (prefix <> "_"),-                "  leading <- textCharSet ('0' :| \"1234567\")",-                "  crockford <- textCharSet ('0' :| \"123456789abcdefghjkmnpqrstvwxyz\")",-                "  suffix <- textRepeatBetween 25 25 crockford",-                "  pure (textConcat (prefix :| [leading, suffix]))"-              ]-        validationGuard =-          [ "    | Left _ <- validateIdDomainText (typeIdV7Domain " <> tshow prefix <> ") value = Nothing"-          | enforced-          ]-    emitConsumerEnumProjection nominal binding constructors =-      nl $-        [ "data " <> tagName,-          "",-          "instance FieldProjection " <> tagName <> " where",-          "  type FieldName " <> tagName <> " = " <> tshow name,-          "  type FieldOwner " <> tagName <> " = " <> ownerType,-          "  type FieldResult " <> tagName <> " = Text",-          "  fieldShapeId _ = " <> tshow equalityIdentity,-          "  projectFieldValue _ = " <> encoderName <> " . nominalToRepresentation " <> bindingName,-          "",-          "instance ExactFieldProjection " <> tagName <> " where",-          "  fieldProjectionDomain _ = finiteProjectionDomain (" <> renderNonEmpty (map (tshow . snd) (NE.toList constructors)) <> ")",-          "  reconstructFieldOwner _ = \\case"-        ]-          <> [ "    " <> tshow wire <> " -> Just (nominalFromRepresentation " <> bindingName <> " " <> representationConstructor constructor <> ")"-             | (constructor, wire) <- NE.toList constructors-             ]-          <> [ "    _ -> Nothing",-               "",-               witnessName <> " :: FieldWitness " <> tagName,-               witnessName <> " = exactFieldWitness @" <> tagName-             ]-      where-        name = resolvedNominalName nominal-        tagName = nominalEqualityTagName nominal-        witnessName = nominalEqualityWitnessName nominal-        ownerType = renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding))-        bindingName = renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding))-        representationModule = nominalRepresentationModule ctx name-        encoderName = renderReferenceOrDie importPlan (HaskellReference representationModule (lowerFirst name <> "RepresentationText") ValueNamespace RequireQualified)-        representationConstructor constructor = renderReferenceOrDie importPlan (HaskellReference representationModule constructor ConstructorNamespace RequireQualified)-        equalityIdentity = fromMaybe (error "consumer enum equality contract missing") (nominalEqualityIdentityForService languageContract nominal)-    scalarHaskellType representation = case representation of-      ScalarRepresentation NominalText -> "Text"-      ScalarRepresentation NominalInt -> "Int"-      ScalarRepresentation NominalNatural -> "Natural"-      ScalarRepresentation NominalBool -> "Bool"-      ScalarRepresentation NominalTime -> "UTCTime"-      IdRepresentation {} -> "()"-      EnumRepresentation {} -> "()"--structuralProjectionModule :: Context -> Text-structuralProjectionModule ctx = structuralPrefix ctx <> "Projections"--emitShape :: Context -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text-emitShape ctx graph declaration shape =-  nl $-    languagePragmas-      <> [ generatedBanner,-           "module " <> moduleName <> " (" <> shapeType <> " (..)) where",-           ""-         ]-      <> map ("import " <>) imports-      <> T.lines (renderPlannedImports importPlan)-      <> ["" | not (null imports) || not (T.null (renderPlannedImports importPlan))]-      <> [shapeDeclaration]-  where-    moduleName = structuralShapeModule ctx (sdName declaration)-    shapeType = sdName declaration <> "Shape"-    requirements = shapeRequirements ctx graph shape-    languagePragmas = renderGeneratedLanguagePragmas []-    imports =-      sort . nub $-        ["Data.Aeson (Value)" | ReqJson `elem` requirements]-          <> ["Data.Map.Strict (Map)" | ReqMap `elem` requirements]-          <> ["Data.Text (Text)" | ReqText `elem` requirements]-          <> ["Data.Time (UTCTime)" | ReqTime `elem` requirements]-          <> ["GHC.Generics (Generic)"]-          <> ["Numeric.Natural (Natural)" | ReqNatural `elem` requirements]-    shapeDeclaration =-      foldMappedShape-        MappedShapeAlgebra-          { onRecord = \constructor _ fields ->-              nl $-                ["data " <> shapeType <> " = " <> constructor]-                  <> recordFields-                    [ (rwfHaskell field, renderShapeType importPlan ctx graph (rwfType field))-                    | field <- fields-                    ]-                  <> ["  deriving stock (Eq, Generic, Show)"],-            onEnum = \entries ->-              "data "-                <> shapeType-                <> " = "-                <> T.intercalate " | " (map weCtor entries)-                <> "\n  deriving stock (Eq, Generic, Show)",-            onUnion = \_ arms ->-              nl $-                case arms of-                  [] -> ["data " <> shapeType <> " = " <> shapeType <> "Empty", "  deriving stock (Eq, Generic, Show)"]-                  firstArm : rest ->-                    ["data " <> shapeType <> " = " <> renderArm firstArm]-                      <> ["  | " <> renderArm arm | arm <- rest]-                      <> ["  deriving stock (Eq, Generic, Show)"]-          }-        shape-    renderArm arm = rwaCtor arm <> maybe "" ((" !" <>) . renderShapeType importPlan ctx graph) (rwaPayload arm)-    importPlan =-      planImportsOrDie-        moduleName-        (Set.singleton shapeType)-        (Set.fromList [reference | ReqReference reference <- requirements])--data ShapeRequirement-  = ReqJson-  | ReqMap-  | ReqText-  | ReqTime-  | ReqNatural-  | ReqReference !HaskellReference-  deriving stock (Eq, Ord, Show)--shapeRequirements :: Context -> TypeGraph -> ResolvedMappedShape -> [ShapeRequirement]-shapeRequirements ctx graph =-  foldMappedShape-    MappedShapeAlgebra-      { onRecord = \_ _ fields -> concatMap (exprRequirements ctx graph . rwfType) fields,-        onEnum = const [],-        onUnion = \_ arms -> concatMap (maybe [] (exprRequirements ctx graph) . rwaPayload) arms-      }--exprRequirements :: Context -> TypeGraph -> ResolvedTypeExpr -> [ShapeRequirement]-exprRequirements ctx graph =-  foldTypeExpr-    TypeExprAlgebra-      { onText = [ReqText],-        onInt = [],-        onInteger = [],-        onBool = [],-        onNatural = [ReqNatural],-        onTime = [ReqTime],-        onJson = [ReqJson],-        onOptional = id,-        onList = id,-        onMap = (ReqMap :) . (ReqText :),-        onRef = \key -> case Map.lookup key (tgDeclarations graph) of-          Just (ResolvedStructural declaration _) ->-            [ ReqReference-                ( HaskellReference-                    (structuralShapeModule ctx (sdName declaration))-                    (sdName declaration <> "Shape")-                    TypeNamespace-                    RequireQualified-                )-            ]-          Just (ResolvedOpaque declaration) -> [ReqReference (haskellTypeReference (odHaskell declaration))]-          Nothing -> []-      }--renderShapeType :: HaskellImportPlan -> Context -> TypeGraph -> ResolvedTypeExpr -> Text-renderShapeType importPlan ctx graph =-  renderStrictOrApplicationArgument-    . foldTypeExpr-      TypeExprAlgebra-        { onText = atomicShapeType "Text",-          onInt = atomicShapeType "Int",-          onInteger = atomicShapeType "Integer",-          onBool = atomicShapeType "Bool",-          onNatural = atomicShapeType "Natural",-          onTime = atomicShapeType "UTCTime",-          onJson = atomicShapeType "Value",-          onOptional = applicationShapeType . ("Maybe " <>) . renderStrictOrApplicationArgument,-          onList = atomicShapeType . ("[" <>) . (<> "]") . renderedShapeTypeText,-          onMap = applicationShapeType . ("Map Text " <>) . renderStrictOrApplicationArgument,-          onRef =-            atomicShapeType . \key -> case Map.lookup key (tgDeclarations graph) of-              Just (ResolvedStructural nested _) ->-                renderReferenceOrDie-                  importPlan-                  (HaskellReference (structuralShapeModule ctx (sdName nested)) (sdName nested <> "Shape") TypeNamespace RequireQualified)-              Just (ResolvedOpaque opaque) ->-                renderReferenceOrDie importPlan (haskellTypeReference (odHaskell opaque))-              Nothing -> "()"-        }--data ShapeTypePrecedence-  = AtomicShapeType-  | ApplicationShapeType--data RenderedShapeType = RenderedShapeType-  { renderedShapeTypePrecedence :: !ShapeTypePrecedence,-    renderedShapeTypeText :: !Text-  }--atomicShapeType :: Text -> RenderedShapeType-atomicShapeType = RenderedShapeType AtomicShapeType--applicationShapeType :: Text -> RenderedShapeType-applicationShapeType = RenderedShapeType ApplicationShapeType--renderStrictOrApplicationArgument :: RenderedShapeType -> Text-renderStrictOrApplicationArgument rendered = case renderedShapeTypePrecedence rendered of-  AtomicShapeType -> renderedShapeTypeText rendered-  ApplicationShapeType -> "(" <> renderedShapeTypeText rendered <> ")"--data StructuralProjection = StructuralProjection-  { spTag :: !Text,-    spWitness :: !Text,-    spPointer :: !Text,-    spOwner :: !HaskellSource,-    spResult :: !Text,-    spCanonical :: !CanonicalTypeId,-    spBinding :: !QualifiedValueName,-    spSelectors :: ![(Text, Text)]-  }-  deriving stock (Eq, Show)--projectionSpecs :: TypeGraph -> [StructuralProjection]-projectionSpecs graph =-  sortOn spTag . allocateProjectionNames . concat $-    [ projectionsForRoot graph declaration shape-    | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph)-    ]--projectionsForRoot :: TypeGraph -> StructuralDecl -> ResolvedMappedShape -> [StructuralProjection]-projectionsForRoot graph root rootShape = case rootShape of-  RRecord _ _ fields -> concatMap (walkField [] []) fields-  REnum {} -> []-  RUnion {} -> []-  where-    walkField keys selectors field-      | rwfPresence field /= PRequired = []-      | otherwise = case projectionScalar (rwfType field) of-          Just result -> [mkProjection (keys <> [rwfKey field]) (selectors <> [(shapeModuleForOwner, rwfHaskell field)]) result]-          Nothing -> case rwfType field of-            RRef key -> case Map.lookup key (tgDeclarations graph) of-              Just (ResolvedStructural nested (RRecord _ _ nestedFields)) ->-                concatMap-                  (walkNested nested (keys <> [rwfKey field]) (selectors <> [(shapeModuleForOwner, rwfHaskell field)]))-                  nestedFields-              _ -> []-            _ -> []-      where-        shapeModuleForOwner = "__SHAPE__." <> sdName root--    walkNested owner keys selectors field-      | rwfPresence field /= PRequired = []-      | otherwise = case projectionScalar (rwfType field) of-          Just result -> [mkProjection (keys <> [rwfKey field]) (selectors <> [(shapeModuleFor owner, rwfHaskell field)]) result]-          Nothing -> case rwfType field of-            RRef key -> case Map.lookup key (tgDeclarations graph) of-              Just (ResolvedStructural nested (RRecord _ _ nestedFields)) ->-                concatMap-                  (walkNested nested (keys <> [rwfKey field]) (selectors <> [(shapeModuleFor owner, rwfHaskell field)]))-                  nestedFields-              _ -> []-            _ -> []--    -- Context is supplied when rendering; this marker is replaced there.-    shapeModuleFor declaration = "__SHAPE__." <> sdName declaration-    mkProjection keys selectors result =-      StructuralProjection-        { spTag = nameStem <> "Projection",-          spWitness = lowerFirst nameStem <> "Witness",-          spPointer = pointer,-          spOwner = sdHaskell root,-          spResult = result,-          spCanonical = sdCanonical root,-          spBinding = sdBinding root,-          spSelectors = selectors-        }-      where-        pointer = T.concat ["/" <> escapePointer key | key <- keys]-        nameStem = projectionNameStem (sdName root) pointer--projectionScalar :: ResolvedTypeExpr -> Maybe Text-projectionScalar = \case-  RText -> Just "Text"-  RInt -> Just "Int"-  RInteger -> Just "Integer"-  RBool -> Just "Bool"-  RTime -> Just "UTCTime"-  RNatural -> Just "Natural"-  RJson -> Nothing-  ROptional {} -> Nothing-  RList {} -> Nothing-  RMap {} -> Nothing-  RRef {} -> Nothing--escapePointer :: Text -> Text-escapePointer = T.replace "/" "~1" . T.replace "~" "~0"--projectionNameStem :: Name -> Text -> Text-projectionNameStem owner pointer =-  pascal owner-    <> T.concat-      [ normaliseAliasPart (unescapePointer segment)-      | segment <- filter (not . T.null) (T.splitOn "/" pointer)-      ]---- | Add a stable digest only when two distinct wire paths normalize to the--- same Haskell name. Digest collisions receive a deterministic ordinal, so the--- emitter never produces duplicate declarations even in that unlikely case.-allocateProjectionNames :: [StructuralProjection] -> [StructuralProjection]-allocateProjectionNames specs = concatMap allocateGroup groups-  where-    groups = groupBy (\left right -> spTag left == spTag right) (sortOn spTag specs)-    allocateGroup [spec] = [spec]-    allocateGroup collided = reverse named-      where-        ordered = sortOn projectionIdentity collided-        digest spec = T.take 8 (fnv1a64 (projectionIdentity spec))-        digestCounts = Map.fromListWith (+) [(digest spec, 1 :: Int) | spec <- ordered]-        (_, named) = foldl allocate (Map.empty, []) ordered-        allocate (seen, allocated) spec =-          let shortDigest = digest spec-              occurrence = Map.findWithDefault 0 shortDigest seen + 1-              suffix =-                shortDigest-                  <> if Map.findWithDefault 0 shortDigest digestCounts == 1-                    then ""-                    else tshow' occurrence-           in (Map.insert shortDigest occurrence seen, renameWithSuffix suffix spec : allocated)-    projectionIdentity spec = unCanonicalTypeId (spCanonical spec) <> "#" <> spPointer spec-    renameWithSuffix suffix spec =-      spec-        { spTag = nameStem <> suffix <> "Projection",-          spWitness = lowerFirst nameStem <> suffix <> "Witness"-        }-      where-        nameStem = fromMaybe (spTag spec) (T.stripSuffix "Projection" (spTag spec))--projectionWitnessName :: TypeGraph -> MappedKey -> Text -> Maybe Text-projectionWitnessName graph owner pointer = do-  ResolvedStructural declaration _ <- Map.lookup owner (tgDeclarations graph)-  spWitness-    <$> find-      (\spec -> spCanonical spec == sdCanonical declaration && spPointer spec == pointer)-      (projectionSpecs graph)--emitStructuralProjections :: Context -> TypeGraph -> Text-emitStructuralProjections ctx graph =-  nl $-    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",-           ""-         ]-      <> 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-        (Set.fromList (map spTag specs))-        ( Set.fromList-            ( [haskellTypeReference (spOwner spec) | spec <- specs]-                <> [qualifiedValueReference (spBinding spec) | spec <- specs]-                <> [ HaskellReference shapeModuleName selector ValueNamespace RequireQualified-                   | spec <- specs,-                     (shapeModuleName, selector) <- spSelectors spec-                   ]-            )-        )-    renderProjection spec =-      [ "",-        "data " <> spTag spec,-        "",-        "instance FieldProjection " <> spTag spec <> " where",-        "  type FieldName " <> spTag spec <> " = " <> tshow (spPointer spec),-        "  type FieldOwner " <> spTag spec <> " = " <> renderReferenceOrDie importPlan (haskellTypeReference (spOwner spec)),-        "  type FieldResult " <> spTag spec <> " = " <> spResult spec,-        "  fieldShapeId _ = " <> tshow (unCanonicalTypeId (spCanonical spec)),-        "  projectFieldValue _ owner = " <> renderGetter spec,-        "",-        spWitness spec <> " :: FieldWitness " <> spTag spec,-        spWitness spec <> " = fieldWitness @" <> spTag spec-      ]-    renderGetter spec =-      foldl-        ( \value (shapeModuleName, selector) ->-            renderReferenceOrDie importPlan (HaskellReference shapeModuleName selector ValueNamespace RequireQualified)-              <> " ("-              <> value-              <> ")"-        )-        ("bindingToShape " <> renderReferenceOrDie importPlan (qualifiedValueReference (spBinding spec)) <> " owner")-        (spSelectors spec)--resolveProjectionModules :: Context -> StructuralProjection -> StructuralProjection-resolveProjectionModules ctx spec =-  spec-    { spSelectors =-        [ (replaceModule marker, selector)-        | (marker, selector) <- spSelectors spec-        ]-    }-  where-    replaceModule marker-      | Just name <- T.stripPrefix "__SHAPE__." marker = structuralShapeModule ctx name-      | otherwise = structuralShapeModule ctx (lastSegment marker)--haskellTypeReference :: HaskellSource -> HaskellReference-haskellTypeReference source =-  HaskellReference (hsModule source) (hsType source) TypeNamespace PreferUnqualified--qualifiedValueReference :: QualifiedValueName -> HaskellReference-qualifiedValueReference qualified =-  HaskellReference moduleName valueName ValueNamespace RequireQualified-  where-    (moduleName, valueName) = splitQualified (unQualifiedValueName qualified)--renderReferenceOrDie :: HaskellImportPlan -> HaskellReference -> Text-renderReferenceOrDie importPlan =-  either-    (error . ("validated Haskell reference failed: " <>) . show)-    id-    . renderPlannedReference importPlan--planImportsOrDie :: Text -> Set.Set Text -> Set.Set HaskellReference -> HaskellImportPlan-planImportsOrDie target localDeclarations =-  either-    (error . ("validated Haskell import planning failed: " <>) . show)-    id-    . planHaskellImports-      ImportEnvironment-        { targetModule = target,-          localNames = localDeclarations,-          reservedQualifiers = rendererReservedQualifiers-        }--rendererReservedQualifiers :: Set.Set Text-rendererReservedQualifiers =-  Set.fromList-    [ "Aeson",-      "AesonKey",-      "AesonKeyMap",-      "B",-      "GeneratedNominals",-      "Holes",-      "K",-      "Key",-      "KeyMap",-      "KindID",-      "Map",-      "NominalProjections",-      "NonEmpty",-      "S",-      "Set",-      "StructuralProjections",-      "T"-    ]--splitQualified :: Text -> (Text, Text)-splitQualified value =-  let (prefix, name) = T.breakOnEnd "." value-   in (T.dropEnd 1 prefix, name)--lastSegment :: Text -> Text-lastSegment = snd . T.breakOnEnd "."---- | Emit all modules for one aggregate. The 'Spec' is needed for the shared--- id\/enum declarations.-scaffoldAggregate :: Context -> Spec -> Aggregate -> [ScaffoldModule]-scaffoldAggregate ctx spec = scaffoldAggregateForService ctx (legacyCheckedService spec)---- | Emit all modules for one aggregate after selecting the effective semantic--- contract. This is the normal source/workspace generation entry point.-scaffoldAggregateForService :: Context -> CheckedService -> Aggregate -> [ScaffoldModule]-scaffoldAggregateForService ctx service agg =-  [ genModule a "Domain" (emitDomain a),-    genModule a "Codec" (emitCodec a)-  ]-    ++ ( if hasVersion2Ownership a-           then-             [ genModule a "Transducer" (emitGeneratedTransducer a),-               genModule a "BehaviorContract" (emitBehaviorContract a),-               behaviorHoleModule a-             ]-           else []-       )-    ++ [ genModule a "EventStream" (emitEventStream a),-         genModule a "Projection" (emitProjection a)-       ]-    ++ [holeModule a (emitHoles a) | aggregateNeedsHoleModule a]-  where-    a = resolveAggForService ctx service agg--aggregateNeedsHoleModule :: Agg -> Bool-aggregateNeedsHoleModule aggregate-  | hasVersion2Ownership aggregate = not (null (version2HoleExports aggregate))-  | otherwise = True---- | The generated behavioral contract is deliberately separate from both the--- authoritative transducer and the create-once witness list.  Regeneration can--- replace this module freely while stale textual keys in @BehaviorHoles@ keep--- compiling and are reported by reconciliation.-emitBehaviorContract :: Agg -> Text-emitBehaviorContract aggregate =-  nl $-    renderGeneratedLanguagePragmas [ExtOverloadedLabels | not (null (aRegs aggregate))]-      <> [ 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",-           "import " <> aGenPrefix aggregate <> ".Transducer (" <> valueStem <> "Transducer)",-           "import Data.Aeson (ToJSON (..), object, (.=))",-           "import Data.List (sortOn)",-           "import Data.List.NonEmpty (NonEmpty)",-           "import Data.List.NonEmpty qualified as NonEmpty",-           "import Data.Map.Strict qualified as Map",-           "import Data.Text (Text)",-           "import Data.Text qualified as T",-           "import Keiki.Core qualified as K (" <> T.intercalate ", " behaviorCoreImports <> ")",-           "import Keiro.Codec qualified as Codec (Codec (eventType), EventType (..))",-           "",-           "newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }",-           "  deriving stock (Eq, Ord, Show)",-           "",-           "data ObligationKind = LiveTransition | RequiredRejection | ReplayTransition",-           "  deriving stock (Eq, Ord, Show)",-           "",-           "data EvidenceLevel = GeneratedAuthoritative | HoleWitnessed | LegacyRuntimeWitness",-           "  deriving stock (Eq, Ord, Show)",-           "",-           "data GuardCoverage = GuardTotal | GuardPartial | GuardUnknown | GuardNotApplicable",-           "  deriving stock (Eq, Ord, Show)",-           "",-           "data BehaviorRequirement = BehaviorRequirement",-           "  { requirementKey :: !BehaviorKey",-           "  , requirementKind :: !ObligationKind",-           "  , requirementEvidence :: !EvidenceLevel",-           "  , requirementGuardCoverage :: !GuardCoverage",-           "  , requirementSource :: !" <> aVertexType aggregate,-           "  , requirementCommandName :: !Text",-           "  , requirementExpectedEdge :: !(Maybe (K.EdgeRef " <> aVertexType aggregate <> "))",-           "  , requirementTarget :: !(Maybe " <> aVertexType aggregate <> ")",-           "  , requirementEventKinds :: ![Text]",-           "  , requirementLine :: !Int",-           "  }",-           "  deriving stock (Eq, Show)",-           "",-           "data RejectionClass = RejectNoOutgoingEdges | RejectNoMatchingEdge",-           "  deriving stock (Eq, Show)",-           "",-           "data LiveExpectation",-           "  = Emits (NonEmpty " <> name <> "Event)",-           "  | Rejects RejectionClass",-           "  | NoOp",-           "  deriving stock (Eq, Show)",-           "",-           "data BehaviorWitness",-           "  = Pending BehaviorKey",-           "  | LiveWitness",-           "      { witnessKey :: BehaviorKey",-           "      , witnessHistory :: [" <> name <> "Event]",-           "      , witnessCommand :: " <> name <> "Command",-           "      , witnessExpected :: LiveExpectation",-           "      }",-           "  | ReplayWitness",-           "      { witnessKey :: BehaviorKey",-           "      , witnessHistoryPrefix :: [" <> name <> "Event]",-           "      , witnessObservedChunk :: [" <> name <> "Event]",-           "      }",-           "  deriving stock (Eq, Show)",-           "",-           "data BehaviorFailure = BehaviorFailure",-           "  { failureKey :: !BehaviorKey",-           "  , failureSubject :: !Text",-           "  , failureCode :: !Text",-           "  , failureDetail :: !Text",-           "  }",-           "  deriving stock (Eq, Show)",-           "",-           "instance ToJSON BehaviorFailure where",-           "  toJSON behaviorFailure = object",-           "    [ \"key\" .= unBehaviorKey (failureKey behaviorFailure)",-           "    , \"subject\" .= failureSubject behaviorFailure",-           "    , \"code\" .= failureCode behaviorFailure",-           "    , \"detail\" .= failureDetail behaviorFailure",-           "    ]",-           "",-           "data BehaviorConformanceReport = BehaviorConformanceReport",-           "  { reportRequired :: ![BehaviorKey]",-           "  , reportFilled :: ![BehaviorKey]",-           "  , reportPending :: ![BehaviorKey]",-           "  , reportMissing :: ![BehaviorKey]",-           "  , reportDuplicate :: ![BehaviorKey]",-           "  , reportStale :: ![BehaviorKey]",-           "  , reportFailed :: ![BehaviorFailure]",-           "  , reportVerified :: ![BehaviorKey]",-           "  , reportUnverified :: ![BehaviorKey]",-           "  }",-           "  deriving stock (Eq, Show)",-           "",-           "instance ToJSON BehaviorConformanceReport where",-           "  toJSON report = object",-           "    [ \"schema\" .= (\"keiro/behavior-conformance/1\" :: Text)",-           "    , \"required\" .= keyTexts (reportRequired report)",-           "    , \"filled\" .= keyTexts (reportFilled report)",-           "    , \"pending\" .= keyTexts (reportPending report)",-           "    , \"missing\" .= keyTexts (reportMissing report)",-           "    , \"duplicate\" .= keyTexts (reportDuplicate report)",-           "    , \"stale\" .= keyTexts (reportStale report)",-           "    , \"failed\" .= reportFailed report",-           "    , \"verified\" .= keyTexts (reportVerified report)",-           "    , \"unverified\" .= keyTexts (reportUnverified report)",-           "    ]",-           "",-           "behaviorRequirements :: [BehaviorRequirement]",-           "behaviorRequirements ="-         ]-      <> renderBehaviorRequirementList aggregate-      <> [ "",-           "behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport",-           "behaviorCoverageReport witnesses =",-           "  BehaviorConformanceReport",-           "    { reportRequired = sortedKeys (Map.keys requiredByKey)",-           "    , reportFilled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]",-           "    , reportPending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]",-           "    , reportMissing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]",-           "    , reportDuplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]",-           "    , reportStale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]",-           "    , reportFailed = sortOn (unBehaviorKey . failureKey) failures",-           "    , reportVerified = sortedKeys [requirementKey requirement | (requirement, Right ()) <- executions, proofStrength requirement]",-           "    , reportUnverified = sortedKeys [requirementKey requirement | (requirement, Right ()) <- executions, not (proofStrength requirement)]",-           "    }",-           " where",-           "  requiredByKey = Map.fromList [(requirementKey requirement, requirement) | requirement <- behaviorRequirements]",-           "  witnessGroups = Map.fromListWith (flip (<>)) [(behaviorWitnessKey witness, [witness]) | witness <- witnesses]",-           "  executions =",-           "    [ (requirement, runWitness requirement witness)",-           "    | (key, [witness]) <- Map.toList witnessGroups",-           "    , not (isPending witness)",-           "    , Just requirement <- [Map.lookup key requiredByKey]",-           "    ]",-           "  failures = [behaviorFailure | (_, Left behaviorFailure) <- executions]",-           "",-           "behaviorConformancePassed :: BehaviorConformanceReport -> Bool",-           "behaviorConformancePassed = behaviorConformancePassedWith False",-           "",-           "behaviorConformancePassedWith :: Bool -> BehaviorConformanceReport -> Bool",-           "behaviorConformancePassedWith failOnUnverified report =",-           "  null (reportPending report)",-           "    && null (reportMissing report)",-           "    && null (reportDuplicate report)",-           "    && null (reportStale report)",-           "    && null (reportFailed report)",-           "    && (not failOnUnverified || null (reportUnverified report))",-           "",-           "renderBehaviorConformanceText :: BehaviorConformanceReport -> Text",-           "renderBehaviorConformanceText report = T.unlines",-           "  [ \"behavior conformance: " <> name <> "\"",-           "  , \"schema: keiro/behavior-conformance/1\"",-           "  , countLine \"required\" (reportRequired report)",-           "  , countLine \"filled\" (reportFilled report)",-           "  , countLine \"pending\" (reportPending report)",-           "  , countLine \"missing\" (reportMissing report)",-           "  , countLine \"duplicate\" (reportDuplicate report)",-           "  , countLine \"stale\" (reportStale report)",-           "  , \"failed: \" <> tshow (length (reportFailed report))",-           "  , countLine \"verified\" (reportVerified report)",-           "  , countLine \"unverified\" (reportUnverified report)",-           "  ] <> T.unlines [\"FAIL \" <> unBehaviorKey (failureKey behaviorFailure) <> \" \" <> failureSubject behaviorFailure <> \" [\" <> failureCode behaviorFailure <> \"] \" <> failureDetail behaviorFailure | behaviorFailure <- reportFailed report]",-           "",-           "runWitness :: BehaviorRequirement -> BehaviorWitness -> Either BehaviorFailure ()",-           "runWitness requirement witness = case witness of",-           "  Pending _ -> failure requirement \"pending\" \"witness is still Pending\"",-           "  LiveWitness _ history command expectation -> runLive requirement history command expectation",-           "  ReplayWitness _ prefix chunk -> runReplay requirement prefix chunk",-           "",-           "runLive :: BehaviorRequirement -> [" <> name <> "Event] -> " <> name <> "Command -> LiveExpectation -> Either BehaviorFailure ()",-           "runLive requirement history command expectation = do",-           "  settled <- settleHistory requirement \"history\" history",-           "  ensure requirement (K.replaySuccessState settled == requirementSource requirement) \"history-wrong-source\" \"history does not settle at the required source vertex\"",-           "  ensure requirement (commandKind command == requirementCommandName requirement) \"command-mismatch\" \"witness command constructor does not match the required state/command cell\"",-           "  case requirementKind requirement of",-           "    ReplayTransition -> failure requirement \"witness-kind\" \"a replay-only requirement needs ReplayWitness\"",-           "    RequiredRejection -> runRejection requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation",-           "    LiveTransition -> runAcceptance requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation",-           "",-           "runRejection :: 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\"",-           "  Rejects expectedClass -> case K.stepDetailedEither " <> valueStem <> "Transducer seed command of",-           "    Left K.NoOutgoingEdges {} -> ensure requirement (expectedClass == RejectNoOutgoingEdges) \"rejection-class\" \"expected NoMatchingEdge but runtime returned NoOutgoingEdges\"",-           "    Left K.NoMatchingEdge {} -> ensure requirement (expectedClass == RejectNoMatchingEdge) \"rejection-class\" \"expected NoOutgoingEdges but runtime returned NoMatchingEdge\"",-           "    Left K.AmbiguousEdges {} -> failure requirement \"ambiguous-edges\" \"AmbiguousEdges can never satisfy a rejection witness\"",-           "    Right _ -> failure requirement \"unexpected-acceptance\" \"runtime accepted a command required to reject\"",-           "",-           "runAcceptance :: 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",-           "    Left stepFailure -> failure requirement \"unexpected-rejection\" (tshow stepFailure)",-           "    Right success -> do",-           "      checkAcceptedEnvelope requirement success",-           "      ensure requirement (null (K.stepSuccessOutputs success)) \"noop-emitted\" \"NoOp emitted one or more events\"",-           "      ensure requirement (K.stepSuccessState success == fst seed) \"noop-vertex-change\" \"NoOp changed the control vertex\"",-           "      ensure requirement (regsEqual (K.stepSuccessRegs success) (snd seed)) \"noop-register-change\" \"NoOp changed one or more registers\"",-           "  Emits expectedEvents -> case K.stepDetailedEither " <> valueStem <> "Transducer seed command of",-           "    Left stepFailure -> failure requirement \"unexpected-rejection\" (tshow stepFailure)",-           "    Right success -> do",-           "      checkAcceptedEnvelope requirement success",-           "      let expected = NonEmpty.toList expectedEvents",-           "          actual = K.stepSuccessOutputs success",-           "      ensure requirement (actual == expected) \"event-value-mismatch\" (\"runtime event values differ from the exact witness expectation; 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)",-           "        Right replaySuccess -> Right replaySuccess",-           "      ensure requirement (K.replaySuccessState replayed == K.stepSuccessState success) \"forward-replay-vertex\" \"decoded emissions replay to a different vertex\"",-           "      ensure requirement (regsEqual (K.replaySuccessRegs replayed) (K.stepSuccessRegs success)) \"forward-replay-registers\" \"decoded emissions replay to different registers\"",-           "      checkSingleAttribution requirement K.Live (length decoded) (K.replaySuccessTrace replayed)",-           "",-           "checkAcceptedEnvelope :: 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; 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",-           "  ReplayTransition -> do",-           "    settled <- settleHistory requirement \"history-prefix\" prefix",-           "    ensure requirement (K.replaySuccessState settled == requirementSource requirement) \"history-wrong-source\" \"history prefix does not settle at the replay edge source\"",-           "    ensure requirement (not (null chunk)) \"empty-replay-chunk\" \"a replay-only edge has no observable empty chunk\"",-           "    decoded <- either (failure requirement \"replay-chunk-codec-decode\") Right (decodeEvents chunk)",-           "    replayed <- case K.applyEventsDetailedEither " <> valueStem <> "Transducer (K.replaySuccessState settled, K.replaySuccessRegs settled) decoded of",-           "      Left replayFailure -> failure requirement \"replay-chunk-failed\" (tshow replayFailure)",-           "      Right replaySuccess -> Right replaySuccess",-           "    ensure requirement (Just (K.replaySuccessState replayed) == requirementTarget requirement) \"target-mismatch\" (\"replay chunk reached a different target vertex; 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; 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",-           "    Left replayFailure -> failure requirement (label <> \"-replay-failed\") (tshow replayFailure)",-           "    Right replaySuccess -> Right replaySuccess",-           "",-           "decodeEvents :: [" <> name <> "Event] -> Either Text [" <> name <> "Event]",-           "decodeEvents = traverse (\\event -> parse" <> name <> "Event (Codec.eventType " <> valueStem <> "Codec event) (encode" <> name <> "Event event))"-         ]-      <> renderCommandKind aggregate-      <> [ "",-           "eventKind :: " <> 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 :: 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"-         ]-  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 :: " <> aName aggregate <> "Command -> Text", "commandKind _ = \"\""]-  commands ->-    [ "",-      "commandKind :: " <> aName aggregate <> "Command -> Text",-      "commandKind command = case command of"-    ]-      <> ["  " <> rcName command <> " _ -> " <> tshow (rcName command) | command <- commands]--renderBehaviorRequirementList :: Agg -> [Text]-renderBehaviorRequirementList aggregate =-  case behaviorRequirementsFor aggregate of-    [] -> ["  []"]-    requirements ->-      concat-        [ render index requirement-        | (index, requirement) <- zip [0 ..] requirements-        ]-        <> ["  ]"]-  where-    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"-  _ -> case behaviorEdgeIndex aggregate requirement of-    Nothing -> error ("required behavior transition missing from resolved aggregate: " <> T.unpack (Behavior.requirementCanonical requirement))-    Just edgeIndex ->-      "(Just (K.EdgeRef "-        <> vertexCtor aggregate (Behavior.requirementSource requirement)-        <> " "-        <> tshow' edgeIndex-        <> "))"--behaviorEdgeIndex :: Agg -> Behavior.BehaviorRequirement -> Maybe Int-behaviorEdgeIndex aggregate requirement =-  findIndex-    matches-    [ transition-    | transition <- aTransitions aggregate,-      tSource transition == Behavior.requirementSource requirement-    ]-  where-    matches transition =-      unLoc (tLoc transition) == unLoc (Behavior.requirementLocation requirement)-        && tCommand transition == Behavior.requirementCommand requirement--behaviorRequirementsFor :: Agg -> [Behavior.BehaviorRequirement]-behaviorRequirementsFor aggregate =-  case Behavior.deriveAggregateBehaviorRequirements (aSpec aggregate) (aAggregate aggregate) of-    Left derivationError -> error ("validated aggregate failed behavior derivation: " <> show derivationError)-    Right requirements -> sortOn Behavior.requirementKey requirements--renderBehaviorTextList :: [Text] -> Text-renderBehaviorTextList values = "[" <> T.intercalate ", " (map tshow values) <> "]"--regsEqualityExpression :: Agg -> Text-regsEqualityExpression aggregate = case aRegs aggregate of-  [] -> "regsEqual _ _ = True"-  registers ->-    "regsEqual left right = "-      <> T.intercalate-        " && "-        [ "(left K.! #" <> rrName register <> ") == (right K.! #" <> rrName register <> ")"-        | register <- registers-        ]--behaviorHoleModule :: Agg -> ScaffoldModule-behaviorHoleModule aggregate =-  ScaffoldModule-    { modulePath = T.unpack (T.replace "." "/" (aHolePrefix aggregate) <> "/BehaviorHoles.hs"),-      moduleText = emitBehaviorHoles aggregate,-      kind = HoleStub,-      origin = nodeOrigin "aggregate behavior witnesses" (aName aggregate) (aLoc aggregate)-    }--emitBehaviorHoles :: Agg -> Text-emitBehaviorHoles aggregate =-  nl $-    [ "-- Consumer-owned behavioral witnesses. Created once; never overwritten.",-      "module " <> aHolePrefix aggregate <> ".BehaviorHoles (behaviorWitnesses) where",-      "",-      "import " <> aGenPrefix aggregate <> ".BehaviorContract",-      "",-      "behaviorWitnesses :: [BehaviorWitness]",-      "behaviorWitnesses ="-    ]-      <> case behaviorRequirementsFor aggregate of-        [] -> ["  []"]-        requirements ->-          [ (if index == (0 :: Int) then "  [ " else "  , ")-              <> "Pending (BehaviorKey "-              <> tshow (Behavior.unBehaviorKey (Behavior.requirementKey requirement))-              <> ") -- "-              <> behaviorRequirementLabel aggregate requirement-          | (index, requirement) <- zip [0 ..] requirements-          ]-            <> ["  ]"]---- | Emit the context-wide replay-audit target assembly.------ There is one existential target per aggregate declaration. Process saga--- aggregates are ordinary aggregate nodes referenced by 'SagaRef', so they are--- included by the same single source of truth rather than being duplicated from--- the process declaration.-scaffoldReplayAudit :: Context -> Spec -> [ScaffoldModule]-scaffoldReplayAudit ctx spec-  | null aggregates = []-  | otherwise =-      [ ScaffoldModule-          { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),-            moduleText = emitReplayAudit,-            kind = Generated,-            origin = "context " <> specContext spec <> " replay-audit assembly"-          }-      ]-  where-    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]-    moduleName = contextGeneratedPrefix ctx <> ".ReplayAudit"-    emitReplayAudit =-      nl $-        renderGeneratedLanguagePragmas []-          <> [ generatedBanner,-               "--",-               "-- Deployment contract:",-               "--   * replay-neutral diff: no data audit is required;",-               "--   * affected diff: run AuditTargeted with the emitted affected set",-               "--     against a production copy under the candidate binary;",-               "--   * one-time runtime cutover: run AuditFull;",-               "--   * any non-zero audit exit blocks deployment.",-               "module " <> moduleName <> " (auditTargets) where",-               ""-             ]-          ++ [ "import " <> genPrefixFor ctx (aggName aggregate) <> ".EventStream qualified as " <> aggName aggregate-             | aggregate <- aggregates-             ]-          ++ [ "import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory)",-               "import Keiro.Stream qualified as Stream",-               "",-               "auditTargets :: [SomeAuditTarget]",-               "auditTargets ="-             ]-          ++ concat-            [ [ if index == (0 :: Int) then "  [ SomeAuditTarget" else "  , SomeAuditTarget",-                "      AuditTarget",-                "        { eventStream = " <> aggregateName <> "." <> lowerFirst aggregateName <> "EventStream",-                "        , category = Stream.categoryText " <> aggregateName <> "." <> lowerFirst aggregateName <> "Category",-                "        , mkStream = streamInCategory (Stream.categoryText " <> aggregateName <> "." <> lowerFirst aggregateName <> "Category)",-                "        }"-              ]-            | (index, aggregate) <- zip [0 ..] aggregates,-              let aggregateName = aggName aggregate-            ]-          ++ ["  ]"]--genModule :: Agg -> Text -> Text -> ScaffoldModule-genModule a name body =-  ScaffoldModule-    { modulePath = T.unpack (T.replace "." "/" (aGenPrefix a) <> "/" <> name <> ".hs"),-      moduleText = body,-      kind = Generated,-      origin = nodeOrigin "aggregate" (aName a) (aLoc a)-    }--holeModule :: Agg -> Text -> ScaffoldModule-holeModule a body =-  ScaffoldModule-    { modulePath = T.unpack (T.replace "." "/" (aHolePrefix a) <> "/" <> "Holes.hs"),-      moduleText = body,-      kind = HoleStub,-      origin = nodeOrigin "aggregate" (aName a) (aLoc a)-    }------------------------------------------------------------------------------------- Integration contract (EP-4): a self-contained payload ADT + codec------------------------------------------------------------------------------------- | Emit the deterministic, symbol-free contract layer: a payload ADT--- (per-event records), the topic constants, the @messageType@ discriminator, and a--- strict encode\/decode keyed by it. Self-contained (base\/text\/aeson), so it--- compiles standalone — the cross-service schema both producer and consumer agree--- on. No keiki symbolic operator (firewall holds).-scaffoldContract :: Context -> ContractNode -> [ScaffoldModule]-scaffoldContract ctx = scaffoldContractWithLanguage ctx (effectiveLanguageContract LegacyUnversioned)---- | Emit a contract under the checked service's released semantic contract.--- Language versions 1 through 3 retain the legacy Text representation; only--- runtime semantics 3 lowers declared TypeID fields to prefix-indexed KindIDs.-scaffoldContractForService :: Context -> CheckedService -> ContractNode -> [ScaffoldModule]-scaffoldContractForService ctx service = scaffoldContractWithLanguage ctx (checkedLanguageContract service)--scaffoldContractWithLanguage :: Context -> EffectiveLanguageContract -> ContractNode -> [ScaffoldModule]-scaffoldContractWithLanguage ctx languageContract c =-  [ ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Contract.hs"),-        moduleText = emitContractGen languageContract genPrefix c,-        kind = Generated,-        origin = nodeOrigin "contract" (ctrName c) (ctrLoc c)-      }-  ]-  where-    genPrefix = genPrefixFor ctx (pascal (ctrName c))--emitContractGen :: EffectiveLanguageContract -> Text -> ContractNode -> Text-emitContractGen languageContract genPrefix c =-  ( nl $-      pragmas-        ++ [generatedBanner]-        ++ moduleHeader-        ++ [ "",-             -- 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-        ++ [ "import Data.Text (Text)",-             "import qualified Data.Text as T"-           ]-        ++ ["import Keiro.Codec.IdDomain (parseKindIdV7Value)" | hasTypedTypeIds]-        ++ [ "",-             "-- topic constants"-           ]-        ++ topicConstants-        ++ [ "",-             "-- the closed payload set (discriminated by " <> tshow (ctrDiscriminator c) <> ")"-           ]-        ++ [emitPayloadAdt languageContract payloadTy (ctrEvents c)]-        ++ [ "",-             "messageTypeOf :: " <> payloadTy <> " -> Text",-             "messageTypeOf = \\case"-           ]-        ++ ["  " <> ceName e <> " {} -> " <> tshow (ceName e) | e <- ctrEvents c]-        ++ [ "",-             "encode" <> payloadTy <> " :: " <> payloadTy <> " -> Value",-             "encode" <> payloadTy <> " = \\case"-           ]-        ++ concatMap encodeArm (ctrEvents c)-        ++ [ "",-             "parse" <> payloadTy <> " :: Value -> Either Text " <> payloadTy,-             "parse" <> payloadTy <> " = mapLeftText . parseEither (withObject " <> tshow payloadTy <> " go)",-             "  where",-             "    go o = do",-             "      kind <- explicitParseField (withText " <> tshow (ctrDiscriminator c) <> " validateMessageType) o " <> tshow (ctrDiscriminator c),-             "      case kind of"-           ]-        ++ concatMap decodeArm (ctrEvents c)-        ++ [ "        _ -> fail \"validated message type was not handled\"",-             "",-             "mapLeftText :: Either String b -> Either Text b",-             "mapLeftText = either (Left . T.pack) Right",-             "",-             "validateMessageType :: Text -> Parser Text",-             "validateMessageType kind",-             "  | kind `elem` " <> renderTextList (map ceName (ctrEvents c)) <> " = pure kind",-             "  | otherwise = " <> renderUnknownFailure "message type" "kind" (map ceName (ctrEvents c))-           ]-  )-    <> if hasTypedTypeIds then "\n" else ""-  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]-            <> [ExtOverloadedRecordDot | contractUsesRecordDot c]-        )-    typedKindIdImports-      | hasTypedTypeIds = ["import Data.KindID (KindID)", "import qualified Data.KindID as KindID"]-      | otherwise = []-    moduleHeader =-      [ "module " <> genPrefix <> ".Contract",-        "  ( " <> payloadTy <> " (..)"-      ]-        ++ ["  , " <> ceName event <> "Data (..)" | event <- ctrEvents c]-        ++ ["  , " <> lowerFirst alias <> "Topic" | (alias, _) <- ctrTopics c]-        ++ [ "  , messageTypeOf",-             "  , encode" <> payloadTy,-             "  , parse" <> payloadTy,-             "  ) where"-           ]-    topicConstants-      | hasTypedTypeIds =-          [ T.intercalate-              "\n\n"-              [lowerFirst alias <> "Topic :: Text\n" <> lowerFirst alias <> "Topic = " <> tshow topic | (alias, topic) <- ctrTopics c]-          ]-      | otherwise = [lowerFirst alias <> "Topic :: Text\n" <> lowerFirst alias <> "Topic = " <> tshow topic | (alias, topic) <- ctrTopics c]-    isTypedTypeId (CTypeId prefix) = isJust (contractIdDomainContractFor languageContract prefix)-    isTypedTypeId _ = False-    aesonTypesImport = "import Data.Aeson.Types (Parser, explicitParseField, parseEither)"-    encodeArm e =-      [ "  " <> ceName e <> " payload ->",-        "    object"-      ]-        ++ objectEntriesFor ((tshow (ctrDiscriminator c) <> " .= (" <> tshow (ceName e) <> " :: Text)") : map encodeField (ceFields e))-        ++ ["      ]"]-    lead 0 kv = "      [ " <> kv-    lead _ kv = "      , " <> kv-    objectEntriesFor entries-      | hasTypedTypeIds =-          [ (if index == 0 then "      [ " else "        ")-              <> entry-              <> if index < length entries - 1 then "," else ""-          | (index, entry) <- zip [(0 :: Int) ..] entries-          ]-      | otherwise = [lead index entry | (index, entry) <- zip [(0 :: Int) ..] entries]-    decodeArm e =-      ["        " <> tshow (ceName e) <> " ->"]-        ++ case ceFields e of-          [] -> ["          pure (" <> ceName e <> " " <> ceName e <> "Data)"]-          fields ->-            [ "          " <> ceName e,-              "            <$> ( " <> ceName e <> "Data"-            ]-              ++ [ (if index == 0 then "                    <$> " else "                    <*> ") <> decodeField field-                 | (index, field) <- zip [(0 :: Int) ..] fields-                 ]-              ++ ["                )"]-    encodeField field =-      tshow (fieldWireKey identity)-        <> " .= "-        <> case cfType field of-          CTypeId prefix-            | 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 wireKey-      _ -> "o .: " <> tshow wireKey-      where-        wireKey = fieldWireKey (resolveContractFieldIdentity field)--contractNeedsDuplicateRecordFields :: ContractNode -> Bool-contractNeedsDuplicateRecordFields = hasDuplicateNames . concatMap (map (fieldSelector . resolveContractFieldIdentity) . ceFields) . ctrEvents--contractUsesRecordDot :: ContractNode -> Bool-contractUsesRecordDot = any (not . null . ceFields) . ctrEvents--emitPayloadAdt :: EffectiveLanguageContract -> Text -> [ContractEvent] -> Text-emitPayloadAdt languageContract tyName events =-  sectionsOf [map dataRecord events, [sumDecl]]-  where-    hasTypedTypeIds = any (any (isTypedTypeId . cfType) . ceFields) events-    isTypedTypeId (CTypeId prefix) = isJust (contractIdDomainContractFor languageContract prefix)-    isTypedTypeId _ = False-    hsType CText = "Text"-    hsType CInt = "Int"-    hsType (CTypeId prefix)-      | isJust (contractIdDomainContractFor languageContract prefix) = "(KindID " <> tshow prefix <> ")"-      | otherwise = "Text"-    dataRecord e =-      "data "-        <> ceName e-        <> "Data = "-        <> ceName e-        <> (if hasTypedTypeIds then "Data {" else "Data { ")-        <> 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-      [] -> "data " <> tyName <> " = " <> tyName <> "Empty\n  deriving stock (Eq, Show)"-      (e : es) ->-        nl-          ( (if hasTypedTypeIds then ["data " <> tyName, "  = " <> arm e] else ["data " <> tyName <> " = " <> arm e])-              ++ ["  | " <> arm e2 | e2 <- es]-              ++ ["  deriving stock (Eq, Show)"]-          )------------------------------------------------------------------------------------- Integration intake (EP-4): inbox disposition vs the live Keiro.Inbox runtime------------------------------------------------------------------------------------- | Emit the inbox node's deterministic disposition wiring compiled against the--- LIVE @Keiro.Inbox.Types@: the dedupe policy (a real 'InboxDedupePolicy') and a--- disposition function over the real @InboxResult@ (including handler--- failures). This pins the dangerous inversions--- (duplicate ⇒ ackOk, previouslyFailed ⇒ deadLetter) as compiled code over the--- runtime types. The complete declared classification table is also available--- to handler holes through a closed generated outcome type. Firewall holds (no--- keiki symbolic operator).-scaffoldIntake :: Context -> IntakeNode -> [ScaffoldModule]-scaffoldIntake ctx i =-  [ ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Inbox.hs"),-        moduleText = emitIntakeGen genPrefix i,-        kind = Generated,-        origin = nodeOrigin "intake" (inkName i) (inkLoc i)-      }-  ]-  where-    genPrefix = genPrefixFor ctx (pascal (inkName i))--emitIntakeGen :: Text -> IntakeNode -> Text-emitIntakeGen genPrefix i =-  nl $-    renderGeneratedLanguagePragmas []-      <> [ generatedBanner,-           "module " <> genPrefix <> ".Inbox",-           "  ( InboxFailure (..)",-           "  , " <> outcomeType <> " (..)",-           "  , " <> dispositionType <> " (..)",-           "  , inboxDedupePolicy",-           "  , inboxPersistence",-           "  , inboxDispositionFor",-           "  , inboxDisposition",-           "  ) where",-           "",-           "import Data.Text (Text)",-           "import Keiro.Inbox.Types (InboxDedupePolicy (..), InboxPersistence (..), InboxResult (..), RetryDelay (..))",-           "",-           "-- The dedupe policy (hole-kind 4), lowered to the live InboxDedupePolicy.",-           "inboxDedupePolicy :: InboxDedupePolicy",-           "inboxDedupePolicy = " <> inkDedupePolicy i,-           "",-           "-- | Success-path envelope retention passed to runInboxTransactionWith.",-           "-- Failures always retain their full operator-facing dead-letter envelope.",-           "-- Dedupe-only success rows decode with an empty payload.",-           "inboxPersistence :: InboxPersistence",-           "inboxPersistence = " <> persistenceCtor (inkPersist i),-           "",-           "-- Runtime failure detail retained when the inbox wrapper reports a failed handler attempt.",-           "data InboxFailure = InboxFailure",-           "  { inboxFailureReason :: !Text",-           "  , inboxFailureAttempt :: !(Maybe Int)",-           "  }",-           "  deriving stock (Eq, Show)",-           "",-           "-- Every classification named by the spec. Keeping this closed makes the",-           "-- generated table exhaustive and gives handler holes typed inputs.",-           "data " <> outcomeType,-           "  = " <> T.intercalate "\n  | " outcomeConstructors,-           "  deriving stock (Eq, Show)",-           "",-           "-- The service's declared acknowledgement decision, including its details.",-           "data " <> dispositionType,-           "  = InboxAccept",-           "  | InboxRetryAfter !RetryDelay !(Maybe InboxFailure)",-           "  | InboxDeadLetter !(Maybe Text) !(Maybe InboxFailure)",-           "  deriving stock (Eq, Show)",-           "",-           "-- The complete disposition table (hole-kind 2).",-           "inboxDispositionFor :: " <> outcomeType <> " -> " <> dispositionType,-           "inboxDispositionFor outcome = case outcome of"-         ]-      ++ ["  " <> outcomeConstructor (drOutcome row) <> " -> " <> actionExpression (drAction row) | row <- inkDisposition i]-      ++ [ "",-           "-- Lower the LIVE Keiro.Inbox.Types.InboxResult without an open fallback.",-           "inboxDisposition :: InboxResult a -> " <> dispositionType,-           "inboxDisposition r = case r of",-           "  InboxProcessed _ -> inboxDispositionFor " <> outcomeConstructor "processed",-           "  InboxDuplicate -> inboxDispositionFor " <> outcomeConstructor "duplicate",-           "  InboxInProgress -> inboxDispositionFor " <> outcomeConstructor "inProgress",-           "  InboxPreviouslyFailed failureReason ->",-           "    maybe (inboxDispositionFor " <> outcomeConstructor "previouslyFailed" <> ")",-           "      (\\reason -> attachFailure (InboxFailure reason Nothing) (inboxDispositionFor " <> outcomeConstructor "previouslyFailed" <> "))",-           "      failureReason",-           "  InboxHandlerFailed reason attempts ->",-           "    attachFailure (InboxFailure reason (Just attempts)) (inboxDispositionFor " <> outcomeConstructor "storeFailed" <> ")",-           "",-           "attachFailure :: InboxFailure -> " <> dispositionType <> " -> " <> dispositionType,-           "attachFailure failure disposition = case disposition of",-           "  InboxRetryAfter delay _ -> InboxRetryAfter delay (Just failure)",-           "  InboxDeadLetter reason _ -> InboxDeadLetter reason (Just failure)",-           "  InboxAccept -> InboxAccept"-         ]-  where-    stem = pascal (inkName i)-    outcomeType = stem <> "Outcome"-    dispositionType = stem <> "Disposition"-    outcomeConstructor = (stem <>) . pascal-    outcomeConstructors = map (outcomeConstructor . drOutcome) (inkDisposition i)-    actionExpression IAckOk = "InboxAccept"-    actionExpression (IRetry win) = "InboxRetryAfter (RetryDelay " <> windowText win <> ") Nothing"-    actionExpression (IDeadLetter mr) = "InboxDeadLetter " <> maybe "Nothing" (\reason -> "(Just " <> tshow reason <> ")") mr <> " Nothing"-    persistenceCtor InkPersistFull = "PersistFullEnvelope"-    persistenceCtor InkPersistDedupeOnly = "PersistDedupeOnly"------------------------------------------------------------------------------------- Integration publisher (EP-4): config vs the live Keiro.Outbox runtime------------------------------------------------------------------------------------- | Emit the publisher's at-least-once policy compiled against the LIVE--- @Keiro.Outbox.Types@: the ordering policy (a real 'OrderingPolicy'), the backoff--- curve (a real 'BackoffSchedule'), and the max-attempts ceiling. Firewall holds.-scaffoldPublisher :: Context -> PublisherNode -> [ScaffoldModule]-scaffoldPublisher ctx pb =-  [ ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Publisher.hs"),-        moduleText = emitPublisherGen genPrefix pb,-        kind = Generated,-        origin = nodeOrigin "publisher" (pubName pb) (pubLoc pb)-      }-  ]-  where-    genPrefix = genPrefixFor ctx (pascal (pubName pb))--emitPublisherGen :: Text -> PublisherNode -> Text-emitPublisherGen genPrefix pb =-  nl-    [ generatedBanner,-      "module " <> genPrefix <> ".Publisher",-      "  ( publisherOrdering",-      "  , publisherBackoff",-      "  , publisherMaxAttempts",-      "  ) where",-      "",-      -- 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,-      "",-      "publisherBackoff :: BackoffSchedule",-      "publisherBackoff = " <> backoffExpr (pubBackoff pb),-      "",-      "publisherMaxAttempts :: Int",-      "publisherMaxAttempts = " <> tshow' (pubMaxAttempts pb)-    ]-  where-    backoffExpr b = case boKind b of-      "constant" -> "ConstantBackoff " <> windowText (boWindow b)-      "exponential" ->-        "ExponentialBackoff ExponentialBackoffOptions { initial = "-          <> windowText (boWindow b)-          <> ", maxDelay = "-          <> maybe "0" windowText (boMax b)-          <> ", multiplier = "-          <> fromMaybe "0" (boMultiplier b)-          <> " }"-      _ -> "error \"keiro-dsl: unlowerable backoff kind\""------------------------------------------------------------------------------------- pgmq workqueue (EP-5): a self-contained Job payload record + codec------------------------------------------------------------------------------------- | Emit the deterministic, symbol-free pgmq layer: the Job payload record, the--- field→wire-name JSON codec, and the captured physical\/dlq\/table name constants.--- Self-contained (base\/text\/aeson). The fan-out body and the raw-SQL dedup--- predicate are holes (not emitted). Firewall holds.-scaffoldWorkqueue :: Context -> WorkqueueNode -> [ScaffoldModule]-scaffoldWorkqueue ctx w =-  [ ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Queue.hs"),-        moduleText = emitWorkqueueGen genPrefix w,-        kind = Generated,-        origin = nodeOrigin "workqueue" (wqName w) (wqLoc w)-      },-    ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/QueuePolicy.hs"),-        moduleText = emitQueuePolicy genPrefix w,-        kind = Generated,-        origin = nodeOrigin "workqueue" (wqName w) (wqLoc w)-      },-    ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/QueueCodec.hs"),-        moduleText = emitQueueCodec genPrefix w,-        kind = Generated,-        origin = nodeOrigin "workqueue" (wqName w) (wqLoc w)-      }-  ]-  where-    genPrefix = genPrefixFor ctx (pascal (wqName w))--emitWorkqueueGen :: Text -> WorkqueueNode -> Text-emitWorkqueueGen genPrefix w =-  nl $-    renderGeneratedLanguagePragmas [ExtOverloadedRecordDot | workqueueUsesRecordDot w]-      <> [ generatedBanner,-           "module " <> genPrefix <> ".Queue",-           "  ( " <> payloadTy <> " (..)",-           "  , encode" <> payloadTy,-           "  , parse" <> payloadTy,-           "  , queuePhysical, queueDlq, queueTable",-           groupKeyExport,-           "  ) where",-           "",-           "import Data.Aeson (Value, object, withObject, (.:), (.=))",-           "import Data.Aeson.Types (parseEither)",-           "import Data.Text (Text)",-           "import qualified Data.Text as T",-           "",-           "queuePhysical, queueDlq, queueTable :: Text",-           "queuePhysical = " <> tshow (wqPhysical w),-           "queueDlq = " <> tshow (wqDlq w),-           "queueTable = " <> tshow (wqTable w),-           ""-         ]-      ++ groupKeyLines-      ++ [ "data " <> payloadTy <> " = " <> payloadTy,-           "  { " <> T.intercalate "\n  , " [wqfName f <> " :: !" <> hsType (wqfType f) | f <- wqPayload w],-           "  }",-           "  deriving stock (Eq, Show)",-           "",-           "encode" <> payloadTy <> " :: " <> payloadTy <> " -> Value",-           "encode" <> payloadTy <> " p =",-           "  object"-         ]-      ++ [lead i (tshow (wqfWire f) <> " .= p." <> wqfName f) | (i, f) <- zip [(0 :: Int) ..] (wqPayload w)]-      ++ [ "    ]",-           "",-           "parse" <> payloadTy <> " :: Value -> Either Text " <> payloadTy,-           "parse" <> payloadTy <> " = mapLeftText . parseEither (withObject " <> tshow payloadTy <> " go)",-           "  where",-           "    go o = " <> payloadTy <> fieldApps (wqPayload w),-           "",-           "mapLeftText :: Either String b -> Either Text b",-           "mapLeftText = either (Left . T.pack) Right"-         ]-  where-    payloadTy = wqPayloadName w-    groupKeyExport = case wqGroupKey w of-      Nothing -> ""-      Just groupKey-        | gkVia groupKey == "raw" -> "  , groupKeyField, groupKeyFor"-        | otherwise -> "  , groupKeyField"-    groupKeyLines = case wqGroupKey w of-      Nothing -> []-      Just groupKey -> common <> derivationLines groupKey-        where-          common =-            [ "groupKeyField :: Text",-              "groupKeyField = " <> tshow (gkField groupKey),-              ""-            ]-          derivationLines key-            | gkVia key == "raw" =-                [ "groupKeyFor :: " <> payloadTy <> " -> Text",-                  "groupKeyFor payload = payload." <> gkField key,-                  ""-                ]-            | otherwise =-                [ "-- Opaque group-key derivation '" <> gkVia key <> "' remains hand-owned.",-                  "-- Captured fixture: " <> fromMaybe "<missing>" (gkFixture key),-                  ""-                ]-    hsType "bool" = "Bool"-    hsType "int" = "Int"-    hsType _ = "Text"-    lead 0 kv = "    [ " <> kv-    lead _ kv = "    , " <> kv-    fieldApps [] = ""-    fieldApps fs = " <$> " <> T.intercalate " <*> " ["o .: " <> tshow (wqfWire f) | f <- fs]--workqueueUsesRecordDot :: WorkqueueNode -> Bool-workqueueUsesRecordDot workqueue =-  not (null (wqPayload workqueue))-    || maybe False ((== "raw") . gkVia) (wqGroupKey workqueue)---- | Emit the versioned PGMQ envelope adapter.  The payload record remains--- symbol-free and dependency-light in Queue.hs; this runtime-facing module is--- the opt-in assembly point applications import into their Job values.-emitQueueCodec :: Text -> WorkqueueNode -> Text-emitQueueCodec genPrefix w =-  nl-    [ generatedBanner,-      "-- | Versioned job payload envelope: @{\\\"v\\\",\\\"t\\\",\\\"data\\\"}@.",-      "--",-      "-- Deploy workers before producers when raising its schema version. Do not",-      "-- adopt this codec on a non-empty bare-payload queue without draining it",-      "-- (or supplying a transitional codec), or in-flight messages will",-      "-- dead-letter. This is telemetry-neutral:",-      "-- docs/adr/0001-keiro-pgmq-job-processing-telemetry-contract.md owns",-      "-- spans and acknowledgement vocabulary.",-      "module " <> genPrefix <> ".QueueCodec (" <> stem <> "PayloadCodec, " <> stem <> "JobCodec) where",-      "",-      "import Data.List.NonEmpty (NonEmpty (..))",-      "import Keiro.Codec (Codec (..), EventType (..))",-      "import Keiro.PGMQ.Codec (JobCodec, keiroJobCodec)",-      "import " <> genPrefix <> ".Queue (" <> payloadTy <> ", encode" <> payloadTy <> ", parse" <> payloadTy <> ")",-      "",-      stem <> "PayloadCodec :: Codec " <> payloadTy,-      stem <> "PayloadCodec =",-      "  Codec",-      "    { eventTypes = EventType " <> tshow payloadTy <> " :| []",-      "    , eventType = \\_ -> EventType " <> tshow payloadTy,-      "    , schemaVersion = 1",-      "    , encode = encode" <> payloadTy,-      "    , decode = \\_ -> parse" <> payloadTy,-      "    , upcasters = []",-      "    }",-      "",-      stem <> "JobCodec :: JobCodec " <> payloadTy,-      stem <> "JobCodec = keiroJobCodec " <> stem <> "PayloadCodec"-    ]-  where-    payloadTy = wqPayloadName w-    stem = lowerFirst (T.concat (map pascal (T.splitOn "_" (wqName w))))---- | Emit the pgmq retry policy + JobOutcome disposition compiled against the--- LIVE @Keiro.PGMQ.Job@ runtime (RetryPolicy / JobOutcome / RetryDelay). This pins--- the dangerous inversions over the runtime types: storeFailure ⇒ Retry (transient)--- and decodeFailure ⇒ Dead (poison).-emitQueuePolicy :: Text -> WorkqueueNode -> Text-emitQueuePolicy genPrefix w =-  nl $-    [ generatedBanner,-      "module " <> genPrefix <> ".QueuePolicy",-      "  ( " <> outcomeType <> " (..)",-      "  , retryPolicy, jobOutcomeFor",-      "  , jobOrdering, jobTuningFor, queueProvision",-      "  ) where",-      "",-      "import Keiro.PGMQ.Job (" <> T.intercalate ", " queuePolicyImports <> ")",-      "",-      "jobOrdering :: JobOrdering",-      "jobOrdering = " <> orderingCtor,-      "",-      "-- Deployment owns visibility timeout, batch size, and polling; the spec owns ordering.",-      "jobTuningFor :: JobTuning -> JobTuning",-      "jobTuningFor = withOrdering jobOrdering",-      "",-      "-- Pass this to ensureJobQueueWith at worker startup. FIFO adds the required GIN index; the DLQ remains standard.",-      "queueProvision :: QueueProvision",-      "queueProvision = " <> provisionExpr,-      "",-      "retryPolicy :: RetryPolicy",-      "retryPolicy =",-      "  RetryPolicy",-      "    { maxRetries = " <> tshow' (wqMaxRetries w),-      "    , defaultRetryDelay = RetryDelay " <> windowText (wqDelay w),-      "    , useDeadLetter = " <> (if wqDlqOn w then "True" else "False"),-      "    }",-      "",-      "-- The consumer JobOutcome disposition over the spec's named domain outcomes,",-      "-- lowered to the live Keiro.PGMQ.Job.JobOutcome.",-      "data " <> outcomeType,-      "  = " <> T.intercalate "\n  | " (map (pascal . wqdOutcome) (wqDisposition w)),-      "  deriving stock (Eq, Show)",-      "",-      "jobOutcomeFor :: " <> outcomeType <> " -> JobOutcome",-      "jobOutcomeFor o = case o of"-    ]-      ++ ["  " <> 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"-      WqFifoRoundRobin -> "FifoRoundRobin"-    provisionExpr = fifoWrap baseProvision-    fifoWrap expression = case wqOrdering w of-      WqUnordered -> expression-      _ -> "withFifoIndexProvision (" <> expression <> ")"-    baseProvision = case wqProvision w of-      WqStandard -> "standardProvision"-      WqUnlogged -> "unloggedProvision"-      WqPartitioned interval retention ->-        "partitionedProvision (PartitionSpec { partitionInterval = "-          <> tshow interval-          <> ", retentionInterval = "-          <> tshow retention-          <> " })"-    outcome IAckOk = "Done"-    outcome (IRetry win) = "Retry (RetryDelay " <> windowText win <> ")"-    outcome (IDeadLetter mr) = "Dead " <> tshow (fromMaybe "dead-lettered" mr)------------------------------------------------------------------------------------- First-class read models (EP-107)------------------------------------------------------------------------------------- | Emit an acyclic three-module read-model vertical. @ReadModelTable@ owns the--- qualified-table constant shared by the hand-owned query and the generated--- runtime record; @ReadModel@ re-exports it as part of the public surface.-scaffoldReadModel :: Context -> ReadModelNode -> [ScaffoldModule]-scaffoldReadModel ctx readModel =-  [ generated "ReadModelTable" (emitReadModelTable tableModule stem readModel),-    generated "ReadModel" (emitReadModelGen ctx readModelModule tableModule readModelHolePrefix stem readModel),-    ScaffoldModule-      { modulePath = modulePathFor readModelHolePrefix "ReadModelHoles",-        moduleText = emitReadModelHoles tableModule readModelHolePrefix stem readModel,-        kind = HoleStub,-        origin = readModelOrigin-      }-  ]-  where-    nodeSegment = pascal (rmName readModel)-    stem = readModelStem readModel-    readModelModule = genPrefixFor ctx nodeSegment-    tableModule = readModelModule <> ".ReadModelTable"-    readModelHolePrefix = holePrefixFor ctx nodeSegment-    readModelOrigin = nodeOrigin "readmodel" (rmName readModel) (rmLoc readModel)-    generated leaf body =-      ScaffoldModule-        { modulePath = modulePathFor readModelModule leaf,-          moduleText = body,-          kind = Generated,-          origin = readModelOrigin-        }--modulePathFor :: Text -> Text -> FilePath-modulePathFor prefix leaf = T.unpack (T.replace "." "/" prefix <> "/" <> leaf <> ".hs")--readModelStem :: ReadModelNode -> Text-readModelStem = lowerFirst . T.concat . map pascal . T.splitOn "_" . rmName--emitReadModelTable :: Text -> Text -> ReadModelNode -> Text-emitReadModelTable tableModule stem readModel =-  nl-    [ generatedBanner,-      "module " <> tableModule <> " (" <> qualifiedName <> ") where",-      "",-      "import Data.Text (Text)",-      "import Keiro.Connection (qualifyTable)",-      "",-      "-- The fully-qualified, double-quoted data-table reference.",-      qualifiedName <> " :: Text",-      qualifiedName <> " = qualifyTable " <> tshow (rmSchema readModel) <> " " <> tshow (rmTable readModel)-    ]-  where-    qualifiedName = stem <> "QualifiedTable"--emitReadModelGen :: Context -> Text -> Text -> Text -> Text -> ReadModelNode -> Text-emitReadModelGen ctx readModelModule tableModule readModelHolePrefix stem readModel =-  nl $-    renderGeneratedLanguagePragmas [ExtOverloadedRecordDot | rmFeed readModel == RmSubscription]-      <> [ generatedBanner,-           "module " <> readModelModule <> ".ReadModel",-           "  ( " <> T.intercalate "\n  , " exports,-           "  ) where",-           "",-           "import Data.Functor (void)",-           "import Effectful (Eff, (:>))",-           "import " <> tableModule <> " (" <> qualifiedName <> ")",-           "import " <> readModelHolePrefix <> ".ReadModelHoles (" <> T.intercalate ", " holeImports <> ")"-         ]-      ++ asyncImports-      ++ [ "import Keiro.ReadModel (ConsistencyMode (..), ReadModel (..), ReadModelMetadata, StrongScope (..), registerReadModel)",-           "import Keiro.ReadModel.Rebuild qualified as Rebuild",-           "import Kiroku.Store.Effect (Store)",-           "import Kiroku.Store.Types (" <> kirokuTypes <> ")",-           "",-           readModelName <> " :: ReadModel " <> queryInputType <> " " <> queryResultType,-           readModelName <> " =",-           "  ReadModel",-           "    { name = " <> tshow registryName,-           "    , tableName = " <> tshow (rmTable readModel),-           "    , schema = " <> tshow (rmSchema readModel),-           "    , subscriptionName = " <> tshow subscriptionName,-           "    , version = " <> tshow' (rmVersion readModel),-           "    , shapeHash = " <> tshow (rmShape readModel),-           "    , defaultConsistency = " <> consistencyExpr (rmConsistency readModel),-           "    , strongScope = " <> scopeExpr (rmScope readModel),-           "    , query = " <> queryName,-           "    }",-           "",-           "-- Call once at projection startup before serving queries.",-           registerName <> " :: (Store :> es) => Eff es ()",-           registerName <> " =",-           "  void (registerReadModel " <> tshow registryName <> " " <> tshow' (rmVersion readModel) <> " " <> tshow (rmShape readModel) <> ")",-           "",-           startName <> " :: (Store :> es) => GlobalPosition -> Eff es ReadModelMetadata",-           startName <> " =",-           "  Rebuild.startRebuild " <> readModelName <> " " <> projectionNames,-           "",-           finishName <> " :: (Store :> es) => GlobalPosition -> Eff es (Either Rebuild.RebuildError ReadModelMetadata)",-           finishName <> " =",-           "  Rebuild.finishRebuild " <> readModelName <> " " <> projectionNames,-           "",-           abandonName <> " :: (Store :> es) => Eff es ReadModelMetadata",-           abandonName <> " = Rebuild.abandonRebuild " <> readModelName-         ]-      ++ asyncDefinition-  where-    registryName = registryNameFor (contextName ctx) readModel-    subscriptionName = subscriptionNameFor (contextName ctx) readModel-    asyncName = registryName <> "-async"-    readModelName = stem <> "ReadModel"-    qualifiedName = stem <> "QualifiedTable"-    registerName = "register" <> pascal stem-    startName = "start" <> pascal stem <> "Rebuild"-    finishName = "finish" <> pascal stem <> "Rebuild"-    abandonName = "abandon" <> pascal stem <> "Rebuild"-    asyncValueName = stem <> "AsyncProjection"-    queryInputType = pascal stem <> "QueryInput"-    queryResultType = pascal stem <> "QueryResult"-    queryName = stem <> "Query"-    applyName = "apply" <> pascal stem-    exports =-      [ readModelName,-        qualifiedName,-        registerName,-        startName,-        finishName,-        abandonName-      ]-        ++ [asyncValueName | rmFeed readModel == RmSubscription]-    holeImports = [queryInputType, queryResultType, queryName] ++ [applyName | rmFeed readModel == RmSubscription]-    asyncImports = case rmFeed readModel of-      RmInline -> []-      RmSubscription -> ["import Keiro.Projection (AsyncProjection (..))"]-    kirokuTypes = case rmFeed readModel of-      RmInline -> "GlobalPosition"-      RmSubscription -> "GlobalPosition, RecordedEvent (..)"-    projectionNames = case rmFeed readModel of-      RmInline -> "[]"-      RmSubscription -> "[" <> tshow asyncName <> "]"-    asyncDefinition = case rmFeed readModel of-      RmInline -> []-      RmSubscription ->-        [ "",-          asyncValueName <> " :: AsyncProjection",-          asyncValueName <> " =",-          "  AsyncProjection",-          "    { name = " <> tshow asyncName,-          "    , readModelName = " <> tshow registryName,-          "    , subscriptionName = " <> tshow subscriptionName,-          "    , applyRecorded = " <> applyName,-          "    , idempotencyKey = \\recorded -> recorded.eventId",-          "    }"-        ]-    consistencyExpr Strong = "Strong"-    consistencyExpr Eventual = "Eventual"-    scopeExpr Nothing = "EntireLog"-    scopeExpr (Just RmEntireLog) = "EntireLog"-    scopeExpr (Just (RmCategory categoryName)) = "CategoryHead " <> tshow categoryName--emitReadModelHoles :: Text -> Text -> Text -> ReadModelNode -> Text-emitReadModelHoles tableModule readModelHolePrefix stem readModel =-  nl $-    [ "-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.",-      "module " <> readModelHolePrefix <> ".ReadModelHoles",-      "  ( " <> T.intercalate "\n  , " exports,-      "  ) where",-      "",-      "import " <> tableModule <> " (" <> qualifiedName <> ")",-      "import Hasql.Transaction qualified as Tx"-    ]-      ++ ["import Kiroku.Store.Types (RecordedEvent(..))" | rmFeed readModel == RmSubscription]-      ++ [ "",-           "-- HOLE: replace these aliases with the real query input and result types.",-           "type " <> queryInputType <> " = ()",-           "type " <> queryResultType <> " = ()",-           "",-           "-- HOLE: query " <> qualifiedTableLiteral readModel <> " via " <> qualifiedName <> "; never rely on search_path.",-           "-- Declared columns:"-         ]-      ++ map (("--   " <>) . readModelColumnDoc) (rmColumns readModel)-      ++ [ queryName <> " :: " <> queryInputType <> " -> Tx.Transaction " <> queryResultType,-           queryName <> " _input = " <> qualifiedName <> " `seq` error " <> tshow ("HOLE: fill " <> rmName readModel <> " query")-         ]-      ++ applyStub-  where-    qualifiedName = stem <> "QualifiedTable"-    queryInputType = pascal stem <> "QueryInput"-    queryResultType = pascal stem <> "QueryResult"-    queryName = stem <> "Query"-    applyName = "apply" <> pascal stem-    exports = [queryInputType, queryResultType, queryName] ++ [applyName | rmFeed readModel == RmSubscription]-    applyStub = case rmFeed readModel of-      RmInline -> []-      RmSubscription ->-        [ "",-          "-- HOLE: apply one recorded event; runtime deduplication makes redelivery safe.",-          applyName <> " :: RecordedEvent -> Tx.Transaction ()",-          applyName <> " _recorded = error " <> tshow ("HOLE: fill " <> rmName readModel <> " async apply")-        ]--qualifiedTableLiteral :: ReadModelNode -> Text-qualifiedTableLiteral readModel = quoteSqlIdentifier (rmSchema readModel) <> "." <> quoteSqlIdentifier (rmTable readModel)--quoteSqlIdentifier :: Text -> Text-quoteSqlIdentifier identifier = "\"" <> T.replace "\"" "\"\"" identifier <> "\""--readModelColumnDoc :: RmColumn -> Text-readModelColumnDoc columnDecl =-  rmcName columnDecl-    <> " "-    <> rmcType columnDecl-    <> if rmcRequired columnDecl then " NOT NULL" else ""------------------------------------------------------------------------------------- Router + shared worker-policy lowering (EP-108)-----------------------------------------------------------------------------------scaffoldRouter :: Context -> RouterNode -> [ScaffoldModule]-scaffoldRouter ctx router =-  [ ScaffoldModule-      { modulePath = modulePathFor genPrefix "Router",-        moduleText = emitRouterGen genPrefix router,-        kind = Generated,-        origin = routerOrigin-      },-    ScaffoldModule-      { modulePath = modulePathFor holePrefix "RouterHoles",-        moduleText = emitRouterHoles holePrefix router,-        kind = HoleStub,-        origin = routerOrigin-      }-  ]-  where-    genPrefix = genPrefixFor ctx (rtId router)-    holePrefix = holePrefixFor ctx (rtId router)-    routerOrigin = nodeOrigin "router" (rtId router) (rtLoc router)--emitRouterGen :: Text -> RouterNode -> Text-emitRouterGen genPrefix router =-  nl $-    [ generatedBanner,-      "module " <> genPrefix <> ".Router",-      "  ( " <> stem <> "Name",-      "  , " <> stem <> "WorkerOptions",-      "  ) where",-      "",-      "import Data.Text (Text)"-    ]-      ++ workerPolicyImports (rtPoison router)-      ++ [ "",-           "-- The STABLE router name. It participates in every target-keyed",-           "-- deterministicRouterCommandId; renaming it re-keys replayed dispatches.",-           stem <> "Name :: Text",-           stem <> "Name = " <> tshow (rtName router),-           "",-           "-- Runtime-owned dispatch id inputs: (name, key, sourceEventId,",-           "-- targetStreamName, occurrence). Target-keyed, not positional.",-           "",-           "-- Node-level worker policy lowered from the spec. Pass this value to",-           "-- Keiro.Router.runRouterWorkerWith; do not silently use defaultWorkerOptions."-         ]-      ++ workerOptionsLines (stem <> "WorkerOptions") (rtRejected router) (rtPoison router)-  where-    stem = lowerFirst (rtId router)--emitRouterHoles :: Text -> RouterNode -> Text-emitRouterHoles holePrefix router =-  nl-    [ "-- HAND-OWNED hole module for the router's behaviour-bearing bodies.",-      "-- keiro-dsl creates it once and never overwrites it.",-      "module " <> holePrefix <> ".RouterHoles () where",-      "",-      "-- HOLE resolve :: " <> inName (rtInput router) <> " -> Eff es [PMCommand targetCommand]",-      "--   Spec source: " <> resolveSourceText (rvSource (rtResolve router)) <> ".",-      "--   The spec's 'stable' keyword acknowledges that retry attempts accumulate",-      "--   the UNION of resolved target identities. Keep the recipient set stable",-      "--   for a source event whenever an exact recipient set matters.",-      "-- HOLE router value: assemble Keiro.Router.Router with name = " <> lowerFirst (rtId router) <> "Name,",-      "--   key, resolve, targetEventStream, and targetProjections; run it with",-      "--   runRouterWorkerWith " <> lowerFirst (rtId router) <> "WorkerOptions.",-      "-- HOLE targetProjections: spec projections = " <> renderNames (rtProjections router) <> ".",-      "-- NOTE on-duplicate AckOk is sound because Keiro.Router confirms a duplicate",-      "--   event id against the TARGET stream via confirmBenignDuplicate before",-      "--   returning PMCommandDuplicate. Hand-rolled dispatch paths must do likewise."-    ]-  where-    renderNames names = "[" <> T.intercalate ", " names <> "]"--resolveSourceText :: ResolveSource -> Text-resolveSourceText (ResolveReadModel name) = "read-model " <> name <> " (typically Keiro.ReadModel.runQuery)"-resolveSourceText ResolveHole = "typed resolver hole"--workerPolicyImports :: PolicyChoice -> [Text]-workerPolicyImports poison =-  [ "import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))",-    "import Shibuya.Core.Ack (RetryDelay (..))"-  ]-    ++ if poison == PolHalt-      then []-      else ["import Effectful (Eff)", "import Shibuya.Core.Types (Envelope)"]--workerOptionsLines :: Text -> PolicyChoice -> PolicyChoice -> [Text]-workerOptionsLines valueName rejected poison =-  [ valueName <> signature,-    valueName <> argument <> " =",-    "  WorkerOptions",-    "    { poisonPolicy = " <> poisonExpr <> ",",-    "      rejectedCommandPolicy = " <> rejectedExpr rejected <> ",",-    "      transientRetryDelay = RetryDelay 5, -- matches defaultWorkerOptions; runtime tuning",-    "      metrics = Nothing -- runtime configuration; install at call site",-    "    }"-  ]-  where-    signature = case poison of-      PolHalt -> " :: WorkerOptions es msg"-      _ -> " :: (Envelope msg -> Eff es ()) -> WorkerOptions es msg"-    argument = case poison of-      PolHalt -> ""-      _ -> " poisonCallback"-    poisonExpr = case poison of-      PolHalt -> "PoisonHalt"-      PolDeadLetter -> "PoisonDeadLetter poisonCallback"-      PolSkip -> "PoisonSkip poisonCallback"-    rejectedExpr = \case-      PolHalt -> "RejectedHalt"-      PolDeadLetter -> "RejectedDeadLetter"-      PolSkip -> "RejectedSkip"------------------------------------------------------------------------------------- Process manager + durable timer (EP-3)------------------------------------------------------------------------------------- | Emit the symbol-free deterministic wiring for a process manager + its timer--- into a @Generated@ module, plus a create-if-absent @ProcessHoles@ module for the--- behaviour-bearing bodies (the @handle@ reaction, the deadline window, and the--- fire command). The @Generated@ module contains no keiki symbolic operator (the--- saga's transducer is the separate aggregate hole), so the firewall invariant--- holds. The timer worker uses the spec's @max-attempts@ ceiling, never the--- dangerous @defaultTimerWorkerOptions@ (@Nothing@) default.-scaffoldProcess :: Context -> ProcessNode -> [ScaffoldModule]-scaffoldProcess ctx p =-  [ ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Process.hs"),-        moduleText = emitProcessGen sagaGenPrefix genPrefix holePrefix p,-        kind = Generated,-        origin = nodeOrigin "process" (procId p) (procLoc p)-      },-    ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" holePrefix <> "/ProcessHoles.hs"),-        moduleText = emitProcessHoles genPrefix holePrefix p,-        kind = HoleStub,-        origin = nodeOrigin "process" (procId p) (procLoc p)-      }-  ]-  where-    genPrefix = genPrefixFor ctx (procId p)-    holePrefix = holePrefixFor ctx (procId p)-    sagaGenPrefix = genPrefixFor ctx (pascal (sagaAgg (procSaga p)))--emitProcessGen :: Text -> Text -> Text -> ProcessNode -> Text-emitProcessGen sagaGenPrefix genPrefix _holePrefix p =-  nl $-    [ generatedBanner,-      "module " <> genPrefix <> ".Process",-      "  ( " <> lo <> "ProcessName",-      "  , " <> lo <> "Category",-      "  , " <> lo <> "ProcessWorkerOptions",-      "  , " <> lo <> "TimerRequest",-      "  , " <> lo <> "FireOutcome",-      "  ) where",-      "",-      "import Data.Aeson (Value, object, (.=))",-      "import Data.Text (Text)",-      "import qualified Data.Text as T",-      "import Data.Time (UTCTime)",-      "import Data.UUID (UUID)",-      "import qualified Data.UUID.V5 as UUID.V5",-      "import " <> sagaGenPrefix <> ".EventStream (" <> sagaEventStreamType <> ")",-      "import Keiro.Command (CommandError (..))",-      "import Keiro.Stream qualified as Stream",-      "import Keiro.Timer (TimerId (..), TimerRequest (..))"-    ]-      ++ workerPolicyImports (procPoison p)-      ++ [ "",-           "-- The define-once ProcessManager name (hole-kind 5: referenced, never retyped).",-           lo <> "ProcessName :: Text",-           lo <> "ProcessName = " <> tshow (procName p),-           "",-           "-- The validated saga stream category (hole-kind 5: referenced, never retyped).",-           "-- Saga streams are '<category>-<correlationId>' via Keiro.Stream.entityStream.",-           "-- categoryUnsafe is safe here because keiro-dsl check proved the literal legal.",-           lo <> "Category :: Stream.StreamCategory " <> sagaEventStreamType,-           lo <> "Category = Stream.categoryUnsafe " <> tshow categoryName,-           "",-           "-- Node-level worker policy lowered from the spec. Pass this value to",-           "-- Keiro.ProcessManager.runProcessManagerWorkerWith."-         ]-      ++ workerOptionsLines (lo <> "ProcessWorkerOptions") (procRejected p) (procPoison p)-      ++ [ "",-           "-- The deterministic timer-request builder: id derived from the correlation",-           "-- key (hole-kind 1), processManagerName referenced, payload from the spec.",-           "-- (timer id derived as uuidv5 of " <> tshow (idePrefix (tmId timer)) <> " <> correlationId)",-           lo <> "TimerRequest :: Text -> UTCTime -> TimerRequest",-           lo <> "TimerRequest correlationId fireAtTime =",-           "  TimerRequest",-           "    { timerId = TimerId (namedUuid (" <> tshow (idePrefix (tmId timer)) <> " <> correlationId))",-           "    , processManagerName = " <> lo <> "ProcessName",-           "    , correlationId = correlationId",-           "    , fireAt = fireAtTime",-           "    , payload = " <> payloadExpr (tmPayload timer),-           "    }",-           "",-           "-- The timer-fire disposition table (hole-kind 2), derived from the spec.",-           "-- on-reject => " <> showOutcome (onReject fd) <> " is the benign inversion.",-           "-- A duplicate append reaches on-error unless it is confirmed against the",-           "-- target stream. Use Keiro.ProcessManager.confirmBenignDuplicate:",-           "--   StreamName -> EventId -> CommandError -> Eff es Bool",-           "-- Fold True into the duplicate result and surface False as the failure.",-           lo <> "FireOutcome :: Either CommandError a -> Maybe ()",-           lo <> "FireOutcome result = case result of",-           "  Right{} -> " <> outcomeToMaybe (onOk fd),-           "  Left CommandRejected -> " <> outcomeToMaybe (onReject fd),-           "  Left (CommandAmbiguous _) -> " <> outcomeToMaybe (onAmbiguous fd) <> "  -- explicit definition-bug arm",-           "  Left{} -> " <> outcomeToMaybe (onError fd),-           "",-           "-- max-attempts = " <> tshow' (tmMaxAttempts timer) <> ", dead-letter = " <> tshow (tmDeadLetter timer),-           "-- (the timer worker must pass Just " <> tshow' (tmMaxAttempts timer) <> " to runTimerWorkerWith, never the",-           "--  defaultTimerWorkerOptions Nothing ceiling that retries forever).",-           "",-           "-- deterministic v5 UUID of a correlation-keyed string (hole-kind 1).",-           "namedUuid :: Text -> UUID",-           "namedUuid v = UUID.V5.generateNamed UUID.V5.namespaceURL (map (fromIntegral . fromEnum) (T.unpack v))"-         ]-  where-    lo = lowerFirst (procId p)-    sagaEventStreamType = pascal (sagaAgg (procSaga p)) <> "EventStreamDef"-    categoryName = staticCategory ("process " <> procId p) (sagaCategory (procSaga p))-    timer = procTimer p-    fd = fireDisposition (tmFire timer)---- | The timer payload, restricted to the spec's literal (@name=\"value\"@)--- bindings so it compiles in the deterministic builder. Bare fields and--- ref-valued bindings are input-driven (the agent-written hole), not emitted.-payloadExpr :: [FieldBinding] -> Text-payloadExpr fs = case [b | b <- fs, isLiteral b] of-  [] -> "object []"-  lits -> "object [ " <> T.intercalate ", " (map kv lits) <> " ]"-  where-    isLiteral b = maybe False (const True) (fbValue b >>= stripWrappingQuotes)-    kv b = tshow (fbName b) <> " .= (" <> maybe "\"\"" tshow (fbValue b >>= stripWrappingQuotes) <> " :: Value)"-    stripWrappingQuotes value = T.stripPrefix "\"" value >>= T.stripSuffix "\""--showOutcome :: FireOutcome -> Text-showOutcome OFired = "Fired"-showOutcome ORetry = "Retry"--outcomeToMaybe :: FireOutcome -> Text-outcomeToMaybe OFired = "Just ()  -- Fired"-outcomeToMaybe ORetry = "Nothing  -- Retry"--emitProcessHoles :: Text -> Text -> ProcessNode -> Text-emitProcessHoles _genPrefix holePrefix p =-  nl-    [ "-- HAND-OWNED hole module for the process manager's behaviour-bearing bodies.",-      "-- keiro-dsl creates it once and never overwrites it.",-      "module " <> holePrefix <> ".ProcessHoles () where",-      "",-      "-- HOLE handle: build the ProcessManagerAction (the self-advance",-      "--   '" <> advCommand (hAdvance (procHandle p)) <> "', the dispatch(es), and the timer) from the input.",-      "-- HOLE streams: build streamFor with entityStream " <> lowerFirst (procId p) <> "Category;",-      "--   build target streams with entityStream " <> lowerFirst (procTarget p) <> "CommandCategory. Never concatenate raw stream names.",-      "-- HOLE window: the deadline policy, e.g. surgeWindow :: NominalDiffTime;",-      "--   surgeDeadline observedAt = addUTCTime surgeWindow observedAt  (TIME INJECTED).",-      "-- HOLE fire command: construct " <> fireCommand (tmFire (procTimer p)) <> " for the timer fire,",-      "--   keyed by correlationId; the fired-event-id is the deterministic uuidv5 of",-      "--   " <> tshow (idePrefix (fireFiredEventId (tmFire (procTimer p)))) <> " <> correlationId.",-      "-- NOTE on-duplicate AckOk is sound because the runtime confirms a duplicate",-      "--   event id against the TARGET stream via confirmBenignDuplicate before",-      "--   returning PMCommandDuplicate. Its effective signature is:",-      "--     StreamName -> EventId -> CommandError -> Eff es Bool",-      "--   Hand-rolled paths must call it with the target stream and attempted event id,",-      "--   fold True into the duplicate result, and surface False as the original failure.",-      "--   Never pattern-match DuplicateEvent as success: event ids are globally unique."-    ]------------------------------------------------------------------------------------- Domain module-----------------------------------------------------------------------------------emitDomain :: Agg -> Text-emitDomain a =-  nl $-    renderGeneratedLanguagePragmas-      ( [ExtDeriveAnyClass | hasSnapshot a]-          <> [ExtDuplicateRecordFields | domainNeedsDuplicateRecordFields a]-          <> [ExtTemplateHaskell]-      )-      ++ [ generatedBanner,-           "module " <> aGenPrefix a <> ".Domain where",-           ""-         ]-      ++ ["import Data.Aeson (FromJSON, ToJSON)" | hasSnapshot a]-      ++ ["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]-      ++ generatedNominalDomainImports a-      ++ map ("import " <>) (domainStaticImports a)-      ++ T.lines (renderPlannedImports importPlan)-      ++ [ "import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)",-           "",-           sectionsOf-             [ [emitVertex a],-               map (emitRecord importPlan a) (aCommands a),-               [emitSum (aName a <> "Command") (aCommands a)],-               map (emitRecord importPlan a) (aEvents a),-               [emitSum (aName a <> "Event") (aEvents a)],-               [emitRegsType importPlan a, emitInitialRegs importPlan a],-               [ "$(deriveAggregateCtorsAll ''" <> aName a <> "Command ''" <> aName a <> "Regs)",-                 "",-                 "$(deriveWireCtorsAll ''" <> aName a <> "Event)"-               ]-             ]-         ]-  where-    importPlan = domainImportPlan a--domainNeedsDuplicateRecordFields :: Agg -> Bool-domainNeedsDuplicateRecordFields aggregate = hasDuplicateNames selectorNames-  where-    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.-    selectorNames = commandSelectors <> eventSelectors <> eventSelectors <> registerSelectors--hasDuplicateNames :: [Text] -> Bool-hasDuplicateNames names = length names /= Set.size (Set.fromList names)--hasSnapshot :: Agg -> Bool-hasSnapshot = maybe False (const True) . aSnapshot--emitVertex :: Agg -> Text-emitVertex a =-  nl $-    [ "data " <> aVertexType a <> " = " <> T.intercalate " | " (map (vertexCtor a . stName) (aStates a)),-      "  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)"-    ]-      ++ ["  deriving anyclass (ToJSON, FromJSON)" | hasSnapshot a]-      ++ [ line-         | hasSnapshot a,-           line <--             [ "instance CanonicalStateShape " <> aVertexType a,-               "instance CanonicalTypeName " <> aVertexType a-             ]-         ]--emitRecord :: HaskellImportPlan -> Agg -> ResolvedCtor -> Text-emitRecord importPlan a rc =-  nl $-    [ "data " <> rcName rc <> "Data = " <> rcName rc <> "Data"-    ]-      ++ recordFields [(fieldSelector identity, renderDomainType importPlan a fieldType) | (identity, fieldType) <- rcFields rc]-      ++ ["  deriving stock (Generic, Eq, Show)"]--recordFields :: [(Text, Text)] -> [Text]-recordFields [] =-  ["  {"]-    <> ["  }"]-recordFields fs =-  [ lead i <> n <> " :: !" <> ty-  | (i, (n, ty)) <- zip [(0 :: Int) ..] fs-  ]-    ++ ["  }"]-  where-    lead 0 = "  { "-    lead _ = "  , "--emitSum :: Text -> [ResolvedCtor] -> Text-emitSum tyName ctors =-  nl $-    [firstLine] ++ restLines ++ ["  deriving stock (Generic, Eq, Show)"]-  where-    arm rc = rc' rc-    rc' rc = rcName rc <> " !" <> rcName rc <> "Data"-    (firstLine, restLines) = case ctors of-      [] -> ("data " <> tyName, [])-      (c : cs) ->-        ( "data " <> tyName <> " = " <> arm c,-          ["  | " <> arm c2 | c2 <- cs]-        )--emitRegsType :: HaskellImportPlan -> Agg -> Text-emitRegsType importPlan a =-  nl $-    ["type " <> aName a <> "Regs ="]-      ++ regListLines importPlan a (aRegs a)--regListLines :: HaskellImportPlan -> Agg -> [ResolvedRegister] -> [Text]-regListLines _ _ [] = ["  '[]"]-regListLines importPlan a rs =-  [ lead i <> "'(" <> tshow (rrName r) <> ", " <> renderDomainType importPlan a (rrType r) <> ")"-  | (i, r) <- zip [(0 :: Int) ..] rs-  ]-    ++ ["   ]"]-  where-    lead 0 = "  '[ "-    lead _ = "   , "--emitInitialRegs :: HaskellImportPlan -> Agg -> Text-emitInitialRegs importPlan a =-  nl $-    [ "initial" <> aName a <> "Regs :: RegFile " <> aName a <> "Regs",-      "initial" <> aName a <> "Regs ="-    ]-      ++ chain (aRegs a)-  where-    chain [] = ["  RNil"]-    chain rs =-      [ "  RCons (Proxy @" <> tshow (rrName r) <> ") " <> regInitialValue importPlan a r <> " $"-      | r <- init rs-      ]-        ++ ["  RCons (Proxy @" <> tshow (rrName lastR) <> ") " <> regInitialValue importPlan a lastR <> " RNil"]-      where-        lastR = last rs---- | The Haskell initial value for a register, by the category of its type.-regInitialValue :: HaskellImportPlan -> Agg -> ResolvedRegister -> Text-regInitialValue importPlan aggregate register = case rrInitial register of-  InitialId name -> case find ((== name) . resolvedNominalName) (aGeneratedNominals aggregate) >>= generatedIdSampleHaskell aggregate of-    Just value -> value-    Nothing -> renderRegisterInitial (rrInitial register)-  InitialNominal _ value -> renderReferenceOrDie importPlan (qualifiedValueReference value)-  InitialMapped _ value -> renderReferenceOrDie importPlan (qualifiedValueReference value)-  _ -> renderRegisterInitial (rrInitial register)--domainImportPlan :: Agg -> HaskellImportPlan-domainImportPlan aggregate =-  planImportsOrDie-    (aGenPrefix aggregate <> ".Domain")-    localDeclarations-    (Set.unions (map aggregateSourceReferences (domainAggregateSources aggregate)) <> initialReferences)-  where-    localDeclarations =-      Set.fromList-        ( [ aVertexType aggregate,-            aName aggregate <> "Command",-            aName aggregate <> "Event",-            aName aggregate <> "Regs"-          ]-            <> [rcName constructor <> "Data" | constructor <- aCommands aggregate <> aEvents aggregate]-            <> map resolvedNominalName (aGeneratedNominals aggregate)-        )-    initialReferences =-      Set.fromList-        ( [ qualifiedValueReference initialValue-          | declaration <- mappedUses aggregate,-            initialValue <- maybeToListText (mappedInitial declaration)-          ]-            <> [ qualifiedValueReference initialValue-               | resolvedType <- aggregateTypes aggregate,-                 AggregateNominal nominal <- [resolvedType],-                 ConsumerNominal binding <- [resolvedNominalOwnership nominal],-                 initialValue <- maybeToListText (consumerNominalInitial binding)-               ]-        )--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 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 =-  map (aggregateConsumerHaskellSource (aSymbols aggregate)) (aggregateTypes aggregate)--aggregateTypes :: Agg -> [ResolvedAggregateType]-aggregateTypes aggregate =-  map snd (concatMap rcFields (aCommands aggregate <> aEvents aggregate)) <> map rrType (aRegs aggregate)--mappedUses :: Agg -> [ResolvedMappedDecl]-mappedUses a =-  [ declaration-  | resolvedType <--      map snd (concatMap rcFields (aCommands a <> aEvents a))-        <> map rrType (aRegs a),-    declaration <- maybeToListText (mappedDeclFor a resolvedType)-  ]--mappedDeclFor :: Agg -> ResolvedAggregateType -> Maybe ResolvedMappedDecl-mappedDeclFor a resolvedType = do-  key <- case resolvedType of-    AggregateMapped mappedKey -> Just mappedKey-    _ -> Nothing-  graph <- aTypeGraph a-  Map.lookup key (tgDeclarations graph)--mappedInitial :: ResolvedMappedDecl -> Maybe QualifiedValueName-mappedInitial (ResolvedStructural declaration _) = sdInitial declaration-mappedInitial (ResolvedOpaque declaration) = odInitial declaration--renderDomainType :: HaskellImportPlan -> Agg -> ResolvedAggregateType -> Text-renderDomainType importPlan aggregate resolvedType =-  either-    (error . ("validated aggregate Haskell reference failed: " <>) . show)-    id-    (renderAggregateHaskellSource importPlan (aggregateConsumerHaskellSource (aSymbols aggregate) resolvedType))--maybeToListText :: Maybe value -> [value]-maybeToListText = maybe [] pure------------------------------------------------------------------------------------- Codec module-----------------------------------------------------------------------------------emitCodec :: Agg -> Text-emitCodec a =-  nl $-    renderGeneratedLanguagePragmas [ExtOverloadedRecordDot | codecUsesRecordDot a]-      ++ [ generatedBanner,-           "module " <> aGenPrefix a <> ".Codec (",-           "    " <> lowerFirst (aName a) <> "Codec,",-           "    parse" <> aName a <> "Event,",-           "    encode" <> aName a <> "Event,"-         ]-      ++ concatMap mappedExports (codecMappedDeclarations a)-      ++ [ ") where",-           "",-           "import " <> aGenPrefix a <> ".Domain"-         ]-      ++ generatedNominalCodecImports (aggregateCheckedService a) (aContext a) (codecGeneratedNominals a)-      ++ ["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 codecUsesMap a-             then ["import Data.Map.Strict (Map)", "import Data.Map.Strict qualified as Map"]-             else []-         )-      ++ [ "import Data.Text (Text)",-           "import qualified Data.Text as T"-         ]-      ++ ["import Data.KindID qualified as KindID" | hasConsumerNominalIdCodec a]-      ++ ["import Keiro.Codec.IdDomain (typeIdV7Domain, validateIdDomainText)" | hasEnforcedConsumerNominalIdCodec a]-      ++ ["import Keiro.Codec.Nominal (nominalFromRepresentation, nominalToRepresentation)" | hasConsumerNominalCodec a]-      ++ ["import Keiro.Codec.Structural (bindingFromShape, bindingToShape)" | hasStructuralMappedCodec a]-      ++ [ "import Keiro.Codec (Codec (..), EventType (..))",-           upcasterImport a-         ]-      ++ [nl (map ("import " <>) (codecMappedImports a)) | hasMappedCodec a]-      ++ [nl (map ("import " <>) (codecNominalImports a)) | hasConsumerNominalCodec a]-      ++ T.lines (renderPlannedImports importPlan)-      ++ [ "",-           emitEnumParsers a,-           emitConsumerNominalParsers importPlan a-         ]-      ++ [emitMappedCodecs importPlan a | hasMappedCodec a]-      ++ [ "",-           emitEventTypes a,-           "",-           emitCodecValue a,-           "",-           emitEncode importPlan a,-           "",-           emitDecode importPlan a,-           "",-           "mapLeftText :: Either String b -> Either Text b",-           "mapLeftText = either (Left . T.pack) Right",-           "",-           "renderExpectedEventTypes :: NonEmpty EventType -> String",-           "renderExpectedEventTypes =",-           "  T.unpack",-           "    . T.intercalate \", \"",-           "    . map (\\(EventType eventTypeName) -> eventTypeName)",-           "    . NonEmpty.toList"-         ]-      ++ ( 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))",-                 "  where",-                 "    extras = filter (`notElem` allowed) (map Key.toText (KeyMap.keys objectValue))"-               ]-             else []-         )-  where-    importPlan = codecImportPlan a-    mappedExports (ResolvedStructural declaration _) =-      [ "    encode" <> sdName declaration <> "Mapped,",-        "    decode" <> sdName declaration <> "Mapped,"-      ]-    mappedExports ResolvedOpaque {} = []--codecUsesRecordDot :: Agg -> Bool-codecUsesRecordDot = any (not . null . rcFields) . aEvents--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--hasConsumerNominalIdCodec :: Agg -> Bool-hasConsumerNominalIdCodec aggregate =-  any-    (\nominal -> case resolvedNominalRepresentation nominal of IdRepresentation {} -> True; _ -> False)-    (codecConsumerNominals aggregate)--hasEnforcedConsumerNominalIdCodec :: Agg -> Bool-hasEnforcedConsumerNominalIdCodec aggregate =-  any-    ( \nominal -> case resolvedNominalRepresentation nominal of-        IdRepresentation prefix -> isJust (idDomainContractFor (aLanguageContract aggregate) prefix)-        _ -> False-    )-    (codecConsumerNominals aggregate)--emitEnumParsers :: Agg -> Text-emitEnumParsers a =-  sectionsOf-    [ [emitEnumParser nominal | nominal <- codecGeneratedNominals a, EnumRepresentation {} <- [resolvedNominalRepresentation nominal]]-    ]--emitEnumParser :: ResolvedNominalType -> Text-emitEnumParser nominal = case resolvedNominalRepresentation nominal of-  EnumRepresentation constructors ->-    nl $-      [ "parse" <> name <> " :: Text -> Parser " <> name,-        "parse" <> name <> " = \\case"-      ]-        ++ ["  " <> tshow wire <> " -> pure " <> constructor | (constructor, wire) <- NE.toList constructors]-        ++ ["  tag -> " <> renderUnknownFailure name "tag" (map snd (NE.toList constructors))]-  _ -> error "non-enum reached generated enum parser emission"-  where-    name = resolvedNominalName nominal--emitConsumerNominalParsers :: HaskellImportPlan -> Agg -> Text-emitConsumerNominalParsers importPlan aggregate = sectionsOf [map emitParser (codecConsumerNominals aggregate)]-  where-    emitParser nominal = case (resolvedNominalRepresentation nominal, resolvedNominalOwnership nominal) of-      (IdRepresentation prefix, ConsumerNominal binding) ->-        nl $-          [ parserName nominal <> " :: Text -> Parser " <> renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding))-          ]-            <> parserBody nominal prefix binding-      (EnumRepresentation constructors, ConsumerNominal binding) ->-        nl $-          [ parserName nominal <> " :: Text -> Parser " <> renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding)),-            parserName nominal <> " = \\case"-          ]-            <> [ "  "-                   <> tshow wire-                   <> " -> pure (nominalFromRepresentation "-                   <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding))-                   <> " "-                   <> renderReferenceOrDie importPlan (nominalRepresentationConstructorReference (aContext aggregate) nominal constructor)-                   <> ")"-               | (constructor, wire) <- NE.toList constructors-               ]-            <> ["  tag -> " <> renderUnknownFailure (resolvedNominalName nominal <> " wire value") "tag" (map snd (NE.toList constructors))]-      _ -> ""-    parserName nominal = "parse" <> resolvedNominalName nominal <> "Nominal"-    parserBody nominal prefix binding = case idDomainContractFor (aLanguageContract aggregate) prefix of-      Nothing ->-        [ parserName nominal <> " input = case KindID.parseText @" <> tshow prefix <> " input of",-          "  Left reason -> fail (show reason)",-          "  Right representation -> pure (nominalFromRepresentation " <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)) <> " representation)"-        ]-      Just _ ->-        [ parserName nominal <> " input = case validateIdDomainText (typeIdV7Domain " <> tshow prefix <> ") input of",-          "  Left reason -> fail (show reason)",-          "  Right () -> case KindID.parseText @" <> tshow prefix <> " input of",-          "    Left reason -> fail (show reason)",-          "    Right representation -> pure (nominalFromRepresentation " <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)) <> " representation)"-        ]--emitCodecValue :: Agg -> Text-emitCodecValue a =-  nl $-    [ lowerFirst (aName a) <> "Codec :: Codec " <> aName a <> "Event",-      lowerFirst (aName a) <> "Codec =",-      "  Codec",-      "    { eventTypes = " <> eventTypesName a,-      "    , eventType = \\case"-    ]-      ++ ["        " <> rcName e <> "{} -> EventType " <> tshow (rcName e) | e <- aEvents a]-      ++ [ "    , schemaVersion = " <> tshow' (maxEventVersion a),-           "    , encode = encode" <> aName a <> "Event",-           "    , decode = parse" <> aName a <> "Event",-           "    , upcasters = " <> upcastersExpr a,-           "    }"-         ]-      ++ upcasterRungDecls a--emitEventTypes :: Agg -> Text-emitEventTypes aggregate =-  nl-    [ eventTypesName aggregate <> " :: NonEmpty EventType",-      eventTypesName aggregate <> " = " <> eventTypesExpr-    ]-  where-    eventTypesExpr = case map rcName (aEvents aggregate) of-      [] -> "error \"no events\""-      event : rest -> "EventType " <> tshow event <> " :| [" <> T.intercalate ", " (map (("EventType " <>) . tshow) rest) <> "]"--eventTypesName :: Agg -> Text-eventTypesName aggregate = lowerFirst (aName aggregate) <> "EventTypes"---- | The codec's @schemaVersion@: the maximum declared event version (EP-2).-maxEventVersion :: Agg -> Int-maxEventVersion a = maximum (1 : map rcVersion (aEvents a))---- | One @(sourceVersion, upcasterName)@ entry per event that declares an--- @upcast from@. The upcaster name is per-event (e.g. @upcastFooV1@) and its--- body is a hole in the hand-owned Holes module.-upcasterEntries :: Agg -> [(Int, Text, Text)]-upcasterEntries a =-  [ (m, rcName e, "upcast" <> rcName e <> "V" <> tshow' m)-  | e <- aEvents a,-    Just m <- [rcUpcastFrom e]-  ]--upcastersExpr :: Agg -> Text-upcastersExpr a =-  "[" <> T.intercalate ", " ["(" <> tshow' m <> ", upcastRungV" <> tshow' m <> ")" | (m, _) <- upcasterRungs a] <> "]"---- | Group event-specific holes into one migration rung per aggregate-global--- source version.  Event metadata stamps every kind with the aggregate's--- schema version, so a rung must explicitly pass foreign event kinds through.-upcasterRungs :: Agg -> [(Int, [(Text, Text)])]-upcasterRungs a =-  [ (source, [(eventName, fn) | (_, eventName, fn) <- entries])-  | entries@((source, _, _) : _) <- groupBy sameSource (sortOn firstSource (upcasterEntries a))-  ]-  where-    firstSource (source, _, _) = source-    sameSource (source, _, _) (otherSource, _, _) = source == otherSource--upcasterRungDecls :: Agg -> [Text]-upcasterRungDecls a = concatMap rung (upcasterRungs a)-  where-    rung (source, entries) =-      [ "",-        "upcastRungV" <> tshow' source <> " :: EventType -> Value -> Either Text Value"-      ]-        ++ [ "upcastRungV" <> tshow' source <> " (EventType " <> tshow eventName <> ") value = " <> fn <> " value"-           | (eventName, fn) <- entries-           ]-        ++ [ "-- Kinds whose shape did not change at this rung pass through unchanged; their",-             "-- stamped version is aggregate-global, not their own shape history.",-             "upcastRungV" <> tshow' source <> " _ value = Right value"-           ]---- | When the codec references upcasters, it imports their (hole) definitions--- from the hand-owned Holes module.-upcasterImport :: Agg -> Text-upcasterImport a = case upcasterEntries a of-  [] -> ""-  es -> "import " <> aHolePrefix a <> ".Holes (" <> T.intercalate ", " [fn | (_, _, fn) <- es] <> ")"--emitEncode :: HaskellImportPlan -> Agg -> Text-emitEncode importPlan a =-  nl $-    [ "encode" <> aName a <> "Event :: " <> aName a <> "Event -> Value",-      "encode" <> aName a <> "Event = \\case"-    ]-      ++ concatMap encodeArm (aEvents a)-  where-    encodeArm e =-      [ "  " <> rcName e <> " payload ->",-        "    object"-      ]-        ++ [ lead i <> kv-           | (i, kv) <- zip [(0 :: Int) ..] (("\"kind\" .= (" <> tshow (rcName e) <> " :: Text)") : map encodeField (rcFields e))-           ]-        ++ ["      ]"]-    lead 0 = "      [ "-    lead _ = "      , "-    encodeField (identity, ty) =-      tshow (fieldWireKey identity)-        <> " .= "-        <> 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." <> 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-        EnumRepresentation {} -> lowerFirst (resolvedNominalName nominal) <> "Text " <> value-        ScalarRepresentation {} -> value-      ConsumerNominal binding -> case resolvedNominalRepresentation nominal of-        IdRepresentation {} -> "KindID.toText (nominalToRepresentation " <> bindingName binding <> " " <> value <> ")"-        EnumRepresentation {} ->-          renderReferenceOrDie importPlan (nominalRepresentationEncoderReference (aContext a) nominal)-            <> " (nominalToRepresentation "-            <> bindingName binding-            <> " "-            <> value-            <> ")"-        ScalarRepresentation {} -> "nominalToRepresentation " <> bindingName binding <> " " <> value-    bindingName = renderReferenceOrDie importPlan . qualifiedValueReference . consumerNominalBinding--emitDecode :: HaskellImportPlan -> Agg -> Text-emitDecode importPlan a =-  nl $-    [ "parse" <> aName a <> "Event :: EventType -> Value -> Either Text " <> aName a <> "Event",-      "parse" <> aName a <> "Event (EventType tag) = mapLeftText . parseEither (withObject " <> tshow (aName a <> "Event") <> " go)",-      "  where",-      "    go o = do",-      "      case tag of"-    ]-      ++ concatMap decodeArm (aEvents a)-      ++ ["        _ -> " <> renderUnknownEventTypeFailure a "tag"]-  where-    decodeArm e =-      ["        " <> tshow (rcName e) <> " ->"]-        ++ case rcFields e of-          [] -> ["          pure (" <> rcName e <> " " <> rcName e <> "Data)"]-          fields ->-            [ "          " <> rcName e,-              "            <$> ( " <> rcName e <> "Data"-            ]-              ++ [ (if index == 0 then "                    <$> " else "                    <*> ") <> decodeField field-                 | (index, field) <- zip [(0 :: Int) ..] fields-                 ]-              ++ ["                )"]-    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 (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-          Nothing -> "(" <> resolvedNominalName nominal <> " <$> o .: " <> tshow name <> ")"-          Just _ -> "(" <> legacyNominalConstructorName nominal <> " <$> o .: " <> tshow name <> ")"-        EnumRepresentation {} ->-          "explicitParseField (withText "-            <> tshow (resolvedNominalName nominal)-            <> " parse"-            <> resolvedNominalName nominal-            <> ") o "-            <> tshow name-        ScalarRepresentation {} -> "o .: " <> tshow name-      ConsumerNominal binding -> case resolvedNominalRepresentation nominal of-        IdRepresentation {} -> consumerNominalFieldParser name nominal-        EnumRepresentation {} -> consumerNominalFieldParser name nominal-        ScalarRepresentation {} -> "(nominalFromRepresentation " <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)) <> " <$> o .: " <> tshow name <> ")"-    consumerNominalFieldParser fieldName nominal =-      "explicitParseField (withText "-        <> tshow (resolvedNominalName nominal)-        <> " parse"-        <> resolvedNominalName nominal-        <> "Nominal) o "-        <> tshow fieldName--codecConsumerNominals :: Agg -> [ResolvedNominalType]-codecConsumerNominals aggregate =-  Map.elems . Map.fromList $-    [ (resolvedNominalName nominal, nominal)-    | event <- aEvents aggregate,-      (_, AggregateNominal nominal) <- rcFields event,-      ConsumerNominal {} <- [resolvedNominalOwnership nominal]-    ]--codecGeneratedNominals :: Agg -> [ResolvedNominalType]-codecGeneratedNominals aggregate =-  generatedNominalsInTypes-    [ resolvedType-    | event <- aEvents aggregate,-      (_, resolvedType) <- rcFields event-    ]--codecImportPlan :: Agg -> HaskellImportPlan-codecImportPlan aggregate =-  planImportsOrDie-    (aGenPrefix aggregate <> ".Codec")-    (Set.fromList [aName aggregate <> "Event"])-    (Set.fromList (nominalReferences <> mappedReferences <> nominalRepresentationReferences <> shapeReferences))-  where-    nominalReferences =-      [ reference-      | nominal <- codecConsumerNominals aggregate,-        ConsumerNominal binding <- [resolvedNominalOwnership nominal],-        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,-        reference <--          [ haskellTypeReference (sdHaskell declaration),-            qualifiedValueReference (sdBinding declaration)-          ]-      ]-    nominalRepresentationReferences =-      [ reference-      | nominal <- codecConsumerNominals aggregate,-        EnumRepresentation constructors <- [resolvedNominalRepresentation nominal],-        reference <--          nominalRepresentationEncoderReference (aContext aggregate) nominal-            : [ nominalRepresentationConstructorReference (aContext aggregate) nominal constructor-              | (constructor, _) <- NE.toList constructors-              ]-      ]-    shapeReferences =-      [ reference-      | ResolvedStructural declaration shape <- codecMappedDeclarations aggregate,-        reference <- structuralShapeReferences (aContext aggregate) declaration shape-      ]--codecNominalImports :: Agg -> [Text]-codecNominalImports _ = []--codecMappedImports :: Agg -> [Text]-codecMappedImports a = case aTypeGraph a of-  Nothing -> []-  Just graph ->-    sort . nub $-      [ hsModule (odHaskell declaration) <> " ()"-      | ResolvedOpaque declaration <- codecMappedDeclarations a-      ]-        <> [ hsModule (odHaskell declaration) <> " ()"-           | ResolvedStructural _ shape <- codecMappedDeclarations a,-             key <- directShapeRefs shape,-             Just (ResolvedOpaque declaration) <- [Map.lookup key (tgDeclarations graph)]-           ]--codecMappedDeclarations :: Agg -> [ResolvedMappedDecl]-codecMappedDeclarations a = case aTypeGraph a of-  Nothing -> []-  Just graph ->-    mapMaybe (\key -> Map.lookup key (tgDeclarations graph)) (sort (Map.keys selected))-    where-      roots =-        [ key-        | event <- aEvents a,-          (_, AggregateMapped key) <- rcFields event,-          Map.member key (tgDeclarations graph)-        ]-      selected =-        Map.fromList-          [ (key, ())-          | root <- roots,-            key <- root : maybe [] (Map.keys . Map.fromSet (const ())) (Map.lookup root (tgReachability graph))-          ]--directShapeRefs :: ResolvedMappedShape -> [MappedKey]-directShapeRefs =-  foldMappedShape-    MappedShapeAlgebra-      { onRecord = \_ _ fields -> concatMap (exprRefs . rwfType) fields,-        onEnum = const [],-        onUnion = \_ arms -> concatMap (maybe [] exprRefs . rwaPayload) arms-      }--exprRefs :: ResolvedTypeExpr -> [MappedKey]-exprRefs =-  foldTypeExpr-    TypeExprAlgebra-      { onText = [],-        onInt = [],-        onInteger = [],-        onBool = [],-        onNatural = [],-        onTime = [],-        onJson = [],-        onOptional = id,-        onList = id,-        onMap = id,-        onRef = pure-      }--emitMappedCodecs :: HaskellImportPlan -> Agg -> Text-emitMappedCodecs importPlan a = case aTypeGraph a of-  Nothing -> ""-  Just graph ->-    T.intercalate-      "\n\n"-      [ emitStructuralCodec importPlan a graph declaration shape-      | ResolvedStructural declaration shape <- codecMappedDeclarations a-      ]--emitStructuralCodec :: HaskellImportPlan -> Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text-emitStructuralCodec importPlan a graph declaration shape =-  nl-    [ "encode" <> name <> "Mapped :: " <> consumerType <> " -> Value",-      "encode" <> name <> "Mapped = encode" <> name <> "Shape . bindingToShape " <> binding,-      "",-      "parse" <> name <> "Mapped :: Value -> Parser " <> consumerType,-      "parse" <> name <> "Mapped value = bindingFromShape " <> binding <> " <$> parse" <> name <> "Shape value",-      "",-      "decode" <> name <> "Mapped :: Value -> Either Text " <> consumerType,-      "decode" <> name <> "Mapped = mapLeftText . parseEither parse" <> name <> "Mapped",-      "",-      "encode" <> name <> "Shape :: " <> shapeType <> " -> Value",-      emitShapeEncoder importPlan a graph declaration shape,-      "",-      "parse" <> name <> "Shape :: Value -> Parser " <> shapeType,-      emitShapeDecoder importPlan a graph declaration shape-    ]-  where-    name = sdName declaration-    consumerType = renderReferenceOrDie importPlan (haskellTypeReference (sdHaskell declaration))-    shapeType = renderReferenceOrDie importPlan (qualifiedTypeReference (structuralShapeModule (aContext a) name) (name <> "Shape"))-    binding = renderReferenceOrDie importPlan (qualifiedValueReference (sdBinding declaration))--emitShapeEncoder :: HaskellImportPlan -> Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text-emitShapeEncoder importPlan a graph declaration =-  foldMappedShape-    MappedShapeAlgebra-      { onRecord = \_ _ fields ->-          nl $-            ["encode" <> name <> "Shape shape =", "  object"]-              <> objectEntries-                [ tshow (rwfKey field)-                    <> " .= "-                    <> encodeShapeExpr a graph (rwfType field) (shapeValue (rwfHaskell field) <> " shape")-                | field <- fields-                ],-        onEnum = \entries ->-          nl $-            ["encode" <> name <> "Shape = \\case"]-              <> ["  " <> shapeConstructor (weCtor entry) <> " -> String " <> tshow (weTag entry) | entry <- entries],-        onUnion = \encoding arms ->-          nl $-            ["encode" <> name <> "Shape = \\case"]-              <> concatMap (unionEncodeArm encoding) arms-      }-  where-    name = sdName declaration-    shapeModuleName = structuralShapeModule (aContext a) name-    shapeConstructor constructor = renderReferenceOrDie importPlan (constructorReference shapeModuleName constructor)-    shapeValue value = renderReferenceOrDie importPlan (HaskellReference shapeModuleName value ValueNamespace RequireQualified)-    unionEncodeArm encoding arm =-      [ "  " <> shapeConstructor (rwaCtor arm) <> payloadPattern <> " ->",-        "    object"-      ]-        <> objectEntries-          ( [tshow (ueTagField encoding) <> " .= (" <> tshow (rwaTag arm) <> " :: Text)"]-              <> [ tshow (ueContentsField encoding) <> " .= " <> encodeShapeExpr a graph payload "payload"-                 | payload <- maybeToListText (rwaPayload arm)-                 ]-          )-      where-        payloadPattern = maybe "" (const " payload") (rwaPayload arm)--emitShapeDecoder :: HaskellImportPlan -> Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text-emitShapeDecoder importPlan a graph declaration =-  foldMappedShape-    MappedShapeAlgebra-      { onRecord = \constructor unknownFields fields ->-          nl $-            [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do"-            ]-              <> rejectLine "  " unknownFields (map rwfKey fields) "objectValue"-              <> [ "  " <> shapeConstructor constructor,-                   "    <$> " <> T.intercalate "\n    <*> " (map (decodeRecordField importPlan a graph) fields)-                 ],-        onEnum = \entries ->-          nl $-            [ "parse" <> name <> "Shape = withText " <> tshow (name <> "Shape") <> " $ \\tag -> case tag of"-            ]-              <> ["  " <> tshow (weTag entry) <> " -> pure " <> shapeConstructor (weCtor entry) | entry <- entries]-              <> ["  unknownTag -> " <> renderUnknownFailure (name <> " wire value") "unknownTag" (map weTag entries)],-        onUnion = \encoding arms ->-          nl $-            [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do",-              "  tag <- explicitParseField (withText " <> tshow (name <> " tag") <> " validate" <> name <> "Tag) objectValue " <> tshow (ueTagField encoding),-              "  case tag of"-            ]-              <> concatMap (unionDecodeArm encoding) arms-              <> [ "    _ -> fail \"validated union tag was not handled\"",-                   "",-                   "validate" <> name <> "Tag :: Text -> Parser Text",-                   "validate" <> name <> "Tag tag",-                   "  | tag `elem` " <> renderTextList (map rwaTag arms) <> " = pure tag",-                   "  | otherwise = " <> renderUnknownFailure (name <> " union tag") "tag" (map rwaTag arms)-                 ]-      }-  where-    name = sdName declaration-    shapeModuleName = structuralShapeModule (aContext a) name-    shapeConstructor constructor = renderReferenceOrDie importPlan (constructorReference shapeModuleName constructor)-    rejectLine _ IgnoreUnknown _ _ = []-    rejectLine indent RejectUnknown allowed objectName =-      [indent <> "rejectUnknownFields " <> tshow name <> " " <> renderTextList allowed <> " " <> objectName]-    unionDecodeArm encoding arm =-      ["    " <> tshow (rwaTag arm) <> " -> do"]-        <> rejectLine "      " (ueUnknownFields encoding) allowed "objectValue"-        <> [ case rwaPayload arm of-               Nothing -> "      pure " <> shapeConstructor (rwaCtor arm)-               Just payload ->-                 "      "-                   <> shapeConstructor (rwaCtor arm)-                   <> " <$> explicitParseField ("-                   <> decodeShapeExpr a graph payload-                   <> ") objectValue "-                   <> tshow (ueContentsField encoding)-           ]-      where-        allowed = ueTagField encoding : [ueContentsField encoding | rwaPayload arm /= Nothing]--decodeRecordField :: HaskellImportPlan -> Agg -> TypeGraph -> ResolvedWireField -> Text-decodeRecordField importPlan a graph field = case rwfPresence field of-  PRequired ->-    "explicitParseField (" <> decoder <> ") objectValue " <> key-  POptional ->-    "parseOptionalField ("-      <> missing-      <> ") ("-      <> decoder-      <> ") objectValue "-      <> key-  where-    key = tshow (rwfKey field)-    decoder = decodeShapeExpr a graph (rwfType field)-    missing = case rwfOnMissing field of-      Nothing -> "fail " <> tshow ("missing optional field without default: " <> rwfKey field)-      Just onMissing -> "pure " <> renderMissingDefault importPlan a graph (rwfType field) onMissing--encodeShapeExpr :: Agg -> TypeGraph -> ResolvedTypeExpr -> Text -> Text-encodeShapeExpr _a graph expression value =-  foldTypeExpr-    TypeExprAlgebra-      { onText = \v -> "toJSON (" <> v <> ")",-        onInt = \v -> "toJSON (" <> v <> ")",-        onInteger = \v -> "toJSON (" <> v <> ")",-        onBool = \v -> "toJSON (" <> v <> ")",-        onNatural = \v -> "toJSON (" <> v <> ")",-        onTime = \v -> "toJSON (" <> v <> ")",-        onJson = id,-        onOptional = \encode v -> "maybe Null (\\item -> " <> encode "item" <> ") (" <> v <> ")",-        onList = \encode v -> "toJSON (map (\\item -> " <> encode "item" <> ") (" <> v <> "))",-        onMap = \encode v -> "toJSON (Map.map (\\item -> " <> encode "item" <> ") (" <> v <> "))",-        onRef = \key v -> case Map.lookup key (tgDeclarations graph) of-          Just (ResolvedStructural nested _) -> "encode" <> sdName nested <> "Shape (" <> v <> ")"-          Just (ResolvedOpaque _) -> "toJSON (" <> v <> ")"-          Nothing -> "toJSON (" <> v <> ")"-      }-    expression-    value--decodeShapeExpr :: Agg -> TypeGraph -> ResolvedTypeExpr -> Text-decodeShapeExpr _a graph =-  foldTypeExpr-    TypeExprAlgebra-      { onText = "parseJSON",-        onInt = "parseJSON",-        onInteger = "parseJSON",-        onBool = "parseJSON",-        onNatural = "parseJSON",-        onTime = "parseJSON",-        onJson = "pure",-        onOptional = \decode -> "\\value -> case value of Null -> pure Nothing; other -> Just <$> " <> decode <> " other",-        onList = \decode -> "\\value -> (parseJSON value :: Parser [Value]) >>= traverse (" <> decode <> ")",-        onMap = \decode -> "\\value -> (parseJSON value :: Parser (Map Text Value)) >>= traverse (" <> decode <> ")",-        onRef = \key -> case Map.lookup key (tgDeclarations graph) of-          Just (ResolvedStructural nested _) -> "parse" <> sdName nested <> "Shape"-          Just (ResolvedOpaque _) -> "parseJSON"-          Nothing -> "parseJSON"-      }--renderMissingDefault :: HaskellImportPlan -> Agg -> TypeGraph -> ResolvedTypeExpr -> OnMissing -> Text-renderMissingDefault importPlan a graph expression = \case-  OmNull -> "Nothing"-  OmText value -> tshow value-  OmInt value -> T.pack (show value)-  OmBool value -> if value then "True" else "False"-  OmEmptyList -> "[]"-  OmEmptyMap -> "Map.empty"-  OmCtor constructor -> case expression of-    RRef key -> case Map.lookup key (tgDeclarations graph) of-      Just (ResolvedStructural declaration _) -> renderReferenceOrDie importPlan (constructorReference (structuralShapeModule (aContext a) (sdName declaration)) constructor)-      _ -> constructor-    _ -> constructor--objectEntries :: [Text] -> [Text]-objectEntries entries =-  [lead index <> entry | (index, entry) <- zip [(0 :: Int) ..] entries]-    <> ["      ]"]-  where-    lead 0 = "      [ "-    lead _ = "      , "--renderTextList :: [Text] -> Text-renderTextList values = "[" <> T.intercalate ", " (map tshow values) <> "]"---- | Emit a parser failure that names the rejected runtime value and the full,--- deterministic wire set accepted at that point.-renderUnknownFailure :: Text -> Text -> [Text] -> Text-renderUnknownFailure label variable expected =-  "fail ("-    <> tshow ("unknown " <> label <> " ")-    <> " <> show "-    <> variable-    <> " <> "-    <> tshow ("; expected one of: " <> expectedText)-    <> ")"-  where-    expectedText = case expected of-      [] -> "<none>"-      values -> T.intercalate ", " values--renderUnknownEventTypeFailure :: Agg -> Text -> Text-renderUnknownEventTypeFailure aggregate variable =-  "fail ("-    <> tshow "unknown event type "-    <> " <> show "-    <> variable-    <> " <> "-    <> tshow "; expected one of: "-    <> " <> renderExpectedEventTypes "-    <> eventTypesName aggregate-    <> ")"------------------------------------------------------------------------------------- Authoritative version-2 expressions and transducer-----------------------------------------------------------------------------------hasVersion2Ownership :: Agg -> Bool-hasVersion2Ownership = any ((/= LegacyHoleImplementation) . tImplementation) . aTransitions--transitionEntries :: Agg -> [(Int, Transition)]-transitionEntries aggregate =-  [ (layoutDeclarationIndex entry, layoutTransition entry)-  | entry <- transitionLayout (aTransitions aggregate)-  ]--transitionStem :: Int -> Transition -> Text-transitionStem index transition =-  "transition"-    <> tshow' index-    <> pascal (tSource transition)-    <> pascal (tCommand transition)--guardFunctionName :: Int -> Transition -> Text-guardFunctionName index transition = transitionStem index transition <> "Guard"--writeFunctionName :: Int -> Transition -> Name -> Text-writeFunctionName index transition registerName =-  transitionStem index transition <> "Write" <> pascal registerName--holeFunctionName :: Int -> Transition -> Text-holeFunctionName index transition = transitionStem index transition <> "Hole"--holeFoldVersionName :: Int -> Transition -> Text-holeFoldVersionName index transition = holeFunctionName index transition <> "FoldVersion"--outputFunctionName :: Int -> Transition -> Int -> Name -> Text-outputFunctionName transitionIndex transition emitIndex eventName =-  transitionStem transitionIndex transition-    <> "Output"-    <> tshow' emitIndex-    <> pascal eventName---- | Legacy create-once output-hook names made obsolete by authoritative--- version-2 @fields(Command)@ generation.  Scaffolding reports these names as--- safe-to-remove candidates without parsing or modifying consumer Haskell.-obsoleteGeneratedOutputHooks :: Spec -> [(Name, Text)]-obsoleteGeneratedOutputHooks spec =-  [ ( aggName aggregate,-      outputFunctionName transitionIndex transition emitIndex eventName-    )-  | aggregate <- [value | NAggregate value <- specNodes spec],-    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]-  ]--commandForTransition :: Agg -> Transition -> ResolvedCtor-commandForTransition aggregate transition =-  fromMaybe-    (error ("validated aggregate command disappeared: " <> T.unpack (tCommand transition)))-    (find ((== tCommand transition) . rcName) (aCommands aggregate))--eventForName :: Agg -> Name -> ResolvedCtor-eventForName aggregate eventName =-  fromMaybe-    (error ("validated aggregate event disappeared: " <> T.unpack eventName))-    (find ((== eventName) . rcName) (aEvents aggregate))--commandFieldsType :: Transition -> Text-commandFieldsType transition = "RegFieldsOf " <> tCommand transition <> "Data"--payloadProjectionType :: Agg -> Transition -> Text-payloadProjectionType aggregate transition =-  "B.PayloadProj "-    <> aName aggregate-    <> "Regs "-    <> aName aggregate-    <> "Command ("-    <> commandFieldsType transition-    <> ")"--data ResolvedGeneratedTransition = ResolvedGeneratedTransition-  { resolvedTransitionIndex :: !Int,-    resolvedTransitionSource :: !Transition,-    resolvedTransitionGuard :: !(Maybe TypedScalarExpr),-    resolvedTransitionWrites :: ![(Name, TypedScalarExpr)]-  }-  deriving stock (Eq, Show)---- Resolve each generated-owned transition exactly once. Import analysis,--- projection planning, and Haskell emission all consume this inventory.-resolvedGeneratedTransitions :: Agg -> [ResolvedGeneratedTransition]-resolvedGeneratedTransitions aggregate =-  [ ResolvedGeneratedTransition-      { resolvedTransitionIndex = index,-        resolvedTransitionSource = transition,-        resolvedTransitionGuard = resolvedGuard index transition <$> tGuard transition,-        resolvedTransitionWrites =-          [ (registerName, resolvedWrite index transition registerName expression)-          | (registerName, expression) <- tWrites transition-          ]-      }-  | (index, transition) <- transitionEntries aggregate,-    tImplementation transition == GeneratedImplementation-  ]-  where-    environment transition = expressionEnvironment (aSpec aggregate) (aAggregate aggregate) transition-    resolvedGuard index transition expression =-      expressionOrDie (guardFunctionName index transition) (resolveGuardExpr (environment transition) expression)-    resolvedWrite index transition registerName expression =-      expressionOrDie (writeFunctionName index transition registerName) (resolveWriteExpr (environment transition) registerName expression)--resolvedGeneratedExpressions :: Agg -> [TypedScalarExpr]-resolvedGeneratedExpressions = generatedTransitionExpressions . resolvedGeneratedTransitions--generatedTransitionExpressions :: [ResolvedGeneratedTransition] -> [TypedScalarExpr]-generatedTransitionExpressions = concatMap transitionExpressions-  where-    transitionExpressions resolved =-      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)--typedExpressionChildren :: TypedScalarExpr -> [TypedScalarExpr]-typedExpressionChildren expression = case typedScalarNode expression of-  TypedLiteral {} -> []-  TypedRoot {} -> []-  TypedProject {} -> []-  TypedAdd _ left right -> [left, right]-  TypedSubtract _ left right -> [left, right]-  TypedMultiply _ left right -> [left, right]-  TypedEqual left right -> [left, right]-  TypedNotEqual left right -> [left, right]-  TypedCompare _ left right -> [left, right]-  TypedAnd left right -> [left, right]-  TypedOr left right -> [left, right]--typedConsumerLiteralNominals :: TypedScalarExpr -> [ResolvedNominalType]-typedConsumerLiteralNominals expression = own <> concatMap typedConsumerLiteralNominals (typedExpressionChildren expression)-  where-    own = case (typedScalarType expression, typedScalarNode expression) of-      (AggregateNominal nominal, TypedLiteral ScalarEnumValue {})-        | ConsumerNominal {} <- resolvedNominalOwnership nominal -> [nominal]-      (AggregateNominal nominal, TypedLiteral ScalarIdValue {})-        | ConsumerNominal {} <- resolvedNominalOwnership nominal -> [nominal]-      _ -> []--typedGeneratedNominals :: TypedScalarExpr -> [ResolvedNominalType]-typedGeneratedNominals expression = own <> concatMap typedGeneratedNominals (typedExpressionChildren expression)-  where-    own = case typedScalarType expression of-      AggregateNominal nominal-        | GeneratedNominal <- resolvedNominalOwnership nominal -> [nominal]-      _ -> []--expressionOrDie :: Text -> Either (NonEmpty ExpressionDiagnostic) TypedScalarExpr -> TypedScalarExpr-expressionOrDie owner = either (error . (("validated expression disappeared for " <> T.unpack owner <> ": ") <>) . show) id--data ProjectionAliasTarget-  = StructuralProjectionAlias !ScalarRootProvenance !ResolvedScalarProjection-  | NominalProjectionAlias !ResolvedNominalType !ScalarRootProvenance-  deriving stock (Eq, Show)--data ProjectionAlias = ProjectionAlias-  { projectionAliasTarget :: !ProjectionAliasTarget,-    projectionAliasName :: !Text-  }-  deriving stock (Eq, Show)--projectionAliasesForTransition :: ResolvedGeneratedTransition -> [ProjectionAlias]-projectionAliasesForTransition resolved = allocateAliases targets-  where-    expressions =-      maybe [] pure (resolvedTransitionGuard resolved)-        <> map snd (resolvedTransitionWrites resolved)-    targets = nub (concatMap projectionAliasTargets expressions)--projectionAliasTargets :: TypedScalarExpr -> [ProjectionAliasTarget]-projectionAliasTargets expression = own <> comparisonTargets <> concatMap projectionAliasTargets children-  where-    children = typedExpressionChildren expression-    own = case typedScalarNode expression of-      TypedProject provenance projection -> [StructuralProjectionAlias provenance projection]-      _ -> []-    comparisonTargets = case typedScalarNode expression of-      TypedEqual left right -> mapMaybe nominalTarget [left, right]-      TypedNotEqual left right -> mapMaybe nominalTarget [left, right]-      _ -> []-    nominalTarget operand = case (typedScalarType operand, typedScalarNode operand) of-      (AggregateNominal nominal, TypedRoot provenance)-        | nominalComparisonProjection nominal -> Just (NominalProjectionAlias nominal provenance)-      _ -> Nothing--allocateAliases :: [ProjectionAliasTarget] -> [ProjectionAlias]-allocateAliases = snd . foldl allocate (Map.empty, [])-  where-    allocate (counts, aliases) target =-      let base = projectionAliasBase target-          occurrence = Map.findWithDefault 0 base counts + 1-          alias = if occurrence == 1 then base else base <> tshow' occurrence-       in (Map.insert base occurrence counts, aliases <> [ProjectionAlias target alias])--projectionAliasBase :: ProjectionAliasTarget -> Text-projectionAliasBase target = prefix <> pascal rootName <> pathSuffix-  where-    provenance = case target of-      StructuralProjectionAlias value _ -> value-      NominalProjectionAlias _ value -> value-    (prefix, rootName) = case provenance of-      ScalarRegisterRoot name _ -> ("register", name)-      ScalarCommandRoot name _ -> ("command", name)-    pathSuffix = case target of-      NominalProjectionAlias {} -> ""-      StructuralProjectionAlias _ projection ->-        T.concat-          [ normaliseAliasPart (unescapePointer segment)-          | segment <- filter (not . T.null) (T.splitOn "/" (scalarProjectionPointer projection))-          ]--normaliseAliasPart :: Text -> Text-normaliseAliasPart value = case filter (not . T.null) (T.split (not . isAlphaNum) value) of-  [] -> "Field"-  pieces -> T.concat (map pascal pieces)--unescapePointer :: Text -> Text-unescapePointer = T.replace "~0" "~" . T.replace "~1" "/"--projectionAliasFor :: [ProjectionAlias] -> ProjectionAliasTarget -> Text-projectionAliasFor aliases target =-  maybe-    (error ("resolved projection alias disappeared: " <> show target))-    projectionAliasName-    (find ((== target) . projectionAliasTarget) aliases)--data RenderAssociativity = RenderLeft | RenderRight | RenderNonAssociative-  deriving stock (Eq, Show)--data RenderOperandSide = RenderLeftOperand | RenderRightOperand-  deriving stock (Eq, Show)--data RenderedKeikiExpr = RenderedKeikiExpr-  { renderedKeikiText :: !Text,-    renderedKeikiPrecedence :: !Int-  }-  deriving stock (Eq, Show)--renderedAtom :: Text -> RenderedKeikiExpr-renderedAtom value = RenderedKeikiExpr value 10--renderedInfix :: Int -> RenderAssociativity -> Text -> RenderedKeikiExpr -> RenderedKeikiExpr -> RenderedKeikiExpr-renderedInfix precedence associativity operator left right =-  RenderedKeikiExpr-    ( renderInfixChild precedence associativity RenderLeftOperand left-        <> " "-        <> operator-        <> " "-        <> renderInfixChild precedence associativity RenderRightOperand right-    )-    precedence--renderInfixChild :: Int -> RenderAssociativity -> RenderOperandSide -> RenderedKeikiExpr -> Text-renderInfixChild parentPrecedence associativity side child-  | renderedKeikiPrecedence child > parentPrecedence = renderedKeikiText child-  | renderedKeikiPrecedence child < parentPrecedence = parenthesized-  | otherwise = case associativity of-      RenderLeft-        | side == RenderLeftOperand -> renderedKeikiText child-      RenderRight-        | side == RenderRightOperand -> renderedKeikiText child-      _ -> parenthesized-  where-    parenthesized = "(" <> renderedKeikiText child <> ")"--renderKeikiPredicate :: HaskellImportPlan -> [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> Text-renderKeikiPredicate importPlan aliases aggregate transition =-  renderedKeikiText . renderPredicate-  where-    renderPredicate expression = case typedScalarNode expression of-      TypedEqual left right -> comparison ".==" left right-      TypedNotEqual left right -> comparison "./=" left right-      TypedCompare operator left right -> comparison (renderComparisonOperator operator) left right-      TypedAnd left right -> boolean 3 RenderRight ".&&" left right-      TypedOr left right -> boolean 2 RenderRight ".||" left right-      _ ->-        renderedInfix-          4-          RenderNonAssociative-          ".=="-          (renderKeikiTerm importPlan aliases aggregate transition expression)-          (renderedAtom "K.lit True")-    comparison operator left right =-      renderedInfix-        4-        RenderNonAssociative-        operator-        (renderComparisonTerm importPlan aliases aggregate transition left)-        (renderComparisonTerm importPlan aliases aggregate transition right)-    boolean precedence associativity operator left right =-      renderedInfix precedence associativity operator (renderPredicate left) (renderPredicate right)--renderComparisonOperator :: CmpOp -> Text-renderComparisonOperator = \case-  OpEq -> ".=="-  OpNeq -> "./="-  OpLt -> ".<"-  OpLe -> ".<="-  OpGt -> ".>"-  OpGe -> ".>="--renderComparisonTerm :: HaskellImportPlan -> [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> RenderedKeikiExpr-renderComparisonTerm importPlan aliases aggregate transition expression = case (typedScalarType expression, typedScalarNode expression) of-  (AggregateNominal nominal, TypedRoot provenance)-    | nominalComparisonProjection nominal ->-        renderedAtom (projectionAliasFor aliases (NominalProjectionAlias nominal provenance))-  (AggregateNominal nominal, TypedLiteral (ScalarEnumValue _ constructor)) ->-    renderedAtom ("K.lit (" <> tshow (enumWireFor nominal constructor) <> " :: Text)")-  (AggregateNominal _, TypedLiteral (ScalarIdValue _ value)) ->-    renderedAtom ("K.lit (" <> tshow value <> " :: Text)")-  _ -> renderKeikiTerm importPlan aliases aggregate transition expression--nominalComparisonProjection :: ResolvedNominalType -> Bool-nominalComparisonProjection nominal = case resolvedNominalRepresentation nominal of-  IdRepresentation {} -> True-  EnumRepresentation {} -> True-  ScalarRepresentation {} -> case resolvedNominalOwnership nominal of-    ConsumerNominal {} -> True-    GeneratedNominal -> False--enumWireFor :: ResolvedNominalType -> Name -> Text-enumWireFor nominal constructor = case resolvedNominalRepresentation nominal of-  EnumRepresentation constructors -> fromMaybe (error "validated enum literal lost its wire spelling") (lookup constructor (NE.toList constructors))-  _ -> error "validated enum literal lost its enum representation"--renderNominalProjectionTerm :: HaskellImportPlan -> Agg -> Transition -> ResolvedNominalType -> ScalarRootProvenance -> Text-renderNominalProjectionTerm importPlan aggregate transition nominal provenance = case provenance of-  ScalarRegisterRoot registerName ownerType ->-    "K.regProj "-      <> projectionQualifier-      <> "."-      <> witness-      <> " (#"-      <> registerName-      <> " :: K.Index "-      <> aName aggregate-      <> "Regs "-      <> renderDomainType importPlan aggregate ownerType-      <> ")"-  ScalarCommandRoot fieldName ownerType ->-    "K.inpProj "-      <> projectionQualifier-      <> "."-      <> witness-      <> " inCtor"-      <> tCommand transition-      <> " (#"-      <> commandFieldSelector aggregate (tCommand transition) fieldName-      <> " :: K.Index ("-      <> commandFieldsType transition-      <> ") "-      <> renderDomainType importPlan aggregate ownerType-      <> ")"-  where-    projectionQualifier = case resolvedNominalOwnership nominal of-      GeneratedNominal -> "GeneratedNominals"-      ConsumerNominal {} -> "NominalProjections"-    witness = case resolvedNominalRepresentation nominal of-      ScalarRepresentation {} -> lowerFirst (resolvedNominalName nominal) <> "Witness"-      IdRepresentation {} -> nominalEqualityWitnessName nominal-      EnumRepresentation {} -> nominalEqualityWitnessName nominal--renderKeikiTerm :: HaskellImportPlan -> [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> RenderedKeikiExpr-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." <> commandFieldSelector aggregate (tCommand transition) fieldName)-  TypedProject provenance projection ->-    renderedAtom (projectionAliasFor aliases (StructuralProjectionAlias provenance projection))-  TypedAdd _ left right -> arithmetic 6 ".+" left right-  TypedSubtract _ left right -> arithmetic 6 ".-" left right-  TypedMultiply _ left right -> arithmetic 7 ".*" left right-  TypedEqual {} -> impossiblePredicate-  TypedNotEqual {} -> impossiblePredicate-  TypedCompare {} -> impossiblePredicate-  TypedAnd {} -> impossiblePredicate-  TypedOr {} -> impossiblePredicate-  where-    arithmetic precedence operator left right =-      renderedInfix-        precedence-        RenderLeft-        operator-        (renderKeikiTerm importPlan aliases aggregate transition left)-        (renderKeikiTerm importPlan aliases aggregate transition right)-    impossiblePredicate = error "predicate-valued Boolean expressions cannot be lowered as register terms"--renderStructuralProjectionTerm :: HaskellImportPlan -> Agg -> Transition -> ScalarRootProvenance -> ResolvedScalarProjection -> Text-renderStructuralProjectionTerm importPlan aggregate transition provenance projection = case provenance of-  ScalarRegisterRoot registerName ownerType ->-    "K.regProj StructuralProjections."-      <> witness-      <> " (#"-      <> registerName-      <> " :: K.Index "-      <> aName aggregate-      <> "Regs "-      <> renderDomainType importPlan aggregate ownerType-      <> ")"-  ScalarCommandRoot fieldName ownerType ->-    "K.inpProj StructuralProjections."-      <> witness-      <> " inCtor"-      <> tCommand transition-      <> " (#"-      <> commandFieldSelector aggregate (tCommand transition) fieldName-      <> " :: K.Index ("-      <> commandFieldsType transition-      <> ") "-      <> renderDomainType importPlan aggregate ownerType-      <> ")"-  where-    witness =-      fromMaybe-        (error ("resolved structural projection witness disappeared: " <> show projection))-        (aTypeGraph aggregate >>= \graph -> projectionWitnessName graph (scalarProjectionOwner projection) (scalarProjectionPointer projection))--renderKeikiLiteral :: HaskellImportPlan -> Agg -> ResolvedAggregateType -> ScalarValue -> Text-renderKeikiLiteral importPlan aggregate scalarType = \case-  ScalarTextValue value -> "K.lit (" <> tshow value <> " :: Text)"-  ScalarIntValue value -> "K.lit (" <> tshow' value <> " :: Int)"-  ScalarIntegerValue value -> "K.lit (" <> T.pack (show value) <> " :: Integer)"-  ScalarNaturalValue value -> "K.lit (" <> T.pack (show value) <> " :: Natural)"-  ScalarBoolValue value -> "K.lit " <> if value then "True" else "False"-  ScalarTimeValue value -> "K.lit " <> renderRegisterInitial (InitialTime value)-  ScalarEnumValue _typeName constructor -> case scalarType of-    AggregateNominal nominal -> case resolvedNominalOwnership nominal of-      GeneratedNominal -> "K.lit " <> constructor-      ConsumerNominal binding ->-        "K.lit (nominalFromRepresentation "-          <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding))-          <> " "-          <> renderReferenceOrDie importPlan (nominalRepresentationConstructorReference (aContext aggregate) nominal constructor)-          <> ")"-    _ -> error "validated enum literal lost its nominal type"-  ScalarIdValue typeName value -> case scalarType of-    AggregateNominal nominal -> case resolvedNominalOwnership nominal of-      GeneratedNominal -> case idDomainContractFor (aLanguageContract aggregate) =<< idPrefixOf nominal of-        Nothing -> "K.lit (" <> typeName <> " " <> tshow value <> ")"-        Just _ ->-          "K.lit (case parse"-            <> typeName-            <> " "-            <> tshow value-            <> " of Right parsed -> parsed; Left _ -> error \"validated ID literal failed to parse\")"-      ConsumerNominal binding -> case resolvedNominalRepresentation nominal of-        IdRepresentation prefix ->-          "K.lit (nominalFromRepresentation "-            <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding))-            <> " (case KindID.parseText @"-            <> tshow prefix-            <> " "-            <> tshow value-            <> " of Right parsed -> parsed; Left _ -> error \"validated ID literal failed to parse\"))"-        _ -> error "validated ID literal lost its ID representation"-    _ -> error "validated ID literal lost its nominal type"-  where-    idPrefixOf nominal = case resolvedNominalRepresentation nominal of-      IdRepresentation prefix -> Just prefix-      _ -> Nothing--generatedIdSampleHaskell :: Agg -> ResolvedNominalType -> Maybe Text-generatedIdSampleHaskell aggregate nominal = do-  prefix <- case resolvedNominalRepresentation nominal of-    IdRepresentation value -> Just value-    _ -> Nothing-  contract <- idDomainContractFor (aLanguageContract aggregate) prefix-  let name = resolvedNominalName nominal-      sample = idDomainSampleText contract-  pure-    ( "(case parse"-        <> name-        <> " "-        <> tshow sample-        <> " of Right parsed -> parsed; Left _ -> error \"generated valid ID sample failed to parse\")"-    )--emitGeneratedTransducer :: Agg -> Text-emitGeneratedTransducer aggregate =-  nl $-    renderGeneratedLanguagePragmas-      ( [ExtBlockArguments, ExtQualifiedDo]-          <> [ExtOverloadedLabels | not (null projectionAliases)]-          <> [ExtOverloadedRecordDot | transducerUsesRecordDot aggregate]-      )-      ++ [ generatedBanner,-           "module " <> aGenPrefix aggregate <> ".Transducer",-           "  ( " <> lowerFirst (aName aggregate) <> "Transducer",-           "  , " <> lowerFirst (aName aggregate) <> "FoldFingerprint",-           "  , BehaviorOwnership (..)",-           "  , " <> lowerFirst (aName aggregate) <> "PredicateVerifications",-           "  ) where",-           "",-           "import " <> aGenPrefix aggregate <> ".Domain",-           "import Data.Text (Text)"-         ]-      ++ ["import Data.Time.Calendar (fromGregorian)" | expressionUsesTimeLiteral]-      ++ ["import Data.Time.Clock (UTCTime (..), picosecondsToDiffTime)" | expressionUsesTimeLiteral]-      ++ ["import Numeric.Natural (Natural)" | expressionUsesNaturalLiteral]-      ++ generatedNominalTypeImportsWithParsers-        (aggregateCheckedService aggregate)-        (aContext aggregate)-        generatedExpressionNominals-        generatedLiteralNominals-      ++ structuralProjectionImport-      ++ generatedNominalProjectionImport-      ++ consumerNominalProjectionImport-      ++ consumerImports-      ++ ["import Data.KindID qualified as KindID" | expressionUsesConsumerIdLiteral]-      ++ ["import Keiro.Codec.Nominal (nominalFromRepresentation)" | expressionUsesConsumerNominalLiteral]-      ++ [ "import Keiki.Builder qualified as B",-           "import Keiki.Core (" <> T.intercalate ", " keikiCoreImports <> ")",-           "import Keiki.Core qualified as K",-           "import Keiki.Symbolic qualified as S"-         ]-      ++ ["import " <> aHolePrefix aggregate <> ".Holes qualified as Holes" | transducerUsesHoles aggregate]-      ++ ["import Data.Text qualified as T" | anyHoleOwned aggregate]-      ++ ["import Keiki.Builder ((=:))" | any (not . null . tWrites . snd) (transitionEntries aggregate)]-      ++ ["import Keiki.Generics (RegFieldsOf)" | not (null projectionAliases)]-      ++ ["import Keiro.Snapshot.Codec (FoldVersion (..))" | anyHoleOwned aggregate]-      ++ [ "",-           lowerFirst (aName aggregate) <> "Transducer",-           "  :: SymTransducer",-           "       (HsPred " <> aName aggregate <> "Regs " <> aName aggregate <> "Command)",-           "       " <> aName aggregate <> "Regs",-           "       " <> aVertexType aggregate,-           "       " <> aName aggregate <> "Command",-           "       " <> aName aggregate <> "Event",-           lowerFirst (aName aggregate) <> "Transducer =",-           "  B.buildTransducer " <> initialVertex aggregate <> " initial" <> aName aggregate <> "Regs isTerminal do",-           nl (concatMap (generatedFromBlock importPlan aggregate resolvedTransitions) (groupTransitionEntriesBySource aggregate)),-           " where",-           "  isTerminal = \\case",-           nl ["    " <> vertexCtor aggregate (stName state) <> " -> True" | state <- aStates aggregate, stTerminal state],-           "    _ -> False",-           "",-           lowerFirst (aName aggregate) <> "FoldFingerprint :: Text",-           lowerFirst (aName aggregate) <> "FoldFingerprint = " <> foldFingerprintExpression aggregate,-           "",-           "data BehaviorOwnership = GeneratedOwned | HoleOwned",-           "  deriving stock (Eq, Show)",-           "",-           "-- Every checked transition predicate is audited through Keiki's conservative",-           "-- symbolic verifier. Opaque Hole terms remain explicitly unverified.",-           lowerFirst (aName aggregate) <> "PredicateVerifications :: IO [(Text, BehaviorOwnership, S.PredicateVerification)]",-           lowerFirst (aName aggregate) <> "PredicateVerifications = sequence",-           nl (renderVerificationList aggregate),-           " where",-           "  verifyTransition label owner source edgeIndex =",-           "    case drop edgeIndex (K.edgesOut " <> lowerFirst (aName aggregate) <> "Transducer source) of",-           "      K.Edge predicate _ _ _ _ : _ -> (\\result -> (label, owner, result)) <$> S.verifyPredicate predicate",-           "      [] -> pure (label, owner, S.UnverifiedSolverFailure \"generated transition edge missing\")"-         ]-  where-    resolvedTransitions = resolvedGeneratedTransitions aggregate-    resolvedExpressions = generatedTransitionExpressions resolvedTransitions-    projectionAliases = concatMap projectionAliasesForTransition resolvedTransitions-    projectionTargets = map projectionAliasTarget projectionAliases-    structuralProjectionImport =-      [ "import " <> structuralProjectionModule (aContext aggregate) <> " qualified as StructuralProjections"-      | any isStructuralProjection projectionTargets-      ]-    generatedNominalProjectionImport =-      [ "import " <> generatedNominalModule (aContext aggregate) <> " qualified as GeneratedNominals"-      | any isGeneratedNominalProjection projectionTargets-      ]-    consumerNominalProjectionImport =-      [ "import " <> nominalProjectionModule (aContext aggregate) <> " qualified as NominalProjections"-      | any isConsumerNominalProjection projectionTargets-      ]-    consumerImports =-      T.lines (renderPlannedImports importPlan)-    expressionImportTypes =-      nub-        ( concatMap typedExpressionImportTypes (generatedTransitionGuards resolvedTransitions)-            <> concatMap typedExpressionLiteralTypes resolvedExpressions-        )-    consumerLiteralNominals = nub [nominal | expression <- resolvedExpressions, nominal <- typedConsumerLiteralNominals expression]-    importPlan = transducerImportPlan aggregate expressionImportTypes consumerLiteralNominals-    generatedExpressionNominals =-      stableNominals-        [ nominal-        | 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)-    expressionUsesConsumerIdLiteral = any (isIdRepresentation . resolvedNominalRepresentation) consumerLiteralNominals-    usedOperators = nub (concatMap generatedTransitionOperators resolvedTransitions)-    keikiCoreImports = ["HsPred", "SymTransducer"] <> ["(" <> operator <> ")" | operator <- expressionOperatorOrder, operator `elem` usedOperators]-    isTimeLiteral expression = case typedScalarNode expression of-      TypedLiteral ScalarTimeValue {} -> True-      _ -> False-    isNaturalLiteral expression = case typedScalarNode expression of-      TypedLiteral ScalarNaturalValue {} -> True-      _ -> False-    isIdRepresentation IdRepresentation {} = True-    isIdRepresentation _ = False--transducerUsesRecordDot :: Agg -> Bool-transducerUsesRecordDot aggregate =-  any expressionUsesCommandRoot (resolvedGeneratedExpressions aggregate)-    || any generatedOutputUsesCommandField generatedOutputs-  where-    generatedOutputs =-      [ outputMappingFor aggregate transitionIndex emitIndex-      | (transitionIndex, transition) <- transitionEntries aggregate,-        tImplementation transition == GeneratedImplementation,-        emitIndex <- [1 .. length (tEmits transition)]-      ]-    generatedOutputUsesCommandField (GeneratedCommandIdentity _ fields) = not (null fields)-    generatedOutputUsesCommandField HandOwnedEventOutput {} = False-    expressionUsesCommandRoot = anyTypedExpression isCommandRoot-    isCommandRoot expression = case typedScalarNode expression of-      TypedRoot ScalarCommandRoot {} -> True-      _ -> False--transducerImportPlan :: Agg -> [ResolvedAggregateType] -> [ResolvedNominalType] -> HaskellImportPlan-transducerImportPlan aggregate importedTypes literalNominals =-  planImportsOrDie-    (aGenPrefix aggregate <> ".Transducer")-    (Set.fromList [aName aggregate <> "Regs", aName aggregate <> "Command", aName aggregate <> "Event"])-    ( Set.unions-        [ aggregateSourceReferences (aggregateConsumerHaskellSource (aSymbols aggregate) resolvedType)-        | resolvedType <- importedTypes-        ]-        <> Set.fromList-          [ reference-          | nominal <- literalNominals,-            ConsumerNominal binding <- [resolvedNominalOwnership nominal],-            reference <--              qualifiedValueReference (consumerNominalBinding binding)-                : case resolvedNominalRepresentation nominal of-                  EnumRepresentation constructors ->-                    [ nominalRepresentationConstructorReference (aContext aggregate) nominal constructor-                    | (constructor, _) <- NE.toList constructors-                    ]-                  _ -> []-          ]-    )--typedExpressionImportTypes :: TypedScalarExpr -> [ResolvedAggregateType]-typedExpressionImportTypes expression = own <> concatMap typedExpressionImportTypes (typedExpressionChildren expression)-  where-    own = case typedScalarNode expression of-      TypedLiteral {} -> [typedScalarType expression]-      TypedRoot provenance -> [scalarRootType provenance]-      TypedProject provenance _ -> [scalarRootType provenance]-      _ -> []--scalarRootType :: ScalarRootProvenance -> ResolvedAggregateType-scalarRootType = \case-  ScalarRegisterRoot _ resolvedType -> resolvedType-  ScalarCommandRoot _ resolvedType -> resolvedType--isStructuralProjection :: ProjectionAliasTarget -> Bool-isStructuralProjection StructuralProjectionAlias {} = True-isStructuralProjection NominalProjectionAlias {} = False--isGeneratedNominalProjection :: ProjectionAliasTarget -> Bool-isGeneratedNominalProjection (NominalProjectionAlias nominal _) = resolvedNominalOwnership nominal == GeneratedNominal-isGeneratedNominalProjection StructuralProjectionAlias {} = False--isConsumerNominalProjection :: ProjectionAliasTarget -> Bool-isConsumerNominalProjection (NominalProjectionAlias nominal _) = case resolvedNominalOwnership nominal of-  ConsumerNominal {} -> True-  GeneratedNominal -> False-isConsumerNominalProjection StructuralProjectionAlias {} = False--expressionOperatorOrder :: [Text]-expressionOperatorOrder = [".*", ".+", ".-", ".==", "./=", ".<", ".<=", ".>", ".>=", ".&&", ".||"]--generatedTransitionOperators :: ResolvedGeneratedTransition -> [Text]-generatedTransitionOperators resolved =-  maybe [] predicateOperators (resolvedTransitionGuard resolved)-    <> concatMap (termOperators . snd) (resolvedTransitionWrites resolved)-  where-    predicateOperators expression = case typedScalarNode expression of-      TypedEqual left right -> ".==" : termOperators left <> termOperators right-      TypedNotEqual left right -> "./=" : termOperators left <> termOperators right-      TypedCompare operator left right -> renderComparisonOperator operator : termOperators left <> termOperators right-      TypedAnd left right -> ".&&" : predicateOperators left <> predicateOperators right-      TypedOr left right -> ".||" : predicateOperators left <> predicateOperators right-      _ -> ".==" : termOperators expression-    termOperators expression = case typedScalarNode expression of-      TypedAdd _ left right -> ".+" : termOperators left <> termOperators right-      TypedSubtract _ left right -> ".-" : termOperators left <> termOperators right-      TypedMultiply _ left right -> ".*" : termOperators left <> termOperators right-      _ -> concatMap termOperators (typedExpressionChildren expression)--anyHoleOwned :: Agg -> Bool-anyHoleOwned = any ((== HoleImplementation) . tImplementation) . aTransitions--transducerUsesHoles :: Agg -> Bool-transducerUsesHoles aggregate =-  anyHoleOwned aggregate-    || any isHandOwned (Map.elems (aOutputMappings aggregate))-  where-    isHandOwned HandOwnedEventOutput {} = True-    isHandOwned GeneratedCommandIdentity {} = False--renderVerificationList :: Agg -> [Text]-renderVerificationList aggregate =-  [ (if listIndex == (0 :: Int) then "  [ " else "  , ")-      <> "verifyTransition "-      <> tshow (transitionStem transitionIndex transition)-      <> " "-      <> ownership-      <> " "-      <> vertexCtor aggregate source-      <> " "-      <> tshow' edgeIndex-  | (listIndex, (source, edgeIndex, transitionIndex, transition)) <- zip [0 ..] entries,-    let ownership = case tImplementation transition of-          GeneratedImplementation -> "GeneratedOwned"-          HoleImplementation -> "HoleOwned"-          LegacyHoleImplementation -> error "legacy transition reached version-2 verification generation"-  ]-    <> ["  ]"]-  where-    entries =-      [ (source, edgeIndex, transitionIndex, transition)-      | (source, transitions) <- groupTransitionLayoutBySource (transitionLayout (aTransitions aggregate)),-        entry <- transitions,-        let edgeIndex = layoutOutgoingIndex entry-            transitionIndex = layoutDeclarationIndex entry-            transition = layoutTransition entry-      ]--foldFingerprintExpression :: Agg -> Text-foldFingerprintExpression aggregate = case holeVersions of-  [] -> tshow (aFoldFingerprint aggregate)-  _ ->-    "T.intercalate \"|\" ("-      <> tshow (aFoldFingerprint aggregate)-      <> " : [foldToken "-      <> T.intercalate ", foldToken " holeVersions-      <> "] ) where foldToken (FoldVersion token) = T.pack (show (T.length token)) <> \":\" <> token"-  where-    holeVersions =-      [ "Holes." <> holeFoldVersionName index transition-      | (index, transition) <- transitionEntries aggregate,-        tImplementation transition == HoleImplementation-      ]--groupTransitionEntriesBySource :: Agg -> [(Text, [(Int, Transition)])]-groupTransitionEntriesBySource aggregate =-  [ ( 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) =-  ["    B.from " <> vertexCtor aggregate source <> " do"]-    ++ concatMap (uncurry (generatedOnCmdBlock importPlan aggregate resolvedTransitions)) transitions--generatedOnCmdBlock :: HaskellImportPlan -> Agg -> [ResolvedGeneratedTransition] -> Int -> Transition -> [Text]-generatedOnCmdBlock importPlan aggregate resolvedTransitions index transition =-  ["      B.onCmd inCtor" <> tCommand transition <> " $ \\" <> payloadBinder <> " -> B.do"]-    ++ projectionBindingLines-    ++ ["        B.replayOnly" | tMode transition == TmReplayOnly]-    ++ generatedBehavior-    ++ outputLines-    ++ ["        B.noEmit" | null (tEmits transition)]-    ++ ["        B.goto " <> vertexCtor aggregate (tGoto transition)]-  where-    generatedBehavior = case tImplementation transition of-      GeneratedImplementation ->-        maybe [] (renderGuardLines importPlan aliases aggregate transition) (resolvedTransitionGuard resolved)-          ++ [ "        B.slot @" <> tshow registerName <> " =: " <> renderAssignmentOperand (renderKeikiTerm importPlan aliases aggregate transition expression)-             | (registerName, expression) <- resolvedTransitionWrites resolved-             ]-      HoleImplementation -> ["        Holes." <> holeFunctionName index transition <> " d"]-      LegacyHoleImplementation -> error "legacy transition reached version-2 transducer generation"-    resolved =-      fromMaybe-        (error ("resolved generated transition disappeared: " <> show index))-        (find ((== index) . resolvedTransitionIndex) resolvedTransitions)-    aliases-      | tImplementation transition == GeneratedImplementation = projectionAliasesForTransition resolved-      | otherwise = []-    projectionBindingLines = case aliases of-      [] -> []-      firstAlias : remainingAliases ->-        ["        let " <> renderProjectionAliasBinding importPlan aggregate transition firstAlias]-          <> ["            " <> renderProjectionAliasBinding importPlan aggregate transition alias | alias <- remainingAliases]-    outputLines =-      concat-        [ generatedOutputLines aggregate index transition emitIndex eventName-        | (emitIndex, eventName) <- zip [1 ..] (tEmits transition)-        ]-    payloadBinder-      | payloadIsUsed = "d"-      | otherwise = "_d"-    payloadIsUsed = case tImplementation transition of-      GeneratedImplementation ->-        isJust (resolvedTransitionGuard resolved)-          || not (null (resolvedTransitionWrites resolved))-          || any outputUsesPayload (zip [1 ..] (tEmits transition))-      HoleImplementation -> True-      LegacyHoleImplementation -> True-    outputUsesPayload (emitIndex, _) = case outputMappingFor aggregate index emitIndex of-      GeneratedCommandIdentity _ fields -> not (null fields)-      HandOwnedEventOutput {} -> True--renderProjectionAliasBinding :: HaskellImportPlan -> Agg -> Transition -> ProjectionAlias -> Text-renderProjectionAliasBinding importPlan aggregate transition alias =-  projectionAliasName alias <> " = " <> case projectionAliasTarget alias of-    StructuralProjectionAlias provenance projection -> renderStructuralProjectionTerm importPlan aggregate transition provenance projection-    NominalProjectionAlias nominal provenance -> renderNominalProjectionTerm importPlan aggregate transition nominal provenance--renderGuardLines :: HaskellImportPlan -> [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> [Text]-renderGuardLines importPlan aliases aggregate transition expression =-  ["        B.requireGuard $"]-    <> ["          " <> line | line <- T.lines readable]-  where-    readable =-      T.replace " .|| " "\n.|| "-        . T.replace " .&& " "\n.&& "-        $ renderKeikiPredicate importPlan aliases aggregate transition expression--renderAssignmentOperand :: RenderedKeikiExpr -> Text-renderAssignmentOperand expression-  | renderedKeikiPrecedence expression <= 6 = "(" <> renderedKeikiText expression <> ")"-  | otherwise = renderedKeikiText expression--generatedOutputLines :: Agg -> Int -> Transition -> Int -> Name -> [Text]-generatedOutputLines aggregate transitionIndex transition emitIndex eventName =-  case outputMappingFor aggregate transitionIndex emitIndex of-    GeneratedCommandIdentity sourceCommand fields -> case fields of-      [] -> ["        B.emit wire" <> eventName <> " B.oNil"]-      _ ->-        [ "        B.emit wire" <> eventName <> " (" <> eventName <> "TermFields"-        ]-          <> [ lead fieldIndex-                 <> resolvedSelector sourceCommand field-                 <> " = d."-                 <> resolvedSelector sourceCommand field-             | (fieldIndex, field) <- zip [0 :: Int ..] fields-             ]-          <> ["          })"]-    HandOwnedEventOutput {} ->-      [ "        B.emit wire"-          <> eventName-          <> " (Holes."-          <> outputFunctionName transitionIndex transition emitIndex eventName-          <> " d)"-      ]-  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-    (error ("missing checked event-output mapping for transition " <> show transitionIndex <> ", emit " <> show emitIndex))-    (Map.lookup (transitionIndex, emitIndex) (aOutputMappings aggregate))------------------------------------------------------------------------------------- EventStream module-----------------------------------------------------------------------------------emitEventStream :: Agg -> Text-emitEventStream a =-  nl $-    [ generatedBanner,-      "module " <> aGenPrefix a <> ".EventStream",-      "  ( " <> lowerFirst (aName a) <> "Category",-      "  , " <> lowerFirst (aName a) <> "CommandCategory",-      "  , " <> lowerFirst (aName a) <> "EventStream",-      "  , " <> lowerFirst (aName a) <> "EventStreamDef",-      "  , " <> aName a <> "EventStream",-      "  , " <> aName a <> "EventStreamDef"-    ]-      ++ ["  , " <> lowerFirst (aName a) <> "SnapshotFixture" | hasSnapshot a]-      ++ [ "  ) where",-           "",-           "import " <> aGenPrefix a <> ".Domain",-           "import " <> aGenPrefix a <> ".Codec (" <> lowerFirst (aName a) <> "Codec)",-           transducerImport a,-           "import Keiki.Core (HsPred)",-           "import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))",-           "import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)"-         ]-      ++ ["import Data.Text (Text)" | hasSnapshot a]-      ++ ["import Keiro.Snapshot.Codec (defaultStateCodec, withFoldFingerprint)" | hasSnapshot a]-      ++ [ "import Keiro.Stream qualified as Stream",-           "",-           "-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).",-           "-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.",-           "-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.",-           lowerFirst (aName a) <> "Category :: Stream.StreamCategory " <> aName a <> "EventStreamDef",-           lowerFirst (aName a) <> "Category = Stream.categoryUnsafe " <> tshow categoryName,-           "",-           "-- The same category text, typed for command envelopes such as PMCommand.",-           lowerFirst (aName a) <> "CommandCategory :: Stream.StreamCategory " <> aName a <> "Command",-           lowerFirst (aName a) <> "CommandCategory = Stream.categoryUnsafe " <> tshow categoryName,-           "",-           "type " <> aName a <> "EventStreamDef =",-           "  EventStream (HsPred " <> aName a <> "Regs " <> aName a <> "Command) " <> aName a <> "Regs " <> aVertexType a <> " " <> aName a <> "Command " <> aName a <> "Event",-           "",-           "type " <> aName a <> "EventStream =",-           "  ValidatedEventStream (HsPred " <> aName a <> "Regs " <> aName a <> "Command) " <> aName a <> "Regs " <> aVertexType a <> " " <> aName a <> "Command " <> aName a <> "Event",-           "",-           lowerFirst (aName a) <> "EventStreamDef :: " <> aName a <> "EventStreamDef",-           lowerFirst (aName a) <> "EventStreamDef =",-           "  EventStream",-           "    { transducer = " <> lowerFirst (aName a) <> "Transducer,",-           "      initialState = " <> initialVertex a <> ",",-           "      initialRegisters = initial" <> aName a <> "Regs,",-           "      eventCodec = " <> lowerFirst (aName a) <> "Codec,",-           "      resolveStreamName = Stream.streamName,",-           "      snapshotPolicy = " <> snapshotPolicyExpr a <> ","-         ]-      ++ stateCodecFieldLines a-      ++ [ "    }",-           ""-         ]-      ++ snapshotFixtureLines a-      ++ [ lowerFirst (aName a) <> "EventStream :: " <> aName a <> "EventStream",-           lowerFirst (aName a) <> "EventStream =",-           "  mkEventStreamOrThrow " <> tshow (aName a) <> " " <> lowerFirst (aName a) <> "EventStreamDef"-         ]-  where-    categoryName = staticCategory ("aggregate " <> aName a) (lowerFirst (aName a))--snapshotPolicyExpr :: Agg -> Text-snapshotPolicyExpr aggregate = case aSnapshot aggregate of-  Nothing -> "Never"-  Just snapshot -> case snapPolicy snapshot of-    SnapEvery interval -> "Every " <> tshow' interval-    SnapOnTerminal -> "OnTerminal"--stateCodecExpr :: Agg -> Text-stateCodecExpr aggregate = case aSnapshot aggregate of-  Nothing -> "Nothing"-  Just snapshot ->-    "Just (withFoldFingerprint "-      <> foldFingerprintValue aggregate-      <> " (defaultStateCodec "-      <> tshow' (snapCodecVersion snapshot)-      <> "))"--transducerImport :: Agg -> Text-transducerImport aggregate-  | hasVersion2Ownership aggregate =-      "import "-        <> aGenPrefix aggregate-        <> ".Transducer ("-        <> (if hasSnapshot aggregate then lowerFirst (aName aggregate) <> "FoldFingerprint, " else "")-        <> lowerFirst (aName aggregate)-        <> "Transducer)"-  | otherwise =-      "import "-        <> aHolePrefix aggregate-        <> ".Holes ("-        <> lowerFirst (aName aggregate)-        <> "Transducer)"--foldFingerprintValue :: Agg -> Text-foldFingerprintValue aggregate-  | hasVersion2Ownership aggregate = lowerFirst (aName aggregate) <> "FoldFingerprint"-  | otherwise = tshow (aFoldFingerprint aggregate)--stateCodecFieldLines :: Agg -> [Text]-stateCodecFieldLines aggregate = case aSnapshot aggregate of-  Nothing -> ["      stateCodec = Nothing"]-  Just _-    | hasVersion2Ownership aggregate ->-        [ "      -- The snapshot discriminator composes: the spec's state-codec version (bump it",-          "      -- in the spec's `state-codec version=` clause), keiki's register and",-          "      -- control-state shape hashes, and this fold fingerprint derived from the",-          "      -- spec's transition surface (guards, writes, emits, states, register",-          "      -- initials, referenced rules). Spec-visible fold changes invalidate old",-          "      -- snapshots automatically. Version-2 Hole-owned transitions additionally",-          "      -- compose their explicit hand-owned FoldVersion tokens here; bump the",-          "      -- corresponding token whenever that Hole behavior changes.",-          "      stateCodec = " <> stateCodecExpr aggregate-        ]-    | otherwise ->-        [ "      -- The snapshot discriminator composes: the spec's state-codec version (bump it",-          "      -- in the spec's `state-codec version=` clause), keiki's register and",-          "      -- control-state shape hashes, and this fold fingerprint derived from the",-          "      -- spec's transition surface (guards, writes, emits, states, register",-          "      -- initials, referenced rules). Spec-visible fold changes invalidate old",-          "      -- snapshots automatically. Fold changes made ONLY in the hand-owned Holes",-          "      -- module are invisible here: bump `state-codec version=` manually or old",-          "      -- snapshots will be served stale.",-          "      stateCodec = " <> stateCodecExpr aggregate-        ]--snapshotFixtureLines :: Agg -> [Text]-snapshotFixtureLines aggregate = case aSnapshot aggregate of-  Nothing -> []-  Just snapshot ->-    [ lowerFirst (aName aggregate) <> "SnapshotFixture :: (Int, Text)",-      lowerFirst (aName aggregate) <> "SnapshotFixture = (" <> tshow' (snapCodecVersion snapshot) <> ", " <> tshow (snapShapeHash snapshot) <> ")",-      ""-    ]------------------------------------------------------------------------------------- Projection module-----------------------------------------------------------------------------------emitProjection :: Agg -> Text-emitProjection a = case aProjection a of-  Nothing ->-    nl-      ( renderGeneratedLanguagePragmas []-          <> [ generatedBanner,-               "module " <> aGenPrefix a <> ".Projection () where",-               "",-               "-- No projection declarations are present; this module keeps the generated manifest inventory total."-             ]-      )-  Just p ->-    nl-      [ generatedBanner,-        "module " <> aGenPrefix a <> ".Projection",-        "  ( " <> lowerFirst (projTable p) <> "Projection",-        "  , " <> lowerFirst (projTable p) <> "StatusFor",-        "  ) where",-        "",-        "import " <> aGenPrefix a <> ".Domain",-        "import " <> aHolePrefix a <> ".Holes (apply" <> pascal (projTable p) <> ")",-        "import Data.Text (Text)",-        "import Keiro.Projection (InlineProjection (..))",-        "",-        "-- The deterministic event->status mapping (hole-kind 3, /mapping/), derived",-        "-- from the spec's status-map. The read-model SQL that consumes it lives in",-        "-- the hand-owned Holes module (a DB-coupled hole, delegated to codd).",-        projectionTableComment a p,-        lowerFirst (projTable p) <> "StatusFor :: " <> aName a <> "Event -> Maybe Text",-        lowerFirst (projTable p) <> "StatusFor = \\case",-        nl (statusArms a p),-        "",-        lowerFirst (projTable p) <> "Projection :: InlineProjection " <> aName a <> "Event",-        lowerFirst (projTable p) <> "Projection =",-        "  InlineProjection",-        "    { name = " <> tshow (contextNameToProjName a p),-        "    , apply = apply" <> pascal (projTable p),-        "    }"-      ]--statusArms :: Agg -> ProjectionSpec -> [Text]-statusArms a p =-  [ "  " <> rcName e <> " {} -> " <> statusFor e-  | e <- aEvents a-  ]-    ++ ["  _ -> Nothing" | hasWildcard]-  where-    pairs = maybe [] mapPairs (projStatusMap p)-    statusFor e = case lookup (rcName e) pairs of-      Just value -> "Just " <> tshow value-      Nothing -> "Nothing"-    -- A wildcard is only needed if some event is uncovered; otherwise every arm-    -- is explicit and a wildcard would be redundant (and -Wall would warn).-    hasWildcard = False--contextNameToProjName :: Agg -> ProjectionSpec -> Text-contextNameToProjName a p = contextKebab a <> "-" <> projTable p <> "-inline"--contextKebab :: Agg -> Text-contextKebab = kebabFromPascal . aCtxPascal--projectionReadModel :: Agg -> Maybe ReadModelNode-projectionReadModel aggregate = do-  projection <- aProjection aggregate-  find ((== projTable projection) . rmName) (aReadModels aggregate)--projectionTableComment :: Agg -> ProjectionSpec -> Text-projectionTableComment aggregate projection = case projectionReadModel aggregate of-  Nothing ->-    "-- WARNING: no readmodel node declares '"-      <> projTable projection-      <> "'; unqualified SQL depends on search_path."-  Just readModel ->-    "-- Qualified table "-      <> qualifiedTableLiteral readModel-      <> "; use "-      <> genPrefixFor (aContext aggregate) (pascal (rmName readModel))-      <> ".ReadModelTable."-      <> readModelStem readModel-      <> "QualifiedTable."------------------------------------------------------------------------------------- Holes module (create-if-absent)-----------------------------------------------------------------------------------emitHoles :: Agg -> Text-emitHoles aggregate-  | hasVersion2Ownership aggregate = emitVersion2Holes aggregate-  | otherwise = emitLegacyHoles aggregate--emitLegacyHoles :: Agg -> Text-emitLegacyHoles a =-  nl-    [ "{-# LANGUAGE BlockArguments #-}",-      "{-# LANGUAGE DataKinds #-}",-      "{-# LANGUAGE OverloadedRecordDot #-}",-      "{-# LANGUAGE QualifiedDo #-}",-      "{-# LANGUAGE TypeApplications #-}",-      "-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never",-      "-- overwrites it. Fill the transducer body (and any other holes) against the",-      "-- generated signatures, then run the harness to confirm behaviour.",-      "module " <> aHolePrefix a <> ".Holes",-      "  ( " <> lowerFirst (aName a) <> "Transducer",-      holeProjectionExport a,-      holeUpcasterExports a,-      "  ) where",-      "",-      "import " <> aGenPrefix a <> ".Domain",-      "import Keiki.Builder ((=:))",-      "import qualified Keiki.Builder as B",-      "import Keiki.Core (HsPred, RegFile, SymTransducer, lit, (.==), (./=), (.||))",-      holeUpcasterImports a,-      holeProjectionImports a,-      "",-      "-- HOLE: the transducer body. Reproduce the structure below, replacing each",-      "-- `-- HOLE` line with the keiki symbolic operators it describes.",-      lowerFirst (aName a) <> "Transducer",-      "  :: SymTransducer",-      "       (HsPred " <> aName a <> "Regs " <> aName a <> "Command)",-      "       " <> aName a <> "Regs",-      "       " <> aVertexType a,-      "       " <> aName a <> "Command",-      "       " <> aName a <> "Event",-      lowerFirst (aName a) <> "Transducer =",-      "  B.buildTransducer " <> initialVertex a <> " initial" <> aName a <> "Regs isTerminal do",-      nl (concatMap (fromBlock a) (groupBySource a)),-      " where",-      "  isTerminal = \\case",-      nl ["    " <> vertexCtor a (stName s) <> " -> True" | s <- aStates a, stTerminal s],-      "    _ -> False",-      holeProjectionStub a,-      holeUpcasterStubs a-    ]--emitVersion2Holes :: Agg -> Text-emitVersion2Holes aggregate =-  nl $-    [ "{-# LANGUAGE BlockArguments #-}",-      "{-# LANGUAGE DataKinds #-}",-      "{-# LANGUAGE DuplicateRecordFields #-}",-      "{-# LANGUAGE OverloadedRecordDot #-}",-      "{-# LANGUAGE QualifiedDo #-}",-      "{-# LANGUAGE TypeApplications #-}",-      "-- This is a HAND-OWNED version-2 hook module. keiro-dsl creates it once",-      "-- and never overwrites it. Generated code owns every transition envelope",-      "-- and every declared guard/write. This module supplies explicit event-field",-      "-- mappings and explicitly selected Hole behavior only; fields(Command)",-      "-- identity mappings are generated directly and have no hook."-    ]-      ++ version2HoleModuleDeclaration aggregate-      ++ [ "",-           "import " <> aGenPrefix aggregate <> ".Domain",-           "import Keiki.Builder qualified as B",-           "import Keiki.Generics (RegFieldsOf)",-           holeUpcasterImports aggregate,-           holeProjectionImports aggregate-         ]-      ++ ["import Keiki.Core qualified as K" | anyHoleOwned aggregate || anyZeroFieldOutput aggregate]-      ++ ["import Keiro.Snapshot.Codec (FoldVersion (..))" | anyHoleOwned aggregate]-      ++ concatMap (uncurry (emitOutputHooks aggregate)) (transitionEntries aggregate)-      ++ concatMap (uncurry (emitHoleImplementation aggregate)) (transitionEntries aggregate)-      ++ [holeProjectionStub aggregate, holeUpcasterStubs aggregate]--anyZeroFieldOutput :: Agg -> Bool-anyZeroFieldOutput aggregate =-  or-    [ isHandOwned (outputMappingFor aggregate transitionIndex emitIndex)-        && null (rcFields (eventForName aggregate eventName))-    | (transitionIndex, transition) <- transitionEntries aggregate,-      (emitIndex, eventName) <- zip [1 ..] (tEmits transition)-    ]-  where-    isHandOwned HandOwnedEventOutput {} = True-    isHandOwned GeneratedCommandIdentity {} = False--version2HoleModuleDeclaration :: Agg -> [Text]-version2HoleModuleDeclaration aggregate = case version2HoleExports aggregate of-  [] -> ["module " <> aHolePrefix aggregate <> ".Holes () where"]-  firstExport : rest ->-    [ "module " <> aHolePrefix aggregate <> ".Holes",-      "  ( " <> firstExport-    ]-      ++ ["  , " <> value | value <- rest]-      ++ ["  ) where"]--version2HoleExports :: Agg -> [Text]-version2HoleExports aggregate =-  outputExports-    <> holeExports-    <> projectionExports-    <> [functionName | (_, _, functionName) <- upcasterEntries aggregate]-  where-    outputExports =-      [ outputFunctionName transitionIndex transition emitIndex eventName-      | (transitionIndex, transition) <- transitionEntries aggregate,-        (emitIndex, eventName) <- zip [1 ..] (tEmits transition),-        HandOwnedEventOutput {} <- [outputMappingFor aggregate transitionIndex emitIndex]-      ]-    holeExports =-      concat-        [ [holeFunctionName index transition, holeFoldVersionName index transition]-        | (index, transition) <- transitionEntries aggregate,-          tImplementation transition == HoleImplementation-        ]-    projectionExports = case aProjection aggregate of-      Nothing -> []-      Just projection -> ["apply" <> pascal (projTable projection)]--emitOutputHooks :: Agg -> Int -> Transition -> [Text]-emitOutputHooks aggregate transitionIndex transition =-  concat-    [ emitOutputHook aggregate transitionIndex transition emitIndex (eventForName aggregate eventName)-    | (emitIndex, eventName) <- zip [1 ..] (tEmits transition),-      HandOwnedEventOutput {} <- [outputMappingFor aggregate transitionIndex emitIndex]-    ]--emitOutputHook :: Agg -> Int -> Transition -> Int -> ResolvedCtor -> [Text]-emitOutputHook aggregate transitionIndex transition emitIndex event =-  [ "",-    "-- Hand-owned event-field hook inside the generated transition envelope.",-    functionName-      <> " :: "-      <> payloadProjectionType aggregate transition-      <> " -> "-      <> outputType,-    functionName <> " d = " <> outputValue-  ]-  where-    functionName = outputFunctionName transitionIndex transition emitIndex (rcName event)-    inputFields = "(" <> commandFieldsType transition <> ")"-    outputType-      | null (rcFields event) =-          "K.OutFields "-            <> aName aggregate-            <> "Regs "-            <> aName aggregate-            <> "Command "-            <> inputFields-            <> " ()"-      | otherwise =-          rcName event-            <> "TermFields "-            <> aName aggregate-            <> "Regs "-            <> aName aggregate-            <> "Command "-            <> inputFields-    outputValue-      | null (rcFields event) = "B.oNil"-      | otherwise =-          rcName event-            <> "TermFields\n"-            <> nl-              ( valueRecord-                  [ (fieldSelector identity, outputFieldValue identity fieldType)-                  | (identity, fieldType) <- rcFields event-                  ]-              )-    command = commandForTransition aggregate transition-    outputFieldValue identity fieldType-      | Just (commandIdentity, commandType) <- find ((== fieldDslName identity) . fieldDslName . fst) (rcFields command),-        commandType == fieldType =-          "d." <> fieldSelector commandIdentity-      | Just register <- find ((== fieldDslName identity) . rrName) (aRegs aggregate),-        rrType register == fieldType =-          "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-      ]-        ++ ["  }"]-    lead 0 = "  { "-    lead _ = "  , "--emitHoleImplementation :: Agg -> Int -> Transition -> [Text]-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.",-        holeFoldVersionName index transition <> " :: FoldVersion",-        holeFoldVersionName index transition <> " = FoldVersion " <> tshow (transitionStem index transition <> "-fold-v1")-      ]---- | Export, import, and stub the per-event upcaster holes (EP-2 evolution).-holeUpcasterExports :: Agg -> Text-holeUpcasterExports a = case upcasterEntries a of-  [] -> ""-  es -> nl ["  , " <> fn | (_, _, fn) <- es]--holeUpcasterImports :: Agg -> Text-holeUpcasterImports a = case upcasterEntries a of-  [] -> ""-  _ -> nl ["import Data.Aeson (Value)", "import Data.Text (Text)"]--holeUpcasterStubs :: Agg -> Text-holeUpcasterStubs a = case upcasterEntries a of-  [] -> ""-  es ->-    nl $-      concat-        [ [ "",-            "-- HOLE upcaster: this hole receives ONLY " <> eventName <> " payloads stored at",-            "-- aggregate schema version " <> tshow' source <> "; other event kinds pass through the",-            "-- generated rung dispatch automatically. Bring this payload up one version and decide",-            "-- the default/derivation for any field added at the new version here.",-            fn <> " :: Value -> Either Text Value",-            fn <> " _ = Left \"HOLE: upcaster not implemented\""-          ]-        | (source, eventName, fn) <- es-        ]--holeProjectionExport :: Agg -> Text-holeProjectionExport a = case aProjection a of-  Nothing -> "  -- (no projection)"-  Just p -> "  , apply" <> pascal (projTable p)--holeProjectionImports :: Agg -> Text-holeProjectionImports aggregate = case projectionReadModel aggregate of-  Nothing -> ""-  Just readModel ->-    "import "-      <> genPrefixFor (aContext aggregate) (pascal (rmName readModel))-      <> ".ReadModelTable ("-      <> readModelStem readModel-      <> "QualifiedTable)"--holeProjectionStub :: Agg -> Text-holeProjectionStub a = case aProjection a of-  Nothing -> ""-  Just p ->-    nl-      ( [ "",-          "-- HOLE: the read-model SQL for the projection (a DB-coupled hole; the",-          "-- pure event->status mapping is generated as " <> lowerFirst (projTable p) <> "StatusFor)."-        ]-          ++ projectionGuidance-          ++ [ "apply" <> pascal (projTable p) <> " :: " <> aName a <> "Event -> recorded -> txn ()",-               "apply" <> pascal (projTable p) <> " _event _recorded = " <> projectionTableUse <> "error \"HOLE: fill " <> projTable p <> " projection apply\""-             ]-      )-    where-      projectionGuidance = case projectionReadModel a of-        Nothing ->-          ["-- WARNING: no readmodel node declares this table's schema; unqualified SQL depends on search_path."]-        Just readModel ->-          [ "-- Table: " <> qualifiedTableLiteral readModel <> ". Use " <> readModelStem readModel <> "QualifiedTable; never rely on search_path.",-            "-- Declared columns:"-          ]-            ++ map (("--   " <>) . readModelColumnDoc) (rmColumns readModel)-      projectionTableUse = case projectionReadModel a of-        Nothing -> ""-        Just readModel -> readModelStem readModel <> "QualifiedTable `seq` "---- Group transitions by source state, preserving order, for the B.from blocks.-groupBySource :: Agg -> [(Text, [Transition])]-groupBySource a =-  [ (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.)-transitionsOf :: Agg -> [Transition]-transitionsOf = aTransitions--fromBlock :: Agg -> (Text, [Transition]) -> [Text]-fromBlock a (src, ts) =-  [ "    B.from " <> vertexCtor a src <> " do"-  ]-    ++ concatMap (onCmdBlock a) ts--onCmdBlock :: Agg -> Transition -> [Text]-onCmdBlock a t =-  [ "      B.onCmd inCtor" <> tCommand t <> " $ \\d -> B.do"-  ]-    -- Plan 143: the mode is structural, not hole-owned — a replay-only-    -- transition lowers to B.replayOnly (keiki ReplayOnly edge).-    ++ ["        B.replayOnly" | tMode t == TmReplayOnly]-    ++ maybe [] (\g -> ["        -- HOLE guard: " <> renderGuard g]) (tGuard t)-    ++ ["        -- HOLE write " <> r <> " := " <> renderGuard e | (r, e) <- tWrites t]-    ++ ["        -- HOLE emit " <> ev <> " (B.emit wire" <> ev <> " ...)" | ev <- tEmits t]-    ++ ["        B.goto " <> vertexCtor a (tGoto t)]------------------------------------------------------------------------------------- Field categories and shared helpers-----------------------------------------------------------------------------------data FieldCat-  = IdCat-  | EnumCat-  | MappedStructuralCat !StructuralDecl !ResolvedMappedShape-  | MappedOpaqueCat !OpaqueDecl-  | OtherCat-  deriving stock (Eq, Show)--fieldCat :: Agg -> ResolvedAggregateType -> FieldCat-fieldCat a ty-  | AggregateNominal nominal <- ty,-    IdRepresentation {} <- resolvedNominalRepresentation nominal =-      IdCat-  | AggregateNominal nominal <- ty,-    EnumRepresentation {} <- resolvedNominalRepresentation nominal =-      EnumCat-  | Just (ResolvedStructural declaration shape) <- mappedDeclFor a ty = MappedStructuralCat declaration shape-  | Just (ResolvedOpaque declaration) <- mappedDeclFor a ty = MappedOpaqueCat declaration-  | otherwise = OtherCat---- | The first constructor of a declared enum, used to build sample values.-firstEnumCtor :: Agg -> Text -> Maybe Text-firstEnumCtor a ty =-  case [c | e <- aEnums a, enumName e == ty, (c, _) <- take 1 (enumCtors e)] of-    (c : _) -> Just c-    [] -> Nothing--vertexCtor :: Agg -> Text -> Text-vertexCtor a s = aName a <> s--initialVertex :: Agg -> Text-initialVertex a = case aStates a of-  (s : _) -> vertexCtor a (stName s)-  [] -> aName a <> "Init"--generatedBanner :: Text-generatedBanner = "-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec."---- | The provenance line written by a concrete scaffold plan. The package--- version comes from Cabal's build metadata, while the language and origin come--- from the checked semantic input and the emitted module respectively.-generatedBannerFor :: EffectiveLanguageContract -> Text -> Text-generatedBannerFor languageContract sourceOrigin =-  "-- @generated by keiro-dsl "-    <> T.pack (showVersion Package.version)-    <> " (language keiro-dsl "-    <> languageVersionText (effectiveContractLanguageVersion languageContract)-    <> ") from "-    <> stableBannerOrigin sourceOrigin-    <> "; do not edit."---- Source line numbers are useful refusal metadata but are not stable ownership:--- moving an unchanged node within or between workspace members must not rewrite--- every Generated file. The node kind and name remain the banner authority.-stableBannerOrigin :: Text -> Text-stableBannerOrigin sourceOrigin =-  case T.breakOnEnd " (line " withoutMemberPath of-    (prefixWithMarker, lineWithClose)-      | not (T.null prefixWithMarker),-        Just lineNumber <- T.stripSuffix ")" lineWithClose,-        not (T.null lineNumber),-        T.all isDigit lineNumber ->-          T.dropEnd (T.length " (line ") prefixWithMarker-    _ -> withoutMemberPath-  where-    withoutMemberPath = case T.breakOn ": " sourceOrigin of-      (memberPath, attributedOrigin)-        | ".keiro" `T.isSuffixOf` memberPath,-          not (T.null attributedOrigin) ->-            T.drop 2 attributedOrigin-      _ -> sourceOrigin---- | Recognize the exact historical banner or the frozen stamped format. This--- intentionally rejects arbitrary comments that merely start with--- @-- \@generated@.-isGeneratedBannerLine :: Text -> Bool-isGeneratedBannerLine line =-  line == generatedBanner-    || ( stampedPrefix `T.isPrefixOf` line-           && " (language keiro-dsl " `T.isInfixOf` line-           && ") from " `T.isInfixOf` line-           && "; do not edit." `T.isSuffixOf` line-       )-  where-    stampedPrefix = "-- @generated by keiro-dsl "---- | Replace an emitter's legacy placeholder (or an earlier stamp) with the--- provenance for this plan. A Generated module with a specialized banner gets--- the standard stamp prepended, so every planned Generated file is covered.-stampGeneratedModule :: EffectiveLanguageContract -> ScaffoldModule -> ScaffoldModule-stampGeneratedModule languageContract moduleValue-  | kind moduleValue == HoleStub = moduleValue-  | otherwise = moduleValue {moduleText = stampedText}-  where-    banner = generatedBannerFor languageContract (origin moduleValue)-    sourceLines = T.splitOn "\n" (moduleText moduleValue)-    stampedText = case replaceFirstGeneratedBanner banner sourceLines of-      Nothing -> banner <> "\n" <> moduleText moduleValue-      Just linesWithStamp -> T.intercalate "\n" linesWithStamp--stampGeneratedModules :: EffectiveLanguageContract -> [ScaffoldModule] -> [ScaffoldModule]-stampGeneratedModules languageContract = map (stampGeneratedModule languageContract)--replaceFirstGeneratedBanner :: Text -> [Text] -> Maybe [Text]-replaceFirstGeneratedBanner _ [] = Nothing-replaceFirstGeneratedBanner replacement (line : rest)-  | isGeneratedBannerLine line = Just (replacement : rest)-  | otherwise = (line :) <$> replaceFirstGeneratedBanner replacement rest--nodeOrigin :: Text -> Text -> Loc -> Text-nodeOrigin nodeKind nodeName loc =-  nodeKind <> " " <> nodeName <> case unLoc loc of-    0 -> ""-    line -> " (line " <> tshow' line <> ")"---- | Conditions that the deterministic emitters cannot lower faithfully. The--- pre-write scaffold pipeline treats each returned message as a refusal. The--- list is extended alongside the policy and type lowering milestones.-scaffoldRefusals :: Spec -> [Text]-scaffoldRefusals spec =-  concatMap aggregateRefusals aggregates-    <> concatMap contractRefusals contracts-    <> concatMap publisherRefusals publishers-  where-    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]-    contracts = [contract | NContract contract <- specNodes spec]-    publishers = [publisher | NPublisher publisher <- specNodes spec]-    symbols = aggregateSymbols spec+-- The load-bearing invariant of this module is the __firewall__: generated+-- aggregate @Transducer.hs@ owns transition terms, while an outcome-enabled+-- @EventStream.hs@ may evaluate its checked reason terms after exact-edge+-- selection. Hand-owned Hole modules remain the other intentional construction+-- boundary. A generated-text scan enforces these narrow exceptions.+--+-- Version-2 generated-owned transition bodies are rendered authoritatively in+-- that transducer. Explicit Hole-owned transitions keep only predicate/update+-- ownership; the generated command/event/target envelope remains authoritative.+-- Read-model SQL (the projection @apply@) is still a DB-coupled Hole delegated+-- to @codd@/the agent; the @Generated@ Projection module emits deterministic+-- @InlineProjection@ wiring and the pure event→status mapping. The decode emitted+-- here is /strict/ (every field required); lenient\/optional decode is EP-4's+-- concern.+module Keiro.Dsl.Scaffold+  ( ScaffoldModule (..),+    ModuleRole (..),+    moduleRole,+    ModuleKind (..),+    Context (..),+    Placement (..),+    defaultContext,+    genPrefixFor,+    contextGeneratedPrefix,+    holePrefixFor,+    generatedNominalModule,+    behaviorSourceMapModule,+    NominalUseSite (..),+    NominalGenerationOwner (..),+    planNominalGeneration,+    planNominalGenerationForService,+    generatedNominalsInTypes,+    generatedNominalTypeImports,+    generatedNominalTypeImportsForService,+    generatedIdSampleHaskell,+    scaffoldReplayAudit,+    scaffoldStructural,+    scaffoldStructuralForService,+    scaffoldStructuralOwners,+    scaffoldStructuralOwnersForService,+    codecComparisonModule,+    codecComparisonBanner,+    bindingSkeletonModules,+    bindingSkeletonOwners,+    scaffoldAggregateForService,+    scaffoldAggregate,+    obsoleteGeneratedOutputHooks,+    obsoleteGeneratedOutputHooksForService,+    scaffoldProcess,+    scaffoldRouter,+    scaffoldRouterForService,+    scaffoldContract,+    scaffoldContractForService,+    scaffoldIntake,+    scaffoldPublisher,+    scaffoldWorkqueue,+    scaffoldWorkqueueForService,+    scaffoldReadModel,+    scaffoldReadModelForService,+    resolveCatalogReadModel,+    scaffoldProjectionCatalog,+    scaffoldProjectionCatalogForService,+    scaffoldRefusals,+    scaffoldRefusalsForService,+    windowSeconds,++    -- * Firewall self-check (M3)+    FirewallSurface (..),+    firewallSurface,+    firewallBreaches,++    -- * Internal resolution, shared with "Keiro.Dsl.Harness"+    Agg (..),+    ResolvedDomainOutcomeTypes (..),+    aggregateCheckedService,+    ResolvedRegister (..),+    ResolvedCtor (..),+    StructuralProjection (..),+    resolveAggForService,+    resolveAgg,+    nominalEqualityUsedInGeneratedExpressions,+    projectionSpecs,+    resolveProjectionModules,+    nominalProjectionModule,+    codecMappedDeclarations,+    FieldCat (..),+    fieldCat,+    vertexCtor,+    initialVertex,+    firstEnumCtor,+    lowerFirst,+    pascal,+    pascalFromKebab,+    generatedBanner,+    generatedBannerFor,+    isGeneratedBannerLine,+    stampGeneratedModule,+    stampGeneratedModules,+  )+where++import Data.Char (isAlpha, isAlphaNum, isDigit, isUpper)+import Data.List (find, groupBy, isSuffixOf, nub, sort, sortOn)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe, maybeToList)+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.BehaviorSourceMap qualified as BehaviorSource+import Keiro.Dsl.CodecCompare (BranchArm (..), BranchField (..), BranchSchema (..))+import Keiro.Dsl.ConsumerTypePlan+import Keiro.Dsl.EventOutput+import Keiro.Dsl.ExplainBindings (BindingObligation (..), BindingObligationKind (..), bindingObligations, bindingObligationsForService)+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.MappedCodecPlan+import Keiro.Dsl.NominalType+import Keiro.Dsl.PrettyPrint (renderExpr)+import Keiro.Dsl.ProjectionMappedImpact (projectionAggregateSourceFingerprint, projectionAggregateSourceFingerprintForService)+import Keiro.Dsl.ProjectionSupply+import Keiro.Dsl.ReadModelShape (fnv1a64, registryNameFor, subscriptionNameFor)+import Keiro.Dsl.RouterSelection+import Keiro.Dsl.SemanticContract (CheckedService, EffectiveLanguageContract, checkedLanguageContract, checkedProjectionSupplies, checkedSpec, checkedTypeGraph, effectiveContractLanguageVersion, effectiveLanguageContract, legacyCheckedService)+import Keiro.Dsl.SourceIndex qualified as SourceIndex+import Keiro.Dsl.TypeGraph+import Keiro.Dsl.Validate (sagaCategoryError)+import Paths_keiro_dsl qualified as Package+import Text.Read (readMaybe)++-- | One emitted module: its on-disk path (relative to the scaffold @--out@+-- directory), its full text, and whether it is overwritten every run+-- ('Generated') or written only when absent ('HoleStub').+data ScaffoldModule = ScaffoldModule+  { modulePath :: !FilePath,+    moduleText :: !Text,+    kind :: !ModuleKind,+    origin :: !Text+  }+  deriving stock (Eq, Show)++-- | 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+  | -- | Hand-owned; created only when absent, never overwritten.+    HoleStub+  deriving stock (Eq, Show)++-- | The threading context: the spec's @context@ name, the chosen output+-- module-namespace root, and the placement style. Extended additively (never+-- re-shaped) by later verticals.+data Context = Context+  { contextName :: !Text,+    -- | @""@ means no namespace prefix (the historical default).+    moduleRoot :: !Text,+    -- | 'GeneratedPrefix' is the historical default.+    placement :: !Placement+  }+  deriving stock (Eq, Show)++-- | One aggregate-level reason a generated nominal declaration must be visible.+-- The declaration itself is context-owned; these use sites determine the+-- aggregate modules that import it.+data NominalUseSite = NominalUseSite+  { nominalUseAggregate :: !Name,+    nominalUseKind :: !AggregateUseSite+  }+  deriving stock (Eq, Ord, Show)++-- | The checked generation owner for one unbound ID or enum. Every owner in a+-- service points at the same context-level module, while retaining its source+-- location through 'ResolvedNominalType' and all aggregate use sites explicitly.+data NominalGenerationOwner = NominalGenerationOwner+  { nominalDeclaration :: !ResolvedNominalType,+    nominalModule :: !Text,+    nominalUseSites :: !(Set.Set NominalUseSite),+    nominalEqualityUsed :: !Bool+  }+  deriving stock (Eq, Show)++-- | A context with today's default placement ('GeneratedPrefix', no root prefix)+-- for the given @context@ name. Callers that do not care about placement (the+-- @parse@ path, tests) build their context with this.+defaultContext :: Text -> Context+defaultContext name = Context {contextName = name, moduleRoot = "", placement = GeneratedPrefix}++-- | The generated-layer namespace for a node, honouring the root prefix and the+-- placement style. The 'Text' argument is the already-pascalised node name (e.g.+-- @Reservation@, @HospitalSurge@). For 'GeneratedPrefix' this is+-- @\<root\>.Generated.\<Ctx\>.\<Node\>@ (identical to the historical layout); for+-- 'CollocatedLeaf' it is @\<root\>.\<Ctx\>.\<Node\>.Generated@.+genPrefixFor :: Context -> Text -> Text+genPrefixFor ctx node = case placement ctx of+  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> "." <> node+  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> "." <> node <> ".Generated"++-- | The generated-layer namespace shared by modules emitted once for a whole+-- service context, such as Nominals, ReplayAudit, and Conformance.+contextGeneratedPrefix :: Context -> Text+contextGeneratedPrefix ctx = case placement ctx of+  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx+  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated"++-- | The hand-owned (hole) namespace for a node: @\<root\>.\<Ctx\>.\<Node\>@ —+-- the same for both placement styles (holes always sit beside the domain).+holePrefixFor :: Context -> Text -> Text+holePrefixFor ctx node = rootPrefix ctx <> ctxPascalOf ctx <> "." <> node++-- | The one context-level Haskell owner for generated IDs and enums.+generatedNominalModule :: Context -> Text+generatedNominalModule ctx = contextGeneratedPrefix ctx <> ".Nominals"++-- | Emit the one context-owned table that contains every current behavior+-- source position. Services without behavior requirements emit no table and,+-- consequently, no aggregate behavior contract imports one.+behaviorSourceMapModule :: Context -> [BehaviorSource.BehaviorSourceEntry] -> Maybe ScaffoldModule+behaviorSourceMapModule _ [] = Nothing+behaviorSourceMapModule ctx entries =+  Just+    ScaffoldModule+      { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),+        moduleText =+          nl+            ( renderGeneratedLanguagePragmas []+                <> [ generatedBanner,+                     "module " <> moduleName,+                     "  ( BehaviorSourceLocation (..)",+                     "  , behaviorSourceLocation",+                     "  , renderBehaviorSourceLocation",+                     "  ) where",+                     "",+                     "import Data.Text (Text)",+                     "import Data.Text qualified as T",+                     "",+                     "data BehaviorSourceLocation = BehaviorSourceLocation",+                     "  { sourceFile :: !FilePath",+                     "  , sourceLine :: !Int",+                     "  , sourceColumn :: !Int",+                     "  }",+                     "  deriving stock (Eq, Ord, Show)",+                     "",+                     "behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation",+                     "behaviorSourceLocation key = case key of"+                   ]+                <> [ "  "+                       <> tshow (Behavior.unBehaviorKey (BehaviorSource.behaviorSourceKey entry))+                       <> " -> Just (BehaviorSourceLocation "+                       <> tshow (T.pack (BehaviorSource.behaviorSourceFile entry))+                       <> " "+                       <> tshow' (BehaviorSource.behaviorSourceLine entry)+                       <> " "+                       <> tshow' (BehaviorSource.behaviorSourceColumn entry)+                       <> ")"+                   | entry <- sortOn BehaviorSource.behaviorSourceKey entries+                   ]+                <> [ "  _ -> Nothing",+                     "",+                     "renderBehaviorSourceLocation :: Text -> Text",+                     "renderBehaviorSourceLocation key = case behaviorSourceLocation key of",+                     "  Just location -> T.pack (sourceFile location) <> \":\" <> tshow (sourceLine location) <> \":\" <> tshow (sourceColumn location)",+                     "  Nothing -> \"<internal invariant: missing behavior source for \" <> key <> \">\"",+                     "",+                     "tshow :: Show value => value -> Text",+                     "tshow = T.pack . show"+                   ]+            ),+        kind = Generated,+        origin = "context " <> contextName ctx <> " behavior source map"+      }+  where+    moduleName = contextGeneratedPrefix ctx <> ".BehaviorSourceMap"++-- | The root namespace prefix, dot-terminated, or @""@ when no root is set.+rootPrefix :: Context -> Text+rootPrefix ctx = case moduleRoot ctx of r | T.null r -> ""; r -> r <> "."++-- | The context name in PascalCase, e.g. @hospital-capacity@ -> @HospitalCapacity@.+ctxPascalOf :: Context -> Text+ctxPascalOf = pascalFromKebab . contextName++--------------------------------------------------------------------------------+-- Firewall self-check (M3)+--------------------------------------------------------------------------------++-- | The canonical keiki surface forbidden in generated modules. Symbolic+-- operators are matched as maximal Haskell symbol tokens, identifiers as complete+-- tokens, qualifiers by their leading module alias, and imports structurally.+data FirewallSurface = FirewallSurface+  { forbiddenSymbolic :: ![Text],+    forbiddenIdents :: ![Text],+    forbiddenQualifiers :: ![Text],+    forbiddenImports :: ![Text],+    restrictedImports :: ![(Text, [Text])]+  }+  deriving stock (Eq, Show)++firewallSurface :: FirewallSurface+firewallSurface =+  FirewallSurface+    { forbiddenSymbolic = [".==", "./=", ".<", ".<=", ".>", ".>=", ".&&", ".||", ".+", ".-", ".*", "=:", "*:"],+      forbiddenIdents = ["lit", "pnot", "tadd", "tsub", "tmul"],+      forbiddenQualifiers = ["B"],+      forbiddenImports = ["Keiki.Builder", "Keiki.Operators", "Keiki.Symbolic"],+      -- Generated aggregate modules use the first two names; generated+      -- harnesses validate, step, and replay filled holes register by register.+      restrictedImports =+        [ ( "Keiki.Core",+            [ "RegFile",+              "HsPred",+              "FieldProjection",+              "ExactFieldProjection",+              "FieldWitness",+              "fieldWitness",+              "exactFieldWitness",+              "fieldWitnessGet",+              "fieldWitnessAgrees",+              "applyEventsEither",+              "defaultValidationOptions",+              "step",+              "validateTransducer",+              "EdgeMode",+              "EdgeRef",+              "StepSuccess",+              "StepFailure",+              "ReplayEventSpan",+              "ReplayAttribution",+              "ReplaySuccess",+              "applyEventsDetailedEither",+              "stepDetailedEither",+              "!"+            ]+          )+        ]+    }++-- | Scan generated modules for firewall breaches, returning every offending+-- @(module path, token, 1-based line number)@. Only modules whose 'kind' is+-- 'Generated' are scanned. Strings and comments are skipped, symbol runs use+-- maximal munch, and keiki imports are checked independently of token spelling.+firewallBreaches :: [ScaffoldModule] -> [(FilePath, Text, Int)]+firewallBreaches mods =+  [ (modulePath m, breach, n)+  | m <- mods,+    kind m == Generated,+    not (authoritativeScalarModule m),+    (n, line) <- zip [1 ..] (T.lines (moduleText m)),+    breach <- lineBreaches line+  ]++-- The version-2 aggregate transducer and an outcome-enabled aggregate event+-- stream are the narrow, intentional exceptions to the generated+-- symbolic-operator firewall. The former owns transition terms; the latter+-- evaluates a checked reason term only after Keiki has selected an exact edge.+-- Ordinary event-stream modules remain scanned.+authoritativeScalarModule :: ScaffoldModule -> Bool+authoritativeScalarModule scaffoldModule =+  "/Transducer.hs" `isSuffixOf` path+    || ( "/EventStream.hs" `isSuffixOf` path+           && "DomainCommandHandler" `T.isInfixOf` moduleText scaffoldModule+       )+  where+    path = modulePath scaffoldModule++lineBreaches :: Text -> [Text]+lineBreaches line = case importModule line of+  Just _ -> importBreaches line+  Nothing -> tokenBreaches (codeTokens line)+  where+    tokenBreaches = mapMaybe breachFor+    breachFor (IdentToken ident)+      | ident `elem` forbiddenIdents firewallSurface = Just ident+    breachFor (QualifiedToken qualifier)+      | qualifier `elem` forbiddenQualifiers firewallSurface = Just (qualifier <> ".*")+    breachFor (SymbolToken symbol)+      | symbol `elem` forbiddenSymbolic firewallSurface = Just symbol+    breachFor _ = Nothing++data CodeToken = IdentToken !Text | QualifiedToken !Text | SymbolToken !Text++codeTokens :: Text -> [CodeToken]+codeTokens = go . T.unpack+  where+    go [] = []+    go ('-' : '-' : _) = []+    go ('"' : rest) = go (dropString rest)+    go ('\'' : rest) = go (dropChar rest)+    go (c : rest)+      | isIdentStart c =+          let (identTail, afterIdent) = span isIdentContinue rest+              ident = T.pack (c : identTail)+           in case afterIdent of+                '.' : next : more+                  | isUpper c && isIdentStart next ->+                      let (_member, afterMember) = span isIdentContinue more+                       in QualifiedToken ident : go afterMember+                _ -> IdentToken ident : go afterIdent+      | isSymbolChar c =+          let (symbolTail, afterSymbol) = span isSymbolChar rest+           in SymbolToken (T.pack (c : symbolTail)) : go afterSymbol+      | otherwise = go rest+    isIdentStart c = isAlpha c || c == '_'+    isIdentContinue c = isAlphaNum c || c == '_' || c == '\''+    isSymbolChar c = c `elem` ("!#$%&*+./<=>?@\\^|-~:" :: String)+    dropString [] = []+    dropString ('\\' : _escaped : rest) = dropString rest+    dropString ('"' : rest) = rest+    dropString (_ : rest) = dropString rest+    dropChar [] = []+    dropChar ('\\' : _escaped : rest) = dropChar rest+    dropChar ('\'' : rest) = rest+    dropChar (_ : rest) = dropChar rest++importBreaches :: Text -> [Text]+importBreaches line = case importModule line of+  Nothing -> []+  Just imported+    | imported `elem` forbiddenImports firewallSurface -> ["import:" <> imported]+    | Just allowed <- lookup imported (restrictedImports firewallSurface),+      not (hasAllowedExplicitImportList allowed line) ->+        ["import:" <> imported]+    | otherwise -> []++importModule :: Text -> Maybe Text+importModule line = case T.words (T.strip line) of+  "import" : rest -> find (T.isPrefixOf "Keiki.") rest+  _ -> Nothing++hasAllowedExplicitImportList :: [Text] -> Text -> Bool+hasAllowedExplicitImportList allowed line =+  case (T.breakOn "(" line, T.breakOnEnd ")" line) of+    ((_, open), (close, _))+      | not (T.null open) && not (T.null close) ->+          let inside = T.takeWhile (/= ')') (T.drop 1 open)+              names = filter (not . T.null) (T.split (not . isAlphaNum) inside)+           in all (`elem` allowed) names+    _ -> False++--------------------------------------------------------------------------------+-- Derived naming+--------------------------------------------------------------------------------++-- | Resolved, denormalized view of an aggregate used by every emitter.+data Agg = Agg+  { aContext :: !Context,+    aCheckedService :: !CheckedService,+    aLanguageContract :: !EffectiveLanguageContract,+    aSpec :: !Spec,+    aAggregate :: !Aggregate,+    aCtxPascal :: !Text,+    aName :: !Text,+    aLoc :: !Loc,+    aVertexType :: !Text,+    aIds :: ![IdDecl],+    aEnums :: ![EnumDecl],+    aRegs :: ![ResolvedRegister],+    aStates :: ![StateDecl],+    aCommands :: ![ResolvedCtor],+    aEvents :: ![ResolvedCtor],+    aDomainOutcomeTypes :: !(Maybe ResolvedDomainOutcomeTypes),+    -- | Generated IDs and enums used by this aggregate, in stable name order.+    aGeneratedNominals :: ![ResolvedNominalType],+    aTransitions :: ![Transition],+    aOutputMappings :: !(Map.Map (Int, Int) EventOutputMapping),+    aWire :: !WireSpec,+    aProjection :: !(Maybe ProjectionSpec),+    aSnapshot :: !(Maybe SnapshotSpec),+    aFoldFingerprint :: !Text,+    aReadModels :: ![ReadModelNode],+    aTypeGraph :: !(Maybe TypeGraph),+    aSymbols :: !AggregateSymbols,+    -- | e.g. @Generated.HospitalCapacity.Reservation@+    aGenPrefix :: !Text,+    -- | e.g. @HospitalCapacity.Reservation@+    aHolePrefix :: !Text+  }++data ResolvedDomainOutcomeTypes = ResolvedDomainOutcomeTypes+  { resolvedRejectionType :: !ResolvedAggregateType,+    resolvedNoOpType :: !ResolvedAggregateType+  }+  deriving stock (Eq, Show)++aggregateCheckedService :: Agg -> CheckedService+aggregateCheckedService = aCheckedService++data ResolvedRegister = ResolvedRegister+  { rrName :: !Name,+    rrType :: !ResolvedAggregateType,+    rrInitial :: !ResolvedRegisterInitial,+    rrLoc :: !Loc+  }+  deriving stock (Eq, Show)++-- | A command or event constructor with its fully-resolved field identities and+-- aggregate types.+data ResolvedCtor = ResolvedCtor+  { rcName :: !Text,+    -- | (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).+    rcUpcastFrom :: !(Maybe Int)+  }++defaultWire :: WireSpec+defaultWire = WireSpec {wireKind = "ctorName", wireFields = "camelCase", wireSchemaVersion = 1}++resolveAgg :: Context -> Spec -> Aggregate -> Agg+resolveAgg ctx spec = resolveAggForService ctx (legacyCheckedService spec)++-- | Resolve one aggregate under the service's effective runtime semantics.+resolveAggForService :: Context -> CheckedService -> Aggregate -> Agg+resolveAggForService ctx service agg =+  Agg+    { aContext = ctx,+      aCheckedService = service,+      aLanguageContract = checkedLanguageContract service,+      aSpec = spec,+      aAggregate = agg,+      aCtxPascal = ctxPascal,+      aName = nm,+      aLoc = aggLoc agg,+      aVertexType = vertexType,+      aIds = specIds spec,+      aEnums = specEnums spec,+      aRegs = map resolveRegister (aggRegs agg),+      aStates = aggStates agg,+      aCommands = map resolveCommand (aggCommands agg),+      aEvents = map resolveEvent (aggEvents agg),+      aDomainOutcomeTypes = resolvedDomainOutcomeTypes,+      aGeneratedNominals = generatedNominalsInTypes aggregateResolvedTypes,+      aTransitions = aggTransitions agg,+      aOutputMappings =+        Map.fromList+          [ ( (transitionIndex, emitIndex),+              orDieOutput (eventOutputMappingFromGraphResult typeGraphResult spec agg transition emitIndex eventName)+            )+          | (transitionIndex, transition) <- zip [1 ..] (aggTransitions agg),+            (emitIndex, eventName) <- zip [1 ..] (tEmits transition)+          ],+      aWire = fromMaybe defaultWire (aggWire agg),+      aProjection = aggProjection agg,+      aSnapshot = aggSnapshot agg,+      aFoldFingerprint = either (error . T.unpack . renderFoldSurfaceError) id (aggregateFoldFingerprintForService service agg),+      aReadModels = [readModel | NReadModel readModel <- specNodes spec],+      aTypeGraph = either (const Nothing) Just typeGraphResult,+      aSymbols = symbols,+      aGenPrefix = genPrefixFor ctx nm,+      aHolePrefix = holePrefixFor ctx nm+    }+  where+    spec = checkedSpec service+    nm = aggName agg+    typeGraphResult = checkedTypeGraph service+    symbols = aggregateSymbolsFromGraphResult typeGraphResult spec+    ctxPascal = pascalFromKebab (contextName ctx)+    vertexType = nm <> "Vertex"+    commandFieldTypes = [(cmdName c, cmdFields c) | c <- aggCommands agg]+    resolveCommand c = (mkCtor CommandFieldUse (cmdName c) (cmdFields c)) {rcVersion = 1, rcUpcastFrom = Nothing}+    resolveEvent e =+      (mkCtor EventFieldUse (evName e) (eventFields e))+        { rcVersion = evVersion e,+          rcUpcastFrom = fst <$> evUpcastFrom e+        }+      where+        eventFields ev = case evBody ev of+          EventFields fs -> fs+          EventFromCommand cn -> fromMaybe [] (lookup cn commandFieldTypes)+    mkCtor useSite cn fs =+      ResolvedCtor+        { rcName = cn,+          rcFields = map (\field -> (resolveAggregateFieldIdentity field, orDie (inferAggregateFieldType symbols agg useSite field))) fs,+          rcVersion = 1,+          rcUpcastFrom = Nothing+        }+    aggregateResolvedTypes =+      map rrType (map resolveRegister (aggRegs agg))+        <> map snd (concatMap rcFields (map resolveCommand (aggCommands agg)))+        <> map snd (concatMap rcFields (map resolveEvent (aggEvents agg)))+    resolvedDomainOutcomeTypes = case aggDomainOutcomeTypes agg of+      Nothing -> Nothing+      Just declaration ->+        Just+          ResolvedDomainOutcomeTypes+            { resolvedRejectionType = resolveOutcomeType declaration (rejectionType declaration),+              resolvedNoOpType = resolveOutcomeType declaration (noOpType declaration)+            }+    resolveOutcomeType declaration name =+      orDie (resolveAggregateType symbols (outcomeTypesLoc declaration) HaskellLoweringUse (TRef name))+    resolveRegister register =+      let resolvedType = orDie (resolveAggregateType symbols (regLoc register) RegisterUse (regType register))+          resolvedInitial = orDie (resolveRegisterInitial symbols (regLoc register) resolvedType (regInitial register))+       in ResolvedRegister+            { rrName = regName register,+              rrType = resolvedType,+              rrInitial = resolvedInitial,+              rrLoc = regLoc register+            }+    orDie = either (error . ("validated aggregate resolution failed: " <>) . show) id+    orDieOutput = either (error . ("validated aggregate output resolution failed: " <>) . show) id++-- | Keep only generated nominal IDs/enums from a resolved aggregate type list.+-- The map both deduplicates and makes declaration/import order independent of+-- member and field order.+generatedNominalsInTypes :: [ResolvedAggregateType] -> [ResolvedNominalType]+generatedNominalsInTypes resolvedTypes =+  Map.elems . Map.fromList $+    [ (resolvedNominalName nominal, nominal)+    | AggregateNominal nominal <- resolvedTypes,+      GeneratedNominal <- [resolvedNominalOwnership nominal]+    ]++-- | Plan declaration ownership and use closure without emitting text. Parsing+-- and validation already reject malformed declarations; retaining the checked+-- error here keeps this function total for direct library callers.+planNominalGeneration :: Context -> Spec -> Either (NonEmpty NominalTypeError) [NominalGenerationOwner]+planNominalGeneration ctx spec = planNominalGenerationForService ctx (legacyCheckedService spec)++planNominalGenerationForService :: Context -> CheckedService -> Either (NonEmpty NominalTypeError) [NominalGenerationOwner]+planNominalGenerationForService ctx service = do+  registry <- resolveNominalTypes spec+  let aggregates = [resolveAggForService ctx service aggregate | NAggregate aggregate <- specNodes spec]+      generated =+        [ nominal+        | nominal <- Map.elems (nominalTypes registry),+          GeneratedNominal <- [resolvedNominalOwnership nominal]+        ]+  pure+    [ NominalGenerationOwner+        { nominalDeclaration = nominal,+          nominalModule = generatedNominalModule ctx,+          nominalUseSites = Set.fromList (concatMap (usesFor nominal) aggregates),+          nominalEqualityUsed = any (nominalEqualityUsedInGeneratedExpressions nominal) aggregates+        }+    | nominal <- generated+    ]+  where+    spec = checkedSpec service+    usesFor nominal aggregate =+      [ NominalUseSite (aName aggregate) useKind+      | useKind <- aggregateUseKinds nominal aggregate+      ]++nominalEqualityUsedInGeneratedExpressions :: ResolvedNominalType -> Agg -> Bool+nominalEqualityUsedInGeneratedExpressions nominal aggregate =+  any+    (anyTypedExpression comparesNominal)+    (resolvedGeneratedExpressions aggregate <> resolvedOutcomeExpressions aggregate)+  where+    comparesNominal expression = case typedScalarNode expression of+      TypedEqual left _ -> typedScalarType left == AggregateNominal nominal+      TypedNotEqual left _ -> typedScalarType left == AggregateNominal nominal+      _ -> False++aggregateUseKinds :: ResolvedNominalType -> Agg -> [AggregateUseSite]+aggregateUseKinds nominal aggregate =+  nub $+    [RegisterUse | nominal `elem` registerNominals]+      <> [CommandFieldUse | nominal `elem` commandNominals]+      <> [EventFieldUse | nominal `elem` eventNominals]+      <> [CodecUse | nominal `elem` eventNominals]+      <> [SnapshotUse | hasSnapshot aggregate && nominal `elem` registerNominals]+      <> [HarnessSampleUse | nominal `elem` commandNominals || nominal `elem` eventNominals]+      <> [HaskellLoweringUse | nominal `elem` (aGeneratedNominals aggregate <> outcomeNominals)]+  where+    registerNominals = generatedNominalsInTypes (map rrType (aRegs aggregate))+    commandNominals = generatedNominalsInTypes (map snd (concatMap rcFields (aCommands aggregate)))+    eventNominals = generatedNominalsInTypes (map snd (concatMap rcFields (aEvents aggregate)))+    outcomeNominals =+      generatedNominalsInTypes+        [ resolvedType+        | outcomeTypes <- maybeToList (aDomainOutcomeTypes aggregate),+          resolvedType <- [resolvedRejectionType outcomeTypes, resolvedNoOpType outcomeTypes]+        ]++--------------------------------------------------------------------------------+-- Entry point+--------------------------------------------------------------------------------++-- | Emit the context-level private structural stratum. Shape modules contain+-- only generated wire representations. The projection facade contains only+-- schema-derived Keiki field witnesses; neither layer owns consumer behavior.+scaffoldStructural :: Context -> Spec -> [ScaffoldModule]+scaffoldStructural ctx spec = scaffoldStructuralForService ctx (legacyCheckedService spec)++scaffoldStructuralForService :: Context -> CheckedService -> [ScaffoldModule]+scaffoldStructuralForService ctx service = map fst (scaffoldStructuralOwnersForService ctx service)++-- | 'scaffoldStructural' paired with the mapped declarations each module was+-- emitted for. A shape module names exactly one declaration; a binding skeleton+-- names every declaration whose obligations it carries (several declarations may+-- share one leaf binding module); the projection facade names __none__, because it+-- is emitted once for the whole context from the complete resolved graph.+--+-- This is the attribution seam whole-workspace scaffolding needs: a workspace+-- emits from one merged spec, and this list says which declaration — and therefore+-- which member file — produced each structural module, without parsing the+-- human-readable 'origin' string.+scaffoldStructuralOwners :: Context -> Spec -> [(ScaffoldModule, [Name])]+scaffoldStructuralOwners ctx spec = scaffoldStructuralOwnersForService ctx (legacyCheckedService spec)++scaffoldStructuralOwnersForService :: Context -> CheckedService -> [(ScaffoldModule, [Name])]+scaffoldStructuralOwnersForService ctx service = case checkedTypeGraph service of+  Left _ -> []+  Right graph ->+    [(shapeModule ctx graph entry, [sdName (fst entry)]) | entry <- structural]+      <> projectionModules+      <> generatedNominalOwners ctx service+      <> nominalRepresentationOwners ctx spec+      <> nominalProjectionOwners ctx service+      <> bindingSkeletonOwnersForService ctx service graph+    where+      structural =+        [ (declaration, shape)+        | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph)+        ]+      projectionModules =+        [ ( ScaffoldModule+              { modulePath = T.unpack (T.replace "." "/" (structuralProjectionModule ctx) <> ".hs"),+                moduleText = emitStructuralProjections ctx graph,+                kind = Generated,+                origin = "context " <> specContext spec <> " mapped structural facade"+              },+            []+          )+        | not (null (projectionSpecs graph))+        ]+      spec = checkedSpec service++-- | Plan one opt-in, non-production historical-codec comparison module.+--+-- The module is intentionally absent from 'scaffoldStructural' and therefore+-- from production manifests and scaffold records. It must be requested by name+-- and is compiled only by consumer-owned test/tool components.+codecComparisonModule :: Context -> Spec -> Name -> Either Text ScaffoldModule+codecComparisonModule ctx spec requestedName = do+  graph <- either (Left . ("mapped type graph did not resolve: " <>) . T.pack . show) Right (resolveTypeGraph spec)+  (declaration, shape) <- case Map.lookup (MappedKey requestedName) (tgDeclarations graph) of+    Nothing -> Left ("codec comparison target is not a mapped declaration: " <> requestedName)+    Just (ResolvedOpaque _) ->+      Left+        ( "codec comparison target "+            <> requestedName+            <> " is opaque; finite evidence must never upgrade an opaque declaration to a structural claim"+        )+    Just (ResolvedStructural declaration shape) -> Right (declaration, shape)+  owner <- case sortOn aggName (comparisonOwners declaration) of+    [] ->+      Left+        ( "codec comparison target "+            <> requestedName+            <> " is not reachable from a persisted private event payload"+        )+    aggregate : _ -> Right aggregate+  let moduleName = structuralPrefix ctx <> ".CodecCompare." <> requestedName+  pure+    ScaffoldModule+      { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),+        moduleText = emitCodecComparison ctx moduleName graph declaration shape owner,+        kind = Generated,+        origin = "non-production codec comparison " <> requestedName+      }+  where+    comparisonOwners declaration =+      [ aggregate+      | NAggregate aggregate <- specNodes spec,+        let resolved = resolveAgg ctx spec aggregate,+        any ((== sdName declaration) . mappedName) (codecMappedDeclarations resolved)+      ]+      where+        mappedName (ResolvedStructural structural _) = sdName structural+        mappedName (ResolvedOpaque opaque) = odName opaque++codecComparisonBanner :: Text+codecComparisonBanner =+  "-- @generated by keiro-dsl codec comparison; non-production migration evidence; do not edit."++emitCodecComparison :: Context -> Text -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Aggregate -> Text+emitCodecComparison ctx moduleName graph declaration shape owner =+  nl+    [ "",+      codecComparisonBanner,+      "-- This module compares historical and generated codecs in consumer-owned tests only.",+      "-- It is never a runtime fallback and never changes the generated codec's authority.",+      "module " <> moduleName <> " (compareWithHistorical) where",+      "",+      "import Control.Monad (filterM)",+      "import Data.Aeson (Value)",+      "import Data.Aeson qualified as Aeson",+      "import Data.List (sort)",+      "import Data.List.NonEmpty qualified as NonEmpty",+      "import Data.Text (Text)",+      "import Data.Text qualified",+      "import " <> codecModule <> " qualified as GeneratedCodec",+      "import Keiro.Codec.Structural (FixtureCases (..))",+      "import Keiro.Dsl.CodecCompare",+      "import Keiro.Dsl.TypeGraph (BindingVersion (..), CanonicalTypeId (..), QualifiedValueName (..))",+      "import System.Directory (doesFileExist, listDirectory)",+      "import System.FilePath (takeExtension, (</>))",+      renderPlannedImports importPlan,+      "",+      "compareWithHistorical :: HistoricalCodec " <> domainType <> " -> FilePath -> IO CompareReport",+      "compareWithHistorical historicalCodec goldenDirectory = do",+      "  names <- sort . filter ((== \".json\") . takeExtension) <$> listDirectory goldenDirectory",+      "  files <- filterM doesFileExist [goldenDirectory </> name | name <- names]",+      "  loaded <- traverse (loadGolden historicalCodec) files",+      "  let inputIssues = [issue | Left issue <- loaded]",+      "      entries = [entry | Right entry <- loaded]",+      "      typedCases = NonEmpty.toList (fixtureCases " <> fixtureReference <> ")",+      "      encodeObservations =",+      "        [ EncodeObservation label (hcEncode historicalCodec value) (GeneratedCodec.encode" <> name <> "Mapped value)",+      "        | (label, value) <- typedCases",+      "        ]",+      "      decodeObservations = [observation | (observation, _) <- entries]",+      "      typedObserved =",+      "        concat",+      "          [ observedBranchesFor FromBinding branchSchema (GeneratedCodec.encode" <> name <> "Mapped value)",+      "          | (_, value) <- typedCases",+      "          ]",+      "      historicalObserved =",+      "        concat [observedBranchesFor HistoricalGolden branchSchema value | (_, values) <- entries, value <- values]",+      "      declared = declaredBranchesFor FromBinding branchSchema <> declaredBranchesFor HistoricalGolden branchSchema",+      "      provenance =",+      "        CompareProvenance",+      "          { cpHistoricalCodecIdentity = hcIdentity historicalCodec",+      "          , cpHistoricalCodecVersion = hcVersion historicalCodec",+      "          , cpCanonicalType = CanonicalTypeId " <> tshow (unCanonicalTypeId (sdCanonical declaration)),+      "          , cpBindingSymbol = QualifiedValueName " <> tshow (unQualifiedValueName (sdBinding declaration)),+      "          , cpBindingVersion = BindingVersion " <> tshow (unBindingVersion (sdBindingVersion declaration)),+      "          , cpWireFingerprint = " <> tshow (wireFingerprint graph name),+      "          }",+      "  pure (compareReport provenance inputIssues (encodeObservations <> decodeObservations) declared (typedObserved <> historicalObserved))",+      "",+      "loadGolden :: HistoricalCodec " <> domainType <> " -> FilePath -> IO (Either CompareInputIssue (CompareObservation, [Value]))",+      "loadGolden historicalCodec path = do",+      "  decoded <- Aeson.eitherDecodeFileStrict path",+      "  pure $ case decoded of",+      "    Left reason -> Left (HistoricalGoldenUnreadable path (fromString reason))",+      "    Right inputValue ->",+      "      let historicalDecoded = hcDecode historicalCodec inputValue",+      "          historicalOutcome = normalizeDecode historicalDecoded",+      "          generatedOutcome = normalizeDecode (GeneratedCodec.decode" <> name <> "Mapped inputValue)",+      "          observation = DecodeObservation path inputValue historicalOutcome generatedOutcome",+      "          coveredValues = case historicalDecoded of",+      "            Right value -> [inputValue, GeneratedCodec.encode" <> name <> "Mapped value]",+      "            Left _ -> []",+      "       in Right (observation, coveredValues)",+      "",+      "normalizeDecode :: Either Text " <> domainType <> " -> DecodeOutcome",+      "normalizeDecode = either DecodeFailed (DecodedShape . GeneratedCodec.encode" <> name <> "Mapped)",+      "",+      "fromString :: String -> Text",+      "fromString = Data.Text.pack",+      "",+      "branchSchema :: BranchSchema",+      "branchSchema = " <> renderBranchSchema (branchSchemaFor graph (ResolvedStructural declaration shape))+    ]+  where+    name = sdName declaration+    domainType = renderReferenceOrDie importPlan (haskellTypeReference (sdHaskell declaration))+    codecModule = genPrefixFor ctx (aggName owner) <> ".Codec"+    fixtureReference = renderReferenceOrDie importPlan (qualifiedValueReference (sdFixtures declaration))+    importPlan =+      planImportsOrDie+        moduleName+        Set.empty+        ( Set.fromList+            [ haskellTypeReference (sdHaskell declaration),+              qualifiedValueReference (sdFixtures declaration)+            ]+        )++branchSchemaFor :: TypeGraph -> ResolvedMappedDecl -> BranchSchema+branchSchemaFor graph =+  foldMappedDecl+    MappedDeclAlgebra+      { onStructuralDecl = \_ shape ->+          foldMappedShape+            MappedShapeAlgebra+              { onRecord = \_ _ fields ->+                  BranchRecord+                    [ BranchField+                        (rwfKey field)+                        (rwfPresence field == POptional)+                        (branchExpr graph (rwfType field))+                    | field <- fields+                    ],+                onEnum = const BranchScalar,+                onUnion = \encoding arms ->+                  BranchUnion+                    (ueTagField encoding)+                    (ueContentsField encoding)+                    [BranchArm (rwaTag arm) (branchExpr graph <$> rwaPayload arm) | arm <- arms]+              }+            shape,+        onOpaqueDecl = const BranchScalar+      }++branchExpr :: TypeGraph -> ResolvedTypeExpr -> BranchSchema+branchExpr graph =+  foldTypeExpr+    TypeExprAlgebra+      { onText = BranchScalar,+        onInt = BranchScalar,+        onInteger = BranchScalar,+        onBool = BranchScalar,+        onNatural = BranchScalar,+        onTime = BranchScalar,+        onJson = BranchScalar,+        onOptional = BranchOptional,+        onList = BranchList,+        onMap = BranchMap,+        onRef = \key -> maybe BranchScalar (branchSchemaFor graph) (Map.lookup key (tgDeclarations graph))+      }++renderBranchSchema :: BranchSchema -> Text+renderBranchSchema schema = case schema of+  BranchScalar -> "BranchScalar"+  BranchOptional nested -> "BranchOptional (" <> renderBranchSchema nested <> ")"+  BranchList nested -> "BranchList (" <> renderBranchSchema nested <> ")"+  BranchMap nested -> "BranchMap (" <> renderBranchSchema nested <> ")"+  BranchRecord fields ->+    "BranchRecord ["+      <> T.intercalate+        ", "+        [ "BranchField "+            <> tshow (bfWireKey field)+            <> " "+            <> (if bfPresenceOptional field then "True" else "False")+            <> " ("+            <> renderBranchSchema (bfSchema field)+            <> ")"+        | field <- fields+        ]+      <> "]"+  BranchUnion tagField contentsField arms ->+    "BranchUnion "+      <> tshow tagField+      <> " "+      <> tshow contentsField+      <> " ["+      <> T.intercalate+        ", "+        [ "BranchArm "+            <> tshow (baWireTag arm)+            <> " "+            <> maybe "Nothing" (\nested -> "(Just (" <> renderBranchSchema nested <> "))") (baPayloadSchema arm)+        | arm <- arms+        ]+      <> "]"++-- | Emit one create-once consumer module per distinct qualified obligation+-- owner. Multiple mapped declarations may intentionally share a leaf binding+-- module, so grouping happens by module rather than by declaration.+bindingSkeletonModules :: Context -> Spec -> TypeGraph -> [ScaffoldModule]+bindingSkeletonModules ctx spec graph = map fst (bindingSkeletonOwners ctx spec graph)++-- | 'bindingSkeletonModules' paired with the mapped declarations whose+-- obligations each skeleton carries, in first-appearance order. A skeleton shared+-- by declarations from different member files therefore names all of them, which+-- is what lets whole-workspace scaffolding treat it as context-level rather than+-- attributing it to an arbitrary member.+bindingSkeletonOwners :: Context -> Spec -> TypeGraph -> [(ScaffoldModule, [Name])]+bindingSkeletonOwners ctx spec graph = bindingSkeletonOwnersWithObligations ctx spec graph (bindingObligations spec)++bindingSkeletonOwnersForService :: Context -> CheckedService -> TypeGraph -> [(ScaffoldModule, [Name])]+bindingSkeletonOwnersForService ctx service graph =+  bindingSkeletonOwnersWithObligations ctx (checkedSpec service) graph (bindingObligationsForService service)++bindingSkeletonOwnersWithObligations :: Context -> Spec -> TypeGraph -> Either errors [BindingObligation] -> [(ScaffoldModule, [Name])]+bindingSkeletonOwnersWithObligations ctx spec graph obligationResult = case obligationResult of+  Left _ -> []+  Right obligations ->+    [ (emitBindingSkeleton ctx spec graph owner entries, nub (map obligationMappedName entries))+    | (owner, entries) <- Map.toAscList (Map.fromListWith (<>) [(obligationModule obligation, [obligation]) | obligation <- obligations])+    ]++emitBindingSkeleton :: Context -> Spec -> TypeGraph -> Text -> [BindingObligation] -> ScaffoldModule+emitBindingSkeleton ctx spec graph owner obligations =+  ScaffoldModule+    { modulePath = T.unpack (T.replace "." "/" owner <> ".hs"),+      moduleText =+        nl $+          [ "{-# LANGUAGE DataKinds #-}",+            "{-# LANGUAGE LambdaCase #-}",+            "",+            "-- This is a HAND-OWNED consumer binding skeleton. keiro-dsl creates it once",+            "-- and never overwrites it. Fill each HOLE and run the generated harness.",+            "module " <> owner <> " ("+          ]+            <> exportLines+            <> [") where", ""]+            <> importLines+            <> [""]+            <> intercalateBlank (map renderObligation obligations),+      kind = HoleStub,+      origin = "consumer binding skeleton " <> owner+    }+  where+    exportLines =+      [ (if index == (0 :: Int) then "    " else "  , ") <> obligationSymbol obligation+      | (index, obligation) <- zip [0 ..] obligations+      ]+    importPlan = bindingSkeletonImportPlan ctx spec graph owner obligations+    importLines =+      sort . nub $+        map ("import " <>) staticImports+          <> T.lines (renderPlannedImports importPlan)+    staticImports =+      sort . nub $+        [ "Keiro.Codec.Structural (FixtureCases, StructuralBinding (..))"+        | any (\obligation -> obligationCategory obligation == "structural" && obligationKind obligation `elem` [BindingValue, FixtureValue]) obligations+        ]+          <> [ "Keiro.Codec.Nominal (NominalBinding (..), NominalFixtureCases)"+             | any ((/= "structural") . obligationCategory) obligations+             ]+          <> [ "Data.KindID (KindID)"+             | obligation <- obligations,+               Just (nominal, _) <- [nominalFor obligation],+               IdRepresentation {} <- [resolvedNominalRepresentation nominal]+             ]+          <> [ "Data.Text (Text)"+             | obligation <- obligations,+               Just (nominal, _) <- [nominalFor obligation],+               ScalarRepresentation NominalText <- [resolvedNominalRepresentation nominal]+             ]+          <> [ "Data.Time (UTCTime)"+             | obligation <- obligations,+               Just (nominal, _) <- [nominalFor obligation],+               ScalarRepresentation NominalTime <- [resolvedNominalRepresentation nominal]+             ]+          <> [ "Numeric.Natural (Natural)"+             | obligation <- obligations,+               Just (nominal, _) <- [nominalFor obligation],+               ScalarRepresentation NominalNatural <- [resolvedNominalRepresentation nominal]+             ]+    renderObligation obligation = case structuralFor obligation of+      Nothing -> case nominalFor obligation of+        Just (nominal, binding) -> renderNominalObligation nominal binding obligation+        Nothing -> ["-- HOLE: declaration disappeared before skeleton rendering"]+      Just (declaration, shape) -> case obligationKind obligation of+        BindingValue -> renderBinding importPlan ctx declaration shape obligation+        FixtureValue ->+          [ "-- HOLE: provide deterministic labelled conformance fixtures for " <> sdName declaration,+            renderStructuralObligationSignature importPlan declaration obligation,+            obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> sdName declaration <> " fixtures")+          ]+        InitialValue ->+          [ "-- HOLE: provide the initial register value for " <> sdName declaration,+            renderStructuralObligationSignature importPlan declaration obligation,+            obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> sdName declaration <> " initial value")+          ]+    structuralFor obligation = case Map.lookup (MappedKey (obligationMappedName obligation)) (tgDeclarations graph) of+      Just (ResolvedStructural declaration shape) -> Just (declaration, shape)+      _ -> Nothing+    nominalFor obligation = do+      registry <- either (const Nothing) Just (resolveNominalTypes spec)+      nominal <- lookupNominalType (obligationMappedName obligation) registry+      binding <- case resolvedNominalOwnership nominal of+        ConsumerNominal value -> Just value+        GeneratedNominal -> Nothing+      pure (nominal, binding)+    renderNominalObligation nominal binding obligation = case obligationKind obligation of+      BindingValue ->+        [ "-- HOLE: complete both total directions; the generated codec remains wire authority.",+          renderNominalObligationSignature importPlan ctx nominal binding obligation,+          obligationSymbol obligation <> " =",+          "  NominalBinding",+          "    { nominalToRepresentation = \\_domainValue -> error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " nominalToRepresentation"),+          "    , nominalFromRepresentation = \\_representationValue -> error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " nominalFromRepresentation"),+          "    }"+        ]+      FixtureValue ->+        [ "-- HOLE: provide deterministic labelled expected-wire fixtures for " <> resolvedNominalName nominal,+          renderNominalObligationSignature importPlan ctx nominal binding obligation,+          obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " fixtures")+        ]+      InitialValue ->+        [ "-- HOLE: provide the initial register value for " <> resolvedNominalName nominal,+          renderNominalObligationSignature importPlan ctx nominal binding obligation,+          obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " initial value")+        ]+    intercalateBlank [] = []+    intercalateBlank (section : rest) = section <> concatMap ("" :) rest++renderBinding :: HaskellImportPlan -> Context -> StructuralDecl -> ResolvedMappedShape -> BindingObligation -> [Text]+renderBinding importPlan ctx declaration shape obligation =+  [ "-- HOLE: complete both total directions; wire policy remains in the generated codec.",+    obligationSymbol obligation <> " :: StructuralBinding " <> domainType <> " " <> shapeType,+    obligationSymbol obligation <> " =",+    "  StructuralBinding",+    "    { bindingToShape = \\case"+  ]+    <> indentCases (bindingCases True)+    <> ["    , bindingFromShape = \\case"]+    <> indentCases (bindingCases False)+    <> ["    }"]+  where+    domainType = renderReferenceOrDie importPlan (haskellTypeReference (sdHaskell declaration))+    shapeModuleName = structuralShapeModule ctx (sdName declaration)+    shapeType = renderReferenceOrDie importPlan (qualifiedTypeReference shapeModuleName (sdName declaration <> "Shape"))+    domainCtor constructor = renderReferenceOrDie importPlan (constructorReference (hsModule (sdHaskell declaration)) constructor)+    shapeCtor constructor = renderReferenceOrDie importPlan (constructorReference shapeModuleName constructor)+    indentCases = map ("      " <>)+    bindingCases toShapeDirection =+      foldMappedShape+        MappedShapeAlgebra+          { onRecord = \constructor _ fields -> [recordCase toShapeDirection constructor fields],+            onEnum = \entries -> map (enumCase toShapeDirection . weCtor) entries,+            onUnion = \_ arms -> map (unionCase toShapeDirection) arms+          }+        shape+    recordCase toShapeDirection constructor fields =+      sourceCtor+        <> arguments variables+        <> " -> "+        <> targetCtor+        <> arguments (map (holeFor toShapeDirection . rwfHaskell) fields)+      where+        variables = map (("_" <>) . (<> "Value") . rwfHaskell) fields+        sourceCtor = if toShapeDirection then domainCtor constructor else shapeCtor constructor+        targetCtor = if toShapeDirection then shapeCtor constructor else domainCtor constructor+    enumCase toShapeDirection constructor =+      sourceCtor <> " -> " <> holeFor toShapeDirection constructor+      where+        sourceCtor = if toShapeDirection then domainCtor constructor else shapeCtor constructor+    unionCase toShapeDirection arm =+      sourceCtor+        <> maybe "" (const " _payloadValue") (rwaPayload arm)+        <> " -> "+        <> case rwaPayload arm of+          Nothing -> holeFor toShapeDirection (rwaCtor arm)+          Just _ -> targetCtor <> " " <> holeFor toShapeDirection (rwaCtor arm <> ".payload")+      where+        sourceCtor = if toShapeDirection then domainCtor (rwaCtor arm) else shapeCtor (rwaCtor arm)+        targetCtor = if toShapeDirection then shapeCtor (rwaCtor arm) else domainCtor (rwaCtor arm)+    arguments [] = ""+    arguments values = " " <> T.unwords values+    holeFor toShapeDirection fieldName =+      "(error "+        <> tshow+          ( "HOLE: fill "+              <> sdName declaration+              <> (if toShapeDirection then " bindingToShape." else " bindingFromShape.")+              <> fieldName+          )+        <> ")"++bindingSkeletonImportPlan :: Context -> Spec -> TypeGraph -> Text -> [BindingObligation] -> HaskellImportPlan+bindingSkeletonImportPlan ctx spec graph owner obligations =+  planImportsOrDie owner (Set.fromList (map obligationSymbol obligations)) (Set.fromList (concatMap obligationReferences obligations))+  where+    obligationReferences obligation = case Map.lookup (MappedKey (obligationMappedName obligation)) (tgDeclarations graph) of+      Just (ResolvedStructural declaration shape) ->+        haskellTypeReference (sdHaskell declaration)+          : [ qualifiedTypeReference shapeModuleName (sdName declaration <> "Shape")+            | obligationKind obligation == BindingValue+            ]+            <> [ reference+               | obligationKind obligation == BindingValue,+                 constructor <- structuralConstructorNames shape,+                 reference <-+                   [ constructorReference (hsModule (sdHaskell declaration)) constructor,+                     constructorReference shapeModuleName constructor+                   ]+               ]+        where+          shapeModuleName = structuralShapeModule ctx (sdName declaration)+      _ -> case nominalForName (obligationMappedName obligation) of+        Just (nominal, binding) ->+          haskellTypeReference (consumerNominalHaskell binding)+            : [ qualifiedTypeReference+                  (nominalRepresentationModule ctx (resolvedNominalName nominal))+                  (resolvedNominalName nominal <> "Representation")+              | obligationKind obligation == BindingValue,+                EnumRepresentation {} <- [resolvedNominalRepresentation nominal]+              ]+        Nothing -> []+    nominalForName name = do+      registry <- either (const Nothing) Just (resolveNominalTypes spec)+      nominal <- lookupNominalType name registry+      binding <- case resolvedNominalOwnership nominal of+        ConsumerNominal value -> Just value+        GeneratedNominal -> Nothing+      pure (nominal, binding)++structuralConstructorNames :: ResolvedMappedShape -> [Text]+structuralConstructorNames =+  foldMappedShape+    MappedShapeAlgebra+      { onRecord = \constructor _ _ -> [constructor],+        onEnum = map weCtor,+        onUnion = \_ -> map rwaCtor+      }++structuralShapeReferences :: Context -> StructuralDecl -> ResolvedMappedShape -> [HaskellReference]+structuralShapeReferences ctx declaration shape =+  qualifiedTypeReference moduleName (sdName declaration <> "Shape")+    : [constructorReference moduleName constructor | constructor <- structuralConstructorNames shape]+      <> [ HaskellReference moduleName selector ValueNamespace RequireQualified+         | selector <- structuralSelectorNames shape+         ]+  where+    moduleName = structuralShapeModule ctx (sdName declaration)++structuralSelectorNames :: ResolvedMappedShape -> [Text]+structuralSelectorNames =+  foldMappedShape+    MappedShapeAlgebra+      { onRecord = \_ _ -> map rwfHaskell,+        onEnum = const [],+        onUnion = \_ _ -> []+      }++nominalRepresentationEncoderReference :: Context -> ResolvedNominalType -> HaskellReference+nominalRepresentationEncoderReference ctx nominal =+  HaskellReference+    (nominalRepresentationModule ctx name)+    (lowerFirst name <> "RepresentationText")+    ValueNamespace+    RequireQualified+  where+    name = resolvedNominalName nominal++nominalRepresentationConstructorReference :: Context -> ResolvedNominalType -> Text -> HaskellReference+nominalRepresentationConstructorReference ctx nominal constructor =+  HaskellReference+    (nominalRepresentationModule ctx (resolvedNominalName nominal))+    constructor+    ConstructorNamespace+    RequireQualified++renderStructuralObligationSignature :: HaskellImportPlan -> StructuralDecl -> BindingObligation -> Text+renderStructuralObligationSignature importPlan declaration obligation =+  obligationSymbol obligation+    <> " :: "+    <> case obligationKind obligation of+      BindingValue -> error "structural binding signatures are rendered with renderBinding"+      FixtureValue -> "FixtureCases " <> domainType+      InitialValue -> domainType+  where+    domainType = renderReferenceOrDie importPlan (haskellTypeReference (sdHaskell declaration))++renderNominalObligationSignature :: HaskellImportPlan -> Context -> ResolvedNominalType -> ConsumerNominalBinding -> BindingObligation -> Text+renderNominalObligationSignature importPlan ctx nominal binding obligation =+  obligationSymbol obligation+    <> " :: "+    <> case obligationKind obligation of+      BindingValue -> "NominalBinding " <> domainType <> " " <> representationType+      FixtureValue -> "NominalFixtureCases " <> domainType+      InitialValue -> domainType+  where+    domainType = renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding))+    representationType = case resolvedNominalRepresentation nominal of+      IdRepresentation prefix -> "(KindID " <> tshow prefix <> ")"+      EnumRepresentation {} ->+        renderReferenceOrDie+          importPlan+          ( qualifiedTypeReference+              (nominalRepresentationModule ctx (resolvedNominalName nominal))+              (resolvedNominalName nominal <> "Representation")+          )+      ScalarRepresentation NominalText -> "Text"+      ScalarRepresentation NominalInt -> "Int"+      ScalarRepresentation NominalNatural -> "Natural"+      ScalarRepresentation NominalBool -> "Bool"+      ScalarRepresentation NominalTime -> "UTCTime"++qualifiedTypeReference :: Text -> Text -> HaskellReference+qualifiedTypeReference moduleName typeName =+  HaskellReference moduleName typeName TypeNamespace RequireQualified++constructorReference :: Text -> Text -> HaskellReference+constructorReference moduleName constructor =+  HaskellReference moduleName constructor ConstructorNamespace RequireQualified++shapeModule :: Context -> TypeGraph -> (StructuralDecl, ResolvedMappedShape) -> ScaffoldModule+shapeModule ctx graph (declaration, shape) =+  ScaffoldModule+    { modulePath = T.unpack (T.replace "." "/" (structuralShapeModule ctx (sdName declaration)) <> ".hs"),+      moduleText = emitShape ctx graph declaration shape,+      kind = Generated,+      origin = nodeOrigin "mapped structural" (sdName declaration) (sdLoc declaration)+    }++structuralPrefix :: Context -> Text+structuralPrefix ctx = case placement ctx of+  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".Structural"+  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.Structural"++structuralShapeModule :: Context -> Name -> Text+structuralShapeModule ctx name = structuralPrefix ctx <> ".Shape." <> name++nominalRepresentationModule :: Context -> Name -> Text+nominalRepresentationModule ctx name = case placement ctx of+  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".Nominal.Shape." <> name+  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Nominal.Shape." <> name <> ".Generated"++-- | Emit the one generated nominal authority for the complete context. The+-- empty declaration attribution is intentional: in a workspace this module is+-- context-level even when all declarations currently happen to live in one+-- member, so moving that member cannot move Haskell type ownership.+generatedNominalOwners :: Context -> CheckedService -> [(ScaffoldModule, [Name])]+generatedNominalOwners ctx service = case planNominalGenerationForService ctx service of+  Left _ -> []+  Right [] -> []+  Right owners ->+    [ ( ScaffoldModule+          { modulePath = T.unpack (T.replace "." "/" (generatedNominalModule ctx) <> ".hs"),+            moduleText = emitGeneratedNominals languageContract ctx owners,+            kind = Generated,+            origin = "context " <> specContext spec <> " generated nominal declarations"+          },+        []+      )+    ]+      <> [ ( ScaffoldModule+               { modulePath = T.unpack (T.replace "." "/" (generatedNominalInternalModule ctx) <> ".hs"),+                 moduleText = emitGeneratedNominalInternals ctx enforcingIds,+                 kind = Generated,+                 origin = "context " <> specContext spec <> " generated nominal ID internals"+               },+             []+           )+         | not (null enforcingIds)+         ]+    where+      enforcingIds =+        [ (nominal, contract)+        | owner <- owners,+          let nominal = nominalDeclaration owner,+          IdRepresentation prefix <- [resolvedNominalRepresentation nominal],+          Just contract <- [idDomainContractFor languageContract prefix]+        ]+  where+    spec = checkedSpec service+    languageContract = checkedLanguageContract service++generatedNominalInternalModule :: Context -> Text+generatedNominalInternalModule ctx = generatedNominalModule ctx <> ".Internal"++emitGeneratedNominals :: EffectiveLanguageContract -> Context -> [NominalGenerationOwner] -> Text+emitGeneratedNominals languageContract ctx owners =+  nl+    ( renderGeneratedLanguagePragmas localExtensions+        <> [ generatedBanner,+             moduleHeader,+             ""+           ]+        <> baseImports+        <> internalImports+        <> equalityImports+        <> if T.null declarations then [] else ["", declarations]+    )+  where+    usesEquality = any nominalEqualityUsed 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,+        let nominal = nominalDeclaration owner,+        IdRepresentation prefix <- [resolvedNominalRepresentation nominal],+        Just _ <- [idDomainContractFor languageContract prefix]+      ]+    moduleHeader+      | null enforcingIds = "module " <> generatedNominalModule ctx <> " where"+      | otherwise =+          nl+            [ "module " <> generatedNominalModule ctx,+              "  ( " <> T.intercalate "\n  , " (concatMap ownerExports owners),+              "  ) where"+            ]+    ownerExports owner =+      baseExports <> equalityExports+      where+        nominal = nominalDeclaration owner+        name = resolvedNominalName nominal+        baseExports = case resolvedNominalRepresentation nominal of+          IdRepresentation prefix+            | Just _ <- idDomainContractFor languageContract prefix ->+                [name, "parse" <> name, "mk" <> name, nominalTextName nominal]+          _ -> [name <> " (..)", nominalTextName nominal]+        equalityExports =+          if nominalEqualityUsed owner+            then [nominalEqualityTagName nominal, nominalEqualityWitnessName nominal]+            else []+    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 (" <> 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+          <> " ("+          <> T.intercalate+            ", "+            (concatMap (\nominal -> [resolvedNominalName nominal, "mk" <> resolvedNominalName nominal, "parse" <> resolvedNominalName nominal, nominalTextName nominal]) enforcingIds)+          <> ")"+      | 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+      IdRepresentation prefix -> isJust (idDomainContractFor languageContract prefix)+      ScalarRepresentation {} -> False+    nominalUsesDeriveAnyClass nominal = case resolvedNominalRepresentation nominal of+      IdRepresentation prefix -> not (isJust (idDomainContractFor languageContract prefix))+      EnumRepresentation {} -> True+      ScalarRepresentation {} -> False++emitGeneratedNominal :: EffectiveLanguageContract -> Bool -> ResolvedNominalType -> Text+emitGeneratedNominal languageContract equalityUsed nominal = case resolvedNominalRepresentation nominal of+  IdRepresentation prefix+    | Just _ <- idDomainContractFor languageContract prefix ->+        nl equalitySection+  IdRepresentation {} ->+    nl $+      [ "newtype " <> name <> " = " <> name <> " Text",+        "  deriving stock (Generic, Eq, Ord, Show)",+        "  deriving anyclass (ToJSON, FromJSON)",+        "",+        "instance CanonicalTypeName " <> name,+        "",+        nominalTextName nominal <> " :: " <> name <> " -> Text",+        nominalTextName nominal <> " (" <> name <> " value) = value"+      ]+        <> equalitySection+  EnumRepresentation constructors ->+    nl $+      [ "data " <> name <> " = " <> T.intercalate " | " (map fst (NE.toList constructors)),+        "  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)",+        "  deriving anyclass (ToJSON, FromJSON)",+        "",+        "instance CanonicalTypeName " <> name,+        "",+        nominalTextName nominal <> " :: " <> name <> " -> Text",+        nominalTextName nominal <> " = \\case",+        nl ["  " <> constructor <> " -> " <> tshow wire | (constructor, wire) <- NE.toList constructors]+      ]+        <> equalitySection+  ScalarRepresentation {} ->+    error "generated nominal scalar reached generated declaration emission"+  where+    name = resolvedNominalName nominal+    equalitySection = if equalityUsed then ["", emitGeneratedNominalEquality languageContract nominal] else []++emitGeneratedNominalEquality :: EffectiveLanguageContract -> ResolvedNominalType -> Text+emitGeneratedNominalEquality languageContract nominal =+  nl $+    [ "data " <> tagName,+      "",+      "instance FieldProjection " <> tagName <> " where",+      "  type FieldName " <> tagName <> " = " <> tshow name,+      "  type FieldOwner " <> tagName <> " = " <> name,+      "  type FieldResult " <> tagName <> " = Text",+      "  fieldShapeId _ = " <> tshow equalityIdentity,+      "  projectFieldValue _ = " <> nominalTextName nominal+    ]+      <> exactInstance+      <> [ "",+           witnessName <> " :: FieldWitness " <> tagName,+           witnessName <> " = " <> witnessConstructor <> " @" <> tagName+         ]+  where+    name = resolvedNominalName nominal+    tagName = nominalEqualityTagName nominal+    witnessName = nominalEqualityWitnessName nominal+    equalityIdentity = fromMaybe (error "generated nominal equality contract missing") (nominalEqualityIdentityForService languageContract nominal)+    (exactInstance, witnessConstructor) = case resolvedNominalRepresentation nominal of+      IdRepresentation prefix -> case idDomainContractFor languageContract prefix of+        Nothing -> ([], "fieldWitness")+        Just _ ->+          ( [ "",+              patternName <> " :: TextPattern",+              patternName <> " = either (error . show) id (idDomainTextPattern (typeIdV7Domain " <> tshow prefix <> "))",+              "",+              "instance ExactFieldProjection " <> tagName <> " where",+              "  fieldProjectionDomain _ = textProjectionDomain " <> patternName,+              "  reconstructFieldOwner _ = either (const Nothing) Just . parse" <> name+            ],+            "exactFieldWitness"+          )+      EnumRepresentation constructors ->+        ( [ "",+            "instance ExactFieldProjection " <> tagName <> " where",+            "  fieldProjectionDomain _ = finiteProjectionDomain (" <> renderNonEmpty (map (tshow . snd) (NE.toList constructors)) <> ")",+            "  reconstructFieldOwner _ = \\case"+          ]+            <> ["    " <> tshow wire <> " -> Just " <> constructor | (constructor, wire) <- NE.toList constructors]+            <> ["    _ -> Nothing"],+          "exactFieldWitness"+        )+      ScalarRepresentation {} -> error "generated nominal scalar equality emission"+    patternName = lowerFirst name <> "IdDomainPattern"++emitGeneratedNominalInternals :: Context -> [(ResolvedNominalType, IdDomainContract)] -> Text+emitGeneratedNominalInternals ctx nominals =+  nl+    [ generatedBanner,+      "module " <> generatedNominalInternalModule ctx,+      "  ( " <> T.intercalate "\n  , " (concatMap exportsFor nominals),+      "  ) where",+      "",+      "import Data.Aeson (FromJSON (..), ToJSON (..), withText)",+      "import Data.Text (Text)",+      "import Data.Text qualified as T",+      "import GHC.Generics (Generic)",+      "import Keiki.Shape (CanonicalTypeName)",+      "import Keiro.Codec.IdDomain (typeIdV7Domain, validateIdDomainText)",+      "",+      sectionsOf [map emitInternal nominals]+    ]+  where+    exportsFor (nominal, _) =+      [ resolvedNominalName nominal,+        "parse" <> resolvedNominalName nominal,+        "mk" <> resolvedNominalName nominal,+        nominalTextName nominal,+        legacyNominalConstructorName nominal+      ]+    emitInternal (nominal, contract) =+      nl+        [ "newtype " <> name <> " = " <> name <> " Text",+          "  deriving stock (Generic, Eq, Ord, Show)",+          "",+          "instance CanonicalTypeName " <> name,+          "",+          "instance ToJSON " <> name <> " where",+          "  toJSON = toJSON . " <> textName,+          "",+          "instance FromJSON " <> name <> " where",+          "  parseJSON = withText " <> tshow name <> " (either (fail . T.unpack) pure . parse" <> name <> ")",+          "",+          "parse" <> name <> " :: Text -> Either Text " <> name,+          "parse" <> name <> " input = case validateIdDomainText (typeIdV7Domain " <> tshow (idDomainPrefix contract) <> ") input of",+          "  Left reason -> Left (T.pack (show reason))",+          "  Right () -> Right (" <> name <> " input)",+          "",+          "mk" <> name <> " :: Text -> Either Text " <> name,+          "mk" <> name <> " = parse" <> name,+          "",+          textName <> " :: " <> name <> " -> Text",+          textName <> " (" <> name <> " value) = value",+          "",+          legacyNominalConstructorName nominal <> " :: Text -> " <> name,+          legacyNominalConstructorName nominal <> " = " <> name+        ]+      where+        name = resolvedNominalName nominal+        textName = nominalTextName nominal++nominalEqualityTagName :: ResolvedNominalType -> Text+nominalEqualityTagName nominal = resolvedNominalName nominal <> "EqualityProjection"++nominalEqualityWitnessName :: ResolvedNominalType -> Text+nominalEqualityWitnessName nominal = lowerFirst (resolvedNominalName nominal) <> "EqualityWitness"++renderNonEmpty :: [Text] -> Text+renderNonEmpty values = case values of+  [] -> error "cannot render an empty exact projection domain"+  firstValue : rest -> firstValue <> " :| [" <> T.intercalate ", " rest <> "]"++nominalTextName :: ResolvedNominalType -> Text+nominalTextName = (<> "Text") . lowerFirst . resolvedNominalName++-- | Explicit type/constructor imports for exactly the generated declarations a+-- generated aggregate module uses. Keeping an import list avoids making every+-- aggregate depend on every service declaration merely because they share the+-- one owner module.+generatedNominalTypeImports :: Context -> [ResolvedNominalType] -> [Text]+generatedNominalTypeImports _ [] = []+generatedNominalTypeImports ctx nominals =+  [ "import "+      <> generatedNominalModule ctx+      <> " ("+      <> T.intercalate ", " [resolvedNominalName nominal <> " (..)" | nominal <- stableNominals nominals]+      <> ")"+  ]++generatedNominalTypeImportsForService :: CheckedService -> Context -> [ResolvedNominalType] -> [Text]+generatedNominalTypeImportsForService 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+      <> " ("+      <> T.intercalate ", " (concatMap importsFor (stableNominals nominals))+      <> ")"+  ]+  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 `elem` parsingNames]+      _ -> [resolvedNominalName nominal <> " (..)"]++generatedNominalCodecImports :: CheckedService -> Context -> [ResolvedNominalType] -> [Text]+generatedNominalCodecImports _ _ [] = []+generatedNominalCodecImports service ctx nominals =+  [ "import "+      <> generatedNominalModule ctx+      <> " ("+      <> T.intercalate+        ", "+        ( concat+            [ publicImports nominal+            | nominal <- stableNominals nominals+            ]+        )+      <> ")"+  ]+    <> [ "import "+           <> generatedNominalInternalModule ctx+           <> " ("+           <> T.intercalate ", " [legacyNominalConstructorName nominal | nominal <- enforcingIds]+           <> ")"+       | not (null enforcingIds)+       ]+  where+    publicImports nominal = case resolvedNominalRepresentation nominal of+      IdRepresentation prefix+        | Just _ <- idDomainContractFor (checkedLanguageContract service) prefix -> [nominalTextName nominal]+      _ -> [resolvedNominalName nominal <> " (..)", nominalTextName nominal]+    enforcingIds =+      [ nominal+      | nominal <- stableNominals nominals,+        IdRepresentation prefix <- [resolvedNominalRepresentation nominal],+        Just _ <- [idDomainContractFor (checkedLanguageContract service) prefix]+      ]++legacyNominalConstructorName :: ResolvedNominalType -> Text+legacyNominalConstructorName nominal = "unsafe" <> resolvedNominalName nominal <> "FromLegacyText"++stableNominals :: [ResolvedNominalType] -> [ResolvedNominalType]+stableNominals = Map.elems . Map.fromList . map (\nominal -> (resolvedNominalName nominal, nominal))++nominalRepresentationOwners :: Context -> Spec -> [(ScaffoldModule, [Name])]+nominalRepresentationOwners ctx spec = case resolveNominalTypes spec of+  Left _ -> []+  Right registry ->+    [ (nominalRepresentationModuleValue ctx nominal constructors, [resolvedNominalName nominal])+    | nominal <- Map.elems (nominalTypes registry),+      ConsumerNominal {} <- [resolvedNominalOwnership nominal],+      EnumRepresentation constructors <- [resolvedNominalRepresentation nominal]+    ]++nominalRepresentationModuleValue :: Context -> ResolvedNominalType -> NonEmpty (Name, Text) -> ScaffoldModule+nominalRepresentationModuleValue ctx nominal constructors =+  ScaffoldModule+    { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),+      moduleText =+        nl+          [ generatedBanner,+            "module " <> moduleName <> " (" <> representationType <> " (..), " <> encoderName <> ") where",+            "",+            "import Data.Text (Text)",+            "import GHC.Generics (Generic)",+            "",+            "data " <> representationType <> " = " <> T.intercalate " | " (map fst (NE.toList constructors)),+            "  deriving stock (Eq, Generic, Ord, Show, Enum, Bounded)",+            "",+            encoderName <> " :: " <> representationType <> " -> Text",+            encoderName <> " = \\case",+            nl ["  " <> constructor <> " -> " <> tshow wire | (constructor, wire) <- NE.toList constructors]+          ],+      kind = Generated,+      origin = nodeOrigin "bound nominal enum representation" (resolvedNominalName nominal) (resolvedNominalLoc nominal)+    }+  where+    moduleName = nominalRepresentationModule ctx (resolvedNominalName nominal)+    representationType = resolvedNominalName nominal <> "Representation"+    encoderName = lowerFirst (resolvedNominalName nominal) <> "RepresentationText"++nominalProjectionModule :: Context -> Text+nominalProjectionModule ctx = case placement ctx of+  GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".NominalProjections"+  CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.NominalProjections"++nominalProjectionOwners :: Context -> CheckedService -> [(ScaffoldModule, [Name])]+nominalProjectionOwners ctx service = case nominalProjectionTypes (checkedTypeGraph service) spec of+  [] -> []+  nominals ->+    [ ( ScaffoldModule+          { modulePath = T.unpack (T.replace "." "/" (nominalProjectionModule ctx) <> ".hs"),+            moduleText = emitNominalProjections (checkedLanguageContract service) ctx nominals,+            kind = Generated,+            origin = "context " <> specContext spec <> " nominal scalar projection facade"+          },+        []+      )+    ]+  where+    spec = checkedSpec service++nominalProjectionTypes :: Either (NE.NonEmpty TypeGraphError) TypeGraph -> Spec -> [ResolvedNominalType]+nominalProjectionTypes typeGraphResult spec =+  Map.elems . Map.fromList $+    [ (resolvedNominalName nominal, nominal)+    | aggregate <- [value | NAggregate value <- specNodes spec],+      resolved <- registerTypes aggregate <> commandTypes aggregate,+      AggregateNominal nominal <- [resolved],+      ConsumerNominal {} <- [resolvedNominalOwnership nominal]+    ]+  where+    symbols = aggregateSymbolsFromGraphResult typeGraphResult spec+    registerTypes aggregate =+      [ resolved+      | register <- aggRegs aggregate,+        Right resolved <- [resolveAggregateType symbols (regLoc register) RegisterUse (regType register)]+      ]+    commandTypes aggregate =+      [ resolved+      | command <- aggCommands aggregate,+        field <- cmdFields command,+        Right resolved <- [inferAggregateFieldType symbols aggregate CommandFieldUse field]+      ]++emitNominalProjections :: EffectiveLanguageContract -> Context -> [ResolvedNominalType] -> Text+emitNominalProjections languageContract ctx nominals =+  nl $+    renderGeneratedLanguagePragmas [ExtTypeFamilies]+      <> [ generatedBanner,+           "module " <> moduleName <> " where",+           ""+         ]+      <> map ("import " <>) imports+      <> T.lines (renderPlannedImports importPlan)+      <> [""]+      <> [T.intercalate "\n\n" (map emitNominalProjection nominals)]+  where+    moduleName = nominalProjectionModule ctx+    imports =+      sort . nub $+        [ "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]+          -- 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 =+      planImportsOrDie+        moduleName+        ( Set.fromList+            [ tagName+            | nominal <- nominals,+              tagName <- case resolvedNominalRepresentation nominal of+                ScalarRepresentation {} -> [resolvedNominalName nominal <> "NominalProjection"]+                IdRepresentation {} -> [nominalEqualityTagName nominal]+                EnumRepresentation {} -> [nominalEqualityTagName nominal]+            ]+        )+        ( Set.fromList+            [ reference+            | nominal <- nominals,+              ConsumerNominal binding <- [resolvedNominalOwnership nominal],+              reference <-+                [ haskellTypeReference (consumerNominalHaskell binding),+                  qualifiedValueReference (consumerNominalBinding binding)+                ]+                  <> case resolvedNominalRepresentation nominal of+                    EnumRepresentation constructors ->+                      HaskellReference representationModule (lowerFirst (resolvedNominalName nominal) <> "RepresentationText") ValueNamespace RequireQualified+                        : [ HaskellReference representationModule constructor ConstructorNamespace RequireQualified+                          | (constructor, _) <- NE.toList constructors+                          ]+                      where+                        representationModule = nominalRepresentationModule ctx (resolvedNominalName nominal)+                    _ -> []+            ]+        )+    emitNominalProjection nominal = case resolvedNominalOwnership nominal of+      GeneratedNominal -> ""+      ConsumerNominal binding -> case resolvedNominalRepresentation nominal of+        ScalarRepresentation {} -> emitScalarProjection nominal binding+        IdRepresentation prefix -> emitConsumerIdProjection nominal binding prefix+        EnumRepresentation constructors -> emitConsumerEnumProjection nominal binding constructors+    emitScalarProjection nominal binding =+      nl+        [ "data " <> tagName,+          "",+          "instance FieldProjection " <> tagName <> " where",+          "  type FieldName " <> tagName <> " = " <> tshow name,+          "  type FieldOwner " <> tagName <> " = " <> renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding)),+          "  type FieldResult " <> tagName <> " = " <> scalarHaskellType (resolvedNominalRepresentation nominal),+          "  fieldShapeId _ = " <> tshow (unCanonicalTypeId (consumerNominalCanonical binding)),+          "  projectFieldValue _ = nominalToRepresentation " <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)),+          "",+          witnessName <> " :: FieldWitness " <> tagName,+          witnessName <> " = fieldWitness @" <> tagName+        ]+      where+        name = resolvedNominalName nominal+        tagName = name <> "NominalProjection"+        witnessName = lowerFirst name <> "Witness"+    emitConsumerIdProjection nominal binding prefix =+      nl+        ( patternLines+            <> [ "",+                 "data " <> tagName,+                 "",+                 "instance FieldProjection " <> tagName <> " where",+                 "  type FieldName " <> tagName <> " = " <> tshow name,+                 "  type FieldOwner " <> tagName <> " = " <> ownerType,+                 "  type FieldResult " <> tagName <> " = Text",+                 "  fieldShapeId _ = " <> tshow equalityIdentity,+                 "  projectFieldValue _ = KindID.toText . nominalToRepresentation " <> bindingName,+                 "",+                 "instance ExactFieldProjection " <> tagName <> " where",+                 "  fieldProjectionDomain _ = textProjectionDomain " <> patternName,+                 "  reconstructFieldOwner _ value"+               ]+            <> validationGuard+            <> [ "    | not (matchesTextPattern " <> patternName <> " value) = Nothing",+                 "    | otherwise = case KindID.parseText @" <> tshow prefix <> " value of",+                 "        Left _ -> Nothing",+                 "        Right representation -> Just (nominalFromRepresentation " <> bindingName <> " representation)",+                 "",+                 witnessName <> " :: FieldWitness " <> tagName,+                 witnessName <> " = exactFieldWitness @" <> tagName+               ]+        )+      where+        name = resolvedNominalName nominal+        tagName = nominalEqualityTagName nominal+        witnessName = nominalEqualityWitnessName nominal+        patternName = lowerFirst name <> "EqualityPattern"+        ownerType = renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding))+        bindingName = renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding))+        equalityIdentity = fromMaybe (error "consumer ID equality contract missing") (nominalEqualityIdentityForService languageContract nominal)+        enforced = isJust (idDomainContractFor languageContract prefix)+        patternLines+          | enforced =+              [ patternName <> " :: TextPattern",+                patternName <> " = either (error . show) id (idDomainTextPattern (typeIdV7Domain " <> tshow prefix <> "))"+              ]+          | otherwise =+              [ patternName <> " :: TextPattern",+                patternName <> " = either (error . show) id $ do",+                "  prefix <- textLiteral " <> tshow (prefix <> "_"),+                "  leading <- textCharSet ('0' :| \"1234567\")",+                "  crockford <- textCharSet ('0' :| \"123456789abcdefghjkmnpqrstvwxyz\")",+                "  suffix <- textRepeatBetween 25 25 crockford",+                "  pure (textConcat (prefix :| [leading, suffix]))"+              ]+        validationGuard =+          [ "    | Left _ <- validateIdDomainText (typeIdV7Domain " <> tshow prefix <> ") value = Nothing"+          | enforced+          ]+    emitConsumerEnumProjection nominal binding constructors =+      nl $+        [ "data " <> tagName,+          "",+          "instance FieldProjection " <> tagName <> " where",+          "  type FieldName " <> tagName <> " = " <> tshow name,+          "  type FieldOwner " <> tagName <> " = " <> ownerType,+          "  type FieldResult " <> tagName <> " = Text",+          "  fieldShapeId _ = " <> tshow equalityIdentity,+          "  projectFieldValue _ = " <> encoderName <> " . nominalToRepresentation " <> bindingName,+          "",+          "instance ExactFieldProjection " <> tagName <> " where",+          "  fieldProjectionDomain _ = finiteProjectionDomain (" <> renderNonEmpty (map (tshow . snd) (NE.toList constructors)) <> ")",+          "  reconstructFieldOwner _ = \\case"+        ]+          <> [ "    " <> tshow wire <> " -> Just (nominalFromRepresentation " <> bindingName <> " " <> representationConstructor constructor <> ")"+             | (constructor, wire) <- NE.toList constructors+             ]+          <> [ "    _ -> Nothing",+               "",+               witnessName <> " :: FieldWitness " <> tagName,+               witnessName <> " = exactFieldWitness @" <> tagName+             ]+      where+        name = resolvedNominalName nominal+        tagName = nominalEqualityTagName nominal+        witnessName = nominalEqualityWitnessName nominal+        ownerType = renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding))+        bindingName = renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding))+        representationModule = nominalRepresentationModule ctx name+        encoderName = renderReferenceOrDie importPlan (HaskellReference representationModule (lowerFirst name <> "RepresentationText") ValueNamespace RequireQualified)+        representationConstructor constructor = renderReferenceOrDie importPlan (HaskellReference representationModule constructor ConstructorNamespace RequireQualified)+        equalityIdentity = fromMaybe (error "consumer enum equality contract missing") (nominalEqualityIdentityForService languageContract nominal)+    scalarHaskellType representation = case representation of+      ScalarRepresentation NominalText -> "Text"+      ScalarRepresentation NominalInt -> "Int"+      ScalarRepresentation NominalNatural -> "Natural"+      ScalarRepresentation NominalBool -> "Bool"+      ScalarRepresentation NominalTime -> "UTCTime"+      IdRepresentation {} -> "()"+      EnumRepresentation {} -> "()"++structuralProjectionModule :: Context -> Text+structuralProjectionModule ctx = structuralPrefix ctx <> "Projections"++emitShape :: Context -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text+emitShape ctx graph declaration shape =+  nl $+    languagePragmas+      <> [ generatedBanner,+           "module " <> moduleName <> " (" <> shapeType <> " (..)) where",+           ""+         ]+      <> map ("import " <>) imports+      <> T.lines (renderPlannedImports importPlan)+      <> ["" | not (null imports) || not (T.null (renderPlannedImports importPlan))]+      <> [shapeDeclaration]+  where+    moduleName = structuralShapeModule ctx (sdName declaration)+    shapeType = sdName declaration <> "Shape"+    requirements = shapeRequirements ctx graph shape+    languagePragmas = renderGeneratedLanguagePragmas []+    imports =+      sort . nub $+        ["Data.Aeson (Value)" | ReqJson `elem` requirements]+          <> ["Data.Map.Strict (Map)" | ReqMap `elem` requirements]+          <> ["Data.Text (Text)" | ReqText `elem` requirements]+          <> ["Data.Time (UTCTime)" | ReqTime `elem` requirements]+          <> ["GHC.Generics (Generic)"]+          <> ["Numeric.Natural (Natural)" | ReqNatural `elem` requirements]+    shapeDeclaration =+      foldMappedShape+        MappedShapeAlgebra+          { onRecord = \constructor _ fields ->+              nl $+                ["data " <> shapeType <> " = " <> constructor]+                  <> recordFields+                    [ (rwfHaskell field, renderShapeType importPlan ctx graph (rwfType field))+                    | field <- fields+                    ]+                  <> ["  deriving stock (Eq, Generic, Show)"],+            onEnum = \entries ->+              "data "+                <> shapeType+                <> " = "+                <> T.intercalate " | " (map weCtor entries)+                <> "\n  deriving stock (Eq, Generic, Show)",+            onUnion = \_ arms ->+              nl $+                case arms of+                  [] -> ["data " <> shapeType <> " = " <> shapeType <> "Empty", "  deriving stock (Eq, Generic, Show)"]+                  firstArm : rest ->+                    ["data " <> shapeType <> " = " <> renderArm firstArm]+                      <> ["  | " <> renderArm arm | arm <- rest]+                      <> ["  deriving stock (Eq, Generic, Show)"]+          }+        shape+    renderArm arm = rwaCtor arm <> maybe "" ((" !" <>) . renderShapeType importPlan ctx graph) (rwaPayload arm)+    importPlan =+      planImportsOrDie+        moduleName+        (Set.singleton shapeType)+        (Set.fromList [reference | ReqReference reference <- requirements])++data ShapeRequirement+  = ReqJson+  | ReqMap+  | ReqText+  | ReqTime+  | ReqNatural+  | ReqReference !HaskellReference+  deriving stock (Eq, Ord, Show)++shapeRequirements :: Context -> TypeGraph -> ResolvedMappedShape -> [ShapeRequirement]+shapeRequirements ctx graph =+  foldMappedShape+    MappedShapeAlgebra+      { onRecord = \_ _ fields -> concatMap (exprRequirements ctx graph . rwfType) fields,+        onEnum = const [],+        onUnion = \_ arms -> concatMap (maybe [] (exprRequirements ctx graph) . rwaPayload) arms+      }++exprRequirements :: Context -> TypeGraph -> ResolvedTypeExpr -> [ShapeRequirement]+exprRequirements ctx graph =+  foldTypeExpr+    TypeExprAlgebra+      { onText = [ReqText],+        onInt = [],+        onInteger = [],+        onBool = [],+        onNatural = [ReqNatural],+        onTime = [ReqTime],+        onJson = [ReqJson],+        onOptional = id,+        onList = id,+        onMap = (ReqMap :) . (ReqText :),+        onRef = \key -> case Map.lookup key (tgDeclarations graph) of+          Just (ResolvedStructural declaration _) ->+            [ ReqReference+                ( HaskellReference+                    (structuralShapeModule ctx (sdName declaration))+                    (sdName declaration <> "Shape")+                    TypeNamespace+                    RequireQualified+                )+            ]+          Just (ResolvedOpaque declaration) -> [ReqReference (haskellTypeReference (odHaskell declaration))]+          Nothing -> []+      }++renderShapeType :: HaskellImportPlan -> Context -> TypeGraph -> ResolvedTypeExpr -> Text+renderShapeType importPlan ctx graph =+  renderStrictOrApplicationArgument+    . foldTypeExpr+      TypeExprAlgebra+        { onText = atomicShapeType "Text",+          onInt = atomicShapeType "Int",+          onInteger = atomicShapeType "Integer",+          onBool = atomicShapeType "Bool",+          onNatural = atomicShapeType "Natural",+          onTime = atomicShapeType "UTCTime",+          onJson = atomicShapeType "Value",+          onOptional = applicationShapeType . ("Maybe " <>) . renderStrictOrApplicationArgument,+          onList = atomicShapeType . ("[" <>) . (<> "]") . renderedShapeTypeText,+          onMap = applicationShapeType . ("Map Text " <>) . renderStrictOrApplicationArgument,+          onRef =+            atomicShapeType . \key -> case Map.lookup key (tgDeclarations graph) of+              Just (ResolvedStructural nested _) ->+                renderReferenceOrDie+                  importPlan+                  (HaskellReference (structuralShapeModule ctx (sdName nested)) (sdName nested <> "Shape") TypeNamespace RequireQualified)+              Just (ResolvedOpaque opaque) ->+                renderReferenceOrDie importPlan (haskellTypeReference (odHaskell opaque))+              Nothing -> "()"+        }++data ShapeTypePrecedence+  = AtomicShapeType+  | ApplicationShapeType++data RenderedShapeType = RenderedShapeType+  { renderedShapeTypePrecedence :: !ShapeTypePrecedence,+    renderedShapeTypeText :: !Text+  }++atomicShapeType :: Text -> RenderedShapeType+atomicShapeType = RenderedShapeType AtomicShapeType++applicationShapeType :: Text -> RenderedShapeType+applicationShapeType = RenderedShapeType ApplicationShapeType++renderStrictOrApplicationArgument :: RenderedShapeType -> Text+renderStrictOrApplicationArgument rendered = case renderedShapeTypePrecedence rendered of+  AtomicShapeType -> renderedShapeTypeText rendered+  ApplicationShapeType -> "(" <> renderedShapeTypeText rendered <> ")"++data StructuralProjection = StructuralProjection+  { spTag :: !Text,+    spWitness :: !Text,+    spPointer :: !Text,+    spOwner :: !HaskellSource,+    spResult :: !Text,+    spCanonical :: !CanonicalTypeId,+    spBinding :: !QualifiedValueName,+    spSelectors :: ![(Text, Text)]+  }+  deriving stock (Eq, Show)++projectionSpecs :: TypeGraph -> [StructuralProjection]+projectionSpecs graph =+  sortOn spTag . allocateProjectionNames . concat $+    [ projectionsForRoot graph declaration shape+    | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph)+    ]++projectionsForRoot :: TypeGraph -> StructuralDecl -> ResolvedMappedShape -> [StructuralProjection]+projectionsForRoot graph root rootShape = case rootShape of+  RRecord _ _ fields -> concatMap (walkField [] []) fields+  REnum {} -> []+  RUnion {} -> []+  where+    walkField keys selectors field+      | rwfPresence field /= PRequired = []+      | otherwise = case projectionScalar (rwfType field) of+          Just result -> [mkProjection (keys <> [rwfKey field]) (selectors <> [(shapeModuleForOwner, rwfHaskell field)]) result]+          Nothing -> case rwfType field of+            RRef key -> case Map.lookup key (tgDeclarations graph) of+              Just (ResolvedStructural nested (RRecord _ _ nestedFields)) ->+                concatMap+                  (walkNested nested (keys <> [rwfKey field]) (selectors <> [(shapeModuleForOwner, rwfHaskell field)]))+                  nestedFields+              _ -> []+            _ -> []+      where+        shapeModuleForOwner = "__SHAPE__." <> sdName root++    walkNested owner keys selectors field+      | rwfPresence field /= PRequired = []+      | otherwise = case projectionScalar (rwfType field) of+          Just result -> [mkProjection (keys <> [rwfKey field]) (selectors <> [(shapeModuleFor owner, rwfHaskell field)]) result]+          Nothing -> case rwfType field of+            RRef key -> case Map.lookup key (tgDeclarations graph) of+              Just (ResolvedStructural nested (RRecord _ _ nestedFields)) ->+                concatMap+                  (walkNested nested (keys <> [rwfKey field]) (selectors <> [(shapeModuleFor owner, rwfHaskell field)]))+                  nestedFields+              _ -> []+            _ -> []++    -- Context is supplied when rendering; this marker is replaced there.+    shapeModuleFor declaration = "__SHAPE__." <> sdName declaration+    mkProjection keys selectors result =+      StructuralProjection+        { spTag = nameStem <> "Projection",+          spWitness = lowerFirst nameStem <> "Witness",+          spPointer = pointer,+          spOwner = sdHaskell root,+          spResult = result,+          spCanonical = sdCanonical root,+          spBinding = sdBinding root,+          spSelectors = selectors+        }+      where+        pointer = T.concat ["/" <> escapePointer key | key <- keys]+        nameStem = projectionNameStem (sdName root) pointer++projectionScalar :: ResolvedTypeExpr -> Maybe Text+projectionScalar = \case+  RText -> Just "Text"+  RInt -> Just "Int"+  RInteger -> Just "Integer"+  RBool -> Just "Bool"+  RTime -> Just "UTCTime"+  RNatural -> Just "Natural"+  RJson -> Nothing+  ROptional {} -> Nothing+  RList {} -> Nothing+  RMap {} -> Nothing+  RRef {} -> Nothing++escapePointer :: Text -> Text+escapePointer = T.replace "/" "~1" . T.replace "~" "~0"++projectionNameStem :: Name -> Text -> Text+projectionNameStem owner pointer =+  pascal owner+    <> T.concat+      [ normaliseAliasPart (unescapePointer segment)+      | segment <- filter (not . T.null) (T.splitOn "/" pointer)+      ]++-- | Add a stable digest only when two distinct wire paths normalize to the+-- same Haskell name. Digest collisions receive a deterministic ordinal, so the+-- emitter never produces duplicate declarations even in that unlikely case.+allocateProjectionNames :: [StructuralProjection] -> [StructuralProjection]+allocateProjectionNames specs = concatMap allocateGroup groups+  where+    groups = groupBy (\left right -> spTag left == spTag right) (sortOn spTag specs)+    allocateGroup [spec] = [spec]+    allocateGroup collided = reverse named+      where+        ordered = sortOn projectionIdentity collided+        digest spec = T.take 8 (fnv1a64 (projectionIdentity spec))+        digestCounts = Map.fromListWith (+) [(digest spec, 1 :: Int) | spec <- ordered]+        (_, named) = foldl allocate (Map.empty, []) ordered+        allocate (seen, allocated) spec =+          let shortDigest = digest spec+              occurrence = Map.findWithDefault 0 shortDigest seen + 1+              suffix =+                shortDigest+                  <> if Map.findWithDefault 0 shortDigest digestCounts == 1+                    then ""+                    else tshow' occurrence+           in (Map.insert shortDigest occurrence seen, renameWithSuffix suffix spec : allocated)+    projectionIdentity spec = unCanonicalTypeId (spCanonical spec) <> "#" <> spPointer spec+    renameWithSuffix suffix spec =+      spec+        { spTag = nameStem <> suffix <> "Projection",+          spWitness = lowerFirst nameStem <> suffix <> "Witness"+        }+      where+        nameStem = fromMaybe (spTag spec) (T.stripSuffix "Projection" (spTag spec))++projectionWitnessName :: TypeGraph -> MappedKey -> Text -> Maybe Text+projectionWitnessName graph owner pointer = do+  ResolvedStructural declaration _ <- Map.lookup owner (tgDeclarations graph)+  spWitness+    <$> find+      (\spec -> spCanonical spec == sdCanonical declaration && spPointer spec == pointer)+      (projectionSpecs graph)++emitStructuralProjections :: Context -> TypeGraph -> Text+emitStructuralProjections ctx graph =+  nl $+    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",+           ""+         ]+      <> 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+        (Set.fromList (map spTag specs))+        ( Set.fromList+            ( [haskellTypeReference (spOwner spec) | spec <- specs]+                <> [qualifiedValueReference (spBinding spec) | spec <- specs]+                <> [ HaskellReference shapeModuleName selector ValueNamespace RequireQualified+                   | spec <- specs,+                     (shapeModuleName, selector) <- spSelectors spec+                   ]+            )+        )+    renderProjection spec =+      [ "",+        "data " <> spTag spec,+        "",+        "instance FieldProjection " <> spTag spec <> " where",+        "  type FieldName " <> spTag spec <> " = " <> tshow (spPointer spec),+        "  type FieldOwner " <> spTag spec <> " = " <> renderReferenceOrDie importPlan (haskellTypeReference (spOwner spec)),+        "  type FieldResult " <> spTag spec <> " = " <> spResult spec,+        "  fieldShapeId _ = " <> tshow (unCanonicalTypeId (spCanonical spec)),+        "  projectFieldValue _ owner = " <> renderGetter spec,+        "",+        spWitness spec <> " :: FieldWitness " <> spTag spec,+        spWitness spec <> " = fieldWitness @" <> spTag spec+      ]+    renderGetter spec =+      foldl+        ( \value (shapeModuleName, selector) ->+            renderReferenceOrDie importPlan (HaskellReference shapeModuleName selector ValueNamespace RequireQualified)+              <> " ("+              <> value+              <> ")"+        )+        ("bindingToShape " <> renderReferenceOrDie importPlan (qualifiedValueReference (spBinding spec)) <> " owner")+        (spSelectors spec)++resolveProjectionModules :: Context -> StructuralProjection -> StructuralProjection+resolveProjectionModules ctx spec =+  spec+    { spSelectors =+        [ (replaceModule marker, selector)+        | (marker, selector) <- spSelectors spec+        ]+    }+  where+    replaceModule marker+      | Just name <- T.stripPrefix "__SHAPE__." marker = structuralShapeModule ctx name+      | otherwise = structuralShapeModule ctx (lastSegment marker)++haskellTypeReference :: HaskellSource -> HaskellReference+haskellTypeReference source =+  HaskellReference (hsModule source) (hsType source) TypeNamespace PreferUnqualified++qualifiedValueReference :: QualifiedValueName -> HaskellReference+qualifiedValueReference qualified =+  HaskellReference moduleName valueName ValueNamespace RequireQualified+  where+    (moduleName, valueName) = splitQualified (unQualifiedValueName qualified)++renderReferenceOrDie :: HaskellImportPlan -> HaskellReference -> Text+renderReferenceOrDie importPlan =+  either+    (error . ("validated Haskell reference failed: " <>) . show)+    id+    . renderPlannedReference importPlan++planImportsOrDie :: Text -> Set.Set Text -> Set.Set HaskellReference -> HaskellImportPlan+planImportsOrDie target localDeclarations =+  either+    (error . ("validated Haskell import planning failed: " <>) . show)+    id+    . planHaskellImports+      ImportEnvironment+        { targetModule = target,+          localNames = localDeclarations,+          reservedQualifiers = rendererReservedQualifiers+        }++rendererReservedQualifiers :: Set.Set Text+rendererReservedQualifiers =+  Set.fromList+    [ "Aeson",+      "AesonKey",+      "AesonKeyMap",+      "B",+      "GeneratedNominals",+      "Holes",+      "K",+      "Key",+      "KeyMap",+      "KindID",+      "Map",+      "NominalProjections",+      "NonEmpty",+      "S",+      "Set",+      "StructuralProjections",+      "T"+    ]++splitQualified :: Text -> (Text, Text)+splitQualified value =+  let (prefix, name) = T.breakOnEnd "." value+   in (T.dropEnd 1 prefix, name)++lastSegment :: Text -> Text+lastSegment = snd . T.breakOnEnd "."++-- | Emit all modules for one aggregate. The 'Spec' is needed for the shared+-- id\/enum declarations.+scaffoldAggregate :: Context -> Spec -> Aggregate -> [ScaffoldModule]+scaffoldAggregate ctx spec = scaffoldAggregateForService ctx (legacyCheckedService spec)++-- | Emit all modules for one aggregate after selecting the effective semantic+-- contract. This is the normal source/workspace generation entry point.+scaffoldAggregateForService :: Context -> CheckedService -> Aggregate -> [ScaffoldModule]+scaffoldAggregateForService ctx service agg =+  [ genModule a "Domain" (emitDomain a),+    genModule a "Codec" (emitCodec a)+  ]+    ++ ( if hasVersion2Ownership a+           then+             [ genModule a "Transducer" (emitGeneratedTransducer a),+               genModule a "BehaviorContract" (emitBehaviorContract a),+               behaviorHoleModule a+             ]+           else []+       )+    ++ [ genModule a "EventStream" (emitEventStream a),+         genModule a "Projection" (emitProjection a)+       ]+    ++ [holeModule a (emitHoles a) | aggregateNeedsHoleModule a]+  where+    a = resolveAggForService ctx service agg++aggregateNeedsHoleModule :: Agg -> Bool+aggregateNeedsHoleModule aggregate+  | hasVersion2Ownership aggregate = not (null (version2HoleExports aggregate))+  | otherwise = True++-- | The generated behavioral contract is deliberately separate from both the+-- authoritative transducer and the create-once witness list.  Regeneration can+-- replace this module freely while stale textual keys in @BehaviorHoles@ keep+-- compiling and are reported by reconciliation.+emitBehaviorContract :: Agg -> Text+emitBehaviorContract aggregate =+  nl $+    renderGeneratedLanguagePragmas [ExtOverloadedLabels | not (null (aRegs aggregate))]+      <> [ 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",+           "import " <> aGenPrefix aggregate <> ".Transducer (" <> valueStem <> "Transducer)",+           "import " <> contextGeneratedPrefix (aContext aggregate) <> ".BehaviorSourceMap qualified as BehaviorSourceMap"+         ]+      <> outcomeBehaviorImports+      <> [ "import Data.Aeson (ToJSON (..), object, (.=))",+           "import Data.List (sortOn)",+           "import Data.List.NonEmpty (NonEmpty)",+           "import Data.List.NonEmpty qualified as NonEmpty",+           "import Data.Map.Strict qualified as Map",+           "import Data.Text (Text)",+           "import Data.Text qualified as T",+           "import Keiki.Core qualified as K (" <> T.intercalate ", " behaviorCoreImports <> ")",+           "import Keiro.Codec qualified as Codec (Codec (eventType), EventType (..))",+           "",+           "newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }",+           "  deriving stock (Eq, Ord, Show)",+           "",+           "data ObligationKind = LiveTransition | RequiredRejection | ReplayTransition",+           "  deriving stock (Eq, Ord, Show)",+           "",+           "data EvidenceLevel = GeneratedAuthoritative | HoleWitnessed | LegacyRuntimeWitness",+           "  deriving stock (Eq, Ord, Show)",+           "",+           "data GuardCoverage = GuardTotal | GuardPartial | GuardUnknown | GuardNotApplicable",+           "  deriving stock (Eq, Ord, Show)",+           "",+           "data BehaviorRequirement = BehaviorRequirement",+           "  { requirementKey :: !BehaviorKey",+           "  , requirementKind :: !ObligationKind",+           "  , requirementEvidence :: !EvidenceLevel",+           "  , requirementGuardCoverage :: !GuardCoverage",+           "  , requirementSource :: !" <> aVertexType aggregate,+           "  , requirementCommandName :: !Text",+           "  , requirementExpectedEdge :: !(Maybe (K.EdgeRef " <> aVertexType aggregate <> "))",+           "  , requirementTarget :: !(Maybe " <> aVertexType aggregate <> ")",+           "  , requirementEventKinds :: ![Text]",+           "  }",+           "  deriving stock (Eq, Show)",+           "",+           "data RejectionClass = RejectNoOutgoingEdges | RejectNoMatchingEdge",+           "  deriving stock (Eq, Show)",+           "",+           "data LiveExpectation",+           "  = Emits (NonEmpty " <> name <> "Event)",+           "  | Rejects RejectionClass"+         ]+      <> outcomeExpectationConstructors+      <> [ "  | NoOp",+           "  deriving stock (Eq, Show)",+           "",+           "data BehaviorWitness",+           "  = Pending BehaviorKey",+           "  | LiveWitness",+           "      { witnessKey :: BehaviorKey",+           "      , witnessHistory :: [" <> name <> "Event]",+           "      , witnessCommand :: " <> name <> "Command",+           "      , witnessExpected :: LiveExpectation",+           "      }",+           "  | ReplayWitness",+           "      { witnessKey :: BehaviorKey",+           "      , witnessHistoryPrefix :: [" <> name <> "Event]",+           "      , witnessObservedChunk :: [" <> name <> "Event]",+           "      }",+           "  deriving stock (Eq, Show)",+           "",+           "data BehaviorFailure = BehaviorFailure",+           "  { failureKey :: !BehaviorKey",+           "  , failureSubject :: !Text",+           "  , failureCode :: !Text",+           "  , failureDetail :: !Text",+           "  }",+           "  deriving stock (Eq, Show)",+           "",+           "instance ToJSON BehaviorFailure where",+           "  toJSON behaviorFailure = object",+           "    [ \"key\" .= unBehaviorKey (failureKey behaviorFailure)",+           "    , \"subject\" .= failureSubject behaviorFailure",+           "    , \"code\" .= failureCode behaviorFailure",+           "    , \"detail\" .= failureDetail behaviorFailure",+           "    ]",+           "",+           "data BehaviorConformanceReport = BehaviorConformanceReport",+           "  { reportRequired :: ![BehaviorKey]",+           "  , reportFilled :: ![BehaviorKey]",+           "  , reportPending :: ![BehaviorKey]",+           "  , reportMissing :: ![BehaviorKey]",+           "  , reportDuplicate :: ![BehaviorKey]",+           "  , reportStale :: ![BehaviorKey]",+           "  , reportFailed :: ![BehaviorFailure]",+           "  , reportVerified :: ![BehaviorKey]",+           "  , reportUnverified :: ![BehaviorKey]",+           "  }",+           "  deriving stock (Eq, Show)",+           "",+           "instance ToJSON BehaviorConformanceReport where",+           "  toJSON report = object",+           "    [ \"schema\" .= (\"keiro/behavior-conformance/1\" :: Text)",+           "    , \"required\" .= keyTexts (reportRequired report)",+           "    , \"filled\" .= keyTexts (reportFilled report)",+           "    , \"pending\" .= keyTexts (reportPending report)",+           "    , \"missing\" .= keyTexts (reportMissing report)",+           "    , \"duplicate\" .= keyTexts (reportDuplicate report)",+           "    , \"stale\" .= keyTexts (reportStale report)",+           "    , \"failed\" .= reportFailed report",+           "    , \"verified\" .= keyTexts (reportVerified report)",+           "    , \"unverified\" .= keyTexts (reportUnverified report)",+           "    ]",+           "",+           "behaviorRequirements :: [BehaviorRequirement]",+           "behaviorRequirements ="+         ]+      <> renderBehaviorRequirementList aggregate+      <> [ "",+           "behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport",+           "behaviorCoverageReport witnesses =",+           "  BehaviorConformanceReport",+           "    { reportRequired = sortedKeys (Map.keys requiredByKey)",+           "    , reportFilled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]",+           "    , reportPending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]",+           "    , reportMissing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]",+           "    , reportDuplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]",+           "    , reportStale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]",+           "    , reportFailed = sortOn (unBehaviorKey . failureKey) failures",+           "    , reportVerified = sortedKeys [requirementKey requirement | (requirement, Right ()) <- executions, proofStrength requirement]",+           "    , reportUnverified = sortedKeys [requirementKey requirement | (requirement, Right ()) <- executions, not (proofStrength requirement)]",+           "    }",+           " where",+           "  requiredByKey = Map.fromList [(requirementKey requirement, requirement) | requirement <- behaviorRequirements]",+           "  witnessGroups = Map.fromListWith (flip (<>)) [(behaviorWitnessKey witness, [witness]) | witness <- witnesses]",+           "  executions =",+           "    [ (requirement, runWitness requirement witness)",+           "    | (key, [witness]) <- Map.toList witnessGroups",+           "    , not (isPending witness)",+           "    , Just requirement <- [Map.lookup key requiredByKey]",+           "    ]",+           "  failures = [behaviorFailure | (_, Left behaviorFailure) <- executions]",+           "",+           "behaviorConformancePassed :: BehaviorConformanceReport -> Bool",+           "behaviorConformancePassed = behaviorConformancePassedWith False",+           "",+           "behaviorConformancePassedWith :: Bool -> BehaviorConformanceReport -> Bool",+           "behaviorConformancePassedWith failOnUnverified report =",+           "  null (reportPending report)",+           "    && null (reportMissing report)",+           "    && null (reportDuplicate report)",+           "    && null (reportStale report)",+           "    && null (reportFailed report)",+           "    && (not failOnUnverified || null (reportUnverified report))",+           "",+           "renderBehaviorConformanceText :: BehaviorConformanceReport -> Text",+           "renderBehaviorConformanceText report = T.unlines",+           "  [ \"behavior conformance: " <> name <> "\"",+           "  , \"schema: keiro/behavior-conformance/1\"",+           "  , countLine \"required\" (reportRequired report)",+           "  , countLine \"filled\" (reportFilled report)",+           "  , countLine \"pending\" (reportPending report)",+           "  , countLine \"missing\" (reportMissing report)",+           "  , countLine \"duplicate\" (reportDuplicate report)",+           "  , countLine \"stale\" (reportStale report)",+           "  , \"failed: \" <> tshow (length (reportFailed report))",+           "  , countLine \"verified\" (reportVerified report)",+           "  , countLine \"unverified\" (reportUnverified report)",+           "  ] <> T.unlines [\"FAIL \" <> unBehaviorKey (failureKey behaviorFailure) <> \" \" <> failureSubject behaviorFailure <> \" [\" <> failureCode behaviorFailure <> \"] \" <> failureDetail behaviorFailure | behaviorFailure <- reportFailed report]",+           "",+           "runWitness :: BehaviorRequirement -> BehaviorWitness -> Either BehaviorFailure ()",+           "runWitness requirement witness = case witness of",+           "  Pending _ -> failure requirement \"pending\" \"witness is still Pending\"",+           "  LiveWitness _ history command expectation -> runLive requirement history command expectation",+           "  ReplayWitness _ prefix chunk -> runReplay requirement prefix chunk",+           "",+           "runLive :: BehaviorRequirement -> [" <> name <> "Event] -> " <> name <> "Command -> LiveExpectation -> Either BehaviorFailure ()",+           "runLive requirement history command expectation = do",+           "  settled <- settleHistory requirement \"history\" history",+           "  ensure requirement (K.replaySuccessState settled == requirementSource requirement) \"history-wrong-source\" \"history does not settle at the required source vertex\"",+           "  ensure requirement (commandKind command == requirementCommandName requirement) \"command-mismatch\" \"witness command constructor does not match the required state/command cell\"",+           "  case requirementKind requirement of",+           "    ReplayTransition -> failure requirement \"witness-kind\" \"a replay-only requirement needs ReplayWitness\"",+           "    RequiredRejection -> runRejection requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation",+           "    LiveTransition -> runAcceptance requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation",+           "",+           "runRejection :: 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\""+         ]+      <> outcomeGenericRejectionCases+      <> [ "  NoOp -> failure requirement \"expectation-kind\" \"a rejection requirement cannot expect an accepted no-op\"",+           "  Rejects expectedClass -> case K.stepDetailedEither " <> valueStem <> "Transducer seed command of",+           "    Left K.NoOutgoingEdges {} -> ensure requirement (expectedClass == RejectNoOutgoingEdges) \"rejection-class\" \"expected NoMatchingEdge but runtime returned NoOutgoingEdges\"",+           "    Left K.NoMatchingEdge {} -> ensure requirement (expectedClass == RejectNoMatchingEdge) \"rejection-class\" \"expected NoOutgoingEdges but runtime returned NoMatchingEdge\"",+           "    Left K.AmbiguousEdges {} -> failure requirement \"ambiguous-edges\" \"AmbiguousEdges can never satisfy a rejection witness\"",+           "    Right _ -> failure requirement \"unexpected-acceptance\" \"runtime accepted a command required to reject\"",+           "",+           "runAcceptance :: 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\""+         ]+      <> outcomeExactAcceptanceCases+      <> genericNoOpAcceptanceLines+      <> [ "  Emits expectedEvents -> case K.stepDetailedEither " <> valueStem <> "Transducer seed command of",+           "    Left stepFailure -> failure requirement \"unexpected-rejection\" (tshow stepFailure)",+           "    Right success -> do",+           "      checkAcceptedEnvelope requirement success",+           "      let expected = NonEmpty.toList expectedEvents",+           "          actual = K.stepSuccessOutputs success",+           "      ensure requirement (actual == expected) \"event-value-mismatch\" (\"runtime event values differ from the exact witness expectation; 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)",+           "        Right replaySuccess -> Right replaySuccess",+           "      ensure requirement (K.replaySuccessState replayed == K.stepSuccessState success) \"forward-replay-vertex\" \"decoded emissions replay to a different vertex\"",+           "      ensure requirement (regsEqual (K.replaySuccessRegs replayed) (K.stepSuccessRegs success)) \"forward-replay-registers\" \"decoded emissions replay to different registers\"",+           "      checkSingleAttribution requirement K.Live (length decoded) (K.replaySuccessTrace replayed)"+         ]+      <> outcomeSilentRunnerLines+      <> [ "",+           "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; 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",+           "  ReplayTransition -> do",+           "    settled <- settleHistory requirement \"history-prefix\" prefix",+           "    ensure requirement (K.replaySuccessState settled == requirementSource requirement) \"history-wrong-source\" \"history prefix does not settle at the replay edge source\"",+           "    ensure requirement (not (null chunk)) \"empty-replay-chunk\" \"a replay-only edge has no observable empty chunk\"",+           "    decoded <- either (failure requirement \"replay-chunk-codec-decode\") Right (decodeEvents chunk)",+           "    replayed <- case K.applyEventsDetailedEither " <> valueStem <> "Transducer (K.replaySuccessState settled, K.replaySuccessRegs settled) decoded of",+           "      Left replayFailure -> failure requirement \"replay-chunk-failed\" (tshow replayFailure)",+           "      Right replaySuccess -> Right replaySuccess",+           "    ensure requirement (Just (K.replaySuccessState replayed) == requirementTarget requirement) \"target-mismatch\" (\"replay chunk reached a different target vertex; 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; 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",+           "    Left replayFailure -> failure requirement (label <> \"-replay-failed\") (tshow replayFailure)",+           "    Right replaySuccess -> Right replaySuccess",+           "",+           "decodeEvents :: [" <> name <> "Event] -> Either Text [" <> name <> "Event]",+           "decodeEvents = traverse (\\event -> parse" <> name <> "Event (Codec.eventType " <> valueStem <> "Codec event) (encode" <> name <> "Event event))"+         ]+      <> renderCommandKind aggregate+      <> [ "",+           "eventKind :: " <> 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 :: BehaviorRequirement -> Text -> Text -> Either BehaviorFailure failed",+           "failure requirement code detail =",+           "  Left",+           "    ( BehaviorFailure",+           "        (requirementKey requirement)",+           "        (tshow (requirementSource requirement) <> \" x \" <> requirementCommandName requirement <> \": \" <> kindPhrase <> \" (\" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey 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"+         ]+  where+    name = aName aggregate+    valueStem = lowerFirst name+    handlerName = valueStem <> "DomainCommandHandler"+    outcomeResultTypes = case aDomainOutcomeTypes aggregate of+      Nothing -> []+      Just outcomeTypes -> [resolvedRejectionType outcomeTypes, resolvedNoOpType outcomeTypes]+    outcomeImportPlan = eventStreamImportPlan aggregate outcomeResultTypes []+    outcomeGeneratedNominals = generatedNominalsInTypes outcomeResultTypes+    outcomeBehaviorImports = case aDomainOutcomeTypes aggregate of+      Nothing -> []+      Just _ ->+        ["import " <> aGenPrefix aggregate <> ".EventStream (" <> handlerName <> ")"]+          <> [ "import "+                 <> generatedNominalModule (aContext aggregate)+                 <> " ("+                 <> T.intercalate ", " (map resolvedNominalName (stableNominals outcomeGeneratedNominals))+                 <> ")"+             | not (null outcomeGeneratedNominals)+             ]+          <> T.lines (renderPlannedImports outcomeImportPlan)+          <> ["import Keiro.Command (DomainCommandHandler (..), SilentCommandContext (..), SilentDomainDecision (..))"]+    outcomeExpectationConstructors = case aDomainOutcomeTypes aggregate of+      Nothing -> []+      Just outcomeTypes ->+        [ "  | RejectedWith " <> renderDomainType outcomeImportPlan aggregate (resolvedRejectionType outcomeTypes),+          "  | NoOpWith " <> renderDomainType outcomeImportPlan aggregate (resolvedNoOpType outcomeTypes)+        ]+    outcomeGenericRejectionCases = case aDomainOutcomeTypes aggregate of+      Nothing -> []+      Just _ ->+        [ "  RejectedWith _ -> failure requirement \"expectation-kind\" \"an unmatched-command rejection cannot expect a selected domain rejection\"",+          "  NoOpWith _ -> failure requirement \"expectation-kind\" \"an unmatched-command rejection cannot expect a selected domain no-op\""+        ]+    genericNoOpAcceptanceLines = case aDomainOutcomeTypes aggregate of+      Just _ -> ["  NoOp -> failure requirement \"expectation-kind\" \"an outcome-enabled transition requires RejectedWith or NoOpWith exact reason evidence\""]+      Nothing ->+        [ "  NoOp -> case K.stepDetailedEither " <> valueStem <> "Transducer seed command of",+          "    Left stepFailure -> failure requirement \"unexpected-rejection\" (tshow stepFailure)",+          "    Right success -> do",+          "      checkAcceptedEnvelope requirement success",+          "      ensure requirement (null (K.stepSuccessOutputs success)) \"noop-emitted\" \"NoOp emitted one or more events\"",+          "      ensure requirement (K.stepSuccessState success == fst seed) \"noop-vertex-change\" \"NoOp changed the control vertex\"",+          "      ensure requirement (regsEqual (K.stepSuccessRegs success) (snd seed)) \"noop-register-change\" \"NoOp changed one or more registers\""+        ]+    outcomeExactAcceptanceCases = case aDomainOutcomeTypes aggregate of+      Nothing -> []+      Just _ ->+        [ "  RejectedWith expectedReason -> do",+          "    decision <- runSilentDecision requirement seed command",+          "    case decision of",+          "      SilentRejected actualReason -> ensure requirement (actualReason == expectedReason) \"domain-rejection-reason\" (\"selected rejection reason differs; actual=\" <> tshow actualReason <> \" expected=\" <> tshow expectedReason)",+          "      SilentNoOp actualReason -> failure requirement \"domain-outcome-kind\" (\"expected a selected rejection but classifier returned no-op \" <> tshow actualReason)",+          "  NoOpWith expectedReason -> do",+          "    decision <- runSilentDecision requirement seed command",+          "    case decision of",+          "      SilentRejected actualReason -> failure requirement \"domain-outcome-kind\" (\"expected a selected no-op but classifier returned rejection \" <> tshow actualReason)",+          "      SilentNoOp actualReason -> ensure requirement (actualReason == expectedReason) \"domain-noop-reason\" (\"selected no-op reason differs; actual=\" <> tshow actualReason <> \" expected=\" <> tshow expectedReason)"+        ]+    outcomeSilentRunnerLines = case aDomainOutcomeTypes aggregate of+      Nothing -> []+      Just outcomeTypes ->+        [ "",+          "runSilentDecision",+          "  :: BehaviorRequirement",+          "  -> (" <> aVertexType aggregate <> ", K.RegFile " <> name <> "Regs)",+          "  -> " <> name <> "Command",+          "  -> Either BehaviorFailure (SilentDomainDecision " <> renderDomainType outcomeImportPlan aggregate (resolvedRejectionType outcomeTypes) <> " " <> renderDomainType outcomeImportPlan aggregate (resolvedNoOpType outcomeTypes) <> ")",+          "runSilentDecision requirement seed command = case K.stepDetailedEither " <> valueStem <> "Transducer seed command of",+          "  Left stepFailure -> failure requirement \"unexpected-rejection\" (tshow stepFailure)",+          "  Right success -> do",+          "    checkAcceptedEnvelope requirement success",+          "    ensure requirement (null (K.stepSuccessOutputs success)) \"silent-emitted\" \"typed silent outcome emitted one or more events\"",+          "    ensure requirement (K.stepSuccessState success == fst seed) \"silent-vertex-change\" \"typed silent outcome changed the control vertex\"",+          "    ensure requirement (regsEqual (K.stepSuccessRegs success) (snd seed)) \"silent-register-change\" \"typed silent outcome changed one or more registers\"",+          "    case " <> handlerName <> " of",+          "      DomainCommandHandler _ classify ->",+          "        Right (classify (SilentCommandContext (fst seed) (snd seed) command (K.stepSuccessEdge success)))"+        ]+    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 :: " <> aName aggregate <> "Command -> Text", "commandKind _ = \"\""]+  commands ->+    [ "",+      "commandKind :: " <> aName aggregate <> "Command -> Text",+      "commandKind command = case command of"+    ]+      <> ["  " <> rcName command <> " _ -> " <> tshow (rcName command) | command <- commands]++renderBehaviorRequirementList :: Agg -> [Text]+renderBehaviorRequirementList aggregate =+  case behaviorRequirementsFor aggregate of+    [] -> ["  []"]+    requirements ->+      concat+        [ render index requirement+        | (index, requirement) <- zip [0 ..] requirements+        ]+        <> ["  ]"]+  where+    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),+        "      }"+      ]++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"+       )++edgeExpr :: Agg -> Behavior.BehaviorRequirement -> Text+edgeExpr aggregate requirement = case Behavior.requirementKind requirement of+  Behavior.RequiredRejection -> "Nothing"+  _ -> case behaviorEdgeIndex aggregate requirement of+    Nothing -> error ("required behavior transition missing from resolved aggregate: " <> T.unpack (Behavior.requirementCanonical requirement))+    Just edgeIndex ->+      "(Just (K.EdgeRef "+        <> vertexCtor aggregate (Behavior.requirementSource requirement)+        <> " "+        <> tshow' edgeIndex+        <> "))"++behaviorEdgeIndex :: Agg -> Behavior.BehaviorRequirement -> Maybe Int+behaviorEdgeIndex aggregate requirement = case Behavior.requirementOrigin requirement of+  Behavior.RejectionRequirementOrigin {} -> Nothing+  Behavior.TransitionRequirementOrigin originAggregate (SourceIndex.TransitionOrdinal ordinal) -> do+    transition <- case drop ordinal (aTransitions aggregate) of+      candidate : _ -> Just candidate+      [] -> Nothing+    if originAggregate == aName aggregate+      && tSource transition == Behavior.requirementSource requirement+      && tCommand transition == Behavior.requirementCommand requirement+      then+        Just+          ( length+              [ ()+              | candidate <- take ordinal (aTransitions aggregate),+                tSource candidate == tSource transition+              ]+          )+      else Nothing++behaviorRequirementsFor :: Agg -> [Behavior.BehaviorRequirement]+behaviorRequirementsFor aggregate =+  case Behavior.deriveAggregateBehaviorRequirements (aSpec aggregate) (aAggregate aggregate) of+    Left derivationError -> error ("validated aggregate failed behavior derivation: " <> show derivationError)+    Right requirements -> sortOn Behavior.requirementKey requirements++renderBehaviorTextList :: [Text] -> Text+renderBehaviorTextList values = "[" <> T.intercalate ", " (map tshow values) <> "]"++regsEqualityExpression :: Agg -> Text+regsEqualityExpression aggregate = case aRegs aggregate of+  [] -> "regsEqual _ _ = True"+  registers ->+    "regsEqual left right = "+      <> T.intercalate+        " && "+        [ "(left K.! #" <> rrName register <> ") == (right K.! #" <> rrName register <> ")"+        | register <- registers+        ]++behaviorHoleModule :: Agg -> ScaffoldModule+behaviorHoleModule aggregate =+  ScaffoldModule+    { modulePath = T.unpack (T.replace "." "/" (aHolePrefix aggregate) <> "/BehaviorHoles.hs"),+      moduleText = emitBehaviorHoles aggregate,+      kind = HoleStub,+      origin = nodeOrigin "aggregate behavior witnesses" (aName aggregate) (aLoc aggregate)+    }++emitBehaviorHoles :: Agg -> Text+emitBehaviorHoles aggregate =+  nl $+    [ "-- Consumer-owned behavioral witnesses. Created once; never overwritten.",+      "module " <> aHolePrefix aggregate <> ".BehaviorHoles (behaviorWitnesses) where",+      "",+      "import " <> aGenPrefix aggregate <> ".BehaviorContract",+      "",+      "behaviorWitnesses :: [BehaviorWitness]",+      "behaviorWitnesses ="+    ]+      <> case behaviorRequirementsFor aggregate of+        [] -> ["  []"]+        requirements ->+          [ (if index == (0 :: Int) then "  [ " else "  , ")+              <> "Pending (BehaviorKey "+              <> tshow (Behavior.unBehaviorKey (Behavior.requirementKey requirement))+              <> ") -- "+              <> behaviorRequirementLabel aggregate requirement+          | (index, requirement) <- zip [0 ..] requirements+          ]+            <> ["  ]"]++-- | Emit the context-wide replay-audit target assembly.+--+-- There is one existential target per aggregate declaration. Process saga+-- aggregates are ordinary aggregate nodes referenced by 'SagaRef', so they are+-- included by the same single source of truth rather than being duplicated from+-- the process declaration.+scaffoldReplayAudit :: Context -> Spec -> [ScaffoldModule]+scaffoldReplayAudit ctx spec+  | null aggregates = []+  | otherwise =+      [ ScaffoldModule+          { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),+            moduleText = emitReplayAudit,+            kind = Generated,+            origin = "context " <> specContext spec <> " replay-audit assembly"+          }+      ]+  where+    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]+    moduleName = contextGeneratedPrefix ctx <> ".ReplayAudit"+    emitReplayAudit =+      nl $+        renderGeneratedLanguagePragmas []+          <> [ generatedBanner,+               "--",+               "-- Deployment contract:",+               "--   * replay-neutral diff: no data audit is required;",+               "--   * affected diff: run AuditTargeted with the emitted affected set",+               "--     against a production copy under the candidate binary;",+               "--   * one-time runtime cutover: run AuditFull;",+               "--   * any non-zero audit exit blocks deployment.",+               "module " <> moduleName <> " (auditTargets) where",+               ""+             ]+          ++ [ "import " <> genPrefixFor ctx (aggName aggregate) <> ".EventStream qualified as " <> aggName aggregate+             | aggregate <- aggregates+             ]+          ++ [ "import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory)",+               "import Keiro.Stream qualified as Stream",+               "",+               "auditTargets :: [SomeAuditTarget]",+               "auditTargets ="+             ]+          ++ concat+            [ [ if index == (0 :: Int) then "  [ SomeAuditTarget" else "  , SomeAuditTarget",+                "      AuditTarget",+                "        { eventStream = " <> aggregateName <> "." <> lowerFirst aggregateName <> "EventStream",+                "        , category = Stream.categoryText " <> aggregateName <> "." <> lowerFirst aggregateName <> "Category",+                "        , mkStream = streamInCategory (Stream.categoryText " <> aggregateName <> "." <> lowerFirst aggregateName <> "Category)",+                "        }"+              ]+            | (index, aggregate) <- zip [0 ..] aggregates,+              let aggregateName = aggName aggregate+            ]+          ++ ["  ]"]++genModule :: Agg -> Text -> Text -> ScaffoldModule+genModule a name body =+  ScaffoldModule+    { modulePath = T.unpack (T.replace "." "/" (aGenPrefix a) <> "/" <> name <> ".hs"),+      moduleText = body,+      kind = Generated,+      origin = nodeOrigin "aggregate" (aName a) (aLoc a)+    }++holeModule :: Agg -> Text -> ScaffoldModule+holeModule a body =+  ScaffoldModule+    { modulePath = T.unpack (T.replace "." "/" (aHolePrefix a) <> "/" <> "Holes.hs"),+      moduleText = body,+      kind = HoleStub,+      origin = nodeOrigin "aggregate" (aName a) (aLoc a)+    }++--------------------------------------------------------------------------------+-- Integration contract (EP-4): a self-contained payload ADT + codec+--------------------------------------------------------------------------------++-- | Emit the deterministic, symbol-free contract layer: a payload ADT+-- (per-event records), the topic constants, the @messageType@ discriminator, and a+-- strict encode\/decode keyed by it. Self-contained (base\/text\/aeson), so it+-- compiles standalone — the cross-service schema both producer and consumer agree+-- on. No keiki symbolic operator (firewall holds).+scaffoldContract :: Context -> ContractNode -> [ScaffoldModule]+scaffoldContract ctx = scaffoldContractWithLanguage ctx (effectiveLanguageContract LegacyUnversioned)++-- | Emit a contract under the checked service's released semantic contract.+-- Language versions 1 through 3 retain the legacy Text representation; only+-- runtime semantics 3 lowers declared TypeID fields to prefix-indexed KindIDs.+scaffoldContractForService :: Context -> CheckedService -> ContractNode -> [ScaffoldModule]+scaffoldContractForService ctx service = scaffoldContractWithLanguage ctx (checkedLanguageContract service)++scaffoldContractWithLanguage :: Context -> EffectiveLanguageContract -> ContractNode -> [ScaffoldModule]+scaffoldContractWithLanguage ctx languageContract c =+  [ ScaffoldModule+      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Contract.hs"),+        moduleText = emitContractGen languageContract genPrefix c,+        kind = Generated,+        origin = nodeOrigin "contract" (ctrName c) (ctrLoc c)+      }+  ]+  where+    genPrefix = genPrefixFor ctx (pascal (ctrName c))++emitContractGen :: EffectiveLanguageContract -> Text -> ContractNode -> Text+emitContractGen languageContract genPrefix c =+  ( nl $+      pragmas+        ++ [generatedBanner]+        ++ moduleHeader+        ++ [ "",+             -- 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+        ++ [ "import Data.Text (Text)",+             "import qualified Data.Text as T"+           ]+        ++ ["import Keiro.Codec.IdDomain (parseKindIdV7Value)" | hasTypedTypeIds]+        ++ [ "",+             "-- topic constants"+           ]+        ++ topicConstants+        ++ [ "",+             "-- the closed payload set (discriminated by " <> tshow (ctrDiscriminator c) <> ")"+           ]+        ++ [emitPayloadAdt languageContract payloadTy (ctrEvents c)]+        ++ [ "",+             "messageTypeOf :: " <> payloadTy <> " -> Text",+             "messageTypeOf = \\case"+           ]+        ++ ["  " <> ceName e <> " {} -> " <> tshow (ceName e) | e <- ctrEvents c]+        ++ [ "",+             "encode" <> payloadTy <> " :: " <> payloadTy <> " -> Value",+             "encode" <> payloadTy <> " = \\case"+           ]+        ++ concatMap encodeArm (ctrEvents c)+        ++ [ "",+             "parse" <> payloadTy <> " :: Value -> Either Text " <> payloadTy,+             "parse" <> payloadTy <> " = mapLeftText . parseEither (withObject " <> tshow payloadTy <> " go)",+             "  where",+             "    go o = do",+             "      kind <- explicitParseField (withText " <> tshow (ctrDiscriminator c) <> " validateMessageType) o " <> tshow (ctrDiscriminator c),+             "      case kind of"+           ]+        ++ concatMap decodeArm (ctrEvents c)+        ++ [ "        _ -> fail \"validated message type was not handled\"",+             "",+             "mapLeftText :: Either String b -> Either Text b",+             "mapLeftText = either (Left . T.pack) Right",+             "",+             "validateMessageType :: Text -> Parser Text",+             "validateMessageType kind",+             "  | kind `elem` " <> renderTextList (map ceName (ctrEvents c)) <> " = pure kind",+             "  | otherwise = " <> renderUnknownFailure "message type" "kind" (map ceName (ctrEvents c))+           ]+  )+    <> if hasTypedTypeIds then "\n" else ""+  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]+            <> [ExtOverloadedRecordDot | contractUsesRecordDot c]+        )+    typedKindIdImports+      | hasTypedTypeIds = ["import Data.KindID (KindID)", "import qualified Data.KindID as KindID"]+      | otherwise = []+    moduleHeader =+      [ "module " <> genPrefix <> ".Contract",+        "  ( " <> payloadTy <> " (..)"+      ]+        ++ ["  , " <> ceName event <> "Data (..)" | event <- ctrEvents c]+        ++ ["  , " <> lowerFirst alias <> "Topic" | (alias, _) <- ctrTopics c]+        ++ [ "  , messageTypeOf",+             "  , encode" <> payloadTy,+             "  , parse" <> payloadTy,+             "  ) where"+           ]+    topicConstants+      | hasTypedTypeIds =+          [ T.intercalate+              "\n\n"+              [lowerFirst alias <> "Topic :: Text\n" <> lowerFirst alias <> "Topic = " <> tshow topic | (alias, topic) <- ctrTopics c]+          ]+      | otherwise = [lowerFirst alias <> "Topic :: Text\n" <> lowerFirst alias <> "Topic = " <> tshow topic | (alias, topic) <- ctrTopics c]+    isTypedTypeId (CTypeId prefix) = isJust (contractIdDomainContractFor languageContract prefix)+    isTypedTypeId _ = False+    aesonTypesImport = "import Data.Aeson.Types (Parser, explicitParseField, parseEither)"+    encodeArm e =+      [ "  " <> ceName e <> " payload ->",+        "    object"+      ]+        ++ objectEntriesFor ((tshow (ctrDiscriminator c) <> " .= (" <> tshow (ceName e) <> " :: Text)") : map encodeField (ceFields e))+        ++ ["      ]"]+    lead 0 kv = "      [ " <> kv+    lead _ kv = "      , " <> kv+    objectEntriesFor entries+      | hasTypedTypeIds =+          [ (if index == 0 then "      [ " else "        ")+              <> entry+              <> if index < length entries - 1 then "," else ""+          | (index, entry) <- zip [(0 :: Int) ..] entries+          ]+      | otherwise = [lead index entry | (index, entry) <- zip [(0 :: Int) ..] entries]+    decodeArm e =+      ["        " <> tshow (ceName e) <> " ->"]+        ++ case ceFields e of+          [] -> ["          pure (" <> ceName e <> " " <> ceName e <> "Data)"]+          fields ->+            [ "          " <> ceName e,+              "            <$> ( " <> ceName e <> "Data"+            ]+              ++ [ (if index == 0 then "                    <$> " else "                    <*> ") <> decodeField field+                 | (index, field) <- zip [(0 :: Int) ..] fields+                 ]+              ++ ["                )"]+    encodeField field =+      tshow (fieldWireKey identity)+        <> " .= "+        <> case cfType field of+          CTypeId prefix+            | 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 wireKey+      _ -> "o .: " <> tshow wireKey+      where+        wireKey = fieldWireKey (resolveContractFieldIdentity field)++contractNeedsDuplicateRecordFields :: ContractNode -> Bool+contractNeedsDuplicateRecordFields = hasDuplicateNames . concatMap (map (fieldSelector . resolveContractFieldIdentity) . ceFields) . ctrEvents++contractUsesRecordDot :: ContractNode -> Bool+contractUsesRecordDot = any (not . null . ceFields) . ctrEvents++emitPayloadAdt :: EffectiveLanguageContract -> Text -> [ContractEvent] -> Text+emitPayloadAdt languageContract tyName events =+  sectionsOf [map dataRecord events, [sumDecl]]+  where+    hasTypedTypeIds = any (any (isTypedTypeId . cfType) . ceFields) events+    isTypedTypeId (CTypeId prefix) = isJust (contractIdDomainContractFor languageContract prefix)+    isTypedTypeId _ = False+    hsType CText = "Text"+    hsType CInt = "Int"+    hsType (CTypeId prefix)+      | isJust (contractIdDomainContractFor languageContract prefix) = "(KindID " <> tshow prefix <> ")"+      | otherwise = "Text"+    dataRecord e =+      "data "+        <> ceName e+        <> "Data = "+        <> ceName e+        <> (if hasTypedTypeIds then "Data {" else "Data { ")+        <> 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+      [] -> "data " <> tyName <> " = " <> tyName <> "Empty\n  deriving stock (Eq, Show)"+      (e : es) ->+        nl+          ( (if hasTypedTypeIds then ["data " <> tyName, "  = " <> arm e] else ["data " <> tyName <> " = " <> arm e])+              ++ ["  | " <> arm e2 | e2 <- es]+              ++ ["  deriving stock (Eq, Show)"]+          )++--------------------------------------------------------------------------------+-- Integration intake (EP-4): inbox disposition vs the live Keiro.Inbox runtime+--------------------------------------------------------------------------------++-- | Emit the inbox node's deterministic disposition wiring compiled against the+-- LIVE @Keiro.Inbox.Types@: the dedupe policy (a real 'InboxDedupePolicy') and a+-- disposition function over the real @InboxResult@ (including handler+-- failures). This pins the dangerous inversions+-- (duplicate ⇒ ackOk, previouslyFailed ⇒ deadLetter) as compiled code over the+-- runtime types. The complete declared classification table is also available+-- to handler holes through a closed generated outcome type. Firewall holds (no+-- keiki symbolic operator).+scaffoldIntake :: Context -> IntakeNode -> [ScaffoldModule]+scaffoldIntake ctx i =+  [ ScaffoldModule+      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Inbox.hs"),+        moduleText = emitIntakeGen genPrefix i,+        kind = Generated,+        origin = nodeOrigin "intake" (inkName i) (inkLoc i)+      }+  ]+  where+    genPrefix = genPrefixFor ctx (pascal (inkName i))++emitIntakeGen :: Text -> IntakeNode -> Text+emitIntakeGen genPrefix i =+  nl $+    renderGeneratedLanguagePragmas []+      <> [ generatedBanner,+           "module " <> genPrefix <> ".Inbox",+           "  ( InboxFailure (..)",+           "  , " <> outcomeType <> " (..)",+           "  , " <> dispositionType <> " (..)",+           "  , inboxDedupePolicy",+           "  , inboxPersistence",+           "  , inboxDispositionFor",+           "  , inboxDisposition",+           "  ) where",+           "",+           "import Data.Text (Text)",+           "import Keiro.Inbox.Types (InboxDedupePolicy (..), InboxPersistence (..), InboxResult (..), RetryDelay (..))",+           "",+           "-- The dedupe policy (hole-kind 4), lowered to the live InboxDedupePolicy.",+           "inboxDedupePolicy :: InboxDedupePolicy",+           "inboxDedupePolicy = " <> inkDedupePolicy i,+           "",+           "-- | Success-path envelope retention passed to runInboxTransactionWith.",+           "-- Failures always retain their full operator-facing dead-letter envelope.",+           "-- Dedupe-only success rows decode with an empty payload.",+           "inboxPersistence :: InboxPersistence",+           "inboxPersistence = " <> persistenceCtor (inkPersist i),+           "",+           "-- Runtime failure detail retained when the inbox wrapper reports a failed handler attempt.",+           "data InboxFailure = InboxFailure",+           "  { inboxFailureReason :: !Text",+           "  , inboxFailureAttempt :: !(Maybe Int)",+           "  }",+           "  deriving stock (Eq, Show)",+           "",+           "-- Every classification named by the spec. Keeping this closed makes the",+           "-- generated table exhaustive and gives handler holes typed inputs.",+           "data " <> outcomeType,+           "  = " <> T.intercalate "\n  | " outcomeConstructors,+           "  deriving stock (Eq, Show)",+           "",+           "-- The service's declared acknowledgement decision, including its details.",+           "data " <> dispositionType,+           "  = InboxAccept",+           "  | InboxRetryAfter !RetryDelay !(Maybe InboxFailure)",+           "  | InboxDeadLetter !(Maybe Text) !(Maybe InboxFailure)",+           "  deriving stock (Eq, Show)",+           "",+           "-- The complete disposition table (hole-kind 2).",+           "inboxDispositionFor :: " <> outcomeType <> " -> " <> dispositionType,+           "inboxDispositionFor outcome = case outcome of"+         ]+      ++ ["  " <> outcomeConstructor (drOutcome row) <> " -> " <> actionExpression (drAction row) | row <- inkDisposition i]+      ++ [ "",+           "-- Lower the LIVE Keiro.Inbox.Types.InboxResult without an open fallback.",+           "inboxDisposition :: InboxResult a -> " <> dispositionType,+           "inboxDisposition r = case r of",+           "  InboxProcessed _ -> inboxDispositionFor " <> outcomeConstructor "processed",+           "  InboxDuplicate -> inboxDispositionFor " <> outcomeConstructor "duplicate",+           "  InboxInProgress -> inboxDispositionFor " <> outcomeConstructor "inProgress",+           "  InboxPreviouslyFailed failureReason ->",+           "    maybe (inboxDispositionFor " <> outcomeConstructor "previouslyFailed" <> ")",+           "      (\\reason -> attachFailure (InboxFailure reason Nothing) (inboxDispositionFor " <> outcomeConstructor "previouslyFailed" <> "))",+           "      failureReason",+           "  InboxHandlerFailed reason attempts ->",+           "    attachFailure (InboxFailure reason (Just attempts)) (inboxDispositionFor " <> outcomeConstructor "storeFailed" <> ")",+           "",+           "attachFailure :: InboxFailure -> " <> dispositionType <> " -> " <> dispositionType,+           "attachFailure failure disposition = case disposition of",+           "  InboxRetryAfter delay _ -> InboxRetryAfter delay (Just failure)",+           "  InboxDeadLetter reason _ -> InboxDeadLetter reason (Just failure)",+           "  InboxAccept -> InboxAccept"+         ]+  where+    stem = pascal (inkName i)+    outcomeType = stem <> "Outcome"+    dispositionType = stem <> "Disposition"+    outcomeConstructor = (stem <>) . pascal+    outcomeConstructors = map (outcomeConstructor . drOutcome) (inkDisposition i)+    actionExpression IAckOk = "InboxAccept"+    actionExpression (IRetry win) = "InboxRetryAfter (RetryDelay " <> windowText win <> ") Nothing"+    actionExpression (IDeadLetter mr) = "InboxDeadLetter " <> maybe "Nothing" (\reason -> "(Just " <> tshow reason <> ")") mr <> " Nothing"+    persistenceCtor InkPersistFull = "PersistFullEnvelope"+    persistenceCtor InkPersistDedupeOnly = "PersistDedupeOnly"++--------------------------------------------------------------------------------+-- Integration publisher (EP-4): config vs the live Keiro.Outbox runtime+--------------------------------------------------------------------------------++-- | Emit the publisher's at-least-once policy compiled against the LIVE+-- @Keiro.Outbox.Types@: the ordering policy (a real 'OrderingPolicy'), the backoff+-- curve (a real 'BackoffSchedule'), and the max-attempts ceiling. Firewall holds.+scaffoldPublisher :: Context -> PublisherNode -> [ScaffoldModule]+scaffoldPublisher ctx pb =+  [ ScaffoldModule+      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Publisher.hs"),+        moduleText = emitPublisherGen genPrefix pb,+        kind = Generated,+        origin = nodeOrigin "publisher" (pubName pb) (pubLoc pb)+      }+  ]+  where+    genPrefix = genPrefixFor ctx (pascal (pubName pb))++emitPublisherGen :: Text -> PublisherNode -> Text+emitPublisherGen genPrefix pb =+  nl+    [ generatedBanner,+      "module " <> genPrefix <> ".Publisher",+      "  ( publisherOrdering",+      "  , publisherBackoff",+      "  , publisherMaxAttempts",+      "  ) where",+      "",+      -- 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,+      "",+      "publisherBackoff :: BackoffSchedule",+      "publisherBackoff = " <> backoffExpr (pubBackoff pb),+      "",+      "publisherMaxAttempts :: Int",+      "publisherMaxAttempts = " <> tshow' (pubMaxAttempts pb)+    ]+  where+    backoffExpr b = case boKind b of+      "constant" -> "ConstantBackoff " <> windowText (boWindow b)+      "exponential" ->+        "ExponentialBackoff ExponentialBackoffOptions { initial = "+          <> windowText (boWindow b)+          <> ", maxDelay = "+          <> maybe "0" windowText (boMax b)+          <> ", multiplier = "+          <> fromMaybe "0" (boMultiplier b)+          <> " }"+      _ -> "error \"keiro-dsl: unlowerable backoff kind\""++--------------------------------------------------------------------------------+-- pgmq workqueue (EP-5): a self-contained Job payload record + codec+--------------------------------------------------------------------------------++-- | Emit the deterministic, symbol-free pgmq layer: the Job payload record, the+-- field→wire-name JSON codec, and the captured physical\/dlq\/table name constants.+-- Self-contained (base\/text\/aeson). The fan-out body and the raw-SQL dedup+-- predicate are holes (not emitted). Firewall holds.+scaffoldWorkqueue :: Context -> WorkqueueNode -> [ScaffoldModule]+scaffoldWorkqueue ctx w =+  scaffoldWorkqueueWithQueueText ctx w (emitWorkqueueGen genPrefix w)+  where+    genPrefix = genPrefixFor ctx (pascal (wqName w))++-- | Service-aware workqueue generation resolves candidate type expressions+-- against the checked graph. Legacy scalar workqueues deliberately stay on+-- 'emitWorkqueueGen' so their generated bytes cannot drift.+scaffoldWorkqueueForService :: Context -> CheckedService -> WorkqueueNode -> [ScaffoldModule]+scaffoldWorkqueueForService ctx service workqueue =+  scaffoldWorkqueueWithQueueText ctx workqueue queueText+  where+    genPrefix = genPrefixFor ctx (pascal (wqName workqueue))+    queueText+      | any isTypedQueueField (wqPayload workqueue) =+          case checkedTypeGraph service of+            Left errors -> error ("checked workqueue type graph failed: " <> show errors)+            Right graph -> emitMappedWorkqueueGen ctx genPrefix graph workqueue+      | otherwise = emitWorkqueueGen genPrefix workqueue++scaffoldWorkqueueWithQueueText :: Context -> WorkqueueNode -> Text -> [ScaffoldModule]+scaffoldWorkqueueWithQueueText ctx w queueText =+  [ ScaffoldModule+      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Queue.hs"),+        moduleText = queueText,+        kind = Generated,+        origin = nodeOrigin "workqueue" (wqName w) (wqLoc w)+      },+    ScaffoldModule+      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/QueuePolicy.hs"),+        moduleText = emitQueuePolicy genPrefix w,+        kind = Generated,+        origin = nodeOrigin "workqueue" (wqName w) (wqLoc w)+      },+    ScaffoldModule+      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/QueueCodec.hs"),+        moduleText = emitQueueCodec genPrefix w,+        kind = Generated,+        origin = nodeOrigin "workqueue" (wqName w) (wqLoc w)+      }+  ]+  where+    genPrefix = genPrefixFor ctx (pascal (wqName w))++isTypedQueueField :: WqField -> Bool+isTypedQueueField field = case wqfType field of+  LegacyQueueScalar {} -> False+  TypedQueueExpression {} -> True++emitWorkqueueGen :: Text -> WorkqueueNode -> Text+emitWorkqueueGen genPrefix w =+  nl $+    renderGeneratedLanguagePragmas [ExtOverloadedRecordDot | workqueueUsesRecordDot w]+      <> [ generatedBanner,+           "module " <> genPrefix <> ".Queue",+           "  ( " <> payloadTy <> " (..)",+           "  , encode" <> payloadTy,+           "  , parse" <> payloadTy,+           "  , queuePhysical, queueDlq, queueTable",+           groupKeyExport,+           "  ) where",+           "",+           "import Data.Aeson (Value, object, withObject, (.:), (.=))",+           "import Data.Aeson.Types (parseEither)",+           "import Data.Text (Text)",+           "import qualified Data.Text as T",+           "",+           "queuePhysical, queueDlq, queueTable :: Text",+           "queuePhysical = " <> tshow (wqPhysical w),+           "queueDlq = " <> tshow (wqDlq w),+           "queueTable = " <> tshow (wqTable w),+           ""+         ]+      ++ groupKeyLines+      ++ [ "data " <> payloadTy <> " = " <> payloadTy,+           "  { " <> T.intercalate "\n  , " [wqfName f <> " :: !" <> payloadFieldType f | f <- wqPayload w],+           "  }",+           "  deriving stock (Eq, Show)",+           "",+           "encode" <> payloadTy <> " :: " <> payloadTy <> " -> Value",+           "encode" <> payloadTy <> " p =",+           "  object"+         ]+      ++ [lead i (tshow (wqfWire f) <> " .= p." <> wqfName f) | (i, f) <- zip [(0 :: Int) ..] (wqPayload w)]+      ++ [ "    ]",+           "",+           "parse" <> payloadTy <> " :: Value -> Either Text " <> payloadTy,+           "parse" <> payloadTy <> " = mapLeftText . parseEither (withObject " <> tshow payloadTy <> " go)",+           "  where",+           "    go o = " <> payloadTy <> fieldApps (wqPayload w),+           "",+           "mapLeftText :: Either String b -> Either Text b",+           "mapLeftText = either (Left . T.pack) Right"+         ]+  where+    payloadTy = wqPayloadName w+    payloadFieldType field = case wqfType field of+      LegacyQueueScalar scalar -> hsType (queueScalarName scalar)+      TypedQueueExpression _ -> error "keiro-dsl internal invariant: mapped queue lowering is pending"+    groupKeyExport = case wqGroupKey w of+      Nothing -> ""+      Just groupKey+        | gkVia groupKey == "raw" -> "  , groupKeyField, groupKeyFor"+        | otherwise -> "  , groupKeyField"+    groupKeyLines = case wqGroupKey w of+      Nothing -> []+      Just groupKey -> common <> derivationLines groupKey+        where+          common =+            [ "groupKeyField :: Text",+              "groupKeyField = " <> tshow (gkField groupKey),+              ""+            ]+          derivationLines key+            | gkVia key == "raw" =+                [ "groupKeyFor :: " <> payloadTy <> " -> Text",+                  "groupKeyFor payload = payload." <> gkField key,+                  ""+                ]+            | otherwise =+                [ "-- Opaque group-key derivation '" <> gkVia key <> "' remains hand-owned.",+                  "-- Captured fixture: " <> fromMaybe "<missing>" (gkFixture key),+                  ""+                ]+    hsType "bool" = "Bool"+    hsType "int" = "Int"+    hsType _ = "Text"+    lead 0 kv = "    [ " <> kv+    lead _ kv = "    , " <> kv+    fieldApps [] = ""+    fieldApps fs = " <$> " <> T.intercalate " <*> " ["o .: " <> tshow (wqfWire f) | f <- fs]++data ResolvedQueueField = ResolvedQueueField+  { resolvedQueueField :: !WqField,+    resolvedQueueExpression :: !(Maybe ResolvedTypeExpr),+    resolvedQueueCodecPlan :: !(Maybe MappedCodecPlan)+  }++emitMappedWorkqueueGen :: Context -> Text -> TypeGraph -> WorkqueueNode -> Text+emitMappedWorkqueueGen ctx genPrefix graph workqueue =+  nl $+    renderGeneratedLanguagePragmas [ExtOverloadedRecordDot | workqueueUsesRecordDot workqueue]+      <> [ generatedBanner,+           "module " <> genPrefix <> ".Queue",+           "  ( " <> payloadType <> " (..)",+           "  , encode" <> payloadType,+           "  , parse" <> payloadType+         ]+      <> concatMap mappedCodecExports structuralDeclarations+      <> [ "  , queuePhysical, queueDlq, queueTable",+           groupKeyExport,+           "  ) where",+           ""+         ]+      <> mappedQueueImports+      <> [ "",+           "queuePhysical, queueDlq, queueTable :: Text",+           "queuePhysical = " <> tshow (wqPhysical workqueue),+           "queueDlq = " <> tshow (wqDlq workqueue),+           "queueTable = " <> tshow (wqTable workqueue),+           ""+         ]+      <> groupKeyLines+      <> [ "data " <> payloadType <> " = " <> payloadType,+           "  { " <> T.intercalate "\n  , " [wqfName raw <> " :: " <> strictQueueFieldType (queueFieldType field) | field@ResolvedQueueField {resolvedQueueField = raw} <- fields],+           "  }",+           "  deriving stock (Eq, Show)",+           ""+         ]+      <> (if hasStructural then [T.intercalate "\n\n" [emitStructuralCodec importPlan ctx graph declaration shape | ResolvedStructural declaration shape <- declarations], ""] else [])+      <> [ "encode" <> payloadType <> " :: " <> payloadType <> " -> Value",+           "encode" <> payloadType <> " payload =",+           "  object"+         ]+      <> [queueLead index (tshow (wqfWire raw) <> " .= " <> encodeQueueField field) | (index, field@ResolvedQueueField {resolvedQueueField = raw}) <- zip [(0 :: Int) ..] fields]+      <> [ "    ]",+           "",+           "parse" <> payloadType <> " :: Value -> Either Text " <> payloadType,+           "parse" <> payloadType <> " = mapLeftText . parseEither (withObject " <> tshow payloadType <> " go)",+           "  where",+           "    go objectValue = " <> payloadType <> queueFieldApplications fields,+           "",+           "mapLeftText :: Either String b -> Either Text b",+           "mapLeftText = either (Left . T.pack) Right"+         ]+      <> optionalFieldHelper+      <> unknownFieldHelper+  where+    payloadType = wqPayloadName workqueue+    fields = map resolveField (wqPayload workqueue)+    resolveField raw = case wqfType raw of+      LegacyQueueScalar {} -> ResolvedQueueField raw Nothing Nothing+      TypedQueueExpression expression ->+        case resolveTypeExpression graph owner (wqfLoc raw) expression of+          Left failure -> error ("checked queue expression failed: " <> show failure)+          Right resolved ->+            ResolvedQueueField raw (Just resolved) (Just (mappedCodecPlanOrDie graph resolved))+      where+        owner = "workqueue '" <> wqName workqueue <> "' payload field '" <> wqfName raw <> "'"+    plans = [plan | ResolvedQueueField {resolvedQueueCodecPlan = Just plan} <- fields]+    rootExpressions = [expression | ResolvedQueueField {resolvedQueueExpression = Just expression} <- fields]+    selectedKeys = Set.unions (map (dependencies . consumerType) plans)+    declarations = mapMaybe (`Map.lookup` tgDeclarations graph) (Set.toAscList selectedKeys)+    structuralDeclarations = [(declaration, shape) | ResolvedStructural declaration shape <- declarations]+    mappedCodecExports (declaration, _) =+      [ "  , encode" <> sdName declaration <> "Mapped",+        "  , decode" <> sdName declaration <> "Mapped"+      ]+    hasStructural = not (null structuralDeclarations)+    allExpressions = rootExpressions <> concatMap (shapeTypeExpressions . snd) structuralDeclarations+    importsPlanReferences =+      Set.unions (map (consumerTypeReferences . consumerType) plans)+        <> Set.fromList+          [ reference+          | (declaration, shape) <- structuralDeclarations,+            reference <-+              haskellTypeReference (sdHaskell declaration)+                : qualifiedValueReference (sdBinding declaration)+                : structuralShapeReferences ctx declaration shape+          ]+    importPlan =+      planImportsOrDie+        (genPrefix <> ".Queue")+        (Set.singleton payloadType)+        importsPlanReferences+    plannedModules = Set.map referenceModule importsPlanReferences+    opaqueInstanceImports =+      sort . nub $+        [ hsModule (odHaskell declaration) <> " ()"+        | ResolvedOpaque declaration <- declarations,+          Set.notMember (hsModule (odHaskell declaration)) plannedModules+        ]+    usesMap = any typeUsesMap allExpressions+    usesOptionalValue = any typeUsesOptional allExpressions+    usesNatural = any typeUsesNatural rootExpressions+    usesTime = any typeUsesTime rootExpressions+    usesParseJson = any (typeUsesParseJson graph) allExpressions+    usesToJson = any (typeUsesToJson graph) allExpressions+    usesValueConstructors = usesOptionalValue || any isEnumShape (map snd structuralDeclarations)+    usesWithText = any isTextShape (map snd structuralDeclarations)+    usesUnknownRejection = any rejectsUnknown (map snd structuralDeclarations)+    usesOptionalField = any hasOptionalField (map snd structuralDeclarations)+    usesKeyMap = usesUnknownRejection || usesOptionalField+    usesParser = hasStructural || any typeUsesParserAnnotation allExpressions+    usesLegacyDecoder = any isLegacy fields+    mappedQueueImports =+      ["import Control.Monad (unless)" | usesUnknownRejection]+        <> ["import Data.Aeson (" <> T.intercalate ", " aesonImports <> ")"]+        <> ["import Data.Aeson.Key qualified as Key" | usesKeyMap]+        <> ["import Data.Aeson.KeyMap qualified as KeyMap" | usesKeyMap]+        <> ["import Data.Aeson.Types (" <> T.intercalate ", " aesonTypesImports <> ")"]+        <> (if usesMap then ["import Data.Map.Strict (Map)", "import Data.Map.Strict qualified as Map"] else [])+        <> ["import Numeric.Natural (Natural)" | usesNatural]+        <> ["import Data.Time (UTCTime)" | usesTime]+        <> [ "import Data.Text (Text)",+             "import qualified Data.Text as T"+           ]+        <> ["import Keiro.Codec.Structural (bindingFromShape, bindingToShape)" | hasStructural]+        <> map ("import " <>) opaqueInstanceImports+        <> T.lines (renderPlannedImports importPlan)+    aesonImports =+      [if usesValueConstructors then "Value (..)" else "Value", "object"]+        <> ["parseJSON" | usesParseJson]+        <> ["toJSON" | usesToJson]+        <> ["withObject"]+        <> ["withText" | usesWithText]+        <> ["(.:)" | usesLegacyDecoder]+        <> ["(.=)"]+    aesonTypesImports =+      ["Parser" | usesParser]+        <> ["explicitParseField", "parseEither"]+    queueFieldType ResolvedQueueField {resolvedQueueField = raw, resolvedQueueExpression = Nothing} = legacyQueueType raw+    queueFieldType ResolvedQueueField {resolvedQueueExpression = Just expression} =+      unHaskellTypeOccurrence $+        either+          (error . ("validated queue consumer type rendering failed: " <>) . show)+          id+          (renderConsumerType importPlan graph expression)+    strictQueueFieldType rendered+      | T.any (== ' ') rendered && not ("[" `T.isPrefixOf` rendered) = "!(" <> rendered <> ")"+      | otherwise = "!" <> rendered+    legacyQueueType raw = case wqfType raw of+      LegacyQueueScalar scalar -> case queueScalarName scalar of+        "bool" -> "Bool"+        "int" -> "Int"+        _ -> "Text"+      TypedQueueExpression {} -> error "typed queue field reached legacy type rendering"+    encodeQueueField ResolvedQueueField {resolvedQueueField = raw, resolvedQueueCodecPlan = Nothing} = "payload." <> wqfName raw+    encodeQueueField ResolvedQueueField {resolvedQueueField = raw, resolvedQueueCodecPlan = Just plan} =+      renderMappedEncode graph ConsumerValueBoundary plan ("payload." <> wqfName raw)+    decodeQueueField ResolvedQueueField {resolvedQueueField = raw, resolvedQueueCodecPlan = Nothing} =+      "objectValue .: " <> tshow (wqfWire raw)+    decodeQueueField ResolvedQueueField {resolvedQueueField = raw, resolvedQueueCodecPlan = Just plan} =+      "explicitParseField ("+        <> renderMappedParse graph ConsumerValueBoundary plan+        <> ") objectValue "+        <> tshow (wqfWire raw)+    queueFieldApplications [] = ""+    queueFieldApplications values = " <$> " <> T.intercalate " <*> " (map decodeQueueField values)+    groupKeyExport = case wqGroupKey workqueue of+      Nothing -> ""+      Just groupKey+        | gkVia groupKey == "raw" -> "  , groupKeyField, groupKeyFor"+        | otherwise -> "  , groupKeyField"+    groupKeyLines = case wqGroupKey workqueue of+      Nothing -> []+      Just groupKey ->+        [ "groupKeyField :: Text",+          "groupKeyField = " <> tshow (gkField groupKey),+          ""+        ]+          <> if gkVia groupKey == "raw"+            then+              [ "groupKeyFor :: " <> payloadType <> " -> Text",+                "groupKeyFor payload = payload." <> gkField groupKey,+                ""+              ]+            else+              [ "-- Opaque group-key derivation '" <> gkVia groupKey <> "' remains hand-owned.",+                "-- Captured fixture: " <> fromMaybe "<missing>" (gkFixture groupKey),+                ""+              ]+    optionalFieldHelper =+      if usesOptionalField+        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 []+    unknownFieldHelper =+      if usesUnknownRejection+        then+          [ "",+            "rejectUnknownFields :: String -> [Text] -> KeyMap.KeyMap Value -> Parser ()",+            "rejectUnknownFields label allowed objectValue =",+            "  unless (null extras) (fail (label <> \" contains unknown fields: \" <> show extras))",+            "  where",+            "    extras = filter (`notElem` allowed) (map Key.toText (KeyMap.keys objectValue))"+          ]+        else []+    isLegacy ResolvedQueueField {resolvedQueueCodecPlan = Nothing} = True+    isLegacy ResolvedQueueField {resolvedQueueCodecPlan = Just _} = False+    isEnumShape REnum {} = True+    isEnumShape _ = False+    isTextShape REnum {} = True+    isTextShape RUnion {} = True+    isTextShape _ = False+    rejectsUnknown (RRecord _ RejectUnknown _) = True+    rejectsUnknown (RUnion encoding _) = ueUnknownFields encoding == RejectUnknown+    rejectsUnknown _ = False+    hasOptionalField (RRecord _ _ shapeFields) = any ((== POptional) . rwfPresence) shapeFields+    hasOptionalField _ = False++queueLead :: Int -> Text -> Text+queueLead 0 keyValue = "    [ " <> keyValue+queueLead _ keyValue = "    , " <> keyValue++typeUsesNatural :: ResolvedTypeExpr -> Bool+typeUsesNatural = foldTypeExpr (falseAlgebra {onNatural = True})+  where+    falseAlgebra = TypeExprAlgebra False False False False False False False id id id (const False)++typeUsesTime :: ResolvedTypeExpr -> Bool+typeUsesTime = foldTypeExpr (falseAlgebra {onTime = True})+  where+    falseAlgebra = TypeExprAlgebra False False False False False False False id id id (const False)++typeUsesText :: ResolvedTypeExpr -> Bool+typeUsesText = foldTypeExpr (falseAlgebra {onText = True, onMap = const True})+  where+    falseAlgebra = TypeExprAlgebra False False False False False False False id id id (const False)++typeUsesJson :: ResolvedTypeExpr -> Bool+typeUsesJson = foldTypeExpr (falseAlgebra {onJson = True})+  where+    falseAlgebra = TypeExprAlgebra False False False False False False False id id id (const False)++typeUsesParserAnnotation :: ResolvedTypeExpr -> Bool+typeUsesParserAnnotation = foldTypeExpr (falseAlgebra {onList = const True, onMap = const True})+  where+    falseAlgebra = TypeExprAlgebra False False False False False False False id id id (const False)++typeUsesParseJson :: TypeGraph -> ResolvedTypeExpr -> Bool+typeUsesParseJson graph =+  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 Map.lookup key (tgDeclarations graph) of+          Just ResolvedOpaque {} -> True+          _ -> False+      }++typeUsesToJson :: TypeGraph -> ResolvedTypeExpr -> Bool+typeUsesToJson = typeUsesParseJson++workqueueUsesRecordDot :: WorkqueueNode -> Bool+workqueueUsesRecordDot workqueue =+  not (null (wqPayload workqueue))+    || maybe False ((== "raw") . gkVia) (wqGroupKey workqueue)++-- | Emit the versioned PGMQ envelope adapter.  The payload record remains+-- symbol-free and dependency-light in Queue.hs; this runtime-facing module is+-- the opt-in assembly point applications import into their Job values.+emitQueueCodec :: Text -> WorkqueueNode -> Text+emitQueueCodec genPrefix w =+  nl+    [ generatedBanner,+      "-- | Versioned job payload envelope: @{\\\"v\\\",\\\"t\\\",\\\"data\\\"}@.",+      "--",+      "-- Deploy workers before producers when raising its schema version. Do not",+      "-- adopt this codec on a non-empty bare-payload queue without draining it",+      "-- (or supplying a transitional codec), or in-flight messages will",+      "-- dead-letter. This is telemetry-neutral:",+      "-- docs/adr/0001-keiro-pgmq-job-processing-telemetry-contract.md owns",+      "-- spans and acknowledgement vocabulary.",+      "module " <> genPrefix <> ".QueueCodec (" <> stem <> "PayloadCodec, " <> stem <> "JobCodec) where",+      "",+      "import Data.List.NonEmpty (NonEmpty (..))",+      "import Keiro.Codec (Codec (..), EventType (..))",+      "import Keiro.PGMQ.Codec (JobCodec, keiroJobCodec)",+      "import " <> genPrefix <> ".Queue (" <> payloadTy <> ", encode" <> payloadTy <> ", parse" <> payloadTy <> ")",+      "",+      stem <> "PayloadCodec :: Codec " <> payloadTy,+      stem <> "PayloadCodec =",+      "  Codec",+      "    { eventTypes = EventType " <> tshow payloadTy <> " :| []",+      "    , eventType = \\_ -> EventType " <> tshow payloadTy,+      "    , schemaVersion = 1",+      "    , encode = encode" <> payloadTy,+      "    , decode = \\_ -> parse" <> payloadTy,+      "    , upcasters = []",+      "    }",+      "",+      stem <> "JobCodec :: JobCodec " <> payloadTy,+      stem <> "JobCodec = keiroJobCodec " <> stem <> "PayloadCodec"+    ]+  where+    payloadTy = wqPayloadName w+    stem = lowerFirst (T.concat (map pascal (T.splitOn "_" (wqName w))))++-- | Emit the pgmq retry policy + JobOutcome disposition compiled against the+-- LIVE @Keiro.PGMQ.Job@ runtime (RetryPolicy / JobOutcome / RetryDelay). This pins+-- the dangerous inversions over the runtime types: storeFailure ⇒ Retry (transient)+-- and decodeFailure ⇒ Dead (poison).+emitQueuePolicy :: Text -> WorkqueueNode -> Text+emitQueuePolicy genPrefix w =+  nl $+    [ generatedBanner,+      "module " <> genPrefix <> ".QueuePolicy",+      "  ( " <> outcomeType <> " (..)",+      "  , retryPolicy, jobOutcomeFor",+      "  , jobOrdering, jobTuningFor, queueProvision",+      "  ) where",+      "",+      "import Keiro.PGMQ.Job (" <> T.intercalate ", " queuePolicyImports <> ")",+      "",+      "jobOrdering :: JobOrdering",+      "jobOrdering = " <> orderingCtor,+      "",+      "-- Deployment owns visibility timeout, batch size, and polling; the spec owns ordering.",+      "jobTuningFor :: JobTuning -> JobTuning",+      "jobTuningFor = withOrdering jobOrdering",+      "",+      "-- Pass this to ensureJobQueueWith at worker startup. FIFO adds the required GIN index; the DLQ remains standard.",+      "queueProvision :: QueueProvision",+      "queueProvision = " <> provisionExpr,+      "",+      "retryPolicy :: RetryPolicy",+      "retryPolicy =",+      "  RetryPolicy",+      "    { maxRetries = " <> tshow' (wqMaxRetries w),+      "    , defaultRetryDelay = RetryDelay " <> windowText (wqDelay w),+      "    , useDeadLetter = " <> (if wqDlqOn w then "True" else "False"),+      "    }",+      "",+      "-- The consumer JobOutcome disposition over the spec's named domain outcomes,",+      "-- lowered to the live Keiro.PGMQ.Job.JobOutcome.",+      "data " <> outcomeType,+      "  = " <> T.intercalate "\n  | " (map (pascal . wqdOutcome) (wqDisposition w)),+      "  deriving stock (Eq, Show)",+      "",+      "jobOutcomeFor :: " <> outcomeType <> " -> JobOutcome",+      "jobOutcomeFor o = case o of"+    ]+      ++ ["  " <> 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"+      WqFifoRoundRobin -> "FifoRoundRobin"+    provisionExpr = fifoWrap baseProvision+    fifoWrap expression = case wqOrdering w of+      WqUnordered -> expression+      _ -> "withFifoIndexProvision (" <> expression <> ")"+    baseProvision = case wqProvision w of+      WqStandard -> "standardProvision"+      WqUnlogged -> "unloggedProvision"+      WqPartitioned interval retention ->+        "partitionedProvision (PartitionSpec { partitionInterval = "+          <> tshow interval+          <> ", retentionInterval = "+          <> tshow retention+          <> " })"+    outcome IAckOk = "Done"+    outcome (IRetry win) = "Retry (RetryDelay " <> windowText win <> ")"+    outcome (IDeadLetter mr) = "Dead " <> tshow (fromMaybe "dead-lettered" mr)++--------------------------------------------------------------------------------+-- First-class read models (EP-107)+--------------------------------------------------------------------------------++-- | Emit an acyclic three-module read-model vertical. @ReadModelTable@ owns the+-- qualified-table constant shared by the hand-owned query and the generated+-- runtime record; @ReadModel@ re-exports it as part of the public surface.+scaffoldReadModel :: Context -> ReadModelNode -> [ScaffoldModule]+scaffoldReadModel ctx readModel =+  [ generated "ReadModelTable" (emitReadModelTable tableModule stem readModel),+    generated "ReadModel" (emitReadModelGen ctx readModelModule tableModule readModelHolePrefix stem readModel),+    ScaffoldModule+      { modulePath = modulePathFor readModelHolePrefix "ReadModelHoles",+        moduleText = emitReadModelHoles tableModule readModelHolePrefix stem readModel,+        kind = HoleStub,+        origin = readModelOrigin+      }+  ]+  where+    nodeSegment = pascal (rmName readModel)+    stem = readModelStem readModel+    readModelModule = genPrefixFor ctx nodeSegment+    tableModule = readModelModule <> ".ReadModelTable"+    readModelHolePrefix = holePrefixFor ctx nodeSegment+    readModelOrigin = nodeOrigin "readmodel" (rmName readModel) (rmLoc readModel)+    generated leaf body =+      ScaffoldModule+        { modulePath = modulePathFor readModelModule leaf,+          moduleText = body,+          kind = Generated,+          origin = readModelOrigin+        }++-- | Service-aware read-model generation adds a generated query contract only+-- for the candidate typed query pair. Legacy read models stay on+-- 'scaffoldReadModel' so their generated and create-once bytes remain exact.+scaffoldReadModelForService :: Context -> CheckedService -> ReadModelNode -> [ScaffoldModule]+scaffoldReadModelForService ctx service readModel = case queryTypes readModel of+  Nothing ->+    [ generated "ReadModelTable" (emitReadModelTable tableModule stem readModel),+      generated "ReadModel" (emitReadModelGenWithContract ctx readModelModule tableModule readModelHolePrefix (ownerDerivedCursor service readModel) Nothing stem readModel),+      ScaffoldModule+        { modulePath = modulePathFor readModelHolePrefix "ReadModelHoles",+          moduleText = emitReadModelHoles tableModule readModelHolePrefix stem readModel,+          kind = HoleStub,+          origin = readModelOrigin+        }+    ]+  Just queryPair ->+    [ generated "ReadModelTable" (emitReadModelTable tableModule stem readModel),+      generated "QueryContract" (emitReadModelQueryContract queryContractModule graph stem readModel queryPair),+      generated "ReadModel" (emitReadModelGenWithContract ctx readModelModule tableModule readModelHolePrefix (ownerDerivedCursor service readModel) (Just queryContractModule) stem readModel),+      ScaffoldModule+        { modulePath = modulePathFor readModelHolePrefix "ReadModelHoles",+          moduleText = emitTypedReadModelHoles tableModule queryContractModule readModelHolePrefix stem readModel,+          kind = HoleStub,+          origin = readModelOrigin+        }+    ]+  where+    nodeSegment = pascal (rmName readModel)+    stem = readModelStem readModel+    readModelModule = genPrefixFor ctx nodeSegment+    tableModule = readModelModule <> ".ReadModelTable"+    queryContractModule = readModelModule <> ".QueryContract"+    readModelHolePrefix = holePrefixFor ctx nodeSegment+    readModelOrigin = nodeOrigin "readmodel" (rmName readModel) (rmLoc readModel)+    graph = case checkedTypeGraph service of+      Left errors -> error ("checked read-model type graph failed: " <> show errors)+      Right value -> value+    generated leaf body =+      ScaffoldModule+        { modulePath = modulePathFor readModelModule leaf,+          moduleText = body,+          kind = Generated,+          origin = readModelOrigin+        }++ownerDerivedCursor :: CheckedService -> ReadModelNode -> Maybe Text+ownerDerivedCursor service readModel = do+  ownerName <- case [ supplyProjectionOwner supply+                    | supply <- resolvedProjectionSupplies (checkedProjectionSupplies service),+                      supplyQueryModel supply == rmName readModel+                    ] of+    [name] -> Just name+    _ -> Nothing+  owner <- case [candidate | NProjectionOwner candidate <- specNodes (checkedSpec service), poName candidate == ownerName] of+    [candidate] -> Just candidate+    _ -> Nothing+  case poDelivery owner of+    DeliveryInline -> Nothing+    DeliverySubscription -> poSubscription owner++-- | Resolve a catalog-bound read model's physical binding to its backing+-- target's coordinates, by name. An unbound or unresolvable model is returned+-- unchanged; validation rejects those forms before scaffolding.+resolveCatalogReadModel :: Spec -> ReadModelNode -> ReadModelNode+resolveCatalogReadModel spec readModel = case rmGroup readModel of+  Nothing -> readModel+  Just _ ->+    let backingName = case rmBackingTarget readModel of+          Just name -> Just name+          Nothing -> case rmObservedTargets readModel of+            [single] -> Just single+            _ -> Nothing+     in case [target | NProjectionTarget target <- specNodes spec, Just (ptName target) == backingName] of+          target : _ -> readModel {rmSchema = ptSchema target, rmTable = ptTable target}+          [] -> readModel++-- | Generate one service-level catalog facade and one create-once module that+-- owns application handler/decoder bodies. The checked DSL graph owns every+-- identity and relationship; the hole supplies only executable projection+-- sets, never a second inventory.+scaffoldProjectionCatalog :: Context -> Spec -> [ScaffoldModule]+scaffoldProjectionCatalog ctx spec =+  scaffoldProjectionCatalogWith+    (projectionAggregateSourceFingerprint spec)+    ctx+    spec+    (analyzeProjectionSupplies spec)++scaffoldProjectionCatalogForService :: Context -> CheckedService -> [ScaffoldModule]+scaffoldProjectionCatalogForService ctx service =+  scaffoldProjectionCatalogWith+    (projectionAggregateSourceFingerprintForService service)+    ctx+    (checkedSpec service)+    (checkedProjectionSupplies service)++scaffoldProjectionCatalogWith :: (Name -> Text) -> Context -> Spec -> ProjectionSupplyAnalysis -> [ScaffoldModule]+scaffoldProjectionCatalogWith aggregateFingerprint ctx spec supplyAnalysis+  | null catalogNodes = []+  | otherwise =+      [ ScaffoldModule+          { modulePath = modulePathFor (contextGeneratedPrefix ctx) "ProjectionCatalog",+            moduleText = emitProjectionCatalogWith aggregateFingerprint ctx spec supplyAnalysis,+            kind = Generated,+            origin = "projection-catalog " <> contextName ctx+          },+        ScaffoldModule+          { modulePath = modulePathFor (holePrefixFor ctx "ProjectionCatalog") "ProjectionCatalogHoles",+            moduleText = emitProjectionCatalogHoles ctx spec owners revisions externalReads,+            kind = HoleStub,+            origin = "projection-catalog " <> contextName ctx+          }+      ]+  where+    catalogNodes = [() | node <- specNodes spec, isCatalogNode node]+    owners = sortOn poOrder [owner | NProjectionOwner owner <- specNodes spec]+    revisions = sortOn prvName [revision | NProjectionRevision revision <- specNodes spec]+    externalReads = sortOn (\externalRead -> (erName externalRead, erVersion externalRead)) [externalRead | NExternalRead externalRead <- specNodes spec]+    isCatalogNode NProjectionTarget {} = True+    isCatalogNode NRebuildGroup {} = True+    isCatalogNode NProjectionRevision {} = True+    isCatalogNode NExternalRead {} = True+    isCatalogNode NProjectionOwner {} = True+    isCatalogNode _ = False++emitProjectionCatalogWith :: (Name -> Text) -> Context -> Spec -> ProjectionSupplyAnalysis -> Text+emitProjectionCatalogWith aggregateFingerprint ctx spec supplyAnalysis =+  nl $+    [ generatedBanner,+      "{-# LANGUAGE OverloadedStrings #-}",+      "module " <> moduleName,+      "  ( projectionCatalog",+      "  , validatedProjectionCatalog",+      "  , projectionCatalogInventory",+      "  , projectionCatalogRegistrations",+      "  , projectionCatalogAsyncRegistrations",+      "  , projectionCatalogQuerySupplies",+      "  , registerProjectionCatalog"+    ]+      ++ map (("  , " <>) . ownerSetName) owners+      ++ map (("  , " <>) . ownerInlineViewName) inlineOwners+      ++ map (("  , " <>) . aggregateInlineViewName . fst) aggregateInlineOwners+      ++ concatMap groupExports groups+      ++ [ "  ) where",+           "",+           "import Data.List.NonEmpty (NonEmpty (..))",+           "import Effectful (Eff, IOE, (:>))"+         ]+      ++ ["import Data.Map.Strict qualified as Map" | not (null revisions)]+      ++ concatMap aggregateImports aggregateSources+      ++ projectionImports+      ++ [ "import Keiro.Projection.Catalog qualified as Catalog",+           "import Keiro.ReadModel.Rebuild qualified as Rebuild",+           "import Kiroku.Store.Effect (Store)"+         ]+      ++ ["import Kiroku.Store.Types qualified as Kiroku" | any sourceUsesCategoryName sources]+      ++ ["import Kiroku.Store.Subscription.Types qualified as KirokuSubscription" | not (null asyncOwners)]+      ++ ["import " <> holesModule <> " qualified as Holes"]+      ++ map readModelImport readModels+      ++ [ "",+           "must :: Show error => Either error value -> value",+           "must = either (error . show) id"+         ]+      ++ concatMap ownerDefinition owners+      ++ concatMap aggregateInlineDefinition aggregateInlineOwners+      ++ [ "",+           "projectionCatalog :: Catalog.ProjectionCatalog",+           "projectionCatalog =",+           "  Catalog.ProjectionCatalog",+           "    " <> renderList sourceExpr sources,+           "    " <> renderList targetExpr targets,+           "    " <> renderList groupExpr groups,+           "    " <> renderList revisionExpr revisions,+           "    " <> renderList externalReadExpr externalReads,+           "    " <> renderList subscriptionExpr asyncOwners,+           "    " <> renderList dedupExpr asyncOwners,+           "    " <> renderList queryExpr boundReadModels,+           "    " <> renderList (("Catalog.SomeProjectionSet " <>) . ownerSetName) owners,+           "",+           "validatedProjectionCatalog :: Catalog.ValidatedProjectionCatalog",+           "validatedProjectionCatalog = case Catalog.validateProjectionCatalog projectionCatalog of",+           "  Catalog.Success catalog -> catalog",+           "  Catalog.Failure diagnostics -> error (\"keiro-dsl generated an invalid projection catalog: \" <> show diagnostics)",+           "",+           "projectionCatalogInventory :: Catalog.CatalogInventory",+           "projectionCatalogInventory = Catalog.catalogInventory validatedProjectionCatalog",+           "",+           "projectionCatalogRegistrations :: [Catalog.CatalogRegistration]",+           "projectionCatalogRegistrations = Catalog.catalogRegistrations validatedProjectionCatalog",+           "",+           "projectionCatalogAsyncRegistrations :: [Catalog.AsyncProjectionRegistration]",+           "projectionCatalogAsyncRegistrations = Catalog.asyncProjectionRegistrations validatedProjectionCatalog",+           "",+           "projectionCatalogQuerySupplies :: [Catalog.ResolvedQuerySupply]",+           "projectionCatalogQuerySupplies = Catalog.resolvedQuerySupplies validatedProjectionCatalog",+           "",+           "registerProjectionCatalog :: (Store :> es) => Eff es (Either Rebuild.CatalogRegistrationError [Rebuild.GroupRebuildMetadata])",+           "registerProjectionCatalog = Rebuild.registerProjectionCatalog validatedProjectionCatalog"+         ]+      ++ concatMap groupDefinitions groups+  where+    moduleName = contextGeneratedPrefix ctx <> ".ProjectionCatalog"+    holesModule = holePrefixFor ctx "ProjectionCatalog" <> ".ProjectionCatalogHoles"+    targets = [target | NProjectionTarget target <- specNodes spec]+    groups = [groupNode | NRebuildGroup groupNode <- specNodes spec]+    revisions = sortOn prvName [revision | NProjectionRevision revision <- specNodes spec]+    externalReads = sortOn (\externalRead -> (erName externalRead, erVersion externalRead)) [externalRead | NExternalRead externalRead <- specNodes spec]+    -- The catalog's list order is the declared total handler order. Keeping the+    -- sort here (rather than in the runtime) makes generated inventory and replay+    -- behavior agree even when declarations are arranged for readability.+    owners = sortOn poOrder [owner | NProjectionOwner owner <- specNodes spec]+    inlineOwners = [owner | owner <- owners, poDelivery owner == DeliveryInline]+    sources = nub (concatMap poSources owners)+    aggregateSources = nub [aggregateName | CatalogAggregate aggregateName <- sources]+    replayableAggregateSources =+      nub+        [ aggregateName+        | owner <- owners,+          poReplay owner == ProjectionReplayExplicit,+          CatalogAggregate aggregateName <- poSources owner+        ]+    asyncOwners = [owner | owner <- owners, poDelivery owner == DeliverySubscription]+    projectionImports = case (null asyncOwners, null inlineOwners) of+      (False, False) -> ["import Keiro.Projection (AsyncProjection (..), InlineProjection (..))"]+      (False, True) -> ["import Keiro.Projection (AsyncProjection (..))"]+      (True, False) -> ["import Keiro.Projection (InlineProjection (..))"]+      (True, True) -> []+    readModels = [readModel | NReadModel readModel <- specNodes spec]+    supplies = resolvedProjectionSupplies supplyAnalysis+    boundReadModels =+      [ readModel+      | supply <- supplies,+        readModel <- readModels,+        rmName readModel == supplyQueryModel supply+      ]+    readModelAlias readModel = "RM" <> pascal (rmName readModel)+    readModelImport readModel = "import " <> genPrefixFor ctx (pascal (rmName readModel)) <> ".ReadModel qualified as " <> readModelAlias readModel+    aggregateImports aggregateName =+      [ "import " <> genPrefixFor ctx aggregateName <> ".Codec qualified as " <> aggregateCodecAlias aggregateName+      | aggregateName `elem` replayableAggregateSources+      ]+        <> ["import " <> genPrefixFor ctx aggregateName <> ".Domain qualified as " <> aggregateDomainAlias aggregateName]+    aggregateCodecAlias aggregateName = pascal aggregateName <> "Codec"+    aggregateDomainAlias aggregateName = pascal aggregateName <> "Domain"+    sourceExpr source =+      "Catalog.SourceDeclaration "+        <> smart "mkSourceId" (catalogSourceId source)+        <> " "+        <> sourceScope source+        <> " "+        <> tshow (sourceFingerprint source)+        <> " "+        <> claim ("source " <> catalogSourceId source)+    sourceScope CatalogAll = "Catalog.AllStreams"+    sourceScope (CatalogCategory categoryName) = "(Catalog.CategorySource (Kiroku.CategoryName " <> tshow categoryName <> "))"+    sourceScope (CatalogAggregate aggregateName) = "(Catalog.CategorySource (Kiroku.CategoryName " <> tshow (lowerFirst aggregateName) <> "))"+    sourceFingerprint CatalogAll = "all-streams/generated-codec/v1"+    sourceFingerprint (CatalogCategory categoryName) = "category:" <> categoryName <> "/application-decoder/v1"+    sourceFingerprint (CatalogAggregate aggregateName) = aggregateFingerprint aggregateName+    sourceUsesCategoryName CatalogAll = False+    sourceUsesCategoryName CatalogCategory {} = True+    sourceUsesCategoryName CatalogAggregate {} = True+    targetExpr target =+      "Catalog.TargetDeclaration "+        <> smart "mkTargetId" (ptName target)+        <> " (Catalog.QualifiedTable "+        <> tshow (ptSchema target)+        <> " "+        <> tshow (ptTable target)+        <> ") "+        <> (case ptReset target of TargetClear -> "Catalog.ClearBeforeReplay"; TargetPreserve -> "Catalog.PreserveAndReconcile")+        <> " "+        <> renderList (smart "mkTargetId") (ptDependsOn target)+        <> " "+        <> claim ("target " <> ptName target)+    groupExpr groupNode =+      "Catalog.RebuildGroupDeclaration "+        <> smart "mkRebuildGroupId" (rgName groupNode)+        <> " "+        <> renderList (smart "mkTargetId") (rgOrder groupNode)+        <> " [] "+        <> claim ("rebuild-group " <> rgName groupNode)+    revisionExpr revision =+      "Catalog.ProjectionRevision "+        <> smart "mkProjectionRevisionId" (prvName revision)+        <> " "+        <> smart "mkRebuildGroupId" (prvGroup revision)+        <> " (Map.fromList "+        <> renderList (revisionTargetExpr revision) (prvTargets revision)+        <> ") "+        <> renderList (revisionLiveHandlerExpr revision) (revisionOwners revision)+        <> " "+        <> "[Catalog.RevisionReplayAdapter "+        <> tshow (prvName revision <> "/replay")+        <> " 1 "+        <> revisionRequiredTargets revision+        <> " Holes."+        <> revisionReplayName revision+        <> "] "+        <> "[Catalog.RevisionVerification "+        <> tshow (prvName revision <> "/verification")+        <> " 1 "+        <> revisionRequiredTargets revision+        <> " Holes."+        <> revisionVerificationName revision+        <> "] [] "+        <> claim ("projection-revision " <> prvName revision)+    revisionOwners revision = [owner | owner <- owners, poGroup owner == prvGroup revision]+    revisionLiveHandlerExpr revision owner =+      "Catalog.RevisionLiveHandler "+        <> tshow (prvName revision <> "/" <> poName owner <> "/live")+        <> " 1 "+        <> revisionLiveDeliveryExpr owner+        <> " "+        <> renderList (smart "mkTargetId") (poTargets owner)+        <> " Holes."+        <> revisionOwnerLiveName revision owner+    revisionLiveDeliveryExpr owner = case poDelivery owner of+      DeliveryInline ->+        "(Catalog.RevisionInlineDelivery "+          <> smart "mkProjectionId" (poName owner)+          <> " "+          <> tshow (poName owner)+          <> ")"+      DeliverySubscription ->+        "(Catalog.RevisionSubscriptionDelivery "+          <> smart "mkProjectionId" (poName owner)+          <> " "+          <> smart "mkSubscriptionId" (fromMaybe "" (poSubscription owner))+          <> " "+          <> smart "mkDedupKeyId" (fromMaybe "" (poDedup owner))+          <> ")"+    revisionTargetExpr revision target =+      "("+        <> smart "mkTargetId" (prtTarget target)+        <> ", Catalog.TargetProvisioner "+        <> tshow (prtProvisioner target)+        <> " "+        <> T.pack (show (prtProvisionerVersion target))+        <> " (Catalog.TargetSchemaVersion "+        <> tshow (prtSchemaVersion target)+        <> ") "+        <> tshow (prtExpectedShape target)+        <> " Holes."+        <> revisionProvisionName revision target+        <> " "+        <> tshow (prtValidator target)+        <> " "+        <> T.pack (show (prtValidatorVersion target))+        <> " (Just Holes."+        <> revisionValidateName revision target+        <> ") "+        <> renderList promotionObjectExpr (prtPromotionObjects target)+        <> ")"+    externalReadExpr externalRead =+      "Catalog.AllRowsExternalRead "+        <> smart "mkExternalReadContractId" (erName externalRead)+        <> " (Catalog.ExternalReadContractVersion "+        <> T.pack (show (erVersion externalRead))+        <> ") "+        <> smart "mkQueryModelId" (erQueryModel externalRead)+        <> " (Catalog.QualifiedSqlType "+        <> tshow (erResultSchema externalRead)+        <> " "+        <> tshow (erResultType externalRead)+        <> ") "+        <> tshow (externalReadShape externalRead)+        <> " "+        <> nonEmptyList (smart "mkProjectionRevisionId") (erCompatibleRevisions externalRead)+        <> " "+        <> T.pack (show (erSurfaceGeneration externalRead))+        <> " "+        <> claim ("external-read " <> erName externalRead <> " v" <> T.pack (show (erVersion externalRead)))+    externalReadShape externalRead = case [rmShape readModel | readModel <- readModels, rmName readModel == erQueryModel externalRead] of+      shape : _ -> shape+      [] -> "keiro-dsl invariant: validated external read query is missing"+    promotionObjectExpr promotionObject =+      "Catalog.PromotionObjectName "+        <> ( case rpoKind promotionObject of+               PromotionIndexNode -> "Catalog.PromotionIndex"+               PromotionConstraintNode -> "Catalog.PromotionConstraint"+               PromotionOwnedSequenceNode -> "Catalog.PromotionOwnedSequence"+           )+        <> " "+        <> tshow (rpoGenerationName promotionObject)+        <> " "+        <> tshow (rpoCanonicalName promotionObject)+    revisionRequiredTargets revision = renderList (smart "mkTargetId") (map prtTarget (prvTargets revision))+    subscriptionExpr owner =+      "Catalog.SubscriptionDeclaration "+        <> smart "mkSubscriptionId" (fromMaybe "" (poSubscription owner))+        <> " "+        <> tshow (fromMaybe "" (poSubscription owner))+        <> " "+        <> smart "mkSourceId" (catalogSourceId (ownerPrimarySource owner))+        <> " "+        <> checkpointOnMissingExpr owner+        <> " "+        <> claim ("projection-owner " <> poName owner <> " subscription")+    dedupExpr owner =+      "Catalog.DedupKeyDeclaration "+        <> smart "mkDedupKeyId" (fromMaybe "" (poDedup owner))+        <> " "+        <> tshow (fromMaybe "" (poDedup owner))+        <> " "+        <> claim ("projection-owner " <> poName owner <> " dedup")+    queryExpr readModel =+      "Catalog.SomeQueryModelBinding (Catalog.QueryModelBinding "+        <> smart "mkQueryModelId" (rmName readModel)+        <> " "+        <> readModelAlias readModel+        <> "."+        <> readModelStem readModel+        <> "ReadModel "+        <> smart "mkRebuildGroupId" (fromMaybe "" (rmGroup readModel))+        <> " "+        <> renderList (smart "mkTargetId") (sort (rmObservedTargets readModel))+        <> " "+        <> claim ("readmodel " <> rmName readModel)+        <> ")"+    ownerSetName owner = lowerFirst (pascal (poName owner)) <> "ProjectionSet"+    ownerInlineViewName owner = lowerFirst (pascal (poName owner)) <> "InlineProjections"+    aggregateInlineViewName aggregateName = lowerFirst (pascal aggregateName) <> "InlineProjections"+    aggregateInlineOwners =+      [ (aggregateName, matchingOwners)+      | aggregateName <- sort aggregateSources,+        let matchingOwners =+              [ owner+              | owner <- inlineOwners,+                ownerPrimarySource owner == CatalogAggregate aggregateName+              ],+        not (null matchingOwners)+      ]+    ownerEventType owner = case ownerPrimarySource owner of+      CatalogAggregate aggregateName -> aggregateDomainAlias aggregateName <> "." <> pascal aggregateName <> "Event"+      _ -> "Holes." <> pascal (poName owner) <> "Event"+    ownerDefinition owner =+      [ "",+        ownerSetName owner <> " :: Catalog.ProjectionSet " <> ownerEventType owner,+        ownerSetName owner <> " =",+        "  Catalog.ProjectionSet",+        "    " <> smart "mkSourceId" (catalogSourceId (ownerPrimarySource owner)),+        "    (Catalog.ProjectionDefinition",+        "      " <> smart "mkProjectionId" (poName owner),+        "      " <> smart "mkRebuildGroupId" (poGroup owner),+        "      " <> nonEmptyList (smart "mkTargetId") (poTargets owner),+        "      " <> replayPolicyExpr owner,+        "      (" <> handlerExpr owner <> " :| [])",+        "      " <> claim ("projection-owner " <> poName owner),+        "      :| [])",+        "    " <> claim ("projection-owner " <> poName owner <> " source")+      ]+        ++ if poDelivery owner == DeliveryInline+          then+            [ "",+              ownerInlineViewName owner <> " :: [InlineProjection " <> ownerEventType owner <> "]",+              ownerInlineViewName owner <> " = Catalog.typedInlineProjections validatedProjectionCatalog " <> ownerSetName owner+            ]+          else []+    aggregateInlineDefinition (aggregateName, sourceOwners) =+      [ "",+        aggregateInlineViewName aggregateName <> " :: [InlineProjection " <> aggregateDomainAlias aggregateName <> "." <> pascal aggregateName <> "Event]",+        aggregateInlineViewName aggregateName+          <> " = concat ["+          <> T.intercalate ", " (map ownerInlineViewName sourceOwners)+          <> "]"+      ]+    replayPolicyExpr owner = case poReplay owner of+      ProjectionLiveOnly reason -> "(Catalog.LiveOnly (Catalog.LiveOnlyReason " <> tshow reason <> "))"+      ProjectionReplayExplicit -> case ownerPrimarySource owner of+        CatalogAggregate aggregateName ->+          "(Catalog.Replayable (Catalog.replayAdapterFromCodec "+            <> aggregateCodecAlias aggregateName+            <> "."+            <> lowerFirst aggregateName+            <> "Codec Holes."+            <> ownerReplayApplyName owner+            <> "))"+        _ ->+          "(Catalog.Replayable (Catalog.ReplayAdapter Holes."+            <> ownerReplayDecodeName owner+            <> " Holes."+            <> ownerReplayApplyName owner+            <> "))"+    handlerExpr owner = case poDelivery owner of+      DeliveryInline ->+        "Catalog.InlineHandler (InlineProjection "+          <> tshow (poName owner)+          <> " Holes."+          <> ownerLiveApplyName owner+          <> ") "+          <> claim ("projection-owner " <> poName owner <> " inline-handler")+      DeliverySubscription ->+        "Catalog.AsyncHandler (AsyncProjection "+          <> tshow (fromMaybe "" (poDedup owner))+          <> " "+          <> tshow (ownerQueryRegistry owner)+          <> " "+          <> tshow (fromMaybe "" (poSubscription owner))+          <> " Holes."+          <> ownerLiveApplyName owner+          <> " Holes."+          <> ownerIdempotencyName owner+          <> ") "+          <> smart "mkSubscriptionId" (fromMaybe "" (poSubscription owner))+          <> " "+          <> smart "mkDedupKeyId" (fromMaybe "" (poDedup owner))+          <> " "+          <> claim ("projection-owner " <> poName owner <> " async-handler")+    ownerQueryRegistry owner = case matchingReadModels owner of+      readModel : _ -> registryNameFor (contextName ctx) readModel+      [] -> ""+    matchingReadModels owner =+      [ readModel+      | supply <- supplies,+        supplyProjectionOwner supply == poName owner,+        readModel <- boundReadModels,+        rmName readModel == supplyQueryModel supply+      ]+    ownerLiveApplyName owner = "apply" <> pascal (poName owner) <> "Live"+    ownerReplayApplyName owner = "apply" <> pascal (poName owner) <> "Replay"+    ownerReplayDecodeName owner = "decode" <> pascal (poName owner) <> "Replay"+    ownerIdempotencyName owner = lowerFirst (pascal (poName owner)) <> "IdempotencyKey"+    revisionProvisionName revision target = "provision" <> pascal (prvName revision) <> pascal (prtTarget target)+    revisionValidateName revision target = "validate" <> pascal (prvName revision) <> pascal (prtTarget target)+    revisionOwnerLiveName revision owner = "apply" <> pascal (prvName revision) <> pascal (poName owner) <> "Live"+    revisionReplayName revision = "apply" <> pascal (prvName revision) <> "Replay"+    revisionVerificationName revision = "verify" <> pascal (prvName revision)+    groupIdName groupNode = lowerFirst (pascal (rgName groupNode)) <> "RebuildGroupId"+    groupStartName groupNode = "start" <> pascal (rgName groupNode) <> "Rebuild"+    groupExports groupNode = ["  , " <> groupIdName groupNode, "  , " <> groupStartName groupNode]+    groupDefinitions groupNode =+      [ "",+        groupIdName groupNode <> " :: Catalog.RebuildGroupId",+        groupIdName groupNode <> " = " <> smart "mkRebuildGroupId" (rgName groupNode),+        "",+        groupStartName groupNode <> " :: (IOE :> es, Store :> es) => Rebuild.RebuildOptions -> Eff es (Either Rebuild.CatalogRebuildError Rebuild.RebuildRunReport)",+        groupStartName groupNode <> " = Rebuild.startCatalogRebuild validatedProjectionCatalog " <> groupIdName groupNode+      ]+    smart constructor value = "(must (Catalog." <> constructor <> " " <> tshow value <> "))"+    claim value = smart "mkClaimSite" value+    renderList render values = "[" <> T.intercalate ", " (map render values) <> "]"+    nonEmptyList _ [] = "error \"keiro-dsl invariant: validated projection owner has no targets\""+    nonEmptyList render (value : values) = "(" <> render value <> " :| " <> renderList render values <> ")"+    ownerPrimarySource owner = case poSources owner of+      source : _ -> source+      [] -> CatalogAll+    checkpointOnMissingExpr owner = case poCheckpointOnMissing owner of+      [CheckpointFromBeginning] -> "KirokuSubscription.FromBeginning"+      [CheckpointFromCurrentHead] -> "KirokuSubscription.FromCurrentHead"+      [CheckpointFail] -> "KirokuSubscription.FailIfMissing"+      _ -> "error \"keiro-dsl invariant: validated subscription owner must declare exactly one checkpoint-on-missing policy\""++emitProjectionCatalogHoles :: Context -> Spec -> [ProjectionOwnerNode] -> [ProjectionRevisionNode] -> [ExternalReadNode] -> Text+emitProjectionCatalogHoles ctx spec owners revisions externalReads =+  nl $+    [ "-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.",+      "module " <> moduleName,+      "  ( " <> T.intercalate "\n  , " exports,+      "  ) where",+      ""+    ]+      ++ ["import " <> genPrefixFor ctx aggregateName <> ".Domain (" <> pascal aggregateName <> "Event)" | aggregateName <- aggregateSources]+      ++ ["import Data.Text (Text)" | not (null revisions)]+      ++ ["import Data.List.NonEmpty (NonEmpty (..))" | not (null externalReads)]+      ++ [ "import Hasql.Transaction qualified as Tx",+           "import Keiro.Projection.Catalog qualified as Catalog",+           "import Kiroku.Store.Types (EventId, RecordedEvent)",+           ""+         ]+      ++ ( if null externalReads+             then []+             else+               [ "must :: Show error => Either error value -> value",+                 "must = either (error . show) id",+                 ""+               ]+         )+      ++ concatMap ownerStubs owners+      ++ concatMap revisionStubs revisions+      ++ concatMap externalReadStubs externalReads+  where+    moduleName = holePrefixFor ctx "ProjectionCatalog" <> ".ProjectionCatalogHoles"+    aggregateSources = nub [aggregateName | owner <- owners, CatalogAggregate aggregateName <- poSources owner]+    exports = concatMap ownerExports owners <> concatMap revisionExports revisions <> map externalReadKeyedName externalReads+    ownerExports owner =+      [pascal (poName owner) <> "Event" | not (isAggregateSource owner)]+        <> [ownerLiveApplyName owner]+        <> [ownerIdempotencyName owner | poDelivery owner == DeliverySubscription]+        <> case poReplay owner of+          ProjectionLiveOnly _ -> []+          ProjectionReplayExplicit -> [ownerReplayApplyName owner] <> [ownerReplayDecodeName owner | not (isAggregateSource owner)]+    ownerStubs owner =+      ["-- Projection owner " <> poName owner <> " (order " <> T.pack (show (poOrder owner)) <> ")."]+        <> ["data " <> ownerEventType owner <> " = " <> ownerEventType owner | not (isAggregateSource owner)]+        <> [ownerLiveSignature owner, ownerLiveApplyName owner <> " = error \"HOLE: fill " <> poName owner <> " live apply\""]+        <> ( if poDelivery owner == DeliverySubscription+               then+                 [ ownerIdempotencyName owner <> " :: RecordedEvent -> EventId",+                   ownerIdempotencyName owner <> " = error \"HOLE: return the durable event id for " <> poName owner <> "\""+                 ]+               else []+           )+        <> replayStubs owner+        <> [""]+    revisionExports revision =+      concatMap (\target -> [revisionProvisionName revision target, revisionValidateName revision target]) (prvTargets revision)+        <> map (revisionOwnerLiveName revision) (revisionOwners revision)+        <> [revisionReplayName revision, revisionVerificationName revision]+    revisionStubs revision =+      ["-- Projection revision " <> prvName revision <> "."]+        <> concatMap targetStubs (prvTargets revision)+        <> concatMap liveStubs (revisionOwners revision)+        <> [ revisionReplayName revision <> " :: Catalog.PhysicalTargets -> RecordedEvent -> Tx.Transaction (Either Catalog.ReplayDecodeError Bool)",+             revisionReplayName revision <> " = error \"HOLE: replay revision " <> prvName revision <> " through PhysicalTargets\"",+             revisionVerificationName revision <> " :: Catalog.PhysicalTargets -> Tx.Transaction (Either Text ())",+             revisionVerificationName revision <> " = error \"HOLE: verify revision " <> prvName revision <> " staging targets\"",+             ""+           ]+      where+        liveStubs owner =+          [ revisionOwnerLiveName revision owner <> " :: Catalog.PhysicalTargets -> RecordedEvent -> Tx.Transaction ()",+            revisionOwnerLiveName revision owner <> " = error \"HOLE: apply " <> poName owner <> " live events for revision " <> prvName revision <> " through its owned PhysicalTargets\""+          ]+        targetStubs target =+          [ revisionProvisionName revision target <> " :: Catalog.TargetProvisioningContext -> Tx.Transaction ()",+            revisionProvisionName revision target <> " = error \"HOLE: provision target " <> prtTarget target <> " for revision " <> prvName revision <> "\"",+            revisionValidateName revision target <> " :: Catalog.TargetProvisioningContext -> Tx.Transaction (Either [Catalog.TargetSchemaViolation] Catalog.TargetSchemaEvidence)",+            revisionValidateName revision target <> " = error \"HOLE: validate target " <> prtTarget target <> " for revision " <> prvName revision <> "\""+          ]+    externalReadStubs externalRead =+      [ "-- Keyed alternative for external-read " <> erName externalRead <> " v" <> T.pack (show (erVersion externalRead)) <> ".",+        "-- Supply typed arguments plus an application-owned private SQL function; do not grant callers access to that inner function.",+        externalReadKeyedName externalRead <> " :: [Catalog.SqlFunctionArgument] -> Catalog.QualifiedFunction -> Int -> Catalog.ExternalReadContract",+        externalReadKeyedName externalRead <> " arguments privateImplementation privateImplementationVersion =",+        "  Catalog.KeyedExternalRead",+        "    " <> smart "mkExternalReadContractId" (erName externalRead),+        "    (Catalog.ExternalReadContractVersion " <> T.pack (show (erVersion externalRead)) <> ")",+        "    " <> smart "mkQueryModelId" (erQueryModel externalRead),+        "    arguments",+        "    (Catalog.QualifiedSqlType " <> tshow (erResultSchema externalRead) <> " " <> tshow (erResultType externalRead) <> ")",+        "    privateImplementation",+        "    privateImplementationVersion",+        "    " <> tshow (externalReadShape externalRead),+        "    " <> nonEmptyList (smart "mkProjectionRevisionId") (erCompatibleRevisions externalRead),+        "    " <> T.pack (show (erSurfaceGeneration externalRead)),+        "    " <> smart "mkClaimSite" ("external-read " <> erName externalRead <> " v" <> T.pack (show (erVersion externalRead)) <> " keyed helper"),+        ""+      ]+    replayStubs owner = case poReplay owner of+      ProjectionLiveOnly _ -> []+      ProjectionReplayExplicit ->+        ( if not (isAggregateSource owner)+            then+              [ ownerReplayDecodeName owner <> " :: RecordedEvent -> Catalog.ReplayDecodeResult " <> ownerEventType owner,+                ownerReplayDecodeName owner <> " = error \"HOLE: classify and decode every " <> poName owner <> " source event\""+              ]+            else []+        )+          <> [ ownerReplayApplyName owner <> " :: " <> ownerEventType owner <> " -> RecordedEvent -> Tx.Transaction ()",+               ownerReplayApplyName owner <> " = error \"HOLE: fill " <> poName owner <> " replay apply without live-only side effects\""+             ]+    ownerLiveSignature owner =+      ownerLiveApplyName owner <> " :: " <> case poDelivery owner of+        DeliveryInline -> ownerEventType owner <> " -> RecordedEvent -> Tx.Transaction ()"+        DeliverySubscription -> "RecordedEvent -> Tx.Transaction ()"+    ownerEventType owner = case ownerPrimarySource owner of+      CatalogAggregate aggregateName -> pascal aggregateName <> "Event"+      _ -> pascal (poName owner) <> "Event"+    isAggregateSource owner = case ownerPrimarySource owner of CatalogAggregate {} -> True; _ -> False+    ownerPrimarySource owner = case poSources owner of source : _ -> source; [] -> CatalogAll+    ownerLiveApplyName owner = "apply" <> pascal (poName owner) <> "Live"+    ownerReplayApplyName owner = "apply" <> pascal (poName owner) <> "Replay"+    ownerReplayDecodeName owner = "decode" <> pascal (poName owner) <> "Replay"+    ownerIdempotencyName owner = lowerFirst (pascal (poName owner)) <> "IdempotencyKey"+    revisionProvisionName revision target = "provision" <> pascal (prvName revision) <> pascal (prtTarget target)+    revisionValidateName revision target = "validate" <> pascal (prvName revision) <> pascal (prtTarget target)+    revisionOwners revision = [owner | owner <- owners, poGroup owner == prvGroup revision]+    revisionOwnerLiveName revision owner = "apply" <> pascal (prvName revision) <> pascal (poName owner) <> "Live"+    revisionReplayName revision = "apply" <> pascal (prvName revision) <> "Replay"+    revisionVerificationName revision = "verify" <> pascal (prvName revision)+    externalReadKeyedName externalRead = lowerFirst (pascal (erName externalRead)) <> "V" <> T.pack (show (erVersion externalRead)) <> "KeyedExternalRead"+    externalReadShape externalRead = case [rmShape readModel | NReadModel readModel <- specNodes spec, rmName readModel == erQueryModel externalRead] of+      shape : _ -> shape+      [] -> "keiro-dsl invariant: validated external read query is missing"+    smart constructor value = "(must (Catalog." <> constructor <> " " <> tshow value <> "))"+    nonEmptyList _ [] = "error \"keiro-dsl invariant: validated external read has no compatible revisions\""+    nonEmptyList render (value : values) = "(" <> render value <> " :| [" <> T.intercalate ", " (map render values) <> "])"++catalogSourceId :: CatalogSource -> Text+catalogSourceId CatalogAll = "all"+catalogSourceId (CatalogCategory categoryName) = "category:" <> categoryName+catalogSourceId (CatalogAggregate aggregateName) = "aggregate:" <> aggregateName++modulePathFor :: Text -> Text -> FilePath+modulePathFor prefix leaf = T.unpack (T.replace "." "/" prefix <> "/" <> leaf <> ".hs")++readModelStem :: ReadModelNode -> Text+readModelStem = lowerFirst . T.concat . map pascal . T.splitOn "_" . rmName++emitReadModelTable :: Text -> Text -> ReadModelNode -> Text+emitReadModelTable tableModule stem readModel =+  nl+    [ generatedBanner,+      "module " <> tableModule <> " (" <> qualifiedName <> ") where",+      "",+      "import Data.Text (Text)",+      "import Keiro.Connection (qualifyTable)",+      "",+      "-- The fully-qualified, double-quoted data-table reference.",+      qualifiedName <> " :: Text",+      qualifiedName <> " = qualifyTable " <> tshow (rmSchema readModel) <> " " <> tshow (rmTable readModel)+    ]+  where+    qualifiedName = stem <> "QualifiedTable"++emitReadModelQueryContract :: Text -> TypeGraph -> Text -> ReadModelNode -> ReadModelQueryTypes -> Text+emitReadModelQueryContract queryContractModule graph stem readModel queryPair =+  nl $+    [ generatedBanner,+      "module " <> queryContractModule,+      "  ( " <> queryInputType,+      "  , " <> queryResultType,+      "  ) where",+      ""+    ]+      <> imports+      <> ["" | not (null imports)]+      <> [ "type " <> queryInputType <> " = " <> renderType inputExpression,+           "type " <> queryResultType <> " = " <> renderType resultExpression+         ]+  where+    queryInputType = pascal stem <> "QueryInput"+    queryResultType = pascal stem <> "QueryResult"+    inputExpression = resolve "input" (inputLoc queryPair) (input queryPair)+    resultExpression = resolve "result" (resultLoc queryPair) (result queryPair)+    expressions = [inputExpression, resultExpression]+    plans = map plan expressions+    references = Set.unions (map consumerTypeReferences plans)+    reservedNames = Set.fromList [queryInputType, queryResultType, "Map", "Natural", "Text", "UTCTime", "Value"]+    importPlan = planImportsOrDie queryContractModule reservedNames references+    imports =+      ["import Data.Aeson (Value)" | any typeUsesJson expressions]+        <> ["import Data.Map.Strict (Map)" | any typeUsesMap expressions]+        <> ["import Data.Text (Text)" | any typeUsesText expressions]+        <> ["import Data.Time (UTCTime)" | any typeUsesTime expressions]+        <> ["import Numeric.Natural (Natural)" | any typeUsesNatural expressions]+        <> T.lines (renderPlannedImports importPlan)+    resolve position location expression =+      either+        (\failure -> error ("checked read-model query " <> T.unpack position <> " failed: " <> show failure))+        id+        (resolveTypeExpression graph owner location expression)+      where+        owner = "readmodel '" <> rmName readModel <> "' query " <> position+    plan expression =+      either+        (error . ("validated read-model consumer type planning failed: " <>) . show)+        id+        (planConsumerType graph expression)+    renderType expression =+      unHaskellTypeOccurrence $+        either+          (error . ("validated read-model consumer type rendering failed: " <>) . show)+          id+          (renderConsumerType importPlan graph expression)++emitReadModelGen :: Context -> Text -> Text -> Text -> Text -> ReadModelNode -> Text+emitReadModelGen ctx readModelModule tableModule readModelHolePrefix stem readModel =+  emitReadModelGenWithContract ctx readModelModule tableModule readModelHolePrefix Nothing Nothing stem readModel++emitReadModelGenWithContract :: Context -> Text -> Text -> Text -> Maybe Text -> Maybe Text -> Text -> ReadModelNode -> Text+emitReadModelGenWithContract ctx readModelModule tableModule readModelHolePrefix resolvedCursor queryContractModule stem readModel =+  nl $+    renderGeneratedLanguagePragmas [ExtOverloadedRecordDot | emitsLegacyAsync]+      <> [ generatedBanner,+           "module " <> readModelModule <> ".ReadModel",+           "  ( " <> T.intercalate "\n  , " exports,+           "  ) where",+           ""+         ]+      ++ (if not catalogManaged then ["import Data.Functor (void)", "import Effectful (Eff, (:>))"] else [])+      ++ ["import " <> tableModule <> " (" <> qualifiedName <> ")"]+      ++ ["import " <> contractModule <> " (" <> queryInputType <> ", " <> queryResultType <> ")" | Just contractModule <- [queryContractModule]]+      ++ ["import " <> readModelHolePrefix <> ".ReadModelHoles (" <> T.intercalate ", " holeImports <> ")"]+      ++ asyncImports+      ++ [ "import Keiro.ReadModel (" <> readModelImports <> ")"+         ]+      ++ (if not catalogManaged then ["import Keiro.ReadModel.Rebuild qualified as Rebuild", "import Kiroku.Store.Effect (Store)", "import Kiroku.Store.Types (" <> kirokuTypes <> ")"] else [])+      ++ readModelDefinition+      ++ legacyLifecycleDefinitions+      ++ asyncDefinition+  where+    catalogManaged = rmGroup readModel /= Nothing+    ownerDerived = rmSupply readModel == OwnerDerivedSupply+    emitsLegacyAsync = not ownerDerived && not catalogManaged && legacyReadModelFeed readModel == Just RmSubscription+    registryName = registryNameFor (contextName ctx) readModel+    subscriptionName = subscriptionNameFor (contextName ctx) readModel+    asyncName = registryName <> "-async"+    readModelName = stem <> "ReadModel"+    qualifiedName = stem <> "QualifiedTable"+    registerName = "register" <> pascal stem+    startName = "start" <> pascal stem <> "Rebuild"+    finishName = "finish" <> pascal stem <> "Rebuild"+    abandonName = "abandon" <> pascal stem <> "Rebuild"+    asyncValueName = stem <> "AsyncProjection"+    queryInputType = pascal stem <> "QueryInput"+    queryResultType = pascal stem <> "QueryResult"+    queryName = stem <> "Query"+    applyName = "apply" <> pascal stem+    exports =+      [ readModelName,+        qualifiedName+      ]+        ++ (if not catalogManaged then [registerName, startName, finishName, abandonName] else [])+        ++ [asyncValueName | emitsLegacyAsync]+    holeImports = (if queryContractModule == Nothing then [queryInputType, queryResultType] else []) ++ [queryName] ++ [applyName | emitsLegacyAsync]+    asyncImports = ["import Keiro.Projection (AsyncProjection (..))" | emitsLegacyAsync]+    readModelImports =+      if ownerDerived+        then+          T.intercalate+            ", "+            ( ["QueryCursorAuthority (..)", "ReadModel", "ReadModelBlueprint (..)"]+                <> ( case rmFreshness readModel of+                       FreshnessImmediate -> ["immediateReadModel"]+                       FreshnessWaitForHead {} -> ["HeadScope (..)", "headWaitingReadModel"]+                   )+                <> if not catalogManaged then ["ReadModelMetadata", "registerReadModel"] else []+            )+        else+          "ConsistencyMode (..), ReadModel (..)"+            <> if catalogManaged+              then ", StrongScope (..)"+              else ", ReadModelMetadata, StrongScope (..), registerReadModel"+    kirokuTypes = case legacyReadModelFeed readModel of+      Just RmSubscription -> "GlobalPosition, RecordedEvent (..)"+      _ -> "GlobalPosition"+    projectionNames = case legacyReadModelFeed readModel of+      Just RmSubscription -> "[" <> tshow asyncName <> "]"+      _ -> "[]"+    readModelDefinition =+      [ "",+        readModelName <> " :: ReadModel " <> queryInputType <> " " <> queryResultType,+        readModelName <> " ="+      ]+        <> if ownerDerived+          then truthfulDefinition+          else legacyDefinition+    truthfulDefinition =+      ( case rmFreshness readModel of+          FreshnessImmediate -> ["  immediateReadModel " <> readModelBlueprintName]+          FreshnessWaitForHead scope ->+            [ "  case headWaitingReadModel " <> headScopeExpr scope <> " " <> readModelBlueprintName <> " of",+              "    Left definitionError -> error (\"keiro-dsl generated an invalid waiting read model: \" <> show definitionError)",+              "    Right model -> model"+            ]+      )+        <> [ "",+             readModelBlueprintName <> " :: ReadModelBlueprint " <> queryInputType <> " " <> queryResultType,+             readModelBlueprintName <> " =",+             "  ReadModelBlueprint",+             "    { name = " <> tshow registryName,+             "    , tableName = " <> tshow (rmTable readModel),+             "    , schema = " <> tshow (rmSchema readModel),+             "    , version = " <> tshow' (rmVersion readModel),+             "    , shapeHash = " <> tshow (rmShape readModel),+             "    , cursorAuthority = " <> maybe "NoQueryCursor" (("DurableQueryCursor " <>) . tshow) resolvedCursor,+             "    , query = " <> queryName,+             "    }"+           ]+    legacyDefinition =+      [ "  ReadModel",+        "    { name = " <> tshow registryName,+        "    , tableName = " <> tshow (rmTable readModel),+        "    , schema = " <> tshow (rmSchema readModel),+        "    , subscriptionName = " <> tshow subscriptionName,+        "    , version = " <> tshow' (rmVersion readModel),+        "    , shapeHash = " <> tshow (rmShape readModel),+        "    , defaultConsistency = " <> consistencyExpr legacyConsistency,+        "    , strongScope = " <> scopeExpr legacyScope,+        "    , query = " <> queryName,+        "    }"+      ]+    readModelBlueprintName = stem <> "ReadModelBlueprint"+    legacyConsistency = fromMaybe Eventual (legacyReadModelConsistency readModel)+    legacyScope = legacyReadModelScope readModel+    headScopeExpr RmEntireLog = "EntireVisibleLog"+    headScopeExpr (RmCategory categoryName) = "(CategoryVisibleHead " <> tshow categoryName <> ")"+    legacyLifecycleDefinitions+      | not catalogManaged =+          [ "",+            "-- Call once at projection startup before serving queries.",+            registerName <> " :: (Store :> es) => Eff es ()",+            registerName <> " =",+            "  void (registerReadModel " <> tshow registryName <> " " <> tshow' (rmVersion readModel) <> " " <> tshow (rmShape readModel) <> ")",+            "",+            startName <> " :: (Store :> es) => GlobalPosition -> Eff es ReadModelMetadata",+            startName <> " =",+            "  Rebuild.startRebuild " <> readModelName <> " " <> projectionNames,+            "",+            finishName <> " :: (Store :> es) => GlobalPosition -> Eff es (Either Rebuild.RebuildError ReadModelMetadata)",+            finishName <> " =",+            "  Rebuild.finishRebuild " <> readModelName <> " " <> projectionNames,+            "",+            abandonName <> " :: (Store :> es) => Eff es ReadModelMetadata",+            abandonName <> " = Rebuild.abandonRebuild " <> readModelName+          ]+      | otherwise = []+    asyncDefinition+      | emitsLegacyAsync =+          [ "",+            asyncValueName <> " :: AsyncProjection",+            asyncValueName <> " =",+            "  AsyncProjection",+            "    { name = " <> tshow asyncName,+            "    , readModelName = " <> tshow registryName,+            "    , subscriptionName = " <> tshow subscriptionName,+            "    , applyRecorded = " <> applyName,+            "    , idempotencyKey = \\recorded -> recorded.eventId",+            "    }"+          ]+      | otherwise = []+    consistencyExpr Strong = "Strong"+    consistencyExpr Eventual = "Eventual"+    scopeExpr Nothing = "EntireLog"+    scopeExpr (Just RmEntireLog) = "EntireLog"+    scopeExpr (Just (RmCategory categoryName)) = "CategoryHead " <> tshow categoryName++emitReadModelHoles :: Text -> Text -> Text -> ReadModelNode -> Text+emitReadModelHoles tableModule readModelHolePrefix stem readModel =+  nl $+    [ "-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.",+      "module " <> readModelHolePrefix <> ".ReadModelHoles",+      "  ( " <> T.intercalate "\n  , " exports,+      "  ) where",+      "",+      "import " <> tableModule <> " (" <> qualifiedName <> ")",+      "import Hasql.Transaction qualified as Tx"+    ]+      ++ ["import Kiroku.Store.Types (RecordedEvent(..))" | emitsLegacyAsync]+      ++ [ "",+           "-- HOLE: replace these aliases with the real query input and result types.",+           "type " <> queryInputType <> " = ()",+           "type " <> queryResultType <> " = ()",+           "",+           "-- HOLE: query " <> qualifiedTableLiteral readModel <> " via " <> qualifiedName <> "; never rely on search_path.",+           "-- Declared columns:"+         ]+      ++ map (("--   " <>) . readModelColumnDoc) (rmColumns readModel)+      ++ [ queryName <> " :: " <> queryInputType <> " -> Tx.Transaction " <> queryResultType,+           queryName <> " _input = " <> qualifiedName <> " `seq` error " <> tshow ("HOLE: fill " <> rmName readModel <> " query")+         ]+      ++ applyStub+  where+    qualifiedName = stem <> "QualifiedTable"+    queryInputType = pascal stem <> "QueryInput"+    queryResultType = pascal stem <> "QueryResult"+    queryName = stem <> "Query"+    applyName = "apply" <> pascal stem+    emitsLegacyAsync = rmGroup readModel == Nothing && legacyReadModelFeed readModel == Just RmSubscription+    exports = [queryInputType, queryResultType, queryName] ++ [applyName | emitsLegacyAsync]+    applyStub+      | emitsLegacyAsync =+          [ "",+            "-- HOLE: apply one recorded event; runtime deduplication makes redelivery safe.",+            applyName <> " :: RecordedEvent -> Tx.Transaction ()",+            applyName <> " _recorded = error " <> tshow ("HOLE: fill " <> rmName readModel <> " async apply")+          ]+      | otherwise = []++emitTypedReadModelHoles :: Text -> Text -> Text -> Text -> ReadModelNode -> Text+emitTypedReadModelHoles tableModule queryContractModule readModelHolePrefix stem readModel =+  nl $+    [ "-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.",+      "module " <> readModelHolePrefix <> ".ReadModelHoles",+      "  ( " <> T.intercalate "\n  , " exports,+      "  ) where",+      "",+      "import " <> tableModule <> " (" <> qualifiedName <> ")",+      "import " <> queryContractModule <> " (" <> queryInputType <> ", " <> queryResultType <> ")",+      "import Hasql.Transaction qualified as Tx"+    ]+      ++ ["import Kiroku.Store.Types (RecordedEvent(..))" | emitsLegacyAsync]+      ++ [ "",+           "-- HOLE: query " <> qualifiedTableLiteral readModel <> " via " <> qualifiedName <> "; never rely on search_path.",+           "-- The generated QueryContract owns query input/result type identity.",+           "-- Declared columns:"+         ]+      ++ map (("--   " <>) . readModelColumnDoc) (rmColumns readModel)+      ++ [ queryName <> " :: " <> queryInputType <> " -> Tx.Transaction " <> queryResultType,+           queryName <> " _input = " <> qualifiedName <> " `seq` error " <> tshow ("HOLE: fill " <> rmName readModel <> " query")+         ]+      ++ applyStub+  where+    qualifiedName = stem <> "QualifiedTable"+    queryInputType = pascal stem <> "QueryInput"+    queryResultType = pascal stem <> "QueryResult"+    queryName = stem <> "Query"+    applyName = "apply" <> pascal stem+    emitsLegacyAsync = rmGroup readModel == Nothing && legacyReadModelFeed readModel == Just RmSubscription+    exports = [queryName] ++ [applyName | emitsLegacyAsync]+    applyStub+      | emitsLegacyAsync =+          [ "",+            "-- HOLE: apply one recorded event; runtime deduplication makes redelivery safe.",+            applyName <> " :: RecordedEvent -> Tx.Transaction ()",+            applyName <> " _recorded = error " <> tshow ("HOLE: fill " <> rmName readModel <> " async apply")+          ]+      | otherwise = []++qualifiedTableLiteral :: ReadModelNode -> Text+qualifiedTableLiteral readModel = quoteSqlIdentifier (rmSchema readModel) <> "." <> quoteSqlIdentifier (rmTable readModel)++quoteSqlIdentifier :: Text -> Text+quoteSqlIdentifier identifier = "\"" <> T.replace "\"" "\"\"" identifier <> "\""++readModelColumnDoc :: RmColumn -> Text+readModelColumnDoc columnDecl =+  rmcName columnDecl+    <> " "+    <> rmcType columnDecl+    <> if rmcRequired columnDecl then " NOT NULL" else ""++--------------------------------------------------------------------------------+-- Router + shared worker-policy lowering (EP-108)+--------------------------------------------------------------------------------++scaffoldRouter :: Context -> RouterNode -> [ScaffoldModule]+scaffoldRouter ctx router =+  [ ScaffoldModule+      { modulePath = modulePathFor genPrefix "Router",+        moduleText = emitRouterGen genPrefix router,+        kind = Generated,+        origin = routerOrigin+      },+    ScaffoldModule+      { modulePath = modulePathFor holePrefix "RouterHoles",+        moduleText = emitRouterHoles holePrefix router,+        kind = HoleStub,+        origin = routerOrigin+      }+  ]+  where+    genPrefix = genPrefixFor ctx (rtId router)+    holePrefix = holePrefixFor ctx (rtId router)+    routerOrigin = nodeOrigin "router" (rtId router) (rtLoc router)++-- | Service-aware router generation preserves the historical custom resolver+-- vertical byte-for-byte, while a checked declarative selection becomes one+-- fully generated module and owns no selection hole.+scaffoldRouterForService :: Context -> CheckedService -> RouterNode -> [ScaffoldModule]+scaffoldRouterForService ctx service router = case rvSource (rtResolve router) of+  ResolveDeclarative {} ->+    [ ScaffoldModule+        { modulePath = modulePathFor genPrefix "Router",+          moduleText = emitDeclarativeRouterGen ctx graph selection readModel targetAggregate targetCommand genPrefix router,+          kind = Generated,+          origin = routerOrigin+        }+    ]+  _ -> scaffoldRouter ctx router+  where+    spec = checkedSpec service+    genPrefix = genPrefixFor ctx (rtId router)+    routerOrigin = nodeOrigin "router" (rtId router) (rtLoc router)+    graph = case checkedTypeGraph service of+      Left errors -> error ("checked declarative router type graph failed: " <> show errors)+      Right value -> value+    selection = case checkRouterSelection (checkedLanguageContract service) graph spec router of+      Left diagnostics -> error ("checked declarative router selection failed: " <> show diagnostics)+      Right value -> value+    readModel = case [value | NReadModel value <- specNodes spec, rmName value == checkedQueryName (checkedQuery selection)] of+      [value] -> value+      _ -> error "checked declarative router read model disappeared"+    targetAggregate = case [aggregate | NAggregate aggregate <- specNodes spec, aggName aggregate == checkedTarget selection] of+      [aggregate] -> aggregate+      _ -> error "checked declarative router target aggregate disappeared"+    targetCommand = case [command | command <- aggCommands targetAggregate, cmdName command == checkedCommand selection] of+      [command] -> command+      _ -> error "checked declarative router target command disappeared"++emitRouterGen :: Text -> RouterNode -> Text+emitRouterGen genPrefix router =+  nl $+    [ generatedBanner,+      "module " <> genPrefix <> ".Router",+      "  ( " <> stem <> "Name",+      "  , " <> stem <> "WorkerOptions",+      "  ) where",+      "",+      "import Data.Text (Text)"+    ]+      ++ workerPolicyImports (rtPoison router)+      ++ [ "",+           "-- The STABLE router name. It participates in every target-keyed",+           "-- deterministicRouterCommandId; renaming it re-keys replayed dispatches.",+           stem <> "Name :: Text",+           stem <> "Name = " <> tshow (rtName router),+           "",+           "-- Runtime-owned dispatch id inputs: (name, key, sourceEventId,",+           "-- targetStreamName, occurrence). Target-keyed, not positional.",+           "",+           "-- Node-level worker policy lowered from the spec. Pass this value to",+           "-- Keiro.Router.runRouterWorkerWith; do not silently use defaultWorkerOptions."+         ]+      ++ workerOptionsLines (stem <> "WorkerOptions") (rtRejected router) (rtPoison router)+  where+    stem = lowerFirst (rtId router)++emitDeclarativeRouterGen :: Context -> TypeGraph -> CheckedRouterSelection -> ReadModelNode -> Aggregate -> Command -> Text -> RouterNode -> Text+emitDeclarativeRouterGen ctx graph selection readModel targetAggregate targetCommand genPrefix router =+  nl $+    [ generatedBanner,+      "module " <> genPrefix <> ".Router",+      "  ( " <> stem <> "Name",+      "  , " <> stem <> "WorkerOptions",+      "  , " <> stem <> "SelectionFingerprint",+      "  , " <> stem <> "SelectionContract",+      "  , " <> stem <> "Select",+      "  , " <> stem,+      "  ) where",+      "",+      "import Data.Text (Text)",+      "import Effectful (Eff, IOE, (:>))",+      "import " <> structuralProjectionModule ctx <> " qualified as StructuralProjections",+      "import " <> queryContractModule <> " (" <> queryInputType <> ")",+      "import " <> readModelModule <> ".ReadModel qualified as SelectionQuery",+      "import " <> targetModule <> ".Domain qualified as TargetDomain",+      "import " <> targetModule <> ".EventStream qualified as TargetStream"+    ]+      <> ["import " <> targetModule <> ".Projection qualified as TargetProjection" | not (null (rtProjections router))]+      <> [ "import Keiki.Core (HsPred, fieldWitnessGet)",+           "import Keiro.ProcessManager (PMCommand (..), PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))",+           "import Keiro.ReadModel (runQuery)",+           "import Keiro.Router",+           "  ( DeclarativeRouter (..)",+           "  , EmptySelectionPolicy (..)",+           "  , PartialDispatchPolicy (..)",+           "  , RedeliveryPolicy (..)",+           "  , RouterSelectionContract (..)",+           "  , RouterSelectionFailure (..)",+           "  , SelectionDedupe (..)",+           "  , SelectionFailurePolicy (..)",+           "  , SelectionFingerprint (..)",+           "  , SelectionIdentity (..)",+           "  , SelectionOrder (..)",+           "  , mkRecipientLimit",+           "  , mkSelectionVersion",+           "  )",+           "import Keiro.Stream (entityStream)",+           "import Kiroku.Store.Effect (Store)",+           "import Shibuya.Core.Ack (RetryDelay (..))"+         ]+      <> ["import Shibuya.Core.Types (Envelope)" | rtPoison router /= PolHalt]+      <> [ "",+           "-- The STABLE router name. It remains part of every target-keyed",+           "-- deterministic router command id; selection metadata never re-keys dispatches.",+           stem <> "Name :: Text",+           stem <> "Name = " <> tshow (rtName router),+           "",+           "-- SHA-256 of the checked selection semantics (locations and formatting excluded).",+           stem <> "SelectionFingerprint :: Text",+           stem <> "SelectionFingerprint = " <> tshow (checkedFingerprint selection),+           "",+           stem <> "SelectionContract :: RouterSelectionContract",+           stem <> "SelectionContract =",+           "  RouterSelectionContract",+           "    { identity = SelectionIdentity " <> tshow (checkedIdentity selection),+           "    , version = checkedSelectionVersion",+           "    , fingerprint = SelectionFingerprint " <> stem <> "SelectionFingerprint",+           "    , limit = checkedRecipientLimit",+           "    , order = OrderByTargetStream",+           "    , dedupe = DedupeByTargetStream",+           "    , emptyPolicy = " <> renderCheckedEmptyPolicy (checkedEmptyPolicy selection),+           "    , failurePolicy = " <> renderCheckedFailurePolicy (checkedFailurePolicy selection),+           "    , redeliveryPolicy = StableUnion",+           "    , partialPolicy = RetainSuccesses",+           "    }",+           "  where",+           "    checkedSelectionVersion = case mkSelectionVersion " <> T.pack (show (checkedVersion selection)) <> " of",+           "      Right value -> value",+           "      Left _ -> error \"keiro-dsl emitted a non-positive checked selection version\"",+           "    checkedRecipientLimit = case mkRecipientLimit " <> T.pack (show (checkedLimit selection)) <> " of",+           "      Right value -> value",+           "      Left _ -> error \"keiro-dsl emitted a non-positive checked recipient limit\"",+           "",+           stem <> "Select ::",+           "  (IOE :> es, Store :> es) =>",+           "  " <> queryInputType <> " ->",+           "  Eff es (Either RouterSelectionFailure [PMCommand TargetDomain." <> targetName <> "Command])",+           stem <> "Select input = do",+           "  queryResult <- runQuery Nothing SelectionQuery." <> readModelValue <> " input",+           "  pure $ case queryResult of",+           "    Left _ -> Left (SelectionQueryFailed " <> tshow ("read-model " <> checkedQueryName (checkedQuery selection) <> " query failed") <> ")",+           "    Right rows ->",+           "      Right",+           "        [ PMCommand",+           "            { target = entityStream TargetStream." <> targetCategory <> " (" <> renderCheckedScalar graph (checkedRecipient selection) <> ")",+           "            , command = " <> renderSelectionCommand graph selection targetCommand,+           "            }",+           "        | row <- rows",+           "        , " <> renderCheckedScalar graph (checkedPredicate selection),+           "        ]",+           "",+           stem <> " ::",+           "  (IOE :> es, Store :> es) =>",+           "  DeclarativeRouter",+           "    " <> queryInputType,+           "    (HsPred TargetDomain." <> targetName <> "Regs TargetDomain." <> targetName <> "Command)",+           "    TargetDomain." <> targetName <> "Regs",+           "    TargetDomain." <> targetName <> "Vertex",+           "    TargetDomain." <> targetName <> "Command",+           "    TargetDomain." <> targetName <> "Event",+           "    es",+           stem <> " =",+           "  DeclarativeRouter",+           "    { name = " <> stem <> "Name",+           "    , key = \\input -> " <> renderCheckedScalar graph (checkedKey selection),+           "    , selectionContract = " <> stem <> "SelectionContract",+           "    , select = " <> stem <> "Select",+           "    , targetEventStream = TargetStream." <> targetEventStream,+           "    , targetProjections = const " <> renderTargetProjections (rtProjections router),+           "    }",+           "",+           "-- Node-level worker policy. Pair it with runDeclarativeRouterWorkerWith.",+           "-- Selection empty/failure policy remains in the generated selection contract."+         ]+      <> workerOptionsLines (stem <> "WorkerOptions") (rtRejected router) (rtPoison router)+  where+    stem = lowerFirst (rtId router)+    targetName = aggName targetAggregate+    targetModule = genPrefixFor ctx targetName+    targetCategory = lowerFirst targetName <> "CommandCategory"+    targetEventStream = lowerFirst targetName <> "EventStream"+    readModelStemValue = readModelStem readModel+    queryInputType = pascal readModelStemValue <> "QueryInput"+    queryNodeSegment = pascal (rmName readModel)+    queryContractModule = genPrefixFor ctx queryNodeSegment <> ".QueryContract"+    readModelModule = genPrefixFor ctx queryNodeSegment+    readModelValue = readModelStemValue <> "ReadModel"+    renderTargetProjections [] = "[]"+    renderTargetProjections names = "[" <> T.intercalate ", " ["TargetProjection." <> lowerFirst name <> "Projection" | name <- names] <> "]"++renderCheckedEmptyPolicy :: CheckedEmptySelectionPolicy -> Text+renderCheckedEmptyPolicy = \case+  CheckedEmptyAck -> "EmptyAck"+  CheckedEmptyRetry -> "EmptyRetry"+  CheckedEmptyDeadLetter -> "EmptyDeadLetter"+  CheckedEmptyHalt -> "EmptyHalt"++renderCheckedFailurePolicy :: CheckedSelectionFailurePolicy -> Text+renderCheckedFailurePolicy = \case+  CheckedFailureRetry -> "FailureRetry"+  CheckedFailureDeadLetter -> "FailureDeadLetter"+  CheckedFailureHalt -> "FailureHalt"++renderCheckedScalar :: TypeGraph -> CheckedScalarExpr -> Text+renderCheckedScalar graph expression = case checkedScalarNode expression of+  CheckedPath root segments ->+    "(fieldWitnessGet StructuralProjections."+      <> witnessName segments+      <> " "+      <> rootName root+      <> ")"+  CheckedTextLiteral value -> tshow value+  CheckedIntegralLiteral value -> T.pack (show value)+  CheckedBoolLiteral value -> if value then "True" else "False"+  CheckedCompare operator left right ->+    "(" <> renderCheckedScalar graph left <> " " <> comparison operator <> " " <> renderCheckedScalar graph right <> ")"+  CheckedAnd left right -> "(" <> renderCheckedScalar graph left <> " && " <> renderCheckedScalar graph right <> ")"+  CheckedOr left right -> "(" <> renderCheckedScalar graph left <> " || " <> renderCheckedScalar graph right <> ")"+  where+    rootName SelectionInput = "input"+    rootName SelectionRow = "row"+    comparison OpEq = "=="+    comparison OpNeq = "/="+    comparison OpLt = "<"+    comparison OpLe = "<="+    comparison OpGt = ">"+    comparison OpGe = ">="+    witnessName [] = error "checked scalar path contained no fields"+    witnessName path@(first : _) =+      fromMaybe+        (error "checked scalar path has no generated structural witness")+        (projectionWitnessName graph (checkedPathOwner first) pointer)+      where+        pointer = T.concat ["/" <> escapePointer (checkedPathWireKey segment) | segment <- path]++renderSelectionCommand :: TypeGraph -> CheckedRouterSelection -> Command -> Text+renderSelectionCommand graph selection command =+  "TargetDomain."+    <> cmdName command+    <> " (TargetDomain."+    <> cmdName command+    <> "Data"+    <> T.concat [" (" <> renderCheckedScalar graph (commandExpression field) <> ")" | field <- cmdFields command]+    <> ")"+  where+    commandExpression field =+      fromMaybe+        (error "checked declarative router command field disappeared")+        (Map.lookup (aggregateFieldName field) (checkedCommandFields selection))++emitRouterHoles :: Text -> RouterNode -> Text+emitRouterHoles holePrefix router =+  nl+    [ "-- HAND-OWNED hole module for the router's behaviour-bearing bodies.",+      "-- keiro-dsl creates it once and never overwrites it.",+      "module " <> holePrefix <> ".RouterHoles () where",+      "",+      "-- HOLE resolve :: " <> inName (rtInput router) <> " -> Eff es [PMCommand targetCommand]",+      "--   Spec source: " <> resolveSourceText (rvSource (rtResolve router)) <> ".",+      "--   The spec's 'stable' keyword acknowledges that retry attempts accumulate",+      "--   the UNION of resolved target identities. Keep the recipient set stable",+      "--   for a source event whenever an exact recipient set matters.",+      "-- HOLE router value: assemble Keiro.Router.Router with name = " <> lowerFirst (rtId router) <> "Name,",+      "--   key, resolve, targetEventStream, and targetProjections; run it with",+      "--   runRouterWorkerWith " <> lowerFirst (rtId router) <> "WorkerOptions.",+      "-- HOLE targetProjections: spec projections = " <> renderNames (rtProjections router) <> ".",+      "-- NOTE on-duplicate AckOk is sound because Keiro.Router confirms a duplicate",+      "--   event id against the TARGET stream via confirmBenignDuplicate before",+      "--   returning PMCommandDuplicate. Hand-rolled dispatch paths must do likewise."+    ]+  where+    renderNames names = "[" <> T.intercalate ", " names <> "]"++resolveSourceText :: ResolveSource -> Text+resolveSourceText (ResolveReadModel name) = "read-model " <> name <> " (typically Keiro.ReadModel.runQuery)"+resolveSourceText ResolveHole = "typed resolver hole"+resolveSourceText (ResolveDeclarative selection) = "declarative selection " <> rsIdentity selection++workerPolicyImports :: PolicyChoice -> [Text]+workerPolicyImports poison =+  [ "import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))",+    "import Shibuya.Core.Ack (RetryDelay (..))"+  ]+    ++ if poison == PolHalt+      then []+      else ["import Effectful (Eff)", "import Shibuya.Core.Types (Envelope)"]++workerOptionsLines :: Text -> PolicyChoice -> PolicyChoice -> [Text]+workerOptionsLines valueName rejected poison =+  [ valueName <> signature,+    valueName <> argument <> " =",+    "  WorkerOptions",+    "    { poisonPolicy = " <> poisonExpr <> ",",+    "      rejectedCommandPolicy = " <> rejectedExpr rejected <> ",",+    "      transientRetryDelay = RetryDelay 5, -- matches defaultWorkerOptions; runtime tuning",+    "      metrics = Nothing -- runtime configuration; install at call site",+    "    }"+  ]+  where+    signature = case poison of+      PolHalt -> " :: WorkerOptions es msg"+      _ -> " :: (Envelope msg -> Eff es ()) -> WorkerOptions es msg"+    argument = case poison of+      PolHalt -> ""+      _ -> " poisonCallback"+    poisonExpr = case poison of+      PolHalt -> "PoisonHalt"+      PolDeadLetter -> "PoisonDeadLetter poisonCallback"+      PolSkip -> "PoisonSkip poisonCallback"+    rejectedExpr = \case+      PolHalt -> "RejectedHalt"+      PolDeadLetter -> "RejectedDeadLetter"+      PolSkip -> "RejectedSkip"++--------------------------------------------------------------------------------+-- Process manager + durable timer (EP-3)+--------------------------------------------------------------------------------++-- | Emit the symbol-free deterministic wiring for a process manager + its timer+-- into a @Generated@ module, plus a create-if-absent @ProcessHoles@ module for the+-- behaviour-bearing bodies (the @handle@ reaction, the deadline window, and the+-- fire command). The @Generated@ module contains no keiki symbolic operator (the+-- saga's transducer is the separate aggregate hole), so the firewall invariant+-- holds. The timer worker uses the spec's @max-attempts@ ceiling, never the+-- dangerous @defaultTimerWorkerOptions@ (@Nothing@) default.+scaffoldProcess :: Context -> ProcessNode -> [ScaffoldModule]+scaffoldProcess ctx p =+  [ ScaffoldModule+      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Process.hs"),+        moduleText = emitProcessGen sagaGenPrefix genPrefix holePrefix p,+        kind = Generated,+        origin = nodeOrigin "process" (procId p) (procLoc p)+      },+    ScaffoldModule+      { modulePath = T.unpack (T.replace "." "/" holePrefix <> "/ProcessHoles.hs"),+        moduleText = emitProcessHoles genPrefix holePrefix p,+        kind = HoleStub,+        origin = nodeOrigin "process" (procId p) (procLoc p)+      }+  ]+  where+    genPrefix = genPrefixFor ctx (procId p)+    holePrefix = holePrefixFor ctx (procId p)+    sagaGenPrefix = genPrefixFor ctx (pascal (sagaAgg (procSaga p)))++emitProcessGen :: Text -> Text -> Text -> ProcessNode -> Text+emitProcessGen sagaGenPrefix genPrefix _holePrefix p =+  nl $+    [ generatedBanner,+      "module " <> genPrefix <> ".Process",+      "  ( " <> lo <> "ProcessName",+      "  , " <> lo <> "Category",+      "  , " <> lo <> "ProcessWorkerOptions",+      "  , " <> lo <> "TimerRequest",+      "  , " <> lo <> "FireOutcome",+      "  ) where",+      "",+      "import Data.Aeson (Value, object, (.=))",+      "import Data.Text (Text)",+      "import qualified Data.Text as T",+      "import Data.Time (UTCTime)",+      "import Data.UUID (UUID)",+      "import qualified Data.UUID.V5 as UUID.V5",+      "import " <> sagaGenPrefix <> ".EventStream (" <> sagaEventStreamType <> ")",+      "import Keiro.Command (CommandError (..))",+      "import Keiro.Stream qualified as Stream",+      "import Keiro.Timer (TimerId (..), TimerRequest (..))"+    ]+      ++ workerPolicyImports (procPoison p)+      ++ [ "",+           "-- The define-once ProcessManager name (hole-kind 5: referenced, never retyped).",+           lo <> "ProcessName :: Text",+           lo <> "ProcessName = " <> tshow (procName p),+           "",+           "-- The validated saga stream category (hole-kind 5: referenced, never retyped).",+           "-- Saga streams are '<category>-<correlationId>' via Keiro.Stream.entityStream.",+           "-- categoryUnsafe is safe here because keiro-dsl check proved the literal legal.",+           lo <> "Category :: Stream.StreamCategory " <> sagaEventStreamType,+           lo <> "Category = Stream.categoryUnsafe " <> tshow categoryName,+           "",+           "-- Node-level worker policy lowered from the spec. Pass this value to",+           "-- Keiro.ProcessManager.runProcessManagerWorkerWith."+         ]+      ++ workerOptionsLines (lo <> "ProcessWorkerOptions") (procRejected p) (procPoison p)+      ++ [ "",+           "-- The deterministic timer-request builder: id derived from the correlation",+           "-- key (hole-kind 1), processManagerName referenced, payload from the spec.",+           "-- (timer id derived as uuidv5 of " <> tshow (idePrefix (tmId timer)) <> " <> correlationId)",+           lo <> "TimerRequest :: Text -> UTCTime -> TimerRequest",+           lo <> "TimerRequest correlationId fireAtTime =",+           "  TimerRequest",+           "    { timerId = TimerId (namedUuid (" <> tshow (idePrefix (tmId timer)) <> " <> correlationId))",+           "    , processManagerName = " <> lo <> "ProcessName",+           "    , correlationId = correlationId",+           "    , fireAt = fireAtTime",+           "    , payload = " <> payloadExpr (tmPayload timer),+           "    }",+           "",+           "-- The timer-fire disposition table (hole-kind 2), derived from the spec.",+           "-- on-reject => " <> showOutcome (onReject fd) <> " is the benign inversion.",+           "-- A duplicate append reaches on-error unless it is confirmed against the",+           "-- target stream. Use Keiro.ProcessManager.confirmBenignDuplicate:",+           "--   StreamName -> EventId -> CommandError -> Eff es Bool",+           "-- Fold True into the duplicate result and surface False as the failure.",+           lo <> "FireOutcome :: Either CommandError a -> Maybe ()",+           lo <> "FireOutcome result = case result of",+           "  Right{} -> " <> outcomeToMaybe (onOk fd),+           "  Left CommandRejected -> " <> outcomeToMaybe (onReject fd),+           "  Left (CommandAmbiguous _) -> " <> outcomeToMaybe (onAmbiguous fd) <> "  -- explicit definition-bug arm",+           "  Left{} -> " <> outcomeToMaybe (onError fd),+           "",+           "-- max-attempts = " <> tshow' (tmMaxAttempts timer) <> ", dead-letter = " <> tshow (tmDeadLetter timer),+           "-- (the timer worker must pass Just " <> tshow' (tmMaxAttempts timer) <> " to runTimerWorkerWith, never the",+           "--  defaultTimerWorkerOptions Nothing ceiling that retries forever).",+           "",+           "-- deterministic v5 UUID of a correlation-keyed string (hole-kind 1).",+           "namedUuid :: Text -> UUID",+           "namedUuid v = UUID.V5.generateNamed UUID.V5.namespaceURL (map (fromIntegral . fromEnum) (T.unpack v))"+         ]+  where+    lo = lowerFirst (procId p)+    sagaEventStreamType = pascal (sagaAgg (procSaga p)) <> "EventStreamDef"+    categoryName = staticCategory ("process " <> procId p) (sagaCategory (procSaga p))+    timer = procTimer p+    fd = fireDisposition (tmFire timer)++-- | The timer payload, restricted to the spec's literal (@name=\"value\"@)+-- bindings so it compiles in the deterministic builder. Bare fields and+-- ref-valued bindings are input-driven (the agent-written hole), not emitted.+payloadExpr :: [FieldBinding] -> Text+payloadExpr fs = case [b | b <- fs, isLiteral b] of+  [] -> "object []"+  lits -> "object [ " <> T.intercalate ", " (map kv lits) <> " ]"+  where+    isLiteral b = maybe False (const True) (fbValue b >>= stripWrappingQuotes)+    kv b = tshow (fbName b) <> " .= (" <> maybe "\"\"" tshow (fbValue b >>= stripWrappingQuotes) <> " :: Value)"+    stripWrappingQuotes value = T.stripPrefix "\"" value >>= T.stripSuffix "\""++showOutcome :: FireOutcome -> Text+showOutcome OFired = "Fired"+showOutcome ORetry = "Retry"++outcomeToMaybe :: FireOutcome -> Text+outcomeToMaybe OFired = "Just ()  -- Fired"+outcomeToMaybe ORetry = "Nothing  -- Retry"++emitProcessHoles :: Text -> Text -> ProcessNode -> Text+emitProcessHoles _genPrefix holePrefix p =+  nl+    [ "-- HAND-OWNED hole module for the process manager's behaviour-bearing bodies.",+      "-- keiro-dsl creates it once and never overwrites it.",+      "module " <> holePrefix <> ".ProcessHoles () where",+      "",+      "-- HOLE handle: build the ProcessManagerAction (the self-advance",+      "--   '" <> advCommand (hAdvance (procHandle p)) <> "', the dispatch(es), and the timer) from the input.",+      "-- HOLE streams: build streamFor with entityStream " <> lowerFirst (procId p) <> "Category;",+      "--   build target streams with entityStream " <> lowerFirst (procTarget p) <> "CommandCategory. Never concatenate raw stream names.",+      "-- HOLE window: the deadline policy, e.g. surgeWindow :: NominalDiffTime;",+      "--   surgeDeadline observedAt = addUTCTime surgeWindow observedAt  (TIME INJECTED).",+      "-- HOLE fire command: construct " <> fireCommand (tmFire (procTimer p)) <> " for the timer fire,",+      "--   keyed by correlationId; the fired-event-id is the deterministic uuidv5 of",+      "--   " <> tshow (idePrefix (fireFiredEventId (tmFire (procTimer p)))) <> " <> correlationId.",+      "-- NOTE on-duplicate AckOk is sound because the runtime confirms a duplicate",+      "--   event id against the TARGET stream via confirmBenignDuplicate before",+      "--   returning PMCommandDuplicate. Its effective signature is:",+      "--     StreamName -> EventId -> CommandError -> Eff es Bool",+      "--   Hand-rolled paths must call it with the target stream and attempted event id,",+      "--   fold True into the duplicate result, and surface False as the original failure.",+      "--   Never pattern-match DuplicateEvent as success: event ids are globally unique."+    ]++--------------------------------------------------------------------------------+-- Domain module+--------------------------------------------------------------------------------++emitDomain :: Agg -> Text+emitDomain a =+  nl $+    renderGeneratedLanguagePragmas+      ( [ExtDeriveAnyClass | hasSnapshot a]+          <> [ExtDuplicateRecordFields | domainNeedsDuplicateRecordFields a]+          <> [ExtTemplateHaskell]+      )+      ++ [ generatedBanner,+           "module " <> aGenPrefix a <> ".Domain where",+           ""+         ]+      ++ ["import Data.Aeson (FromJSON, ToJSON)" | hasSnapshot a]+      ++ ["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]+      ++ generatedNominalDomainImports a+      ++ map ("import " <>) (domainStaticImports a)+      ++ T.lines (renderPlannedImports importPlan)+      ++ [ "import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)",+           "",+           sectionsOf+             [ [emitVertex a],+               map (emitRecord importPlan a) (aCommands a),+               [emitSum (aName a <> "Command") (aCommands a)],+               map (emitRecord importPlan a) (aEvents a),+               [emitSum (aName a <> "Event") (aEvents a)],+               [emitRegsType importPlan a, emitInitialRegs importPlan a],+               [ "$(deriveAggregateCtorsAll ''" <> aName a <> "Command ''" <> aName a <> "Regs)",+                 "",+                 "$(deriveWireCtorsAll ''" <> aName a <> "Event)"+               ]+             ]+         ]+  where+    importPlan = domainImportPlan a++domainNeedsDuplicateRecordFields :: Agg -> Bool+domainNeedsDuplicateRecordFields aggregate = hasDuplicateNames selectorNames+  where+    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.+    selectorNames = commandSelectors <> eventSelectors <> eventSelectors <> registerSelectors++hasDuplicateNames :: [Text] -> Bool+hasDuplicateNames names = length names /= Set.size (Set.fromList names)++hasSnapshot :: Agg -> Bool+hasSnapshot = maybe False (const True) . aSnapshot++emitVertex :: Agg -> Text+emitVertex a =+  nl $+    [ "data " <> aVertexType a <> " = " <> T.intercalate " | " (map (vertexCtor a . stName) (aStates a)),+      "  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)"+    ]+      ++ ["  deriving anyclass (ToJSON, FromJSON)" | hasSnapshot a]+      ++ [ line+         | hasSnapshot a,+           line <-+             [ "instance CanonicalStateShape " <> aVertexType a,+               "instance CanonicalTypeName " <> aVertexType a+             ]+         ]++emitRecord :: HaskellImportPlan -> Agg -> ResolvedCtor -> Text+emitRecord importPlan a rc =+  nl $+    [ "data " <> rcName rc <> "Data = " <> rcName rc <> "Data"+    ]+      ++ recordFields [(fieldSelector identity, renderDomainType importPlan a fieldType) | (identity, fieldType) <- rcFields rc]+      ++ ["  deriving stock (Generic, Eq, Show)"]++recordFields :: [(Text, Text)] -> [Text]+recordFields [] =+  ["  {"]+    <> ["  }"]+recordFields fs =+  [ lead i <> n <> " :: !" <> ty+  | (i, (n, ty)) <- zip [(0 :: Int) ..] fs+  ]+    ++ ["  }"]+  where+    lead 0 = "  { "+    lead _ = "  , "++emitSum :: Text -> [ResolvedCtor] -> Text+emitSum tyName ctors =+  nl $+    [firstLine] ++ restLines ++ ["  deriving stock (Generic, Eq, Show)"]+  where+    arm rc = rc' rc+    rc' rc = rcName rc <> " !" <> rcName rc <> "Data"+    (firstLine, restLines) = case ctors of+      [] -> ("data " <> tyName, [])+      (c : cs) ->+        ( "data " <> tyName <> " = " <> arm c,+          ["  | " <> arm c2 | c2 <- cs]+        )++emitRegsType :: HaskellImportPlan -> Agg -> Text+emitRegsType importPlan a =+  nl $+    ["type " <> aName a <> "Regs ="]+      ++ regListLines importPlan a (aRegs a)++regListLines :: HaskellImportPlan -> Agg -> [ResolvedRegister] -> [Text]+regListLines _ _ [] = ["  '[]"]+regListLines importPlan a rs =+  [ lead i <> "'(" <> tshow (rrName r) <> ", " <> renderDomainType importPlan a (rrType r) <> ")"+  | (i, r) <- zip [(0 :: Int) ..] rs+  ]+    ++ ["   ]"]+  where+    lead 0 = "  '[ "+    lead _ = "   , "++emitInitialRegs :: HaskellImportPlan -> Agg -> Text+emitInitialRegs importPlan a =+  nl $+    [ "initial" <> aName a <> "Regs :: RegFile " <> aName a <> "Regs",+      "initial" <> aName a <> "Regs ="+    ]+      ++ chain (aRegs a)+  where+    chain [] = ["  RNil"]+    chain rs =+      [ "  RCons (Proxy @" <> tshow (rrName r) <> ") " <> regInitialValue importPlan a r <> " $"+      | r <- init rs+      ]+        ++ ["  RCons (Proxy @" <> tshow (rrName lastR) <> ") " <> regInitialValue importPlan a lastR <> " RNil"]+      where+        lastR = last rs++-- | The Haskell initial value for a register, by the category of its type.+regInitialValue :: HaskellImportPlan -> Agg -> ResolvedRegister -> Text+regInitialValue importPlan aggregate register = case rrInitial register of+  InitialId name -> case find ((== name) . resolvedNominalName) (aGeneratedNominals aggregate) >>= generatedIdSampleHaskell aggregate of+    Just value -> value+    Nothing -> renderRegisterInitial (rrInitial register)+  InitialNominal _ value -> renderReferenceOrDie importPlan (qualifiedValueReference value)+  InitialMapped _ value -> renderReferenceOrDie importPlan (qualifiedValueReference value)+  _ -> renderRegisterInitial (rrInitial register)++domainImportPlan :: Agg -> HaskellImportPlan+domainImportPlan aggregate =+  planImportsOrDie+    (aGenPrefix aggregate <> ".Domain")+    localDeclarations+    (Set.unions (map aggregateSourceReferences (domainAggregateSources aggregate)) <> initialReferences)+  where+    localDeclarations =+      Set.fromList+        ( [ aVertexType aggregate,+            aName aggregate <> "Command",+            aName aggregate <> "Event",+            aName aggregate <> "Regs"+          ]+            <> [rcName constructor <> "Data" | constructor <- aCommands aggregate <> aEvents aggregate]+            <> map resolvedNominalName (aGeneratedNominals aggregate)+        )+    initialReferences =+      Set.fromList+        ( [ qualifiedValueReference initialValue+          | declaration <- mappedUses aggregate,+            initialValue <- maybeToListText (mappedInitial declaration)+          ]+            <> [ qualifiedValueReference initialValue+               | resolvedType <- aggregateTypes aggregate,+                 AggregateNominal nominal <- [resolvedType],+                 ConsumerNominal binding <- [resolvedNominalOwnership nominal],+                 initialValue <- maybeToListText (consumerNominalInitial binding)+               ]+        )++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 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 =+  map (aggregateConsumerHaskellSource (aSymbols aggregate)) (aggregateTypes aggregate)++aggregateTypes :: Agg -> [ResolvedAggregateType]+aggregateTypes aggregate =+  map snd (concatMap rcFields (aCommands aggregate <> aEvents aggregate)) <> map rrType (aRegs aggregate)++mappedUses :: Agg -> [ResolvedMappedDecl]+mappedUses a =+  [ declaration+  | resolvedType <-+      map snd (concatMap rcFields (aCommands a <> aEvents a))+        <> map rrType (aRegs a),+    declaration <- maybeToListText (mappedDeclFor a resolvedType)+  ]++mappedDeclFor :: Agg -> ResolvedAggregateType -> Maybe ResolvedMappedDecl+mappedDeclFor a resolvedType = do+  key <- case resolvedType of+    AggregateMapped mappedKey -> Just mappedKey+    _ -> Nothing+  graph <- aTypeGraph a+  Map.lookup key (tgDeclarations graph)++mappedInitial :: ResolvedMappedDecl -> Maybe QualifiedValueName+mappedInitial (ResolvedStructural declaration _) = sdInitial declaration+mappedInitial (ResolvedOpaque declaration) = odInitial declaration++renderDomainType :: HaskellImportPlan -> Agg -> ResolvedAggregateType -> Text+renderDomainType importPlan aggregate resolvedType =+  either+    (error . ("validated aggregate Haskell reference failed: " <>) . show)+    id+    (renderAggregateHaskellSource importPlan (aggregateConsumerHaskellSource (aSymbols aggregate) resolvedType))++maybeToListText :: Maybe value -> [value]+maybeToListText = maybe [] pure++--------------------------------------------------------------------------------+-- Codec module+--------------------------------------------------------------------------------++emitCodec :: Agg -> Text+emitCodec a =+  nl $+    renderGeneratedLanguagePragmas [ExtOverloadedRecordDot | codecUsesRecordDot a]+      ++ [ generatedBanner,+           "module " <> aGenPrefix a <> ".Codec (",+           "    " <> lowerFirst (aName a) <> "Codec,",+           "    parse" <> aName a <> "Event,",+           "    encode" <> aName a <> "Event,"+         ]+      ++ concatMap mappedExports (codecMappedDeclarations a)+      ++ [ ") where",+           "",+           "import " <> aGenPrefix a <> ".Domain"+         ]+      ++ generatedNominalCodecImports (aggregateCheckedService a) (aContext a) (codecGeneratedNominals a)+      ++ ["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 codecUsesMap a+             then ["import Data.Map.Strict (Map)", "import Data.Map.Strict qualified as Map"]+             else []+         )+      ++ [ "import Data.Text (Text)",+           "import qualified Data.Text as T"+         ]+      ++ ["import Data.KindID qualified as KindID" | hasConsumerNominalIdCodec a]+      ++ ["import Keiro.Codec.IdDomain (typeIdV7Domain, validateIdDomainText)" | hasEnforcedConsumerNominalIdCodec a]+      ++ ["import Keiro.Codec.Nominal (nominalFromRepresentation, nominalToRepresentation)" | hasConsumerNominalCodec a]+      ++ ["import Keiro.Codec.Structural (bindingFromShape, bindingToShape)" | hasStructuralMappedCodec a]+      ++ [ "import Keiro.Codec (Codec (..), EventType (..))",+           upcasterImport a+         ]+      ++ [nl (map ("import " <>) (codecMappedImports a)) | hasMappedCodec a]+      ++ [nl (map ("import " <>) (codecNominalImports a)) | hasConsumerNominalCodec a]+      ++ T.lines (renderPlannedImports importPlan)+      ++ [ "",+           emitEnumParsers a,+           emitConsumerNominalParsers importPlan a+         ]+      ++ [emitMappedCodecs importPlan a | hasMappedCodec a]+      ++ [ "",+           emitEventTypes a,+           "",+           emitCodecValue a,+           "",+           emitEncode importPlan a,+           "",+           emitDecode importPlan a,+           "",+           "mapLeftText :: Either String b -> Either Text b",+           "mapLeftText = either (Left . T.pack) Right",+           "",+           "renderExpectedEventTypes :: NonEmpty EventType -> String",+           "renderExpectedEventTypes =",+           "  T.unpack",+           "    . T.intercalate \", \"",+           "    . map (\\(EventType eventTypeName) -> eventTypeName)",+           "    . NonEmpty.toList"+         ]+      ++ ( 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))",+                 "  where",+                 "    extras = filter (`notElem` allowed) (map Key.toText (KeyMap.keys objectValue))"+               ]+             else []+         )+  where+    importPlan = codecImportPlan a+    mappedExports (ResolvedStructural declaration _) =+      [ "    encode" <> sdName declaration <> "Mapped,",+        "    decode" <> sdName declaration <> "Mapped,"+      ]+    mappedExports ResolvedOpaque {} = []++codecUsesRecordDot :: Agg -> Bool+codecUsesRecordDot = any (not . null . rcFields) . aEvents++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++hasConsumerNominalIdCodec :: Agg -> Bool+hasConsumerNominalIdCodec aggregate =+  any+    (\nominal -> case resolvedNominalRepresentation nominal of IdRepresentation {} -> True; _ -> False)+    (codecConsumerNominals aggregate)++hasEnforcedConsumerNominalIdCodec :: Agg -> Bool+hasEnforcedConsumerNominalIdCodec aggregate =+  any+    ( \nominal -> case resolvedNominalRepresentation nominal of+        IdRepresentation prefix -> isJust (idDomainContractFor (aLanguageContract aggregate) prefix)+        _ -> False+    )+    (codecConsumerNominals aggregate)++emitEnumParsers :: Agg -> Text+emitEnumParsers a =+  sectionsOf+    [ [emitEnumParser nominal | nominal <- codecGeneratedNominals a, EnumRepresentation {} <- [resolvedNominalRepresentation nominal]]+    ]++emitEnumParser :: ResolvedNominalType -> Text+emitEnumParser nominal = case resolvedNominalRepresentation nominal of+  EnumRepresentation constructors ->+    nl $+      [ "parse" <> name <> " :: Text -> Parser " <> name,+        "parse" <> name <> " = \\case"+      ]+        ++ ["  " <> tshow wire <> " -> pure " <> constructor | (constructor, wire) <- NE.toList constructors]+        ++ ["  tag -> " <> renderUnknownFailure name "tag" (map snd (NE.toList constructors))]+  _ -> error "non-enum reached generated enum parser emission"+  where+    name = resolvedNominalName nominal++emitConsumerNominalParsers :: HaskellImportPlan -> Agg -> Text+emitConsumerNominalParsers importPlan aggregate = sectionsOf [map emitParser (codecConsumerNominals aggregate)]+  where+    emitParser nominal = case (resolvedNominalRepresentation nominal, resolvedNominalOwnership nominal) of+      (IdRepresentation prefix, ConsumerNominal binding) ->+        nl $+          [ parserName nominal <> " :: Text -> Parser " <> renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding))+          ]+            <> parserBody nominal prefix binding+      (EnumRepresentation constructors, ConsumerNominal binding) ->+        nl $+          [ parserName nominal <> " :: Text -> Parser " <> renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding)),+            parserName nominal <> " = \\case"+          ]+            <> [ "  "+                   <> tshow wire+                   <> " -> pure (nominalFromRepresentation "+                   <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding))+                   <> " "+                   <> renderReferenceOrDie importPlan (nominalRepresentationConstructorReference (aContext aggregate) nominal constructor)+                   <> ")"+               | (constructor, wire) <- NE.toList constructors+               ]+            <> ["  tag -> " <> renderUnknownFailure (resolvedNominalName nominal <> " wire value") "tag" (map snd (NE.toList constructors))]+      _ -> ""+    parserName nominal = "parse" <> resolvedNominalName nominal <> "Nominal"+    parserBody nominal prefix binding = case idDomainContractFor (aLanguageContract aggregate) prefix of+      Nothing ->+        [ parserName nominal <> " input = case KindID.parseText @" <> tshow prefix <> " input of",+          "  Left reason -> fail (show reason)",+          "  Right representation -> pure (nominalFromRepresentation " <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)) <> " representation)"+        ]+      Just _ ->+        [ parserName nominal <> " input = case validateIdDomainText (typeIdV7Domain " <> tshow prefix <> ") input of",+          "  Left reason -> fail (show reason)",+          "  Right () -> case KindID.parseText @" <> tshow prefix <> " input of",+          "    Left reason -> fail (show reason)",+          "    Right representation -> pure (nominalFromRepresentation " <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)) <> " representation)"+        ]++emitCodecValue :: Agg -> Text+emitCodecValue a =+  nl $+    [ lowerFirst (aName a) <> "Codec :: Codec " <> aName a <> "Event",+      lowerFirst (aName a) <> "Codec =",+      "  Codec",+      "    { eventTypes = " <> eventTypesName a,+      "    , eventType = \\case"+    ]+      ++ ["        " <> rcName e <> "{} -> EventType " <> tshow (rcName e) | e <- aEvents a]+      ++ [ "    , schemaVersion = " <> tshow' (maxEventVersion a),+           "    , encode = encode" <> aName a <> "Event",+           "    , decode = parse" <> aName a <> "Event",+           "    , upcasters = " <> upcastersExpr a,+           "    }"+         ]+      ++ upcasterRungDecls a++emitEventTypes :: Agg -> Text+emitEventTypes aggregate =+  nl+    [ eventTypesName aggregate <> " :: NonEmpty EventType",+      eventTypesName aggregate <> " = " <> eventTypesExpr+    ]+  where+    eventTypesExpr = case map rcName (aEvents aggregate) of+      [] -> "error \"no events\""+      event : rest -> "EventType " <> tshow event <> " :| [" <> T.intercalate ", " (map (("EventType " <>) . tshow) rest) <> "]"++eventTypesName :: Agg -> Text+eventTypesName aggregate = lowerFirst (aName aggregate) <> "EventTypes"++-- | The codec's @schemaVersion@: the maximum declared event version (EP-2).+maxEventVersion :: Agg -> Int+maxEventVersion a = maximum (1 : map rcVersion (aEvents a))++-- | One @(sourceVersion, upcasterName)@ entry per event that declares an+-- @upcast from@. The upcaster name is per-event (e.g. @upcastFooV1@) and its+-- body is a hole in the hand-owned Holes module.+upcasterEntries :: Agg -> [(Int, Text, Text)]+upcasterEntries a =+  [ (m, rcName e, "upcast" <> rcName e <> "V" <> tshow' m)+  | e <- aEvents a,+    Just m <- [rcUpcastFrom e]+  ]++upcastersExpr :: Agg -> Text+upcastersExpr a =+  "[" <> T.intercalate ", " ["(" <> tshow' m <> ", upcastRungV" <> tshow' m <> ")" | (m, _) <- upcasterRungs a] <> "]"++-- | Group event-specific holes into one migration rung per aggregate-global+-- source version.  Event metadata stamps every kind with the aggregate's+-- schema version, so a rung must explicitly pass foreign event kinds through.+upcasterRungs :: Agg -> [(Int, [(Text, Text)])]+upcasterRungs a =+  [ (source, [(eventName, fn) | (_, eventName, fn) <- entries])+  | entries@((source, _, _) : _) <- groupBy sameSource (sortOn firstSource (upcasterEntries a))+  ]+  where+    firstSource (source, _, _) = source+    sameSource (source, _, _) (otherSource, _, _) = source == otherSource++upcasterRungDecls :: Agg -> [Text]+upcasterRungDecls a = concatMap rung (upcasterRungs a)+  where+    rung (source, entries) =+      [ "",+        "upcastRungV" <> tshow' source <> " :: EventType -> Value -> Either Text Value"+      ]+        ++ [ "upcastRungV" <> tshow' source <> " (EventType " <> tshow eventName <> ") value = " <> fn <> " value"+           | (eventName, fn) <- entries+           ]+        ++ [ "-- Kinds whose shape did not change at this rung pass through unchanged; their",+             "-- stamped version is aggregate-global, not their own shape history.",+             "upcastRungV" <> tshow' source <> " _ value = Right value"+           ]++-- | When the codec references upcasters, it imports their (hole) definitions+-- from the hand-owned Holes module.+upcasterImport :: Agg -> Text+upcasterImport a = case upcasterEntries a of+  [] -> ""+  es -> "import " <> aHolePrefix a <> ".Holes (" <> T.intercalate ", " [fn | (_, _, fn) <- es] <> ")"++emitEncode :: HaskellImportPlan -> Agg -> Text+emitEncode importPlan a =+  nl $+    [ "encode" <> aName a <> "Event :: " <> aName a <> "Event -> Value",+      "encode" <> aName a <> "Event = \\case"+    ]+      ++ concatMap encodeArm (aEvents a)+  where+    encodeArm e =+      [ "  " <> rcName e <> " payload ->",+        "    object"+      ]+        ++ [ lead i <> kv+           | (i, kv) <- zip [(0 :: Int) ..] (("\"kind\" .= (" <> tshow (rcName e) <> " :: Text)") : map encodeField (rcFields e))+           ]+        ++ ["      ]"]+    lead 0 = "      [ "+    lead _ = "      , "+    encodeField (identity, ty) =+      tshow (fieldWireKey identity)+        <> " .= "+        <> encodeFieldValue (fieldSelector identity) ty+    encodeFieldValue selector ty = case ty of+      AggregateNominal nominal -> encodeNominalValue nominal ("payload." <> selector)+      _ -> case fieldCat a ty of+        MappedStructuralCat {} -> encodeMapped ty ("payload." <> selector)+        MappedOpaqueCat {} -> encodeMapped ty ("payload." <> selector)+        _ -> "payload." <> selector+    encodeMapped (AggregateMapped key) value = case aTypeGraph a of+      Nothing -> error "mapped aggregate field has no resolved type graph"+      Just graph ->+        renderMappedEncode graph ConsumerValueBoundary (mappedCodecPlanOrDie graph (RRef key)) value+    encodeMapped _ _ = error "non-mapped aggregate type reached mapped codec lowering"+    encodeNominalValue nominal value = case resolvedNominalOwnership nominal of+      GeneratedNominal -> case resolvedNominalRepresentation nominal of+        IdRepresentation {} -> lowerFirst (resolvedNominalName nominal) <> "Text " <> value+        EnumRepresentation {} -> lowerFirst (resolvedNominalName nominal) <> "Text " <> value+        ScalarRepresentation {} -> value+      ConsumerNominal binding -> case resolvedNominalRepresentation nominal of+        IdRepresentation {} -> "KindID.toText (nominalToRepresentation " <> bindingName binding <> " " <> value <> ")"+        EnumRepresentation {} ->+          renderReferenceOrDie importPlan (nominalRepresentationEncoderReference (aContext a) nominal)+            <> " (nominalToRepresentation "+            <> bindingName binding+            <> " "+            <> value+            <> ")"+        ScalarRepresentation {} -> "nominalToRepresentation " <> bindingName binding <> " " <> value+    bindingName = renderReferenceOrDie importPlan . qualifiedValueReference . consumerNominalBinding++emitDecode :: HaskellImportPlan -> Agg -> Text+emitDecode importPlan a =+  nl $+    [ "parse" <> aName a <> "Event :: EventType -> Value -> Either Text " <> aName a <> "Event",+      "parse" <> aName a <> "Event (EventType tag) = mapLeftText . parseEither (withObject " <> tshow (aName a <> "Event") <> " go)",+      "  where",+      "    go o = do",+      "      case tag of"+    ]+      ++ concatMap decodeArm (aEvents a)+      ++ ["        _ -> " <> renderUnknownEventTypeFailure a "tag"]+  where+    decodeArm e =+      ["        " <> tshow (rcName e) <> " ->"]+        ++ case rcFields e of+          [] -> ["          pure (" <> rcName e <> " " <> rcName e <> "Data)"]+          fields ->+            [ "          " <> rcName e,+              "            <$> ( " <> rcName e <> "Data"+            ]+              ++ [ (if index == 0 then "                    <$> " else "                    <*> ") <> decodeField field+                 | (index, field) <- zip [(0 :: Int) ..] fields+                 ]+              ++ ["                )"]+    decodeField (identity, ty) = case ty of+      AggregateNominal nominal -> decodeNominalField (fieldWireKey identity) nominal+      _ -> case fieldCat a ty of+        MappedStructuralCat {} -> decodeMapped ty (fieldWireKey identity)+        MappedOpaqueCat {} -> "o .: " <> tshow (fieldWireKey identity)+        _ -> "o .: " <> tshow (fieldWireKey identity)+    decodeMapped (AggregateMapped mappedKey) key = case aTypeGraph a of+      Nothing -> error "mapped aggregate field has no resolved type graph"+      Just graph ->+        "explicitParseField "+          <> renderMappedParse graph ConsumerValueBoundary (mappedCodecPlanOrDie graph (RRef mappedKey))+          <> " o "+          <> tshow key+    decodeMapped _ _ = error "non-mapped aggregate type reached mapped codec lowering"+    decodeNominalField name nominal = case resolvedNominalOwnership nominal of+      GeneratedNominal -> case resolvedNominalRepresentation nominal of+        IdRepresentation prefix -> case idDomainContractFor (aLanguageContract a) prefix of+          Nothing -> "(" <> resolvedNominalName nominal <> " <$> o .: " <> tshow name <> ")"+          Just _ -> "(" <> legacyNominalConstructorName nominal <> " <$> o .: " <> tshow name <> ")"+        EnumRepresentation {} ->+          "explicitParseField (withText "+            <> tshow (resolvedNominalName nominal)+            <> " parse"+            <> resolvedNominalName nominal+            <> ") o "+            <> tshow name+        ScalarRepresentation {} -> "o .: " <> tshow name+      ConsumerNominal binding -> case resolvedNominalRepresentation nominal of+        IdRepresentation {} -> consumerNominalFieldParser name nominal+        EnumRepresentation {} -> consumerNominalFieldParser name nominal+        ScalarRepresentation {} -> "(nominalFromRepresentation " <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)) <> " <$> o .: " <> tshow name <> ")"+    consumerNominalFieldParser fieldName nominal =+      "explicitParseField (withText "+        <> tshow (resolvedNominalName nominal)+        <> " parse"+        <> resolvedNominalName nominal+        <> "Nominal) o "+        <> tshow fieldName++codecConsumerNominals :: Agg -> [ResolvedNominalType]+codecConsumerNominals aggregate =+  Map.elems . Map.fromList $+    [ (resolvedNominalName nominal, nominal)+    | event <- aEvents aggregate,+      (_, AggregateNominal nominal) <- rcFields event,+      ConsumerNominal {} <- [resolvedNominalOwnership nominal]+    ]++codecGeneratedNominals :: Agg -> [ResolvedNominalType]+codecGeneratedNominals aggregate =+  generatedNominalsInTypes+    [ resolvedType+    | event <- aEvents aggregate,+      (_, resolvedType) <- rcFields event+    ]++codecImportPlan :: Agg -> HaskellImportPlan+codecImportPlan aggregate =+  planImportsOrDie+    (aGenPrefix aggregate <> ".Codec")+    (Set.fromList [aName aggregate <> "Event"])+    (Set.fromList (nominalReferences <> mappedReferences <> nominalRepresentationReferences <> shapeReferences))+  where+    nominalReferences =+      [ reference+      | nominal <- codecConsumerNominals aggregate,+        ConsumerNominal binding <- [resolvedNominalOwnership nominal],+        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,+        reference <-+          [ haskellTypeReference (sdHaskell declaration),+            qualifiedValueReference (sdBinding declaration)+          ]+      ]+    nominalRepresentationReferences =+      [ reference+      | nominal <- codecConsumerNominals aggregate,+        EnumRepresentation constructors <- [resolvedNominalRepresentation nominal],+        reference <-+          nominalRepresentationEncoderReference (aContext aggregate) nominal+            : [ nominalRepresentationConstructorReference (aContext aggregate) nominal constructor+              | (constructor, _) <- NE.toList constructors+              ]+      ]+    shapeReferences =+      [ reference+      | ResolvedStructural declaration shape <- codecMappedDeclarations aggregate,+        reference <- structuralShapeReferences (aContext aggregate) declaration shape+      ]++codecNominalImports :: Agg -> [Text]+codecNominalImports _ = []++codecMappedImports :: Agg -> [Text]+codecMappedImports a = case aTypeGraph a of+  Nothing -> []+  Just graph ->+    sort . nub $+      [ hsModule (odHaskell declaration) <> " ()"+      | ResolvedOpaque declaration <- codecMappedDeclarations a+      ]+        <> [ hsModule (odHaskell declaration) <> " ()"+           | ResolvedStructural _ shape <- codecMappedDeclarations a,+             key <- directShapeRefs shape,+             Just (ResolvedOpaque declaration) <- [Map.lookup key (tgDeclarations graph)]+           ]++codecMappedDeclarations :: Agg -> [ResolvedMappedDecl]+codecMappedDeclarations a = case aTypeGraph a of+  Nothing -> []+  Just graph ->+    mapMaybe (\key -> Map.lookup key (tgDeclarations graph)) (sort (Map.keys selected))+    where+      roots =+        [ key+        | event <- aEvents a,+          (_, AggregateMapped key) <- rcFields event,+          Map.member key (tgDeclarations graph)+        ]+      selected =+        Map.fromList+          [ (key, ())+          | root <- roots,+            key <- root : maybe [] (Map.keys . Map.fromSet (const ())) (Map.lookup root (tgReachability graph))+          ]++directShapeRefs :: ResolvedMappedShape -> [MappedKey]+directShapeRefs =+  foldMappedShape+    MappedShapeAlgebra+      { onRecord = \_ _ fields -> concatMap (exprRefs . rwfType) fields,+        onEnum = const [],+        onUnion = \_ arms -> concatMap (maybe [] exprRefs . rwaPayload) arms+      }++exprRefs :: ResolvedTypeExpr -> [MappedKey]+exprRefs =+  foldTypeExpr+    TypeExprAlgebra+      { onText = [],+        onInt = [],+        onInteger = [],+        onBool = [],+        onNatural = [],+        onTime = [],+        onJson = [],+        onOptional = id,+        onList = id,+        onMap = id,+        onRef = pure+      }++emitMappedCodecs :: HaskellImportPlan -> Agg -> Text+emitMappedCodecs importPlan a = case aTypeGraph a of+  Nothing -> ""+  Just graph ->+    T.intercalate+      "\n\n"+      [ emitStructuralCodec importPlan (aContext a) graph declaration shape+      | ResolvedStructural declaration shape <- codecMappedDeclarations a+      ]++emitStructuralCodec :: HaskellImportPlan -> Context -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text+emitStructuralCodec importPlan ctx graph declaration shape =+  nl+    [ "encode" <> name <> "Mapped :: " <> consumerType <> " -> Value",+      "encode" <> name <> "Mapped = encode" <> name <> "Shape . bindingToShape " <> binding,+      "",+      "parse" <> name <> "Mapped :: Value -> Parser " <> consumerType,+      "parse" <> name <> "Mapped value = bindingFromShape " <> binding <> " <$> parse" <> name <> "Shape value",+      "",+      "decode" <> name <> "Mapped :: Value -> Either Text " <> consumerType,+      "decode" <> name <> "Mapped = mapLeftText . parseEither parse" <> name <> "Mapped",+      "",+      "encode" <> name <> "Shape :: " <> shapeType <> " -> Value",+      emitShapeEncoder importPlan ctx graph declaration shape,+      "",+      "parse" <> name <> "Shape :: Value -> Parser " <> shapeType,+      emitShapeDecoder importPlan ctx graph declaration shape+    ]+  where+    name = sdName declaration+    consumerType = renderReferenceOrDie importPlan (haskellTypeReference (sdHaskell declaration))+    shapeType = renderReferenceOrDie importPlan (qualifiedTypeReference (structuralShapeModule ctx name) (name <> "Shape"))+    binding = renderReferenceOrDie importPlan (qualifiedValueReference (sdBinding declaration))++emitShapeEncoder :: HaskellImportPlan -> Context -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text+emitShapeEncoder importPlan ctx graph declaration =+  foldMappedShape+    MappedShapeAlgebra+      { onRecord = \_ _ fields ->+          nl $+            ["encode" <> name <> "Shape shape =", "  object"]+              <> objectEntries+                [ tshow (rwfKey field)+                    <> " .= "+                    <> encodeShapeExpr graph (rwfType field) (shapeValue (rwfHaskell field) <> " shape")+                | field <- fields+                ],+        onEnum = \entries ->+          nl $+            ["encode" <> name <> "Shape = \\case"]+              <> ["  " <> shapeConstructor (weCtor entry) <> " -> String " <> tshow (weTag entry) | entry <- entries],+        onUnion = \encoding arms ->+          nl $+            ["encode" <> name <> "Shape = \\case"]+              <> concatMap (unionEncodeArm encoding) arms+      }+  where+    name = sdName declaration+    shapeModuleName = structuralShapeModule ctx name+    shapeConstructor constructor = renderReferenceOrDie importPlan (constructorReference shapeModuleName constructor)+    shapeValue value = renderReferenceOrDie importPlan (HaskellReference shapeModuleName value ValueNamespace RequireQualified)+    unionEncodeArm encoding arm =+      [ "  " <> shapeConstructor (rwaCtor arm) <> payloadPattern <> " ->",+        "    object"+      ]+        <> objectEntries+          ( [tshow (ueTagField encoding) <> " .= (" <> tshow (rwaTag arm) <> " :: Text)"]+              <> [ tshow (ueContentsField encoding) <> " .= " <> encodeShapeExpr graph payload "payload"+                 | payload <- maybeToListText (rwaPayload arm)+                 ]+          )+      where+        payloadPattern = maybe "" (const " payload") (rwaPayload arm)++emitShapeDecoder :: HaskellImportPlan -> Context -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text+emitShapeDecoder importPlan ctx graph declaration =+  foldMappedShape+    MappedShapeAlgebra+      { onRecord = \constructor unknownFields fields ->+          nl $+            [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do"+            ]+              <> rejectLine "  " unknownFields (map rwfKey fields) "objectValue"+              <> [ "  " <> shapeConstructor constructor,+                   "    <$> " <> T.intercalate "\n    <*> " (map (decodeRecordField importPlan ctx graph) fields)+                 ],+        onEnum = \entries ->+          nl $+            [ "parse" <> name <> "Shape = withText " <> tshow (name <> "Shape") <> " $ \\tag -> case tag of"+            ]+              <> ["  " <> tshow (weTag entry) <> " -> pure " <> shapeConstructor (weCtor entry) | entry <- entries]+              <> ["  unknownTag -> " <> renderUnknownFailure (name <> " wire value") "unknownTag" (map weTag entries)],+        onUnion = \encoding arms ->+          nl $+            [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do",+              "  tag <- explicitParseField (withText " <> tshow (name <> " tag") <> " validate" <> name <> "Tag) objectValue " <> tshow (ueTagField encoding),+              "  case tag of"+            ]+              <> concatMap (unionDecodeArm encoding) arms+              <> [ "    _ -> fail \"validated union tag was not handled\"",+                   "",+                   "validate" <> name <> "Tag :: Text -> Parser Text",+                   "validate" <> name <> "Tag tag",+                   "  | tag `elem` " <> renderTextList (map rwaTag arms) <> " = pure tag",+                   "  | otherwise = " <> renderUnknownFailure (name <> " union tag") "tag" (map rwaTag arms)+                 ]+      }+  where+    name = sdName declaration+    shapeModuleName = structuralShapeModule ctx name+    shapeConstructor constructor = renderReferenceOrDie importPlan (constructorReference shapeModuleName constructor)+    rejectLine _ IgnoreUnknown _ _ = []+    rejectLine indent RejectUnknown allowed objectName =+      [indent <> "rejectUnknownFields " <> tshow name <> " " <> renderTextList allowed <> " " <> objectName]+    unionDecodeArm encoding arm =+      ["    " <> tshow (rwaTag arm) <> " -> do"]+        <> rejectLine "      " (ueUnknownFields encoding) allowed "objectValue"+        <> [ case rwaPayload arm of+               Nothing -> "      pure " <> shapeConstructor (rwaCtor arm)+               Just payload ->+                 "      "+                   <> shapeConstructor (rwaCtor arm)+                   <> " <$> explicitParseField ("+                   <> decodeShapeExpr graph payload+                   <> ") objectValue "+                   <> tshow (ueContentsField encoding)+           ]+      where+        allowed = ueTagField encoding : [ueContentsField encoding | rwaPayload arm /= Nothing]++decodeRecordField :: HaskellImportPlan -> Context -> TypeGraph -> ResolvedWireField -> Text+decodeRecordField importPlan ctx graph field = case rwfPresence field of+  PRequired ->+    "explicitParseField (" <> decoder <> ") objectValue " <> key+  POptional ->+    "parseOptionalField ("+      <> missing+      <> ") ("+      <> decoder+      <> ") objectValue "+      <> key+  where+    key = tshow (rwfKey field)+    decoder = decodeShapeExpr graph (rwfType field)+    missing = case rwfOnMissing field of+      Nothing -> "fail " <> tshow ("missing optional field without default: " <> rwfKey field)+      Just onMissing -> "pure " <> renderMissingDefault importPlan ctx graph (rwfType field) onMissing++encodeShapeExpr :: TypeGraph -> ResolvedTypeExpr -> Text -> Text+encodeShapeExpr graph expression =+  renderMappedEncode graph StructuralShapeBoundary (mappedCodecPlanOrDie graph expression)++decodeShapeExpr :: TypeGraph -> ResolvedTypeExpr -> Text+decodeShapeExpr graph expression =+  renderMappedParse graph StructuralShapeBoundary (mappedCodecPlanOrDie graph expression)++mappedCodecPlanOrDie :: TypeGraph -> ResolvedTypeExpr -> MappedCodecPlan+mappedCodecPlanOrDie graph expression =+  either+    (error . ("validated mapped codec plan failed: " <>) . show)+    id+    (planMappedCodec graph expression)++renderMissingDefault :: HaskellImportPlan -> Context -> TypeGraph -> ResolvedTypeExpr -> OnMissing -> Text+renderMissingDefault importPlan ctx graph expression = \case+  OmNull -> "Nothing"+  OmText value -> tshow value+  OmInt value -> T.pack (show value)+  OmBool value -> if value then "True" else "False"+  OmEmptyList -> "[]"+  OmEmptyMap -> "Map.empty"+  OmCtor constructor -> case expression of+    RRef key -> case Map.lookup key (tgDeclarations graph) of+      Just (ResolvedStructural declaration _) -> renderReferenceOrDie importPlan (constructorReference (structuralShapeModule ctx (sdName declaration)) constructor)+      _ -> constructor+    _ -> constructor++objectEntries :: [Text] -> [Text]+objectEntries entries =+  [lead index <> entry | (index, entry) <- zip [(0 :: Int) ..] entries]+    <> ["      ]"]+  where+    lead 0 = "      [ "+    lead _ = "      , "++renderTextList :: [Text] -> Text+renderTextList values = "[" <> T.intercalate ", " (map tshow values) <> "]"++-- | Emit a parser failure that names the rejected runtime value and the full,+-- deterministic wire set accepted at that point.+renderUnknownFailure :: Text -> Text -> [Text] -> Text+renderUnknownFailure label variable expected =+  "fail ("+    <> tshow ("unknown " <> label <> " ")+    <> " <> show "+    <> variable+    <> " <> "+    <> tshow ("; expected one of: " <> expectedText)+    <> ")"+  where+    expectedText = case expected of+      [] -> "<none>"+      values -> T.intercalate ", " values++renderUnknownEventTypeFailure :: Agg -> Text -> Text+renderUnknownEventTypeFailure aggregate variable =+  "fail ("+    <> tshow "unknown event type "+    <> " <> show "+    <> variable+    <> " <> "+    <> tshow "; expected one of: "+    <> " <> renderExpectedEventTypes "+    <> eventTypesName aggregate+    <> ")"++--------------------------------------------------------------------------------+-- Authoritative version-2 expressions and transducer+--------------------------------------------------------------------------------++hasVersion2Ownership :: Agg -> Bool+hasVersion2Ownership = any ((/= LegacyHoleImplementation) . tImplementation) . aTransitions++transitionEntries :: Agg -> [(Int, Transition)]+transitionEntries aggregate =+  [ (layoutDeclarationIndex entry, layoutTransition entry)+  | entry <- transitionLayout (aTransitions aggregate)+  ]++transitionStem :: Int -> Transition -> Text+transitionStem index transition =+  "transition"+    <> tshow' index+    <> pascal (tSource transition)+    <> pascal (tCommand transition)++guardFunctionName :: Int -> Transition -> Text+guardFunctionName index transition = transitionStem index transition <> "Guard"++writeFunctionName :: Int -> Transition -> Name -> Text+writeFunctionName index transition registerName =+  transitionStem index transition <> "Write" <> pascal registerName++holeFunctionName :: Int -> Transition -> Text+holeFunctionName index transition = transitionStem index transition <> "Hole"++holeFoldVersionName :: Int -> Transition -> Text+holeFoldVersionName index transition = holeFunctionName index transition <> "FoldVersion"++outputFunctionName :: Int -> Transition -> Int -> Name -> Text+outputFunctionName transitionIndex transition emitIndex eventName =+  transitionStem transitionIndex transition+    <> "Output"+    <> tshow' emitIndex+    <> pascal eventName++-- | Legacy create-once output-hook names made obsolete by authoritative+-- version-2 @fields(Command)@ generation.  Scaffolding reports these names as+-- safe-to-remove candidates without parsing or modifying consumer Haskell.+obsoleteGeneratedOutputHooks :: Spec -> [(Name, Text)]+obsoleteGeneratedOutputHooks spec = obsoleteGeneratedOutputHooksWith (eventOutputMapping spec) spec++obsoleteGeneratedOutputHooksForService :: CheckedService -> [(Name, Text)]+obsoleteGeneratedOutputHooksForService service =+  obsoleteGeneratedOutputHooksWith+    (eventOutputMappingFromGraphResult (checkedTypeGraph service) spec)+    spec+  where+    spec = checkedSpec service++obsoleteGeneratedOutputHooksWith :: (Aggregate -> Transition -> Int -> Name -> Either EventOutputError EventOutputMapping) -> Spec -> [(Name, Text)]+obsoleteGeneratedOutputHooksWith outputMapping spec =+  [ ( aggName aggregate,+      outputFunctionName transitionIndex transition emitIndex eventName+    )+  | aggregate <- [value | NAggregate value <- specNodes spec],+    entry <- transitionLayout (aggTransitions aggregate),+    let transitionIndex = layoutDeclarationIndex entry+        transition = layoutTransition entry,+    (emitIndex, eventName) <- zip [1 ..] (tEmits transition),+    Right GeneratedCommandIdentity {} <- [outputMapping aggregate transition emitIndex eventName]+  ]++commandForTransition :: Agg -> Transition -> ResolvedCtor+commandForTransition aggregate transition =+  fromMaybe+    (error ("validated aggregate command disappeared: " <> T.unpack (tCommand transition)))+    (find ((== tCommand transition) . rcName) (aCommands aggregate))++eventForName :: Agg -> Name -> ResolvedCtor+eventForName aggregate eventName =+  fromMaybe+    (error ("validated aggregate event disappeared: " <> T.unpack eventName))+    (find ((== eventName) . rcName) (aEvents aggregate))++commandFieldsType :: Transition -> Text+commandFieldsType transition = "RegFieldsOf " <> tCommand transition <> "Data"++payloadProjectionType :: Agg -> Transition -> Text+payloadProjectionType aggregate transition =+  "B.PayloadProj "+    <> aName aggregate+    <> "Regs "+    <> aName aggregate+    <> "Command ("+    <> commandFieldsType transition+    <> ")"++data ResolvedGeneratedTransition = ResolvedGeneratedTransition+  { resolvedTransitionIndex :: !Int,+    resolvedTransitionSource :: !Transition,+    resolvedTransitionGuard :: !(Maybe TypedScalarExpr),+    resolvedTransitionWrites :: ![(Name, TypedScalarExpr)]+  }+  deriving stock (Eq, Show)++data SilentOutcomeKind = RejectedOutcome | NoOpOutcome+  deriving stock (Eq, Show)++data ResolvedSilentOutcome = ResolvedSilentOutcome+  { resolvedSilentLayout :: !TransitionLayoutEntry,+    resolvedSilentKind :: !SilentOutcomeKind,+    resolvedSilentReason :: !TypedScalarExpr+  }+  deriving stock (Eq, Show)++-- Resolve each generated-owned transition exactly once. Import analysis,+-- projection planning, and Haskell emission all consume this inventory.+resolvedGeneratedTransitions :: Agg -> [ResolvedGeneratedTransition]+resolvedGeneratedTransitions aggregate =+  [ ResolvedGeneratedTransition+      { resolvedTransitionIndex = index,+        resolvedTransitionSource = transition,+        resolvedTransitionGuard = resolvedGuard index transition <$> tGuard transition,+        resolvedTransitionWrites =+          [ (registerName, resolvedWrite index transition registerName expression)+          | (registerName, expression) <- tWrites transition+          ]+      }+  | (index, transition) <- transitionEntries aggregate,+    tImplementation transition == GeneratedImplementation+  ]+  where+    environment transition = expressionEnvironmentWith (aSymbols aggregate) (aTypeGraph aggregate) (aSpec aggregate) (aAggregate aggregate) transition+    resolvedGuard index transition expression =+      expressionOrDie (guardFunctionName index transition) (resolveGuardExpr (environment transition) expression)+    resolvedWrite index transition registerName expression =+      expressionOrDie (writeFunctionName index transition registerName) (resolveWriteExpr (environment transition) registerName expression)++resolvedGeneratedExpressions :: Agg -> [TypedScalarExpr]+resolvedGeneratedExpressions = generatedTransitionExpressions . resolvedGeneratedTransitions++generatedTransitionExpressions :: [ResolvedGeneratedTransition] -> [TypedScalarExpr]+generatedTransitionExpressions = concatMap transitionExpressions+  where+    transitionExpressions resolved =+      maybe [] pure (resolvedTransitionGuard resolved)+        <> map snd (resolvedTransitionWrites resolved)++resolvedSilentOutcomes :: Agg -> [ResolvedSilentOutcome]+resolvedSilentOutcomes aggregate =+  [ ResolvedSilentOutcome+      { resolvedSilentLayout = entry,+        resolvedSilentKind = kind,+        resolvedSilentReason = resolveReason entry expected expression+      }+  | entry <- transitionLayout (aTransitions aggregate),+    let transition = layoutTransition entry,+    tMode transition == TmLive,+    (kind, expected, expression) <- outcomeReason transition+  ]+  where+    outcomeReason transition = case (aDomainOutcomeTypes aggregate, tOutcome transition) of+      (Just outcomeTypes, Just (OutcomeRejected expression _)) ->+        [(RejectedOutcome, resolvedRejectionType outcomeTypes, expression)]+      (Just outcomeTypes, Just (OutcomeNoOp expression _)) ->+        [(NoOpOutcome, resolvedNoOpType outcomeTypes, expression)]+      _ -> []+    resolveReason entry expected expression =+      let transition = layoutTransition entry+          owner = transitionStem (layoutDeclarationIndex entry) transition <> "OutcomeReason"+          environment = expressionEnvironmentWith (aSymbols aggregate) (aTypeGraph aggregate) (aSpec aggregate) (aAggregate aggregate) transition+       in expressionOrDie owner (resolveScalarExpr environment (ExpectScalarType expected) expression)++resolvedOutcomeExpressions :: Agg -> [TypedScalarExpr]+resolvedOutcomeExpressions = map resolvedSilentReason . resolvedSilentOutcomes++-- | 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)++typedExpressionChildren :: TypedScalarExpr -> [TypedScalarExpr]+typedExpressionChildren expression = case typedScalarNode expression of+  TypedLiteral {} -> []+  TypedRoot {} -> []+  TypedProject {} -> []+  TypedAdd _ left right -> [left, right]+  TypedSubtract _ left right -> [left, right]+  TypedMultiply _ left right -> [left, right]+  TypedEqual left right -> [left, right]+  TypedNotEqual left right -> [left, right]+  TypedCompare _ left right -> [left, right]+  TypedAnd left right -> [left, right]+  TypedOr left right -> [left, right]++typedConsumerLiteralNominals :: TypedScalarExpr -> [ResolvedNominalType]+typedConsumerLiteralNominals expression = own <> concatMap typedConsumerLiteralNominals (typedExpressionChildren expression)+  where+    own = case (typedScalarType expression, typedScalarNode expression) of+      (AggregateNominal nominal, TypedLiteral ScalarEnumValue {})+        | ConsumerNominal {} <- resolvedNominalOwnership nominal -> [nominal]+      (AggregateNominal nominal, TypedLiteral ScalarIdValue {})+        | ConsumerNominal {} <- resolvedNominalOwnership nominal -> [nominal]+      _ -> []++typedGeneratedNominals :: TypedScalarExpr -> [ResolvedNominalType]+typedGeneratedNominals expression = own <> concatMap typedGeneratedNominals (typedExpressionChildren expression)+  where+    own = case typedScalarType expression of+      AggregateNominal nominal+        | GeneratedNominal <- resolvedNominalOwnership nominal -> [nominal]+      _ -> []++expressionOrDie :: Text -> Either (NonEmpty ExpressionDiagnostic) TypedScalarExpr -> TypedScalarExpr+expressionOrDie owner = either (error . (("validated expression disappeared for " <> T.unpack owner <> ": ") <>) . show) id++data ProjectionAliasTarget+  = StructuralProjectionAlias !ScalarRootProvenance !ResolvedScalarProjection+  | NominalProjectionAlias !ResolvedNominalType !ScalarRootProvenance+  deriving stock (Eq, Show)++data ProjectionAlias = ProjectionAlias+  { projectionAliasTarget :: !ProjectionAliasTarget,+    projectionAliasName :: !Text+  }+  deriving stock (Eq, Show)++projectionAliasesForTransition :: ResolvedGeneratedTransition -> [ProjectionAlias]+projectionAliasesForTransition resolved = allocateAliases targets+  where+    expressions =+      maybe [] pure (resolvedTransitionGuard resolved)+        <> map snd (resolvedTransitionWrites resolved)+    targets = nub (concatMap projectionAliasTargets expressions)++projectionAliasTargets :: TypedScalarExpr -> [ProjectionAliasTarget]+projectionAliasTargets expression = own <> comparisonTargets <> concatMap projectionAliasTargets children+  where+    children = typedExpressionChildren expression+    own = case typedScalarNode expression of+      TypedProject provenance projection -> [StructuralProjectionAlias provenance projection]+      _ -> []+    comparisonTargets = case typedScalarNode expression of+      TypedEqual left right -> mapMaybe nominalTarget [left, right]+      TypedNotEqual left right -> mapMaybe nominalTarget [left, right]+      _ -> []+    nominalTarget operand = case (typedScalarType operand, typedScalarNode operand) of+      (AggregateNominal nominal, TypedRoot provenance)+        | nominalComparisonProjection nominal -> Just (NominalProjectionAlias nominal provenance)+      _ -> Nothing++allocateAliases :: [ProjectionAliasTarget] -> [ProjectionAlias]+allocateAliases = snd . foldl allocate (Map.empty, [])+  where+    allocate (counts, aliases) target =+      let base = projectionAliasBase target+          occurrence = Map.findWithDefault 0 base counts + 1+          alias = if occurrence == 1 then base else base <> tshow' occurrence+       in (Map.insert base occurrence counts, aliases <> [ProjectionAlias target alias])++projectionAliasBase :: ProjectionAliasTarget -> Text+projectionAliasBase target = prefix <> pascal rootName <> pathSuffix+  where+    provenance = case target of+      StructuralProjectionAlias value _ -> value+      NominalProjectionAlias _ value -> value+    (prefix, rootName) = case provenance of+      ScalarRegisterRoot name _ -> ("register", name)+      ScalarCommandRoot name _ -> ("command", name)+    pathSuffix = case target of+      NominalProjectionAlias {} -> ""+      StructuralProjectionAlias _ projection ->+        T.concat+          [ normaliseAliasPart (unescapePointer segment)+          | segment <- filter (not . T.null) (T.splitOn "/" (scalarProjectionPointer projection))+          ]++normaliseAliasPart :: Text -> Text+normaliseAliasPart value = case filter (not . T.null) (T.split (not . isAlphaNum) value) of+  [] -> "Field"+  pieces -> T.concat (map pascal pieces)++unescapePointer :: Text -> Text+unescapePointer = T.replace "~0" "~" . T.replace "~1" "/"++projectionAliasFor :: [ProjectionAlias] -> ProjectionAliasTarget -> Text+projectionAliasFor aliases target =+  maybe+    (error ("resolved projection alias disappeared: " <> show target))+    projectionAliasName+    (find ((== target) . projectionAliasTarget) aliases)++data RenderAssociativity = RenderLeft | RenderRight | RenderNonAssociative+  deriving stock (Eq, Show)++data RenderOperandSide = RenderLeftOperand | RenderRightOperand+  deriving stock (Eq, Show)++data RenderedKeikiExpr = RenderedKeikiExpr+  { renderedKeikiText :: !Text,+    renderedKeikiPrecedence :: !Int+  }+  deriving stock (Eq, Show)++renderedAtom :: Text -> RenderedKeikiExpr+renderedAtom value = RenderedKeikiExpr value 10++renderedInfix :: Int -> RenderAssociativity -> Text -> RenderedKeikiExpr -> RenderedKeikiExpr -> RenderedKeikiExpr+renderedInfix precedence associativity operator left right =+  RenderedKeikiExpr+    ( renderInfixChild precedence associativity RenderLeftOperand left+        <> " "+        <> operator+        <> " "+        <> renderInfixChild precedence associativity RenderRightOperand right+    )+    precedence++renderInfixChild :: Int -> RenderAssociativity -> RenderOperandSide -> RenderedKeikiExpr -> Text+renderInfixChild parentPrecedence associativity side child+  | renderedKeikiPrecedence child > parentPrecedence = renderedKeikiText child+  | renderedKeikiPrecedence child < parentPrecedence = parenthesized+  | otherwise = case associativity of+      RenderLeft+        | side == RenderLeftOperand -> renderedKeikiText child+      RenderRight+        | side == RenderRightOperand -> renderedKeikiText child+      _ -> parenthesized+  where+    parenthesized = "(" <> renderedKeikiText child <> ")"++renderKeikiPredicate :: HaskellImportPlan -> [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> Text+renderKeikiPredicate importPlan aliases aggregate transition =+  renderedKeikiText . renderPredicate+  where+    renderPredicate expression = case typedScalarNode expression of+      TypedEqual left right -> comparison ".==" left right+      TypedNotEqual left right -> comparison "./=" left right+      TypedCompare operator left right -> comparison (renderComparisonOperator operator) left right+      TypedAnd left right -> boolean 3 RenderRight ".&&" left right+      TypedOr left right -> boolean 2 RenderRight ".||" left right+      _ ->+        renderedInfix+          4+          RenderNonAssociative+          ".=="+          (renderKeikiTerm importPlan aliases aggregate transition expression)+          (renderedAtom "K.lit True")+    comparison operator left right =+      renderedInfix+        4+        RenderNonAssociative+        operator+        (renderComparisonTerm importPlan aliases aggregate transition left)+        (renderComparisonTerm importPlan aliases aggregate transition right)+    boolean precedence associativity operator left right =+      renderedInfix precedence associativity operator (renderPredicate left) (renderPredicate right)++renderComparisonOperator :: CmpOp -> Text+renderComparisonOperator = \case+  OpEq -> ".=="+  OpNeq -> "./="+  OpLt -> ".<"+  OpLe -> ".<="+  OpGt -> ".>"+  OpGe -> ".>="++renderComparisonTerm :: HaskellImportPlan -> [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> RenderedKeikiExpr+renderComparisonTerm importPlan aliases aggregate transition expression = case (typedScalarType expression, typedScalarNode expression) of+  (AggregateNominal nominal, TypedRoot provenance)+    | nominalComparisonProjection nominal ->+        renderedAtom (projectionAliasFor aliases (NominalProjectionAlias nominal provenance))+  (AggregateNominal nominal, TypedLiteral (ScalarEnumValue _ constructor)) ->+    renderedAtom ("K.lit (" <> tshow (enumWireFor nominal constructor) <> " :: Text)")+  (AggregateNominal _, TypedLiteral (ScalarIdValue _ value)) ->+    renderedAtom ("K.lit (" <> tshow value <> " :: Text)")+  _ -> renderKeikiTerm importPlan aliases aggregate transition expression++nominalComparisonProjection :: ResolvedNominalType -> Bool+nominalComparisonProjection nominal = case resolvedNominalRepresentation nominal of+  IdRepresentation {} -> True+  EnumRepresentation {} -> True+  ScalarRepresentation {} -> case resolvedNominalOwnership nominal of+    ConsumerNominal {} -> True+    GeneratedNominal -> False++enumWireFor :: ResolvedNominalType -> Name -> Text+enumWireFor nominal constructor = case resolvedNominalRepresentation nominal of+  EnumRepresentation constructors -> fromMaybe (error "validated enum literal lost its wire spelling") (lookup constructor (NE.toList constructors))+  _ -> error "validated enum literal lost its enum representation"++renderNominalProjectionTerm :: HaskellImportPlan -> Agg -> Transition -> ResolvedNominalType -> ScalarRootProvenance -> Text+renderNominalProjectionTerm importPlan aggregate transition nominal provenance = case provenance of+  ScalarRegisterRoot registerName ownerType ->+    "K.regProj "+      <> projectionQualifier+      <> "."+      <> witness+      <> " (#"+      <> registerName+      <> " :: K.Index "+      <> aName aggregate+      <> "Regs "+      <> renderDomainType importPlan aggregate ownerType+      <> ")"+  ScalarCommandRoot fieldName ownerType ->+    "K.inpProj "+      <> projectionQualifier+      <> "."+      <> witness+      <> " inCtor"+      <> tCommand transition+      <> " (#"+      <> commandFieldSelector aggregate (tCommand transition) fieldName+      <> " :: K.Index ("+      <> commandFieldsType transition+      <> ") "+      <> renderDomainType importPlan aggregate ownerType+      <> ")"+  where+    projectionQualifier = case resolvedNominalOwnership nominal of+      GeneratedNominal -> "GeneratedNominals"+      ConsumerNominal {} -> "NominalProjections"+    witness = case resolvedNominalRepresentation nominal of+      ScalarRepresentation {} -> lowerFirst (resolvedNominalName nominal) <> "Witness"+      IdRepresentation {} -> nominalEqualityWitnessName nominal+      EnumRepresentation {} -> nominalEqualityWitnessName nominal++renderKeikiTerm :: HaskellImportPlan -> [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> RenderedKeikiExpr+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." <> commandFieldSelector aggregate (tCommand transition) fieldName)+  TypedProject provenance projection ->+    renderedAtom (projectionAliasFor aliases (StructuralProjectionAlias provenance projection))+  TypedAdd _ left right -> arithmetic 6 ".+" left right+  TypedSubtract _ left right -> arithmetic 6 ".-" left right+  TypedMultiply _ left right -> arithmetic 7 ".*" left right+  TypedEqual {} -> impossiblePredicate+  TypedNotEqual {} -> impossiblePredicate+  TypedCompare {} -> impossiblePredicate+  TypedAnd {} -> impossiblePredicate+  TypedOr {} -> impossiblePredicate+  where+    arithmetic precedence operator left right =+      renderedInfix+        precedence+        RenderLeft+        operator+        (renderKeikiTerm importPlan aliases aggregate transition left)+        (renderKeikiTerm importPlan aliases aggregate transition right)+    impossiblePredicate = error "predicate-valued Boolean expressions cannot be lowered as register terms"++renderOutcomeReasonEvaluation :: HaskellImportPlan -> Agg -> Transition -> TypedScalarExpr -> Text+renderOutcomeReasonEvaluation importPlan aggregate transition expression =+  evaluator+    <> " ("+    <> renderedKeikiText rendered+    <> ") registers command"+  where+    (evaluator, rendered) = case typedScalarNode expression of+      TypedEqual {} -> ("K.evalPred", renderOutcomePredicate importPlan aggregate transition expression)+      TypedNotEqual {} -> ("K.evalPred", renderOutcomePredicate importPlan aggregate transition expression)+      TypedCompare {} -> ("K.evalPred", renderOutcomePredicate importPlan aggregate transition expression)+      TypedAnd {} -> ("K.evalPred", renderOutcomePredicate importPlan aggregate transition expression)+      TypedOr {} -> ("K.evalPred", renderOutcomePredicate importPlan aggregate transition expression)+      _ -> ("K.evalTerm", renderOutcomeKeikiTerm importPlan aggregate transition expression)++renderOutcomePredicate :: HaskellImportPlan -> Agg -> Transition -> TypedScalarExpr -> RenderedKeikiExpr+renderOutcomePredicate importPlan aggregate transition = renderPredicate+  where+    renderPredicate expression = case typedScalarNode expression of+      TypedEqual left right -> comparison ".==" left right+      TypedNotEqual left right -> comparison "./=" left right+      TypedCompare operator left right -> comparison (renderComparisonOperator operator) left right+      TypedAnd left right -> boolean 3 RenderRight ".&&" left right+      TypedOr left right -> boolean 2 RenderRight ".||" left right+      _ ->+        renderedInfix+          4+          RenderNonAssociative+          ".=="+          (renderOutcomeKeikiTerm importPlan aggregate transition expression)+          (renderedAtom "K.lit True")+    comparison operator left right =+      renderedInfix+        4+        RenderNonAssociative+        operator+        (renderOutcomeComparisonTerm importPlan aggregate transition left)+        (renderOutcomeComparisonTerm importPlan aggregate transition right)+    boolean precedence associativity operator left right =+      renderedInfix precedence associativity operator (renderPredicate left) (renderPredicate right)++renderOutcomeComparisonTerm :: HaskellImportPlan -> Agg -> Transition -> TypedScalarExpr -> RenderedKeikiExpr+renderOutcomeComparisonTerm importPlan aggregate transition expression = case (typedScalarType expression, typedScalarNode expression) of+  (AggregateNominal nominal, TypedRoot provenance)+    | nominalComparisonProjection nominal ->+        renderedAtom (renderNominalProjectionTerm importPlan aggregate transition nominal provenance)+  (AggregateNominal nominal, TypedLiteral (ScalarEnumValue _ constructor)) ->+    renderedAtom ("K.lit (" <> tshow (enumWireFor nominal constructor) <> " :: Text)")+  (AggregateNominal _, TypedLiteral (ScalarIdValue _ value)) ->+    renderedAtom ("K.lit (" <> tshow value <> " :: Text)")+  _ -> renderOutcomeKeikiTerm importPlan aggregate transition expression++renderOutcomeKeikiTerm :: HaskellImportPlan -> Agg -> Transition -> TypedScalarExpr -> RenderedKeikiExpr+renderOutcomeKeikiTerm importPlan 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 ownerType) ->+    renderedAtom+      ( "K.inpCtor inCtor"+          <> tCommand transition+          <> " (#"+          <> commandFieldSelector aggregate (tCommand transition) fieldName+          <> " :: K.Index ("+          <> commandFieldsType transition+          <> ") "+          <> renderDomainType importPlan aggregate ownerType+          <> ")"+      )+  TypedProject provenance projection ->+    renderedAtom (renderStructuralProjectionTerm importPlan aggregate transition provenance projection)+  TypedAdd _ left right -> arithmetic 6 ".+" left right+  TypedSubtract _ left right -> arithmetic 6 ".-" left right+  TypedMultiply _ left right -> arithmetic 7 ".*" left right+  TypedEqual {} -> impossiblePredicate+  TypedNotEqual {} -> impossiblePredicate+  TypedCompare {} -> impossiblePredicate+  TypedAnd {} -> impossiblePredicate+  TypedOr {} -> impossiblePredicate+  where+    arithmetic precedence operator left right =+      renderedInfix+        precedence+        RenderLeft+        operator+        (renderOutcomeKeikiTerm importPlan aggregate transition left)+        (renderOutcomeKeikiTerm importPlan aggregate transition right)+    impossiblePredicate = error "predicate-valued Boolean outcome cannot be lowered as a Keiki term"++renderStructuralProjectionTerm :: HaskellImportPlan -> Agg -> Transition -> ScalarRootProvenance -> ResolvedScalarProjection -> Text+renderStructuralProjectionTerm importPlan aggregate transition provenance projection = case provenance of+  ScalarRegisterRoot registerName ownerType ->+    "K.regProj StructuralProjections."+      <> witness+      <> " (#"+      <> registerName+      <> " :: K.Index "+      <> aName aggregate+      <> "Regs "+      <> renderDomainType importPlan aggregate ownerType+      <> ")"+  ScalarCommandRoot fieldName ownerType ->+    "K.inpProj StructuralProjections."+      <> witness+      <> " inCtor"+      <> tCommand transition+      <> " (#"+      <> commandFieldSelector aggregate (tCommand transition) fieldName+      <> " :: K.Index ("+      <> commandFieldsType transition+      <> ") "+      <> renderDomainType importPlan aggregate ownerType+      <> ")"+  where+    witness =+      fromMaybe+        (error ("resolved structural projection witness disappeared: " <> show projection))+        (aTypeGraph aggregate >>= \graph -> projectionWitnessName graph (scalarProjectionOwner projection) (scalarProjectionPointer projection))++renderKeikiLiteral :: HaskellImportPlan -> Agg -> ResolvedAggregateType -> ScalarValue -> Text+renderKeikiLiteral importPlan aggregate scalarType = \case+  ScalarTextValue value -> "K.lit (" <> tshow value <> " :: Text)"+  ScalarIntValue value -> "K.lit (" <> tshow' value <> " :: Int)"+  ScalarIntegerValue value -> "K.lit (" <> T.pack (show value) <> " :: Integer)"+  ScalarNaturalValue value -> "K.lit (" <> T.pack (show value) <> " :: Natural)"+  ScalarBoolValue value -> "K.lit " <> if value then "True" else "False"+  ScalarTimeValue value -> "K.lit " <> renderRegisterInitial (InitialTime value)+  ScalarEnumValue _typeName constructor -> case scalarType of+    AggregateNominal nominal -> case resolvedNominalOwnership nominal of+      GeneratedNominal -> "K.lit " <> constructor+      ConsumerNominal binding ->+        "K.lit (nominalFromRepresentation "+          <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding))+          <> " "+          <> renderReferenceOrDie importPlan (nominalRepresentationConstructorReference (aContext aggregate) nominal constructor)+          <> ")"+    _ -> error "validated enum literal lost its nominal type"+  ScalarIdValue typeName value -> case scalarType of+    AggregateNominal nominal -> case resolvedNominalOwnership nominal of+      GeneratedNominal -> case idDomainContractFor (aLanguageContract aggregate) =<< idPrefixOf nominal of+        Nothing -> "K.lit (" <> typeName <> " " <> tshow value <> ")"+        Just _ ->+          "K.lit (case parse"+            <> typeName+            <> " "+            <> tshow value+            <> " of Right parsed -> parsed; Left _ -> error \"validated ID literal failed to parse\")"+      ConsumerNominal binding -> case resolvedNominalRepresentation nominal of+        IdRepresentation prefix ->+          "K.lit (nominalFromRepresentation "+            <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding))+            <> " (case KindID.parseText @"+            <> tshow prefix+            <> " "+            <> tshow value+            <> " of Right parsed -> parsed; Left _ -> error \"validated ID literal failed to parse\"))"+        _ -> error "validated ID literal lost its ID representation"+    _ -> error "validated ID literal lost its nominal type"+  where+    idPrefixOf nominal = case resolvedNominalRepresentation nominal of+      IdRepresentation prefix -> Just prefix+      _ -> Nothing++generatedIdSampleHaskell :: Agg -> ResolvedNominalType -> Maybe Text+generatedIdSampleHaskell aggregate nominal = do+  prefix <- case resolvedNominalRepresentation nominal of+    IdRepresentation value -> Just value+    _ -> Nothing+  contract <- idDomainContractFor (aLanguageContract aggregate) prefix+  let name = resolvedNominalName nominal+      sample = idDomainSampleText contract+  pure+    ( "(case parse"+        <> name+        <> " "+        <> tshow sample+        <> " of Right parsed -> parsed; Left _ -> error \"generated valid ID sample failed to parse\")"+    )++emitGeneratedTransducer :: Agg -> Text+emitGeneratedTransducer aggregate =+  nl $+    renderGeneratedLanguagePragmas+      ( [ExtBlockArguments, ExtQualifiedDo]+          <> [ExtOverloadedLabels | not (null projectionAliases)]+          <> [ExtOverloadedRecordDot | transducerUsesRecordDot aggregate]+      )+      ++ [ generatedBanner,+           "module " <> aGenPrefix aggregate <> ".Transducer",+           "  ( " <> lowerFirst (aName aggregate) <> "Transducer",+           "  , " <> lowerFirst (aName aggregate) <> "FoldFingerprint",+           "  , BehaviorOwnership (..)",+           "  , " <> lowerFirst (aName aggregate) <> "PredicateVerifications",+           "  ) where",+           "",+           "import " <> aGenPrefix aggregate <> ".Domain",+           "import Data.Text (Text)"+         ]+      ++ ["import Data.Time.Calendar (fromGregorian)" | expressionUsesTimeLiteral]+      ++ ["import Data.Time.Clock (UTCTime (..), picosecondsToDiffTime)" | expressionUsesTimeLiteral]+      ++ ["import Numeric.Natural (Natural)" | expressionUsesNaturalLiteral]+      ++ generatedNominalTypeImportsWithParsers+        (aggregateCheckedService aggregate)+        (aContext aggregate)+        generatedExpressionNominals+        generatedLiteralNominals+      ++ structuralProjectionImport+      ++ generatedNominalProjectionImport+      ++ consumerNominalProjectionImport+      ++ consumerImports+      ++ ["import Data.KindID qualified as KindID" | expressionUsesConsumerIdLiteral]+      ++ ["import Keiro.Codec.Nominal (nominalFromRepresentation)" | expressionUsesConsumerNominalLiteral]+      ++ [ "import Keiki.Builder qualified as B",+           "import Keiki.Core (" <> T.intercalate ", " keikiCoreImports <> ")",+           "import Keiki.Core qualified as K",+           "import Keiki.Symbolic qualified as S"+         ]+      ++ ["import " <> aHolePrefix aggregate <> ".Holes qualified as Holes" | transducerUsesHoles aggregate]+      ++ ["import Data.Text qualified as T" | anyHoleOwned aggregate]+      ++ ["import Keiki.Builder ((=:))" | any (not . null . tWrites . snd) (transitionEntries aggregate)]+      ++ ["import Keiki.Generics (RegFieldsOf)" | not (null projectionAliases)]+      ++ ["import Keiro.Snapshot.Codec (FoldVersion (..))" | anyHoleOwned aggregate]+      ++ [ "",+           lowerFirst (aName aggregate) <> "Transducer",+           "  :: SymTransducer",+           "       (HsPred " <> aName aggregate <> "Regs " <> aName aggregate <> "Command)",+           "       " <> aName aggregate <> "Regs",+           "       " <> aVertexType aggregate,+           "       " <> aName aggregate <> "Command",+           "       " <> aName aggregate <> "Event",+           lowerFirst (aName aggregate) <> "Transducer =",+           "  B.buildTransducer " <> initialVertex aggregate <> " initial" <> aName aggregate <> "Regs isTerminal do",+           nl (concatMap (generatedFromBlock importPlan aggregate resolvedTransitions) (groupTransitionEntriesBySource aggregate)),+           " where",+           "  isTerminal = \\case",+           nl ["    " <> vertexCtor aggregate (stName state) <> " -> True" | state <- aStates aggregate, stTerminal state],+           "    _ -> False",+           "",+           lowerFirst (aName aggregate) <> "FoldFingerprint :: Text",+           lowerFirst (aName aggregate) <> "FoldFingerprint = " <> foldFingerprintExpression aggregate,+           "",+           "data BehaviorOwnership = GeneratedOwned | HoleOwned",+           "  deriving stock (Eq, Show)",+           "",+           "-- Every checked transition predicate is audited through Keiki's conservative",+           "-- symbolic verifier. Opaque Hole terms remain explicitly unverified.",+           lowerFirst (aName aggregate) <> "PredicateVerifications :: IO [(Text, BehaviorOwnership, S.PredicateVerification)]",+           lowerFirst (aName aggregate) <> "PredicateVerifications = sequence",+           nl (renderVerificationList aggregate),+           " where",+           "  verifyTransition label owner source edgeIndex =",+           "    case drop edgeIndex (K.edgesOut " <> lowerFirst (aName aggregate) <> "Transducer source) of",+           "      K.Edge predicate _ _ _ _ : _ -> (\\result -> (label, owner, result)) <$> S.verifyPredicate predicate",+           "      [] -> pure (label, owner, S.UnverifiedSolverFailure \"generated transition edge missing\")"+         ]+  where+    resolvedTransitions = resolvedGeneratedTransitions aggregate+    resolvedExpressions = generatedTransitionExpressions resolvedTransitions+    projectionAliases = concatMap projectionAliasesForTransition resolvedTransitions+    projectionTargets = map projectionAliasTarget projectionAliases+    structuralProjectionImport =+      [ "import " <> structuralProjectionModule (aContext aggregate) <> " qualified as StructuralProjections"+      | any isStructuralProjection projectionTargets+      ]+    generatedNominalProjectionImport =+      [ "import " <> generatedNominalModule (aContext aggregate) <> " qualified as GeneratedNominals"+      | any isGeneratedNominalProjection projectionTargets+      ]+    consumerNominalProjectionImport =+      [ "import " <> nominalProjectionModule (aContext aggregate) <> " qualified as NominalProjections"+      | any isConsumerNominalProjection projectionTargets+      ]+    consumerImports =+      T.lines (renderPlannedImports importPlan)+    expressionImportTypes =+      nub+        ( concatMap typedExpressionImportTypes (generatedTransitionGuards resolvedTransitions)+            <> concatMap typedExpressionLiteralTypes resolvedExpressions+        )+    consumerLiteralNominals = nub [nominal | expression <- resolvedExpressions, nominal <- typedConsumerLiteralNominals expression]+    importPlan = transducerImportPlan aggregate expressionImportTypes consumerLiteralNominals+    generatedExpressionNominals =+      stableNominals+        [ nominal+        | 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)+    expressionUsesConsumerIdLiteral = any (isIdRepresentation . resolvedNominalRepresentation) consumerLiteralNominals+    usedOperators = nub (concatMap generatedTransitionOperators resolvedTransitions)+    keikiCoreImports = ["HsPred", "SymTransducer"] <> ["(" <> operator <> ")" | operator <- expressionOperatorOrder, operator `elem` usedOperators]+    isTimeLiteral expression = case typedScalarNode expression of+      TypedLiteral ScalarTimeValue {} -> True+      _ -> False+    isNaturalLiteral expression = case typedScalarNode expression of+      TypedLiteral ScalarNaturalValue {} -> True+      _ -> False+    isIdRepresentation IdRepresentation {} = True+    isIdRepresentation _ = False++transducerUsesRecordDot :: Agg -> Bool+transducerUsesRecordDot aggregate =+  any expressionUsesCommandRoot (resolvedGeneratedExpressions aggregate)+    || any generatedOutputUsesCommandField generatedOutputs+  where+    generatedOutputs =+      [ outputMappingFor aggregate transitionIndex emitIndex+      | (transitionIndex, transition) <- transitionEntries aggregate,+        tImplementation transition == GeneratedImplementation,+        emitIndex <- [1 .. length (tEmits transition)]+      ]+    generatedOutputUsesCommandField (GeneratedCommandIdentity _ fields) = not (null fields)+    generatedOutputUsesCommandField HandOwnedEventOutput {} = False+    expressionUsesCommandRoot = anyTypedExpression isCommandRoot+    isCommandRoot expression = case typedScalarNode expression of+      TypedRoot ScalarCommandRoot {} -> True+      _ -> False++transducerImportPlan :: Agg -> [ResolvedAggregateType] -> [ResolvedNominalType] -> HaskellImportPlan+transducerImportPlan aggregate importedTypes literalNominals =+  planImportsOrDie+    (aGenPrefix aggregate <> ".Transducer")+    (Set.fromList [aName aggregate <> "Regs", aName aggregate <> "Command", aName aggregate <> "Event"])+    ( Set.unions+        [ aggregateSourceReferences (aggregateConsumerHaskellSource (aSymbols aggregate) resolvedType)+        | resolvedType <- importedTypes+        ]+        <> Set.fromList+          [ reference+          | nominal <- literalNominals,+            ConsumerNominal binding <- [resolvedNominalOwnership nominal],+            reference <-+              qualifiedValueReference (consumerNominalBinding binding)+                : case resolvedNominalRepresentation nominal of+                  EnumRepresentation constructors ->+                    [ nominalRepresentationConstructorReference (aContext aggregate) nominal constructor+                    | (constructor, _) <- NE.toList constructors+                    ]+                  _ -> []+          ]+    )++typedExpressionImportTypes :: TypedScalarExpr -> [ResolvedAggregateType]+typedExpressionImportTypes expression = own <> concatMap typedExpressionImportTypes (typedExpressionChildren expression)+  where+    own = case typedScalarNode expression of+      TypedLiteral {} -> [typedScalarType expression]+      TypedRoot provenance -> [scalarRootType provenance]+      TypedProject provenance _ -> [scalarRootType provenance]+      _ -> []++scalarRootType :: ScalarRootProvenance -> ResolvedAggregateType+scalarRootType = \case+  ScalarRegisterRoot _ resolvedType -> resolvedType+  ScalarCommandRoot _ resolvedType -> resolvedType++isStructuralProjection :: ProjectionAliasTarget -> Bool+isStructuralProjection StructuralProjectionAlias {} = True+isStructuralProjection NominalProjectionAlias {} = False++isGeneratedNominalProjection :: ProjectionAliasTarget -> Bool+isGeneratedNominalProjection (NominalProjectionAlias nominal _) = resolvedNominalOwnership nominal == GeneratedNominal+isGeneratedNominalProjection StructuralProjectionAlias {} = False++isConsumerNominalProjection :: ProjectionAliasTarget -> Bool+isConsumerNominalProjection (NominalProjectionAlias nominal _) = case resolvedNominalOwnership nominal of+  ConsumerNominal {} -> True+  GeneratedNominal -> False+isConsumerNominalProjection StructuralProjectionAlias {} = False++expressionOperatorOrder :: [Text]+expressionOperatorOrder = [".*", ".+", ".-", ".==", "./=", ".<", ".<=", ".>", ".>=", ".&&", ".||"]++generatedTransitionOperators :: ResolvedGeneratedTransition -> [Text]+generatedTransitionOperators resolved =+  maybe [] expressionPredicateOperators (resolvedTransitionGuard resolved)+    <> concatMap (expressionTermOperators . snd) (resolvedTransitionWrites resolved)++outcomeExpressionOperators :: TypedScalarExpr -> [Text]+outcomeExpressionOperators expression = case typedScalarNode expression of+  TypedEqual {} -> expressionPredicateOperators expression+  TypedNotEqual {} -> expressionPredicateOperators expression+  TypedCompare {} -> expressionPredicateOperators expression+  TypedAnd {} -> expressionPredicateOperators expression+  TypedOr {} -> expressionPredicateOperators expression+  _ -> expressionTermOperators expression++expressionPredicateOperators :: TypedScalarExpr -> [Text]+expressionPredicateOperators expression = case typedScalarNode expression of+  TypedEqual left right -> ".==" : expressionTermOperators left <> expressionTermOperators right+  TypedNotEqual left right -> "./=" : expressionTermOperators left <> expressionTermOperators right+  TypedCompare operator left right -> renderComparisonOperator operator : expressionTermOperators left <> expressionTermOperators right+  TypedAnd left right -> ".&&" : expressionPredicateOperators left <> expressionPredicateOperators right+  TypedOr left right -> ".||" : expressionPredicateOperators left <> expressionPredicateOperators right+  _ -> ".==" : expressionTermOperators expression++expressionTermOperators :: TypedScalarExpr -> [Text]+expressionTermOperators expression = case typedScalarNode expression of+  TypedAdd _ left right -> ".+" : expressionTermOperators left <> expressionTermOperators right+  TypedSubtract _ left right -> ".-" : expressionTermOperators left <> expressionTermOperators right+  TypedMultiply _ left right -> ".*" : expressionTermOperators left <> expressionTermOperators right+  _ -> concatMap expressionTermOperators (typedExpressionChildren expression)++anyHoleOwned :: Agg -> Bool+anyHoleOwned = any ((== HoleImplementation) . tImplementation) . aTransitions++transducerUsesHoles :: Agg -> Bool+transducerUsesHoles aggregate =+  anyHoleOwned aggregate+    || any isHandOwned (Map.elems (aOutputMappings aggregate))+  where+    isHandOwned HandOwnedEventOutput {} = True+    isHandOwned GeneratedCommandIdentity {} = False++renderVerificationList :: Agg -> [Text]+renderVerificationList aggregate =+  [ (if listIndex == (0 :: Int) then "  [ " else "  , ")+      <> "verifyTransition "+      <> tshow (transitionStem transitionIndex transition)+      <> " "+      <> ownership+      <> " "+      <> vertexCtor aggregate source+      <> " "+      <> tshow' edgeIndex+  | (listIndex, (source, edgeIndex, transitionIndex, transition)) <- zip [0 ..] entries,+    let ownership = case tImplementation transition of+          GeneratedImplementation -> "GeneratedOwned"+          HoleImplementation -> "HoleOwned"+          LegacyHoleImplementation -> error "legacy transition reached version-2 verification generation"+  ]+    <> ["  ]"]+  where+    entries =+      [ (source, edgeIndex, transitionIndex, transition)+      | (source, transitions) <- groupTransitionLayoutBySource (transitionLayout (aTransitions aggregate)),+        entry <- transitions,+        let edgeIndex = layoutOutgoingIndex entry+            transitionIndex = layoutDeclarationIndex entry+            transition = layoutTransition entry+      ]++foldFingerprintExpression :: Agg -> Text+foldFingerprintExpression aggregate = case holeVersions of+  [] -> tshow (aFoldFingerprint aggregate)+  _ ->+    "T.intercalate \"|\" ("+      <> tshow (aFoldFingerprint aggregate)+      <> " : [foldToken "+      <> T.intercalate ", foldToken " holeVersions+      <> "] ) where foldToken (FoldVersion token) = T.pack (show (T.length token)) <> \":\" <> token"+  where+    holeVersions =+      [ "Holes." <> holeFoldVersionName index transition+      | (index, transition) <- transitionEntries aggregate,+        tImplementation transition == HoleImplementation+      ]++groupTransitionEntriesBySource :: Agg -> [(Text, [(Int, Transition)])]+groupTransitionEntriesBySource aggregate =+  [ ( 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) =+  ["    B.from " <> vertexCtor aggregate source <> " do"]+    ++ concatMap (uncurry (generatedOnCmdBlock importPlan aggregate resolvedTransitions)) transitions++generatedOnCmdBlock :: HaskellImportPlan -> Agg -> [ResolvedGeneratedTransition] -> Int -> Transition -> [Text]+generatedOnCmdBlock importPlan aggregate resolvedTransitions index transition =+  ["      B.onCmd inCtor" <> tCommand transition <> " $ \\" <> payloadBinder <> " -> B.do"]+    ++ projectionBindingLines+    ++ ["        B.replayOnly" | tMode transition == TmReplayOnly]+    ++ generatedBehavior+    ++ outputLines+    ++ ["        B.noEmit" | null (tEmits transition)]+    ++ ["        B.goto " <> vertexCtor aggregate (tGoto transition)]+  where+    generatedBehavior = case tImplementation transition of+      GeneratedImplementation ->+        maybe [] (renderGuardLines importPlan aliases aggregate transition) (resolvedTransitionGuard resolved)+          ++ [ "        B.slot @" <> tshow registerName <> " =: " <> renderAssignmentOperand (renderKeikiTerm importPlan aliases aggregate transition expression)+             | (registerName, expression) <- resolvedTransitionWrites resolved+             ]+      HoleImplementation -> ["        Holes." <> holeFunctionName index transition <> " d"]+      LegacyHoleImplementation -> error "legacy transition reached version-2 transducer generation"+    resolved =+      fromMaybe+        (error ("resolved generated transition disappeared: " <> show index))+        (find ((== index) . resolvedTransitionIndex) resolvedTransitions)+    aliases+      | tImplementation transition == GeneratedImplementation = projectionAliasesForTransition resolved+      | otherwise = []+    projectionBindingLines = case aliases of+      [] -> []+      firstAlias : remainingAliases ->+        ["        let " <> renderProjectionAliasBinding importPlan aggregate transition firstAlias]+          <> ["            " <> renderProjectionAliasBinding importPlan aggregate transition alias | alias <- remainingAliases]+    outputLines =+      concat+        [ generatedOutputLines aggregate index transition emitIndex eventName+        | (emitIndex, eventName) <- zip [1 ..] (tEmits transition)+        ]+    payloadBinder+      | payloadIsUsed = "d"+      | otherwise = "_d"+    payloadIsUsed = case tImplementation transition of+      GeneratedImplementation ->+        isJust (resolvedTransitionGuard resolved)+          || not (null (resolvedTransitionWrites resolved))+          || any outputUsesPayload (zip [1 ..] (tEmits transition))+      HoleImplementation -> True+      LegacyHoleImplementation -> True+    outputUsesPayload (emitIndex, _) = case outputMappingFor aggregate index emitIndex of+      GeneratedCommandIdentity _ fields -> not (null fields)+      HandOwnedEventOutput {} -> True++renderProjectionAliasBinding :: HaskellImportPlan -> Agg -> Transition -> ProjectionAlias -> Text+renderProjectionAliasBinding importPlan aggregate transition alias =+  projectionAliasName alias <> " = " <> case projectionAliasTarget alias of+    StructuralProjectionAlias provenance projection -> renderStructuralProjectionTerm importPlan aggregate transition provenance projection+    NominalProjectionAlias nominal provenance -> renderNominalProjectionTerm importPlan aggregate transition nominal provenance++renderGuardLines :: HaskellImportPlan -> [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> [Text]+renderGuardLines importPlan aliases aggregate transition expression =+  ["        B.requireGuard $"]+    <> ["          " <> line | line <- T.lines readable]+  where+    readable =+      T.replace " .|| " "\n.|| "+        . T.replace " .&& " "\n.&& "+        $ renderKeikiPredicate importPlan aliases aggregate transition expression++renderAssignmentOperand :: RenderedKeikiExpr -> Text+renderAssignmentOperand expression+  | renderedKeikiPrecedence expression <= 6 = "(" <> renderedKeikiText expression <> ")"+  | otherwise = renderedKeikiText expression++generatedOutputLines :: Agg -> Int -> Transition -> Int -> Name -> [Text]+generatedOutputLines aggregate transitionIndex transition emitIndex eventName =+  case outputMappingFor aggregate transitionIndex emitIndex of+    GeneratedCommandIdentity sourceCommand fields -> case fields of+      [] -> ["        B.emit wire" <> eventName <> " B.oNil"]+      _ ->+        [ "        B.emit wire" <> eventName <> " (" <> eventName <> "TermFields"+        ]+          <> [ lead fieldIndex+                 <> resolvedSelector sourceCommand field+                 <> " = d."+                 <> resolvedSelector sourceCommand field+             | (fieldIndex, field) <- zip [0 :: Int ..] fields+             ]+          <> ["          })"]+    HandOwnedEventOutput {} ->+      [ "        B.emit wire"+          <> eventName+          <> " (Holes."+          <> outputFunctionName transitionIndex transition emitIndex eventName+          <> " d)"+      ]+  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+    (error ("missing checked event-output mapping for transition " <> show transitionIndex <> ", emit " <> show emitIndex))+    (Map.lookup (transitionIndex, emitIndex) (aOutputMappings aggregate))++--------------------------------------------------------------------------------+-- EventStream module+--------------------------------------------------------------------------------++emitEventStream :: Agg -> Text+emitEventStream a =+  nl $+    renderGeneratedLanguagePragmas [ExtOverloadedLabels | outcomeUsesLabels]+      ++ [ generatedBanner,+           "module " <> aGenPrefix a <> ".EventStream",+           "  ( " <> lowerFirst (aName a) <> "Category",+           "  , " <> lowerFirst (aName a) <> "CommandCategory",+           "  , " <> lowerFirst (aName a) <> "EventStream",+           "  , " <> lowerFirst (aName a) <> "EventStreamDef",+           "  , " <> aName a <> "EventStream",+           "  , " <> aName a <> "EventStreamDef"+         ]+      ++ ["  , " <> lowerFirst (aName a) <> "SnapshotFixture" | hasSnapshot a]+      ++ ["  , " <> lowerFirst (aName a) <> "DomainCommandHandler" | outcomeEnabled]+      ++ [ "  ) where",+           "",+           "import " <> aGenPrefix a <> ".Domain",+           "import " <> aGenPrefix a <> ".Codec (" <> lowerFirst (aName a) <> "Codec)",+           transducerImport a+         ]+      ++ generatedOutcomeNominalImports+      ++ structuralProjectionImports+      ++ generatedNominalProjectionImports+      ++ consumerNominalProjectionImports+      ++ consumerImports+      ++ ["import Data.KindID qualified as KindID" | outcomeUsesConsumerIdLiteral]+      ++ ["import Keiro.Codec.Nominal (nominalFromRepresentation)" | outcomeUsesConsumerNominalLiteral]+      ++ ["import Keiki.Builder qualified as B" | outcomeUsesRegisterRoot]+      ++ [keikiCoreImport]+      ++ ["import Keiki.Core qualified as K" | outcomeEnabled]+      ++ ["import Keiki.Generics (RegFieldsOf)" | outcomeUsesCommandRoot]+      ++ ["import Keiro.Command (DomainCommandHandler (..), SilentCommandContext (..), SilentDomainDecision (..))" | outcomeEnabled]+      ++ [ "import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))",+           "import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)"+         ]+      ++ ["import Data.Text (Text)" | hasSnapshot a || outcomeUsesText]+      ++ ["import Data.Time.Calendar (fromGregorian)" | outcomeUsesTimeLiteral]+      ++ ["import Data.Time.Clock (UTCTime (..), picosecondsToDiffTime)" | outcomeUsesTimeLiteral]+      ++ ["import Data.Time.Clock (UTCTime)" | outcomeUsesTimeType && not outcomeUsesTimeLiteral]+      ++ ["import Numeric.Natural (Natural)" | outcomeUsesNaturalType]+      ++ ["import Keiro.Snapshot.Codec (defaultStateCodec, withFoldFingerprint)" | hasSnapshot a]+      ++ [ "import Keiro.Stream qualified as Stream",+           "",+           "-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).",+           "-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.",+           "-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.",+           lowerFirst (aName a) <> "Category :: Stream.StreamCategory " <> aName a <> "EventStreamDef",+           lowerFirst (aName a) <> "Category = Stream.categoryUnsafe " <> tshow categoryName,+           "",+           "-- The same category text, typed for command envelopes such as PMCommand.",+           lowerFirst (aName a) <> "CommandCategory :: Stream.StreamCategory " <> aName a <> "Command",+           lowerFirst (aName a) <> "CommandCategory = Stream.categoryUnsafe " <> tshow categoryName,+           "",+           "type " <> aName a <> "EventStreamDef =",+           "  EventStream (HsPred " <> aName a <> "Regs " <> aName a <> "Command) " <> aName a <> "Regs " <> aVertexType a <> " " <> aName a <> "Command " <> aName a <> "Event",+           "",+           "type " <> aName a <> "EventStream =",+           "  ValidatedEventStream (HsPred " <> aName a <> "Regs " <> aName a <> "Command) " <> aName a <> "Regs " <> aVertexType a <> " " <> aName a <> "Command " <> aName a <> "Event",+           "",+           lowerFirst (aName a) <> "EventStreamDef :: " <> aName a <> "EventStreamDef",+           lowerFirst (aName a) <> "EventStreamDef =",+           "  EventStream",+           "    { transducer = " <> lowerFirst (aName a) <> "Transducer,",+           "      initialState = " <> initialVertex a <> ",",+           "      initialRegisters = initial" <> aName a <> "Regs,",+           "      eventCodec = " <> lowerFirst (aName a) <> "Codec,",+           "      resolveStreamName = Stream.streamName,",+           "      snapshotPolicy = " <> snapshotPolicyExpr a <> ","+         ]+      ++ stateCodecFieldLines a+      ++ [ "    }",+           ""+         ]+      ++ snapshotFixtureLines a+      ++ [ lowerFirst (aName a) <> "EventStream :: " <> aName a <> "EventStream",+           lowerFirst (aName a) <> "EventStream =",+           "  mkEventStreamOrThrow " <> tshow (aName a) <> " " <> lowerFirst (aName a) <> "EventStreamDef"+         ]+      ++ outcomeHandlerLines importPlan a silentOutcomes+  where+    categoryName = staticCategory ("aggregate " <> aName a) (lowerFirst (aName a))+    outcomeEnabled = isJust (aDomainOutcomeTypes a)+    silentOutcomes = resolvedSilentOutcomes a+    outcomeExpressions = map resolvedSilentReason silentOutcomes+    outcomeResultTypes = case aDomainOutcomeTypes a of+      Nothing -> []+      Just outcomeTypes -> [resolvedRejectionType outcomeTypes, resolvedNoOpType outcomeTypes]+    outcomeImportTypes =+      nub+        ( outcomeResultTypes+            <> concatMap typedExpressionImportTypes outcomeExpressions+            <> concatMap typedExpressionLiteralTypes outcomeExpressions+        )+    consumerLiteralNominals = nub [nominal | expression <- outcomeExpressions, nominal <- typedConsumerLiteralNominals expression]+    importPlan = eventStreamImportPlan a outcomeImportTypes consumerLiteralNominals+    consumerImports = T.lines (renderPlannedImports importPlan)+    generatedOutcomeNominals =+      stableNominals+        ( generatedNominalsInTypes outcomeResultTypes+            <> [nominal | expression <- outcomeExpressions, nominal <- typedGeneratedNominals expression]+        )+    generatedLiteralNominals =+      stableNominals+        [ nominal+        | expression <- outcomeExpressions,+          literal <- typedExpressionLiterals expression,+          nominal <- typedGeneratedNominals literal+        ]+    generatedOutcomeNominalImports =+      generatedNominalTypeImportsWithParsers+        (aggregateCheckedService a)+        (aContext a)+        generatedOutcomeNominals+        generatedLiteralNominals+    projectionTargets = nub (concatMap projectionAliasTargets outcomeExpressions)+    structuralProjectionImports =+      [ "import " <> structuralProjectionModule (aContext a) <> " qualified as StructuralProjections"+      | any isStructuralProjection projectionTargets+      ]+    generatedNominalProjectionImports =+      [ "import " <> generatedNominalModule (aContext a) <> " qualified as GeneratedNominals"+      | any isGeneratedNominalProjection projectionTargets+      ]+    consumerNominalProjectionImports =+      [ "import " <> nominalProjectionModule (aContext a) <> " qualified as NominalProjections"+      | any isConsumerNominalProjection projectionTargets+      ]+    outcomeUsesRegisterRoot = any (anyTypedExpression usesRegisterRoot) outcomeExpressions+    outcomeUsesCommandRoot = any (anyTypedExpression usesCommandRoot) outcomeExpressions+    outcomeUsesLabels = outcomeUsesCommandRoot || not (null projectionTargets)+    outcomeUsesText =+      AggregateText `elem` outcomeImportTypes+        || any (anyTypedExpression isTextLiteral) outcomeExpressions+        || any isNominalProjection projectionTargets+    outcomeUsesTimeLiteral = any (anyTypedExpression isTimeLiteral) outcomeExpressions+    outcomeUsesTimeType = AggregateTime `elem` outcomeImportTypes+    outcomeUsesNaturalType = AggregateNatural `elem` outcomeImportTypes+    outcomeUsesConsumerNominalLiteral = not (null consumerLiteralNominals)+    outcomeUsesConsumerIdLiteral = any (isIdRepresentation . resolvedNominalRepresentation) consumerLiteralNominals+    usedOperators = nub (concatMap outcomeExpressionOperators outcomeExpressions)+    keikiCoreImport+      | not outcomeEnabled = "import Keiki.Core (HsPred)"+      | otherwise =+          "import Keiki.Core (EdgeRef (..), HsPred"+            <> T.concat [", (" <> operator <> ")" | operator <- expressionOperatorOrder, operator `elem` usedOperators]+            <> ")"+    usesRegisterRoot expression = case typedScalarNode expression of+      TypedRoot ScalarRegisterRoot {} -> True+      TypedProject provenance _ -> case provenance of+        ScalarRegisterRoot {} -> True+        ScalarCommandRoot {} -> False+      _ -> False+    usesCommandRoot expression = case typedScalarNode expression of+      TypedRoot ScalarCommandRoot {} -> True+      TypedProject provenance _ -> case provenance of+        ScalarCommandRoot {} -> True+        ScalarRegisterRoot {} -> False+      _ -> False+    isTextLiteral expression = case typedScalarNode expression of+      TypedLiteral ScalarTextValue {} -> True+      _ -> False+    isTimeLiteral expression = case typedScalarNode expression of+      TypedLiteral ScalarTimeValue {} -> True+      _ -> False+    isNominalProjection NominalProjectionAlias {} = True+    isNominalProjection StructuralProjectionAlias {} = False+    isIdRepresentation IdRepresentation {} = True+    isIdRepresentation _ = False++outcomeHandlerLines :: HaskellImportPlan -> Agg -> [ResolvedSilentOutcome] -> [Text]+outcomeHandlerLines importPlan aggregate silentOutcomes = case aDomainOutcomeTypes aggregate of+  Nothing -> []+  Just outcomeTypes ->+    [ "",+      handlerName,+      "  :: DomainCommandHandler",+      "       (HsPred " <> aName aggregate <> "Regs " <> aName aggregate <> "Command)",+      "       " <> aName aggregate <> "Regs",+      "       " <> aVertexType aggregate,+      "       " <> aName aggregate <> "Command",+      "       " <> aName aggregate <> "Event",+      "       " <> renderDomainType importPlan aggregate (resolvedRejectionType outcomeTypes),+      "       " <> renderDomainType importPlan aggregate (resolvedNoOpType outcomeTypes),+      handlerName <> " =",+      "  DomainCommandHandler " <> lowerFirst (aName aggregate) <> "EventStream " <> classifierName,+      "",+      classifierName,+      "  :: SilentCommandContext " <> aName aggregate <> "Regs " <> aVertexType aggregate <> " " <> aName aggregate <> "Command",+      "  -> SilentDomainDecision",+      "       " <> renderDomainType importPlan aggregate (resolvedRejectionType outcomeTypes),+      "       " <> renderDomainType importPlan aggregate (resolvedNoOpType outcomeTypes),+      classifierName <> " (SilentCommandContext _ registers command (EdgeRef edgeSource edgeIndex)) =",+      "  case edgeSource of"+    ]+      ++ concatMap renderSourceGroup sourceGroups+      ++ [ "    _ -> outcomeInvariant edgeSource edgeIndex",+           " where",+           "  outcomeInvariant source index =",+           "    error ("+             <> tshow ("generated domain outcome invariant failed for aggregate " <> aName aggregate <> " edge ")+             <> " <> show source <> \"#\" <> show index)"+         ]+  where+    handlerName = lowerFirst (aName aggregate) <> "DomainCommandHandler"+    classifierName = lowerFirst (aName aggregate) <> "SilentDecision"+    sourceGroups =+      [ (source, filter ((== source) . tSource . layoutTransition . resolvedSilentLayout) silentOutcomes)+      | source <- nub (map (tSource . layoutTransition . resolvedSilentLayout) silentOutcomes)+      ]+    renderSourceGroup (source, outcomes) =+      [ "    " <> vertexCtor aggregate source <> " ->",+        "      case edgeIndex of"+      ]+        ++ map renderArm outcomes+        ++ ["        _ -> outcomeInvariant edgeSource edgeIndex"]+    renderArm outcome =+      let entry = resolvedSilentLayout outcome+          transition = layoutTransition entry+          constructor = case resolvedSilentKind outcome of+            RejectedOutcome -> "SilentRejected"+            NoOpOutcome -> "SilentNoOp"+       in "        "+            <> tshow' (layoutOutgoingIndex entry)+            <> " -> "+            <> constructor+            <> " ("+            <> renderOutcomeReasonEvaluation importPlan aggregate transition (resolvedSilentReason outcome)+            <> ")"++eventStreamImportPlan :: Agg -> [ResolvedAggregateType] -> [ResolvedNominalType] -> HaskellImportPlan+eventStreamImportPlan aggregate importedTypes literalNominals =+  planImportsOrDie+    (aGenPrefix aggregate <> ".EventStream")+    localDeclarations+    ( Set.unions+        [ aggregateSourceReferences (aggregateConsumerHaskellSource (aSymbols aggregate) resolvedType)+        | resolvedType <- importedTypes+        ]+        <> Set.fromList+          [ reference+          | nominal <- literalNominals,+            ConsumerNominal binding <- [resolvedNominalOwnership nominal],+            reference <-+              qualifiedValueReference (consumerNominalBinding binding)+                : case resolvedNominalRepresentation nominal of+                  EnumRepresentation constructors ->+                    [ nominalRepresentationConstructorReference (aContext aggregate) nominal constructor+                    | (constructor, _) <- NE.toList constructors+                    ]+                  _ -> []+          ]+    )+  where+    localDeclarations =+      Set.fromList+        ( [ aVertexType aggregate,+            aName aggregate <> "Command",+            aName aggregate <> "Event",+            aName aggregate <> "Regs",+            aName aggregate <> "EventStream",+            aName aggregate <> "EventStreamDef"+          ]+            <> map resolvedNominalName (aGeneratedNominals aggregate)+            <> [ resolvedNominalName nominal+               | resolvedType <- importedTypes,+                 AggregateNominal nominal <- [resolvedType],+                 GeneratedNominal <- [resolvedNominalOwnership nominal]+               ]+        )++snapshotPolicyExpr :: Agg -> Text+snapshotPolicyExpr aggregate = case aSnapshot aggregate of+  Nothing -> "Never"+  Just snapshot -> case snapPolicy snapshot of+    SnapEvery interval -> "Every " <> tshow' interval+    SnapOnTerminal -> "OnTerminal"++stateCodecExpr :: Agg -> Text+stateCodecExpr aggregate = case aSnapshot aggregate of+  Nothing -> "Nothing"+  Just snapshot ->+    "Just (withFoldFingerprint "+      <> foldFingerprintValue aggregate+      <> " (defaultStateCodec "+      <> tshow' (snapCodecVersion snapshot)+      <> "))"++transducerImport :: Agg -> Text+transducerImport aggregate+  | hasVersion2Ownership aggregate =+      "import "+        <> aGenPrefix aggregate+        <> ".Transducer ("+        <> (if hasSnapshot aggregate then lowerFirst (aName aggregate) <> "FoldFingerprint, " else "")+        <> lowerFirst (aName aggregate)+        <> "Transducer)"+  | otherwise =+      "import "+        <> aHolePrefix aggregate+        <> ".Holes ("+        <> lowerFirst (aName aggregate)+        <> "Transducer)"++foldFingerprintValue :: Agg -> Text+foldFingerprintValue aggregate+  | hasVersion2Ownership aggregate = lowerFirst (aName aggregate) <> "FoldFingerprint"+  | otherwise = tshow (aFoldFingerprint aggregate)++stateCodecFieldLines :: Agg -> [Text]+stateCodecFieldLines aggregate = case aSnapshot aggregate of+  Nothing -> ["      stateCodec = Nothing"]+  Just _+    | hasVersion2Ownership aggregate ->+        [ "      -- The snapshot discriminator composes: the spec's state-codec version (bump it",+          "      -- in the spec's `state-codec version=` clause), keiki's register and",+          "      -- control-state shape hashes, and this fold fingerprint derived from the",+          "      -- spec's transition surface (guards, writes, emits, states, register",+          "      -- initials, referenced rules). Spec-visible fold changes invalidate old",+          "      -- snapshots automatically. Version-2 Hole-owned transitions additionally",+          "      -- compose their explicit hand-owned FoldVersion tokens here; bump the",+          "      -- corresponding token whenever that Hole behavior changes.",+          "      stateCodec = " <> stateCodecExpr aggregate+        ]+    | otherwise ->+        [ "      -- The snapshot discriminator composes: the spec's state-codec version (bump it",+          "      -- in the spec's `state-codec version=` clause), keiki's register and",+          "      -- control-state shape hashes, and this fold fingerprint derived from the",+          "      -- spec's transition surface (guards, writes, emits, states, register",+          "      -- initials, referenced rules). Spec-visible fold changes invalidate old",+          "      -- snapshots automatically. Fold changes made ONLY in the hand-owned Holes",+          "      -- module are invisible here: bump `state-codec version=` manually or old",+          "      -- snapshots will be served stale.",+          "      stateCodec = " <> stateCodecExpr aggregate+        ]++snapshotFixtureLines :: Agg -> [Text]+snapshotFixtureLines aggregate = case aSnapshot aggregate of+  Nothing -> []+  Just snapshot ->+    [ lowerFirst (aName aggregate) <> "SnapshotFixture :: (Int, Text)",+      lowerFirst (aName aggregate) <> "SnapshotFixture = (" <> tshow' (snapCodecVersion snapshot) <> ", " <> tshow (snapShapeHash snapshot) <> ")",+      ""+    ]++--------------------------------------------------------------------------------+-- Projection module+--------------------------------------------------------------------------------++emitProjection :: Agg -> Text+emitProjection a = case aProjection a of+  Nothing ->+    nl+      ( renderGeneratedLanguagePragmas []+          <> [ generatedBanner,+               "module " <> aGenPrefix a <> ".Projection () where",+               "",+               "-- No projection declarations are present; this module keeps the generated manifest inventory total."+             ]+      )+  Just p ->+    nl+      [ generatedBanner,+        "module " <> aGenPrefix a <> ".Projection",+        "  ( " <> lowerFirst (projTable p) <> "Projection",+        "  , " <> lowerFirst (projTable p) <> "StatusFor",+        "  ) where",+        "",+        "import " <> aGenPrefix a <> ".Domain",+        "import " <> aHolePrefix a <> ".Holes (apply" <> pascal (projTable p) <> ")",+        "import Data.Text (Text)",+        "import Keiro.Projection (InlineProjection (..))",+        "",+        "-- The deterministic event->status mapping (hole-kind 3, /mapping/), derived",+        "-- from the spec's status-map. The read-model SQL that consumes it lives in",+        "-- the hand-owned Holes module (a DB-coupled hole, delegated to codd).",+        projectionTableComment a p,+        lowerFirst (projTable p) <> "StatusFor :: " <> aName a <> "Event -> Maybe Text",+        lowerFirst (projTable p) <> "StatusFor = \\case",+        nl (statusArms a p),+        "",+        lowerFirst (projTable p) <> "Projection :: InlineProjection " <> aName a <> "Event",+        lowerFirst (projTable p) <> "Projection =",+        "  InlineProjection",+        "    { name = " <> tshow (contextNameToProjName a p),+        "    , apply = apply" <> pascal (projTable p),+        "    }"+      ]++statusArms :: Agg -> ProjectionSpec -> [Text]+statusArms a p =+  [ "  " <> rcName e <> " {} -> " <> statusFor e+  | e <- aEvents a+  ]+    ++ ["  _ -> Nothing" | hasWildcard]+  where+    pairs = maybe [] mapPairs (projStatusMap p)+    statusFor e = case lookup (rcName e) pairs of+      Just value -> "Just " <> tshow value+      Nothing -> "Nothing"+    -- A wildcard is only needed if some event is uncovered; otherwise every arm+    -- is explicit and a wildcard would be redundant (and -Wall would warn).+    hasWildcard = False++contextNameToProjName :: Agg -> ProjectionSpec -> Text+contextNameToProjName a p = contextKebab a <> "-" <> projTable p <> "-inline"++contextKebab :: Agg -> Text+contextKebab = kebabFromPascal . aCtxPascal++projectionReadModel :: Agg -> Maybe ReadModelNode+projectionReadModel aggregate = do+  projection <- aProjection aggregate+  find ((== projTable projection) . rmName) (aReadModels aggregate)++projectionTableComment :: Agg -> ProjectionSpec -> Text+projectionTableComment aggregate projection = case projectionReadModel aggregate of+  Nothing ->+    "-- WARNING: no readmodel node declares '"+      <> projTable projection+      <> "'; unqualified SQL depends on search_path."+  Just readModel ->+    "-- Qualified table "+      <> qualifiedTableLiteral readModel+      <> "; use "+      <> genPrefixFor (aContext aggregate) (pascal (rmName readModel))+      <> ".ReadModelTable."+      <> readModelStem readModel+      <> "QualifiedTable."++--------------------------------------------------------------------------------+-- Holes module (create-if-absent)+--------------------------------------------------------------------------------++emitHoles :: Agg -> Text+emitHoles aggregate+  | hasVersion2Ownership aggregate = emitVersion2Holes aggregate+  | otherwise = emitLegacyHoles aggregate++emitLegacyHoles :: Agg -> Text+emitLegacyHoles a =+  nl+    [ "{-# LANGUAGE BlockArguments #-}",+      "{-# LANGUAGE DataKinds #-}",+      "{-# LANGUAGE OverloadedRecordDot #-}",+      "{-# LANGUAGE QualifiedDo #-}",+      "{-# LANGUAGE TypeApplications #-}",+      "-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never",+      "-- overwrites it. Fill the transducer body (and any other holes) against the",+      "-- generated signatures, then run the harness to confirm behaviour.",+      "module " <> aHolePrefix a <> ".Holes",+      "  ( " <> lowerFirst (aName a) <> "Transducer",+      holeProjectionExport a,+      holeUpcasterExports a,+      "  ) where",+      "",+      "import " <> aGenPrefix a <> ".Domain",+      "import Keiki.Builder ((=:))",+      "import qualified Keiki.Builder as B",+      "import Keiki.Core (HsPred, RegFile, SymTransducer, lit, (.==), (./=), (.||))",+      holeUpcasterImports a,+      holeProjectionImports a,+      "",+      "-- HOLE: the transducer body. Reproduce the structure below, replacing each",+      "-- `-- HOLE` line with the keiki symbolic operators it describes.",+      lowerFirst (aName a) <> "Transducer",+      "  :: SymTransducer",+      "       (HsPred " <> aName a <> "Regs " <> aName a <> "Command)",+      "       " <> aName a <> "Regs",+      "       " <> aVertexType a,+      "       " <> aName a <> "Command",+      "       " <> aName a <> "Event",+      lowerFirst (aName a) <> "Transducer =",+      "  B.buildTransducer " <> initialVertex a <> " initial" <> aName a <> "Regs isTerminal do",+      nl (concatMap (fromBlock a) (groupBySource a)),+      " where",+      "  isTerminal = \\case",+      nl ["    " <> vertexCtor a (stName s) <> " -> True" | s <- aStates a, stTerminal s],+      "    _ -> False",+      holeProjectionStub a,+      holeUpcasterStubs a+    ]++emitVersion2Holes :: Agg -> Text+emitVersion2Holes aggregate =+  nl $+    [ "{-# LANGUAGE BlockArguments #-}",+      "{-# LANGUAGE DataKinds #-}",+      "{-# LANGUAGE DuplicateRecordFields #-}",+      "{-# LANGUAGE OverloadedRecordDot #-}",+      "{-# LANGUAGE QualifiedDo #-}",+      "{-# LANGUAGE TypeApplications #-}",+      "-- This is a HAND-OWNED version-2 hook module. keiro-dsl creates it once",+      "-- and never overwrites it. Generated code owns every transition envelope",+      "-- and every declared guard/write. This module supplies explicit event-field",+      "-- mappings and explicitly selected Hole behavior only; fields(Command)",+      "-- identity mappings are generated directly and have no hook."+    ]+      ++ version2HoleModuleDeclaration aggregate+      ++ [ "",+           "import " <> aGenPrefix aggregate <> ".Domain",+           "import Keiki.Builder qualified as B",+           "import Keiki.Generics (RegFieldsOf)",+           holeUpcasterImports aggregate,+           holeProjectionImports aggregate+         ]+      ++ ["import Keiki.Core qualified as K" | anyHoleOwned aggregate || anyZeroFieldOutput aggregate]+      ++ ["import Keiro.Snapshot.Codec (FoldVersion (..))" | anyHoleOwned aggregate]+      ++ concatMap (uncurry (emitOutputHooks aggregate)) (transitionEntries aggregate)+      ++ concatMap (uncurry (emitHoleImplementation aggregate)) (transitionEntries aggregate)+      ++ [holeProjectionStub aggregate, holeUpcasterStubs aggregate]++anyZeroFieldOutput :: Agg -> Bool+anyZeroFieldOutput aggregate =+  or+    [ isHandOwned (outputMappingFor aggregate transitionIndex emitIndex)+        && null (rcFields (eventForName aggregate eventName))+    | (transitionIndex, transition) <- transitionEntries aggregate,+      (emitIndex, eventName) <- zip [1 ..] (tEmits transition)+    ]+  where+    isHandOwned HandOwnedEventOutput {} = True+    isHandOwned GeneratedCommandIdentity {} = False++version2HoleModuleDeclaration :: Agg -> [Text]+version2HoleModuleDeclaration aggregate = case version2HoleExports aggregate of+  [] -> ["module " <> aHolePrefix aggregate <> ".Holes () where"]+  firstExport : rest ->+    [ "module " <> aHolePrefix aggregate <> ".Holes",+      "  ( " <> firstExport+    ]+      ++ ["  , " <> value | value <- rest]+      ++ ["  ) where"]++version2HoleExports :: Agg -> [Text]+version2HoleExports aggregate =+  outputExports+    <> holeExports+    <> projectionExports+    <> [functionName | (_, _, functionName) <- upcasterEntries aggregate]+  where+    outputExports =+      [ outputFunctionName transitionIndex transition emitIndex eventName+      | (transitionIndex, transition) <- transitionEntries aggregate,+        (emitIndex, eventName) <- zip [1 ..] (tEmits transition),+        HandOwnedEventOutput {} <- [outputMappingFor aggregate transitionIndex emitIndex]+      ]+    holeExports =+      concat+        [ [holeFunctionName index transition, holeFoldVersionName index transition]+        | (index, transition) <- transitionEntries aggregate,+          tImplementation transition == HoleImplementation+        ]+    projectionExports = case aProjection aggregate of+      Nothing -> []+      Just projection -> ["apply" <> pascal (projTable projection)]++emitOutputHooks :: Agg -> Int -> Transition -> [Text]+emitOutputHooks aggregate transitionIndex transition =+  concat+    [ emitOutputHook aggregate transitionIndex transition emitIndex (eventForName aggregate eventName)+    | (emitIndex, eventName) <- zip [1 ..] (tEmits transition),+      HandOwnedEventOutput {} <- [outputMappingFor aggregate transitionIndex emitIndex]+    ]++emitOutputHook :: Agg -> Int -> Transition -> Int -> ResolvedCtor -> [Text]+emitOutputHook aggregate transitionIndex transition emitIndex event =+  [ "",+    "-- Hand-owned event-field hook inside the generated transition envelope.",+    functionName+      <> " :: "+      <> payloadProjectionType aggregate transition+      <> " -> "+      <> outputType,+    functionName <> " d = " <> outputValue+  ]+  where+    functionName = outputFunctionName transitionIndex transition emitIndex (rcName event)+    inputFields = "(" <> commandFieldsType transition <> ")"+    outputType+      | null (rcFields event) =+          "K.OutFields "+            <> aName aggregate+            <> "Regs "+            <> aName aggregate+            <> "Command "+            <> inputFields+            <> " ()"+      | otherwise =+          rcName event+            <> "TermFields "+            <> aName aggregate+            <> "Regs "+            <> aName aggregate+            <> "Command "+            <> inputFields+    outputValue+      | null (rcFields event) = "B.oNil"+      | otherwise =+          rcName event+            <> "TermFields\n"+            <> nl+              ( valueRecord+                  [ (fieldSelector identity, outputFieldValue identity fieldType)+                  | (identity, fieldType) <- rcFields event+                  ]+              )+    command = commandForTransition aggregate transition+    outputFieldValue identity fieldType+      | Just (commandIdentity, commandType) <- find ((== fieldDslName identity) . fieldDslName . fst) (rcFields command),+        commandType == fieldType =+          "d." <> fieldSelector commandIdentity+      | Just register <- find ((== fieldDslName identity) . rrName) (aRegs aggregate),+        rrType register == fieldType =+          "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+      ]+        ++ ["  }"]+    lead 0 = "  { "+    lead _ = "  , "++emitHoleImplementation :: Agg -> Int -> Transition -> [Text]+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.",+        holeFoldVersionName index transition <> " :: FoldVersion",+        holeFoldVersionName index transition <> " = FoldVersion " <> tshow (transitionStem index transition <> "-fold-v1")+      ]++-- | Export, import, and stub the per-event upcaster holes (EP-2 evolution).+holeUpcasterExports :: Agg -> Text+holeUpcasterExports a = case upcasterEntries a of+  [] -> ""+  es -> nl ["  , " <> fn | (_, _, fn) <- es]++holeUpcasterImports :: Agg -> Text+holeUpcasterImports a = case upcasterEntries a of+  [] -> ""+  _ -> nl ["import Data.Aeson (Value)", "import Data.Text (Text)"]++holeUpcasterStubs :: Agg -> Text+holeUpcasterStubs a = case upcasterEntries a of+  [] -> ""+  es ->+    nl $+      concat+        [ [ "",+            "-- HOLE upcaster: this hole receives ONLY " <> eventName <> " payloads stored at",+            "-- aggregate schema version " <> tshow' source <> "; other event kinds pass through the",+            "-- generated rung dispatch automatically. Bring this payload up one version and decide",+            "-- the default/derivation for any field added at the new version here.",+            fn <> " :: Value -> Either Text Value",+            fn <> " _ = Left \"HOLE: upcaster not implemented\""+          ]+        | (source, eventName, fn) <- es+        ]++holeProjectionExport :: Agg -> Text+holeProjectionExport a = case aProjection a of+  Nothing -> "  -- (no projection)"+  Just p -> "  , apply" <> pascal (projTable p)++holeProjectionImports :: Agg -> Text+holeProjectionImports aggregate = case projectionReadModel aggregate of+  Nothing -> ""+  Just readModel ->+    "import "+      <> genPrefixFor (aContext aggregate) (pascal (rmName readModel))+      <> ".ReadModelTable ("+      <> readModelStem readModel+      <> "QualifiedTable)"++holeProjectionStub :: Agg -> Text+holeProjectionStub a = case aProjection a of+  Nothing -> ""+  Just p ->+    nl+      ( [ "",+          "-- HOLE: the read-model SQL for the projection (a DB-coupled hole; the",+          "-- pure event->status mapping is generated as " <> lowerFirst (projTable p) <> "StatusFor)."+        ]+          ++ projectionGuidance+          ++ [ "apply" <> pascal (projTable p) <> " :: " <> aName a <> "Event -> recorded -> txn ()",+               "apply" <> pascal (projTable p) <> " _event _recorded = " <> projectionTableUse <> "error \"HOLE: fill " <> projTable p <> " projection apply\""+             ]+      )+    where+      projectionGuidance = case projectionReadModel a of+        Nothing ->+          ["-- WARNING: no readmodel node declares this table's schema; unqualified SQL depends on search_path."]+        Just readModel ->+          [ "-- Table: " <> qualifiedTableLiteral readModel <> ". Use " <> readModelStem readModel <> "QualifiedTable; never rely on search_path.",+            "-- Declared columns:"+          ]+            ++ map (("--   " <>) . readModelColumnDoc) (rmColumns readModel)+      projectionTableUse = case projectionReadModel a of+        Nothing -> ""+        Just readModel -> readModelStem readModel <> "QualifiedTable `seq` "++-- Group transitions by source state, preserving order, for the B.from blocks.+groupBySource :: Agg -> [(Text, [Transition])]+groupBySource a =+  [ (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.)+transitionsOf :: Agg -> [Transition]+transitionsOf = aTransitions++fromBlock :: Agg -> (Text, [Transition]) -> [Text]+fromBlock a (src, ts) =+  [ "    B.from " <> vertexCtor a src <> " do"+  ]+    ++ concatMap (onCmdBlock a) ts++onCmdBlock :: Agg -> Transition -> [Text]+onCmdBlock a t =+  [ "      B.onCmd inCtor" <> tCommand t <> " $ \\d -> B.do"+  ]+    -- Plan 143: the mode is structural, not hole-owned — a replay-only+    -- transition lowers to B.replayOnly (keiki ReplayOnly edge).+    ++ ["        B.replayOnly" | tMode t == TmReplayOnly]+    ++ maybe [] (\g -> ["        -- HOLE guard: " <> renderGuard g]) (tGuard t)+    ++ ["        -- HOLE write " <> r <> " := " <> renderGuard e | (r, e) <- tWrites t]+    ++ ["        -- HOLE emit " <> ev <> " (B.emit wire" <> ev <> " ...)" | ev <- tEmits t]+    ++ ["        B.goto " <> vertexCtor a (tGoto t)]++--------------------------------------------------------------------------------+-- Field categories and shared helpers+--------------------------------------------------------------------------------++data FieldCat+  = IdCat+  | EnumCat+  | MappedStructuralCat !StructuralDecl !ResolvedMappedShape+  | MappedOpaqueCat !OpaqueDecl+  | OtherCat+  deriving stock (Eq, Show)++fieldCat :: Agg -> ResolvedAggregateType -> FieldCat+fieldCat a ty+  | AggregateNominal nominal <- ty,+    IdRepresentation {} <- resolvedNominalRepresentation nominal =+      IdCat+  | AggregateNominal nominal <- ty,+    EnumRepresentation {} <- resolvedNominalRepresentation nominal =+      EnumCat+  | Just (ResolvedStructural declaration shape) <- mappedDeclFor a ty = MappedStructuralCat declaration shape+  | Just (ResolvedOpaque declaration) <- mappedDeclFor a ty = MappedOpaqueCat declaration+  | otherwise = OtherCat++-- | The first constructor of a declared enum, used to build sample values.+firstEnumCtor :: Agg -> Text -> Maybe Text+firstEnumCtor a ty =+  case [c | e <- aEnums a, enumName e == ty, (c, _) <- take 1 (enumCtors e)] of+    (c : _) -> Just c+    [] -> Nothing++vertexCtor :: Agg -> Text -> Text+vertexCtor a s = aName a <> s++initialVertex :: Agg -> Text+initialVertex a = case aStates a of+  (s : _) -> vertexCtor a (stName s)+  [] -> aName a <> "Init"++generatedBanner :: Text+generatedBanner = "-- @generated by keiro-dsl; do not edit. Regenerated from the .keiro spec."++-- | The provenance line written by a concrete scaffold plan. The package+-- version comes from Cabal's build metadata, while the language and origin come+-- from the checked semantic input and the emitted module respectively.+generatedBannerFor :: EffectiveLanguageContract -> Text -> Text+generatedBannerFor languageContract sourceOrigin =+  "-- @generated by keiro-dsl "+    <> T.pack (showVersion Package.version)+    <> " (language keiro-dsl "+    <> languageVersionText (effectiveContractLanguageVersion languageContract)+    <> ") from "+    <> stableBannerOrigin sourceOrigin+    <> "; do not edit."++-- Source line numbers are useful refusal metadata but are not stable ownership:+-- moving an unchanged node within or between workspace members must not rewrite+-- every Generated file. The node kind and name remain the banner authority.+stableBannerOrigin :: Text -> Text+stableBannerOrigin sourceOrigin =+  case T.breakOnEnd " (line " withoutMemberPath of+    (prefixWithMarker, lineWithClose)+      | not (T.null prefixWithMarker),+        Just lineNumber <- T.stripSuffix ")" lineWithClose,+        not (T.null lineNumber),+        T.all isDigit lineNumber ->+          T.dropEnd (T.length " (line ") prefixWithMarker+    _ -> withoutMemberPath+  where+    withoutMemberPath = case T.breakOn ": " sourceOrigin of+      (memberPath, attributedOrigin)+        | ".keiro" `T.isSuffixOf` memberPath,+          not (T.null attributedOrigin) ->+            T.drop 2 attributedOrigin+      _ -> sourceOrigin++-- | Recognize the exact historical banner or the frozen stamped format. This+-- intentionally rejects arbitrary comments that merely start with+-- @-- \@generated@.+isGeneratedBannerLine :: Text -> Bool+isGeneratedBannerLine line =+  line == generatedBanner+    || ( stampedPrefix `T.isPrefixOf` line+           && " (language keiro-dsl " `T.isInfixOf` line+           && ") from " `T.isInfixOf` line+           && "; do not edit." `T.isSuffixOf` line+       )+  where+    stampedPrefix = "-- @generated by keiro-dsl "++-- | Replace an emitter's legacy placeholder (or an earlier stamp) with the+-- provenance for this plan. A Generated module with a specialized banner gets+-- the standard stamp prepended, so every planned Generated file is covered.+stampGeneratedModule :: EffectiveLanguageContract -> ScaffoldModule -> ScaffoldModule+stampGeneratedModule languageContract moduleValue+  | kind moduleValue == HoleStub = moduleValue+  | otherwise = moduleValue {moduleText = stampedText}+  where+    banner = generatedBannerFor languageContract (origin moduleValue)+    sourceLines = T.splitOn "\n" (moduleText moduleValue)+    stampedText = case replaceFirstGeneratedBanner banner sourceLines of+      Nothing -> banner <> "\n" <> moduleText moduleValue+      Just linesWithStamp -> T.intercalate "\n" linesWithStamp++stampGeneratedModules :: EffectiveLanguageContract -> [ScaffoldModule] -> [ScaffoldModule]+stampGeneratedModules languageContract = map (stampGeneratedModule languageContract)++replaceFirstGeneratedBanner :: Text -> [Text] -> Maybe [Text]+replaceFirstGeneratedBanner _ [] = Nothing+replaceFirstGeneratedBanner replacement (line : rest)+  | isGeneratedBannerLine line = Just (replacement : rest)+  | otherwise = (line :) <$> replaceFirstGeneratedBanner replacement rest++nodeOrigin :: Text -> Text -> Loc -> Text+nodeOrigin nodeKind nodeName loc =+  nodeKind <> " " <> nodeName <> case unLoc loc of+    0 -> ""+    line -> " (line " <> tshow' line <> ")"++-- | Conditions that the deterministic emitters cannot lower faithfully. The+-- pre-write scaffold pipeline treats each returned message as a refusal. The+-- list is extended alongside the policy and type lowering milestones.+scaffoldRefusals :: Spec -> [Text]+scaffoldRefusals spec = scaffoldRefusalsWithSymbols (aggregateSymbols spec) spec++scaffoldRefusalsForService :: CheckedService -> [Text]+scaffoldRefusalsForService service =+  scaffoldRefusalsWithSymbols+    (aggregateSymbolsFromGraphResult (checkedTypeGraph service) spec)+    spec+  where+    spec = checkedSpec service++scaffoldRefusalsWithSymbols :: AggregateSymbols -> Spec -> [Text]+scaffoldRefusalsWithSymbols symbols spec =+  concatMap aggregateRefusals aggregates+    <> concatMap contractRefusals contracts+    <> concatMap publisherRefusals publishers+  where+    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]+    contracts = [contract | NContract contract <- specNodes spec]+    publishers = [publisher | NPublisher publisher <- specNodes spec]     aggregateRefusals aggregate =       [ "AggregateEmpty: aggregate '" <> aggName aggregate <> "' must declare at least one command, event, and transition"       | null (aggCommands aggregate) || null (aggEvents aggregate) || null (aggTransitions aggregate)

src/Keiro/Dsl/ScaffoldRecord.hs view

@@ -9,23 +9,32 @@     renderRecord,     parseRecord,     recordFileName,+    projectionCatalogFacts,+    projectionCatalogFactsForService,   ) where  import Data.Aeson ((.:), (.=)) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as BL-import Data.List (nub)+import Data.List (nub, sort)+import Data.List.NonEmpty qualified as NE+import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as Text import Keiro.Dsl.BehaviorCoverage (BehaviorRecordRow (..))+import Keiro.Dsl.CoordinationImpact (RouterSelectionSnapshot (..)) import Keiro.Dsl.ExplainBindings (BindingHole (..))+import Keiro.Dsl.Grammar import Keiro.Dsl.HaskellName (GeneratedHaskellNamingEdition (..), parseGeneratedHaskellNamingEdition, renderGeneratedHaskellNamingEdition) import Keiro.Dsl.LanguageVersion (SourceLanguage (..)) import Keiro.Dsl.MappedConsumer (MappingIdentity (..))+import Keiro.Dsl.ProjectionSupply+import Keiro.Dsl.ReadModelQueryContract (QueryContractIdentity, queryContractIdentityKey) import Keiro.Dsl.Scaffold (ModuleKind (..), ModuleRole (..))-import Keiro.Dsl.SemanticContract (EffectiveLanguageContract, effectiveLanguageContract)+import Keiro.Dsl.SemanticContract (CheckedService, EffectiveLanguageContract, checkedProjectionSupplies, checkedSpec, effectiveLanguageContract)+import Keiro.Dsl.SemanticImpact (SemanticImpactSnapshot) import Keiro.Dsl.SidecarNames (contextLedgerFileName) import System.FilePath (isAbsolute, splitDirectories) @@ -42,7 +51,12 @@     recIdDomains :: ![Text],     recNominalEqualities :: ![Text],     recBindingObligations :: ![BindingHole],-    recBehaviorRequirements :: ![BehaviorRecordRow]+    recBehaviorRequirements :: ![BehaviorRecordRow],+    recProjectionCatalogFacts :: ![Text],+    recQueryContractBaseline :: !Bool,+    recQueryContracts :: ![QueryContractIdentity],+    recRouterSelections :: ![RouterSelectionSnapshot],+    recSemanticImpact :: !(Maybe SemanticImpactSnapshot)   }   deriving stock (Eq, Show) @@ -101,6 +115,11 @@       <> map ("nominal-equality " <>) (recNominalEqualities record)       <> map renderBindingObligation (recBindingObligations record)       <> map renderBehaviorRequirement (recBehaviorRequirements record)+      <> map ("projection-catalog-fact " <>) (recProjectionCatalogFacts record)+      <> ["query-contract-baseline v1" | recQueryContractBaseline record]+      <> map ("query-contract " <>) (map (Text.decodeUtf8 . BL.toStrict . Aeson.encode) (recQueryContracts record))+      <> map ("router-selection " <>) (map (Text.decodeUtf8 . BL.toStrict . Aeson.encode) (recRouterSelections record))+      <> ["semantic-impact " <> Text.decodeUtf8 (BL.toStrict (Aeson.encode snapshot)) | Just snapshot <- [recSemanticImpact record]]   where     rootLabel = if T.null (recModuleRoot record) then "(none)" else recModuleRoot record     renderFile (Generated, path) = "generated " <> T.pack path@@ -134,7 +153,12 @@         let nominalEqualities = [identity | row <- rows, Just identity <- [T.stripPrefix "nominal-equality " row]]         bindingEntries <- traverse parseBindingObligation (filter ("binding " `T.isPrefixOf`) rows)         behaviorEntries <- traverse parseBehaviorRequirement (filter ("behavior " `T.isPrefixOf`) rows)-        if hasDuplicateMappingNames mappings || hasDuplicates idDomains || hasDuplicates nominalEqualities || hasDuplicateBindingObligations bindingEntries || hasDuplicateBehaviorRequirements behaviorEntries+        let catalogFacts = [fact | row <- rows, Just fact <- [T.stripPrefix "projection-catalog-fact " row]]+        queryContractBaseline <- parseQueryContractBaseline rows+        queryContracts <- traverse parseQueryContract (filter ("query-contract " `T.isPrefixOf`) rows)+        routerSelections <- traverse parseRouterSelection (filter ("router-selection " `T.isPrefixOf`) rows)+        semanticImpact <- parseSemanticImpact rows+        if hasDuplicateMappingNames mappings || hasDuplicates idDomains || hasDuplicates nominalEqualities || hasDuplicateBindingObligations bindingEntries || hasDuplicateBehaviorRequirements behaviorEntries || hasDuplicates catalogFacts || hasDuplicates (map queryContractIdentityKey queryContracts) || hasDuplicates (map selectionRouter routerSelections)           then Nothing           else             pure@@ -151,7 +175,12 @@                   recIdDomains = idDomains,                   recNominalEqualities = nominalEqualities,                   recBindingObligations = bindingEntries,-                  recBehaviorRequirements = behaviorEntries+                  recBehaviorRequirements = behaviorEntries,+                  recProjectionCatalogFacts = catalogFacts,+                  recQueryContractBaseline = queryContractBaseline,+                  recQueryContracts = queryContracts,+                  recRouterSelections = routerSelections,+                  recSemanticImpact = semanticImpact                 }   _ -> Nothing   where@@ -177,6 +206,22 @@     parseBehaviorRequirement row = do       payload <- T.stripPrefix "behavior " row       Aeson.decodeStrict' (Text.encodeUtf8 payload)+    parseQueryContract row = do+      payload <- T.stripPrefix "query-contract " row+      Aeson.decodeStrict' (Text.encodeUtf8 payload)+    parseRouterSelection row = do+      payload <- T.stripPrefix "router-selection " row+      Aeson.decodeStrict' (Text.encodeUtf8 payload)+    parseQueryContractBaseline rows = case filter ("query-contract-baseline " `T.isPrefixOf`) rows of+      [] -> Just False+      ["query-contract-baseline v1"] -> Just True+      _ -> Nothing+    parseSemanticImpact rows = case filter ("semantic-impact " `T.isPrefixOf`) rows of+      [] -> Just Nothing+      [row] -> do+        payload <- T.stripPrefix "semantic-impact " row+        Just <$> Aeson.decodeStrict' (Text.encodeUtf8 payload)+      _ -> Nothing     parseModuleRole row = do       payload <- T.stripPrefix "module-role " row       decoded <- Aeson.decodeStrict' (Text.encodeUtf8 payload)@@ -230,3 +275,166 @@ mappingRowPrefix :: MappingIdentity -> Text mappingRowPrefix NominalMapping {} = "nominal-mapping " mappingRowPrefix _ = "mapping "++-- | Canonical durable catalog identities used when a declaration disappears+-- from the next graph. Source lines remain part of the attribution evidence.+projectionCatalogFacts :: Spec -> [Text]+projectionCatalogFacts spec = projectionCatalogFactsWith spec (analyzeProjectionSupplies spec)++projectionCatalogFactsForService :: CheckedService -> [Text]+projectionCatalogFactsForService service =+  projectionCatalogFactsWith (checkedSpec service) (checkedProjectionSupplies service)++projectionCatalogFactsWith :: Spec -> ProjectionSupplyAnalysis -> [Text]+projectionCatalogFactsWith spec supplyAnalysis = sort (concatMap nodeFacts (specNodes spec) <> map supplyFact supplies)+  where+    supplies = resolvedProjectionSupplies supplyAnalysis+    owners = [owner | NProjectionOwner owner <- specNodes spec]+    nodeFacts (NProjectionTarget target) =+      [T.intercalate "|" ["target", ptName target, ptSchema target, ptTable target, resetText (ptReset target), T.intercalate "," (ptDependsOn target), lineText (ptLoc target)]]+    nodeFacts (NRebuildGroup groupNode) =+      [T.intercalate "|" ["group", rgName groupNode, T.intercalate "," (sort (rgTargets groupNode)), T.intercalate "," (rgOrder groupNode), lineText (rgLoc groupNode)]]+    nodeFacts (NProjectionRevision revision) =+      [ T.intercalate+          "|"+          [ "revision",+            prvName revision,+            prvGroup revision,+            T.intercalate ";" (map revisionTargetText (prvTargets revision)),+            lineText (prvLoc revision)+          ]+      ]+    nodeFacts (NExternalRead externalRead) =+      [ T.intercalate+          "|"+          [ "external-read",+            erName externalRead,+            T.pack (show (erVersion externalRead)),+            erQueryModel externalRead,+            erResultSchema externalRead <> "." <> erResultType externalRead,+            externalReadShape externalRead,+            T.intercalate "," (sort (erCompatibleRevisions externalRead)),+            T.pack (show (erSurfaceGeneration externalRead)),+            lineText (erLoc externalRead)+          ]+      ]+    nodeFacts (NProjectionOwner owner) =+      [ T.intercalate+          "|"+          [ "owner",+            poName owner,+            T.intercalate "," (map sourceText (poSources owner)),+            poGroup owner,+            T.intercalate "," (sort (poTargets owner)),+            T.pack (show (poOrder owner)),+            maybe "" id (poSubscription owner),+            maybe "" id (poDedup owner),+            T.intercalate "," (map checkpointOnMissingText (poCheckpointOnMissing owner)),+            replayText (poReplay owner),+            lineText (poLoc owner)+          ],+        T.intercalate+          "|"+          [ "delivery",+            poName owner,+            deliveryText (poDelivery owner),+            lineText (poLoc owner)+          ]+      ]+    nodeFacts (NReadModel readModel)+      | Just groupName <- rmGroup readModel =+          [ T.intercalate+              "|"+              [ "query",+                rmName readModel,+                groupName,+                T.intercalate "," (sort (rmObservedTargets readModel)),+                fromMaybe "" (effectiveBacking readModel),+                lineText (rmLoc readModel)+              ],+            T.intercalate+              "|"+              [ "freshness",+                rmName readModel,+                freshnessText (rmFreshness readModel),+                lineText (rmLoc readModel)+              ],+            T.intercalate+              "|"+              [ "cursor",+                rmName readModel,+                fromMaybe "none" (resolvedCursor readModel),+                lineText (rmLoc readModel)+              ]+          ]+    nodeFacts _ = []+    externalReadShape externalRead = case [rmShape readModel | NReadModel readModel <- specNodes spec, rmName readModel == erQueryModel externalRead] of+      shape : _ -> shape+      [] -> "missing-query"+    revisionTargetText target =+      T.intercalate+        ","+        [ prtTarget target,+          prtSchemaVersion target,+          prtProvisioner target,+          T.pack (show (prtProvisionerVersion target)),+          prtExpectedShape target,+          prtValidator target,+          T.pack (show (prtValidatorVersion target)),+          T.intercalate ":" (map promotionText (prtPromotionObjects target))+        ]+    promotionText promotionObject =+      T.intercalate+        ">"+        [ promotionKindText (rpoKind promotionObject),+          rpoGenerationName promotionObject,+          rpoCanonicalName promotionObject+        ]+    promotionKindText PromotionIndexNode = "index"+    promotionKindText PromotionConstraintNode = "constraint"+    promotionKindText PromotionOwnedSequenceNode = "owned-sequence"+    supplyFact supply =+      T.intercalate+        "|"+        [ "supply",+          supplyQueryModel supply,+          supplyProjectionOwner supply,+          supplyRebuildGroup supply,+          T.intercalate "," (NE.toList (supplyObservedTargets supply)),+          lineText (supplyQueryLoc supply),+          lineText (supplyOwnerLoc supply)+        ]+    effectiveBacking readModel = case rmBackingTarget readModel of+      Just targetName -> Just targetName+      Nothing -> case sort (rmObservedTargets readModel) of+        [targetName] -> Just targetName+        _ -> Nothing+    resetText TargetClear = "clear"+    resetText TargetPreserve = "preserve"+    sourceText CatalogAll = "all"+    sourceText (CatalogCategory categoryName) = "category:" <> categoryName+    sourceText (CatalogAggregate aggregateName) = "aggregate:" <> aggregateName+    deliveryText DeliveryInline = "inline"+    deliveryText DeliverySubscription = "subscription"+    freshnessText FreshnessImmediate = "immediate"+    freshnessText (FreshnessWaitForHead RmEntireLog) = "wait-for-head:entire-log"+    freshnessText (FreshnessWaitForHead (RmCategory categoryName)) = "wait-for-head:category:" <> categoryName+    resolvedCursor readModel = do+      ownerName <- case [ supplyProjectionOwner supply+                        | supply <- supplies,+                          supplyQueryModel supply == rmName readModel+                        ] of+        [name] -> Just name+        _ -> Nothing+      owner <- case [candidate | candidate <- owners, poName candidate == ownerName] of+        [candidate] -> Just candidate+        _ -> Nothing+      case poDelivery owner of+        DeliveryInline -> Nothing+        DeliverySubscription -> poSubscription owner+    checkpointOnMissingText CheckpointFromBeginning = "from-beginning"+    checkpointOnMissingText CheckpointFromCurrentHead = "from-current-head"+    checkpointOnMissingText CheckpointFail = "fail"+    replayText ProjectionReplayExplicit = "explicit"+    replayText (ProjectionLiveOnly reason) = "live-only:" <> reason+    lineText (Loc lineNumber) = T.pack (show lineNumber)

src/Keiro/Dsl/ScaffoldRun.hs view

@@ -3,21 +3,22 @@ module Keiro.Dsl.ScaffoldRun   ( Refusal (..),     WriteDisposition (..),+    GeneratedArtifactCategory (..),+    GeneratedArtifactImpact (..),     StaleGeneratedEvidence (..),     StaleModule (..),     MappingDrift (..),+    QueryContractMigration (..),     SourceLanguageDrift (..),     ScaffoldReport (..),     scaffoldServiceModules,     scaffoldServiceModulesWithGoldens,     scaffoldModules,     scaffoldModulesWithGoldens,-    planServiceScaffold,-    planServiceScaffoldWithGoldens,-    planServiceScaffoldWithRuntimePackage,-    planServiceScaffoldWithRuntimePackageAndGoldens,-    planScaffold,-    planScaffoldWithGoldens,+    planIndexedServiceScaffold,+    planIndexedServiceScaffoldWithGoldens,+    planIndexedServiceScaffoldWithRuntimePackage,+    planIndexedServiceScaffoldWithRuntimePackageAndGoldens,     executeServiceScaffold,     executeServiceScaffoldWithRuntimePackage,     executeServiceScaffoldWithRuntimePackageAndNameMigrations,@@ -25,6 +26,12 @@     executeScaffoldWithLanguage,     renderRefusals,     renderScaffoldReport,+    checkedSemanticImpactSnapshot,+    semanticImpactForMappingDrift,+    generatedArtifactImpact,+    renderSemanticImpactReport,+    renderGeneratedArtifactImpact,+    renderRouterSelectionDrift,      -- * Shared with whole-workspace scaffolding ("Keiro.Dsl.WorkspaceScaffold") @@ -32,12 +39,12 @@     -- $shared     planningGatePipeline,     planningRefusalDiagnostics,-    checkServiceDiagnostics,+    checkIndexedServiceDiagnostics,     inertNodesOf,     renderInertNodeSection,     withSidecarMovesApplied,     originLine,-    pureRefusals,+    pureRefusalsForService,     auditGeneratedHaskell,     missingGeneratedBanners,     staleAgainst,@@ -45,10 +52,11 @@     preparedSourceMove,     preflightSourceMoves,     applyPreparedSourceMoves,-    constraintPlan,+    constraintPlanForService,     mappingDrift,     behaviorDrift,     newBindingObligations,+    queryContractMigrations,     obligationKindLabel,     renderMappingIdentity,   )@@ -61,8 +69,10 @@ 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 (BehaviorDerivationError, BehaviorKey (..), BehaviorRecordRow (..), behaviorRecordRows, deriveBehaviorRequirementsForService) import Keiro.Dsl.BehaviorCoverage qualified as Behavior+import Keiro.Dsl.BehaviorSourceMap (BehaviorSourceFailure)+import Keiro.Dsl.BehaviorSourceMap qualified as BehaviorSource import Keiro.Dsl.ConformancePackage   ( ConformancePackageFailure,     ConformancePackageReport,@@ -73,27 +83,46 @@     renderConformancePackageFailure,     renderConformancePackageReport,   )+import Keiro.Dsl.CoordinationImpact (RouterSelectionDrift, renderRouterSelectionDrift, routerSelectionDrift, routerSelectionSnapshots) import Keiro.Dsl.ExplainBindings (BindingHole (..), BindingObligationKind (..), bindingHolesForService) import Keiro.Dsl.FoldFingerprint (FoldSurfaceError, aggregateFoldSurfaceForService, renderFoldSurfaceError) import Keiro.Dsl.Goldens (GoldenPayload) import Keiro.Dsl.Grammar (EmitNode (..), Loc (..), Node (..), OperationNode (..), PgmqDispatchNode (..), Spec (..))-import Keiro.Dsl.Harness (harnessForServiceWithGoldens, harnessProcess, harnessReadModel, harnessRouter, harnessWorkflow)+import Keiro.Dsl.Harness (harnessForServiceWithGoldens, harnessProcess, harnessReadModelForService, harnessRouterForService, 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)-import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), MappingIdentity (..), consumerPlan)+import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), MappingIdentity (..), consumerPlanForService) import Keiro.Dsl.NominalType (nominalEqualityIdentitiesForService)+import Keiro.Dsl.ProjectionMappedImpact (ProjectionMappedImpact, projectionMappedImpactForService, renderProjectionMappedImpact)+import Keiro.Dsl.ReadModelQueryContract import Keiro.Dsl.RuntimePackage (RuntimePackageName) import Keiro.Dsl.Scaffold-import Keiro.Dsl.ScaffoldRecord (ScaffoldModuleRoleRow (..), ScaffoldRecord (..), parseRecord, recordFileName, renderRecord)-import Keiro.Dsl.SemanticContract (CheckedService (..), checkedService, effectiveLanguageContract, legacyCheckedService)+import Keiro.Dsl.ScaffoldRecord (ScaffoldModuleRoleRow (..), ScaffoldRecord (..), parseRecord, projectionCatalogFactsForService, recordFileName, renderRecord)+import Keiro.Dsl.SemanticContract (CheckedService, checkedLanguageContract, checkedService, checkedSpec, checkedTypeGraph, effectiveLanguageContract, legacyCheckedService)+import Keiro.Dsl.SemanticImpact+  ( MappedImpactDelta (..),+    MappedRootEvidence (..),+    SemanticImpactReport (..),+    SemanticImpactSnapshot (..),+    diffSemanticImpact,+    mappedConsequenceIdentity,+    mappedConsumerIdentity,+    mappedRootKindIdentity,+    semanticImpactForService,+    semanticImpactReport,+    semanticImpactSnapshot,+  ) 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 Keiro.Dsl.Source (SourcePoint (..), SourceSpan (..))+import Keiro.Dsl.SourceIndex (SemanticSourceIndex)+import Keiro.Dsl.StructuralConformance (structuralConformanceModule)+import Keiro.Dsl.TypeGraph (MappedKey (..), TypeGraph (..), UseSite (..)) import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), Severity (..), validateService) import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile, renameFile) import System.FilePath (takeDirectory, (</>))@@ -114,6 +143,7 @@   | MissingGeneratedBanner ![FilePath]   | ImportCycle ![Text]   | BehaviorRefusal ![BehaviorDerivationError]+  | BehaviorSourceRefusal ![BehaviorSourceFailure]   | -- | Persisted fold identity could not be resolved canonically.     FoldSurfaceRefusal !FoldSurfaceError   | -- | Source provenance and semantic planning selected different contracts.@@ -137,13 +167,27 @@     SidecarMovesAlreadyApplied ![SidecarMove]   deriving stock (Eq, Show) --- | What one module write did. 'Unchanged' is produced only by the workspace--- write path, which compares bytes before overwriting a Generated module so that--- an idempotent re-run is observable in the report; the single-spec 'writeModule'--- never produces it.+-- | What one module write did. 'Unchanged' means an existing Generated module+-- already had identical bytes, or is reported by the workspace write path under+-- the same rule. data WriteDisposition = Overwritten | Created | Skipped | Unchanged   deriving stock (Eq, Show) +data GeneratedArtifactCategory+  = AggregateGeneratedArtifact+  | ServiceStructuralConformanceArtifact+  | BehaviorSourceMapArtifact+  | OtherGeneratedArtifact+  deriving stock (Eq, Ord, Show)++data GeneratedArtifactImpact = GeneratedArtifactImpact+  { artifactCategory :: !GeneratedArtifactCategory,+    artifactRole :: !ModuleRole,+    artifactPath :: !FilePath,+    artifactDisposition :: !WriteDisposition+  }+  deriving stock (Eq, Show)+ data StaleGeneratedEvidence   = ExactGeneratedBannerPresent   | ExactGeneratedBannerMissing@@ -182,6 +226,13 @@     reportConsumerPlan :: !ConsumerPlan,     reportConstraintPlan :: ![Text],     reportMappingDrift :: ![MappingDrift],+    reportQueryContractBaselineUnavailable :: !Bool,+    reportQueryContractDrift :: ![QueryContractDrift],+    reportQueryContractMigrations :: ![QueryContractMigration],+    reportSemanticImpact :: !SemanticImpactReport,+    reportRouterSelectionDrift :: ![RouterSelectionDrift],+    reportProjectionMappedImpact :: !(Maybe ProjectionMappedImpact),+    reportGeneratedArtifactImpact :: ![GeneratedArtifactImpact],     reportSourceLanguageDrift :: !(Maybe SourceLanguageDrift),     reportNewHoles :: ![BindingHole],     reportAddedBehavior :: ![BehaviorRecordRow],@@ -193,6 +244,13 @@   }   deriving stock (Eq, Show) +data QueryContractMigration = QueryContractMigration+  { qcmOwner :: !Text,+    qcmHolePath :: !FilePath,+    qcmRequiredImport :: !Text+  }+  deriving stock (Eq, Show)+ -- | Produce the complete in-memory module set under a checked semantic -- contract. Keeping this registry in one place prevents the CLI and tests from -- drifting apart.@@ -200,19 +258,32 @@ scaffoldServiceModules = scaffoldServiceModulesWithGoldens []  scaffoldServiceModulesWithGoldens :: [GoldenPayload] -> Context -> CheckedService -> [ScaffoldModule]-scaffoldServiceModulesWithGoldens goldens ctx service =-  scaffoldStructuralForService ctx service+scaffoldServiceModulesWithGoldens goldens = scaffoldServiceModulesWithBehaviorSource goldens []++scaffoldServiceModulesWithBehaviorSource :: [GoldenPayload] -> [BehaviorSource.BehaviorSourceEntry] -> Context -> CheckedService -> [ScaffoldModule]+scaffoldServiceModulesWithBehaviorSource goldens sourceEntries ctx service =+  structuralConformanceModules ctx service+    <> maybe [] pure (behaviorSourceMapModule ctx sourceEntries)+    <> scaffoldStructuralForService ctx service     <> scaffoldReplayAudit ctx spec+    <> scaffoldProjectionCatalogForService ctx service     <> concat       [ case node of           NAggregate agg -> scaffoldAggregateForService ctx service agg <> harnessForServiceWithGoldens goldens ctx service agg           NProcess process -> scaffoldProcess ctx process <> harnessProcess ctx process-          NRouter router -> scaffoldRouter ctx router <> harnessRouter ctx router+          NRouter router -> scaffoldRouterForService ctx service router <> harnessRouterForService ctx service router           NContract contract -> scaffoldContractForService ctx service contract           NIntake intake -> scaffoldIntake ctx intake           NPublisher publisher -> scaffoldPublisher ctx publisher-          NWorkqueue workqueue -> scaffoldWorkqueue ctx workqueue-          NReadModel readModel -> scaffoldReadModel ctx readModel <> harnessReadModel ctx readModel+          NWorkqueue workqueue -> scaffoldWorkqueueForService ctx service workqueue+          NReadModel readModel ->+            let resolved = resolveCatalogReadModel spec readModel+             in scaffoldReadModelForService ctx service resolved <> harnessReadModelForService ctx service resolved+          NProjectionTarget _ -> []+          NRebuildGroup _ -> []+          NProjectionRevision _ -> []+          NExternalRead _ -> []+          NProjectionOwner _ -> []           NWorkflow workflow -> harnessWorkflow ctx workflow           NEmit _ -> []           NPgmqDispatch _ -> []@@ -222,6 +293,12 @@   where     spec = checkedSpec service +structuralConformanceModules :: Context -> CheckedService -> [ScaffoldModule]+structuralConformanceModules ctx service = case structuralConformanceModule ctx service of+  Left failures -> error ("checked structural conformance planning failed: " <> show failures)+  Right Nothing -> []+  Right (Just moduleValue) -> [moduleValue]+ -- | Compatibility wrapper that explicitly selects legacy/version-1 semantics. scaffoldModules :: Context -> Spec -> [ScaffoldModule] scaffoldModules = scaffoldModulesWithGoldens []@@ -229,34 +306,51 @@ scaffoldModulesWithGoldens :: [GoldenPayload] -> Context -> Spec -> [ScaffoldModule] scaffoldModulesWithGoldens goldens ctx = scaffoldServiceModulesWithGoldens goldens ctx . legacyCheckedService --- | Run every pure refusal gate under the effective semantic contract.-planServiceScaffold :: Context -> CheckedService -> Either [Refusal] [ScaffoldModule]-planServiceScaffold = planServiceScaffoldWithRuntimePackage Nothing+-- | Run every pure refusal gate under the effective semantic contract. A+-- successful result is the exact write set; a refusal has no write set and+-- therefore cannot be accidentally executed.+planIndexedServiceScaffold :: SemanticSourceIndex -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]+planIndexedServiceScaffold = planIndexedServiceScaffoldWithRuntimePackage Nothing -planServiceScaffoldWithGoldens :: [GoldenPayload] -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]-planServiceScaffoldWithGoldens goldens = planServiceScaffoldWithRuntimePackageAndGoldens goldens Nothing+planIndexedServiceScaffoldWithGoldens :: [GoldenPayload] -> SemanticSourceIndex -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]+planIndexedServiceScaffoldWithGoldens goldens = planIndexedServiceScaffoldWithRuntimePackageAndGoldens goldens Nothing  -- | Add the one service-level conformance facade only when the runtime package -- is explicitly configured. The package name itself is build metadata; facade -- naming depends solely on the service context and placement policy.-planServiceScaffoldWithRuntimePackage :: Maybe RuntimePackageName -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]-planServiceScaffoldWithRuntimePackage = planServiceScaffoldWithRuntimePackageAndGoldens []+planIndexedServiceScaffoldWithRuntimePackage :: Maybe RuntimePackageName -> SemanticSourceIndex -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]+planIndexedServiceScaffoldWithRuntimePackage = planIndexedServiceScaffoldWithRuntimePackageAndGoldens [] -planServiceScaffoldWithRuntimePackageAndGoldens :: [GoldenPayload] -> Maybe RuntimePackageName -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]-planServiceScaffoldWithRuntimePackageAndGoldens goldens runtimePackage ctx service =-  planningGatePipeline ctx service modulePlan (Right ())+planIndexedServiceScaffoldWithRuntimePackageAndGoldens :: [GoldenPayload] -> Maybe RuntimePackageName -> SemanticSourceIndex -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]+planIndexedServiceScaffoldWithRuntimePackageAndGoldens goldens runtimePackage sourceIndex ctx service = do+  -- Preserve the established refusal precedence. Structural/path/import and+  -- behavior-derivation defects are decidable without exact provenance and+  -- must not be hidden by a later source-anchor join failure.+  _ <- planningGatePipeline ctx service baseModulePlan (Right ())+  planningGatePipeline ctx service completeModulePlan (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 ->+    baseModulePlan = case facadeModules of+      Left duplicates -> Left [DuplicateConformanceFactKeys duplicates]+      Right facades ->+        Right $+          stampGeneratedModules+            (checkedLanguageContract service)+            (scaffoldServiceModulesWithGoldens goldens ctx service <> facades)+    completeModulePlan =+      case (behaviorSourcePlan, facadeModules) of+        (Left refusals, _) -> Left refusals+        (_, Left duplicates) -> Left [DuplicateConformanceFactKeys duplicates]+        (Right sourceEntries, Right facades) ->           Right $             stampGeneratedModules               (checkedLanguageContract service)-              (scaffoldServiceModulesWithGoldens goldens ctx service <> facades)+              (scaffoldServiceModulesWithBehaviorSource goldens sourceEntries ctx service <> facades)+    behaviorSourcePlan = do+      requirements <- either (Left . pure . BehaviorRefusal) Right (deriveBehaviorRequirementsForService service)+      either (Left . pure . BehaviorSourceRefusal) Right (BehaviorSource.planBehaviorSourceMap requirements sourceIndex)  -- | The one pure scaffold-planning gate sequence. Both scaffold planners and -- both check paths consume this function, so the first reported refusal cannot@@ -270,23 +364,18 @@ 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+    Right _ -> case scaffoldRefusalsForService service of       lowering@(_ : _) -> Left [LoweringRefusal lowering]       [] -> case modulePlan of         Left refusals -> Left refusals         Right modules -> case packagePlan of           Left refusals -> Left refusals-          Right () -> case pureRefusals ctx spec modules of+          Right () -> case pureRefusalsForService ctx service modules of             [] -> Right modules             refusals -> Left refusals   where     spec = checkedSpec 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@@ -315,12 +404,17 @@         <> " (validated and diff-classified; no generated modules)"     ] -checkServiceDiagnostics :: Maybe RuntimePackageName -> Context -> CheckedService -> [Diagnostic]-checkServiceDiagnostics runtimePackage 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.+checkIndexedServiceDiagnostics :: Maybe RuntimePackageName -> SemanticSourceIndex -> Context -> CheckedService -> [Diagnostic]+checkIndexedServiceDiagnostics runtimePackage sourceIndex ctx service   | any blocksPlanning validationDiagnostics = validationDiagnostics   | otherwise =       validationDiagnostics-        <> case planServiceScaffoldWithRuntimePackage runtimePackage ctx service of+        <> case planIndexedServiceScaffoldWithRuntimePackage runtimePackage sourceIndex ctx service of           Right _ -> []           Left refusals -> planningRefusalDiagnostics refusals   where@@ -347,6 +441,22 @@           "behavior obligations cannot be derived soundly: " <> T.pack (show behaviorError)       | behaviorError <- errors       ]+    diagnosticsFor (BehaviorSourceRefusal failures) =+      [ planningError (behaviorSourceFailureLine failure) (behaviorSourceDiagnosticCode failure) $+          "behavior source map cannot be planned for "+            <> Behavior.unBehaviorKey (BehaviorSource.failureKey failure)+            <> " ("+            <> BehaviorSource.failureAggregate failure+            <> ":"+            <> BehaviorSource.failureState failure+            <> " -- "+            <> BehaviorSource.failureCommand failure+            <> ", subject="+            <> T.pack (show (BehaviorSource.failureSourceSubject failure))+            <> "): "+            <> BehaviorSource.failureMessage failure+      | failure <- failures+      ]     diagnosticsFor (DuplicateConformanceFactKeys duplicates) =       [ planningError 1 ConformanceFactKeyCollision $           "normalized service conformance fact key '"@@ -384,6 +494,14 @@     behaviorErrorLine (Behavior.DuplicateBehaviorIdentity _ locations) = maximum (1 : map unLoc locations)     behaviorErrorLine _ = 1 +    behaviorSourceFailureLine failure = case BehaviorSource.failureSpan failure of+      Just SourceSpan {start = SourcePoint {line = sourceLine}} -> sourceLine+      Nothing -> 1+    behaviorSourceDiagnosticCode failure = case BehaviorSource.failureCode failure of+      BehaviorSource.BehaviorSourceAnchorMissing -> BehaviorSourceAnchorMissing+      BehaviorSource.BehaviorSourceAnchorInexact -> BehaviorSourceAnchorInexact+      BehaviorSource.BehaviorSourceAnchorCollision -> BehaviorSourceAnchorCollision+     planningError diagnosticLine diagnosticCode diagnosticMessage =       Diagnostic         { line = diagnosticLine,@@ -401,27 +519,19 @@   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]-planScaffold = planScaffoldWithGoldens []--planScaffoldWithGoldens :: [GoldenPayload] -> Context -> Spec -> Either [Refusal] [ScaffoldModule]-planScaffoldWithGoldens goldens ctx = planServiceScaffoldWithGoldens goldens ctx . legacyCheckedService- -- | Every pure refusal gate, over an already-built module set: case-folded path -- collisions, generated\/consumer collisions and import cycles, firewall breaches, -- and lowering refusals. Whole-workspace planning builds its module set from the -- merged spec and then runs exactly this, so no gate can apply to one input shape -- and not the other.-pureRefusals :: Context -> Spec -> [ScaffoldModule] -> [Refusal]-pureRefusals ctx spec modules =+pureRefusalsForService :: Context -> CheckedService -> [ScaffoldModule] -> [Refusal]+pureRefusalsForService ctx service modules =   collisionRefusals modules-    <> dependencyRefusals ctx spec modules+    <> dependencyRefusalsForService ctx service 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]]+    <> [LoweringRefusal lowering | let lowering = scaffoldRefusalsForService service, not (null lowering)]+    <> [BehaviorRefusal errors | Left errors <- [deriveBehaviorRequirementsForService service]]   where     breaches = firewallBreaches modules     namingViolations = generatedNameInvariantViolations modules@@ -616,10 +726,10 @@       _character : '\'' : _ -> True       _ -> False -dependencyRefusals :: Context -> Spec -> [ScaffoldModule] -> [Refusal]-dependencyRefusals ctx spec modules = collisionWithConsumers <> namespaceCycles+dependencyRefusalsForService :: Context -> CheckedService -> [ScaffoldModule] -> [Refusal]+dependencyRefusalsForService ctx service modules = collisionWithConsumers <> namespaceCycles   where-    plan = consumerPlan spec+    plan = consumerPlanForService service     generatedByName = Map.fromList [(moduleNameOf (modulePath moduleValue), moduleValue) | moduleValue <- modules, kind moduleValue == Generated]     collisionWithConsumers =       [ PathCollision@@ -735,7 +845,7 @@         (\packageName -> planConformancePackage (StandaloneConformanceService (contextName ctx)) packageName (serviceConformanceModuleName ctx) service)         runtimePackage     executeCheckedScaffold sidecarMoves preparedPackage =-      case deriveBehaviorRequirements spec of+      case deriveBehaviorRequirementsForService service of         Left errors -> pure (Left [BehaviorRefusal errors])         Right requirements -> do           bannerless <- if forceGeneratedOverwrite then pure [] else missingGeneratedBanners out modules@@ -756,8 +866,23 @@                       | otherwise -> do                           applyPreparedSourceMoves out prepared                           stale <- maybe (pure []) (existingStale out modules) previousRecord-                          let currentConsumerPlan = consumerPlan spec+                          queryMigrations <- queryContractMigrations out modules+                          let currentConsumerPlan = consumerPlanForService service                               drift = maybe [] (mappingDrift (consumerMappings currentConsumerPlan) . recMappings) previousRecord+                              currentQueryContracts = either (const []) id (queryContractIdentitiesForService service)+                              queryHistoryBaseline =+                                not (null currentQueryContracts)+                                  || maybe False recQueryContractBaseline previousRecord+                              queryBaselineUnavailable =+                                not (null currentQueryContracts)+                                  && maybe False (not . recQueryContractBaseline) previousRecord+                              queryDrift = case previousRecord of+                                Just previous | recQueryContractBaseline previous -> queryContractDrift currentQueryContracts (recQueryContracts previous)+                                _ -> []+                              currentSemanticImpact = checkedSemanticImpactSnapshot service+                              semanticReport = semanticImpactForMappingDrift (previousRecord >>= recSemanticImpact) currentSemanticImpact drift+                              currentRouterSelections = routerSelectionSnapshots service+                              selectionDrift = maybe [] (\previous -> routerSelectionDrift (recRouterSelections previous) currentRouterSelections) previousRecord                               languageDrift = do                                 previous <- previousRecord                                 if recSourceLanguage previous == sourceLanguage@@ -771,7 +896,7 @@                           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))+                          TIO.writeFile recordPath (renderRecord (currentRecord specPath sourceLanguage ctx service modules queryHistoryBaseline currentBehavior currentSemanticImpact))                           packageReport <- traverse executePreparedConformancePackage preparedPackage                           pure $                             Right@@ -786,13 +911,20 @@                                   reportPreviousSpecPath = recSpecPath <$> previousRecord,                                   reportStale = stale,                                   reportConsumerPlan = currentConsumerPlan,-                                  reportConstraintPlan = constraintPlan spec currentConsumerPlan,+                                  reportConstraintPlan = constraintPlanForService service currentConsumerPlan,                                   reportMappingDrift = drift,+                                  reportQueryContractBaselineUnavailable = queryBaselineUnavailable,+                                  reportQueryContractDrift = queryDrift,+                                  reportQueryContractMigrations = queryMigrations,+                                  reportSemanticImpact = semanticReport,+                                  reportRouterSelectionDrift = selectionDrift,+                                  reportProjectionMappedImpact = projectionMappedImpactForService service,+                                  reportGeneratedArtifactImpact = generatedArtifactImpact dispositions,                                   reportSourceLanguageDrift = languageDrift,                                   reportNewHoles = newHoles,                                   reportAddedBehavior = addedBehavior,                                   reportRemovedBehavior = removedBehavior,-                                  reportObsoleteOutputHooks = obsoleteGeneratedOutputHooks spec,+                                  reportObsoleteOutputHooks = obsoleteGeneratedOutputHooksForService service,                                   reportConformancePackage = packageReport,                                   reportNameMoves = map preparedSourceMove prepared,                                   reportSidecarMoves = sidecarMoves@@ -965,8 +1097,8 @@       "transformed-digest " <> maybe "<missing>" id (moveTransformedDigest move)     ] -constraintPlan :: Spec -> ConsumerPlan -> [Text]-constraintPlan spec plan = case resolveTypeGraph spec of+constraintPlanForService :: CheckedService -> ConsumerPlan -> [Text]+constraintPlanForService service plan = case checkedTypeGraph service of   Left _ -> []   Right graph ->     let registerRoots =@@ -999,6 +1131,43 @@     oldByName = Map.fromList [(mappingSpecName mapping, mapping) | mapping <- previous]     newByName = Map.fromList [(mappingSpecName mapping, mapping) | mapping <- current] +checkedSemanticImpactSnapshot :: CheckedService -> SemanticImpactSnapshot+checkedSemanticImpactSnapshot service = case checkedTypeGraph service of+  Left failures -> error ("validated scaffold type graph did not resolve: " <> show failures)+  Right graph -> semanticImpactSnapshot (semanticImpactForService service graph)++semanticImpactForMappingDrift :: Maybe SemanticImpactSnapshot -> SemanticImpactSnapshot -> [MappingDrift] -> SemanticImpactReport+semanticImpactForMappingDrift previous current drifts =+  semanticImpactReport previous current changedDeclarations+  where+    driftDeclarations = [MappedKey (driftSpecName drift) | drift <- drifts]+    snapshotDeclarations = maybe [] (map impactDeclaration . (`diffSemanticImpact` current)) previous+    changedDeclarations = driftDeclarations <> snapshotDeclarations++generatedArtifactImpact :: [(ScaffoldModule, WriteDisposition)] -> [GeneratedArtifactImpact]+generatedArtifactImpact dispositions =+  sortOn+    artifactPath+    [ GeneratedArtifactImpact+        { artifactCategory = categoryFor role,+          artifactRole = role,+          artifactPath = modulePath scaffoldModule,+          artifactDisposition = disposition+        }+    | (scaffoldModule, disposition) <- dispositions,+      kind scaffoldModule == Generated,+      disposition `elem` [Overwritten, Created],+      let role = moduleRole scaffoldModule+    ]+  where+    categoryFor role+      | roleFamily role == "StructuralConformance" = ServiceStructuralConformanceArtifact+      | roleFamily role == "BehaviorSourceMap" = BehaviorSourceMapArtifact+      | roleOwnerKind role == "aggregate"+          || ": aggregate " `T.isInfixOf` roleOwnerName role =+          AggregateGeneratedArtifact+      | otherwise = OtherGeneratedArtifact+ newBindingObligations :: [BindingHole] -> [BindingHole] -> [BindingHole] newBindingObligations current previous =   [ obligation@@ -1008,6 +1177,44 @@   where     previousSet = Set.fromList previous +-- | Inspect, but never rewrite, an existing create-once read-model hole. A+-- typed plan is complete only after the application removes its legacy local+-- aliases and imports the generated QueryContract aliases.+queryContractMigrations :: FilePath -> [ScaffoldModule] -> IO [QueryContractMigration]+queryContractMigrations out modules = fmap concat (mapM inspect typedHoles)+  where+    typedHoles =+      [ (hole, requiredImport)+      | hole <- modules,+        kind hole == HoleStub,+        roleFamily (moduleRole hole) == "ReadModelHoles",+        requiredImport <- T.lines (moduleText hole),+        "import " `T.isPrefixOf` requiredImport,+        ".QueryContract (" `T.isInfixOf` requiredImport+      ]+    inspect (hole, requiredImport) = do+      let path = out </> modulePath hole+      exists <- doesFileExist path+      if not exists+        then pure []+        else do+          contents <- TIO.readFile path+          let ready = requiredImport `elem` T.lines contents && not (any isLocalQueryAlias (T.lines contents))+          pure+            [ QueryContractMigration+                { qcmOwner = queryOwner (moduleRole hole),+                  qcmHolePath = modulePath hole,+                  qcmRequiredImport = requiredImport+                }+            | not ready+            ]+    isLocalQueryAlias line = case T.words (T.strip line) of+      "type" : alias : "=" : _ -> "QueryInput" `T.isSuffixOf` alias || "QueryResult" `T.isSuffixOf` alias+      _ -> False+    queryOwner role = case T.words (roleOwnerName role) of+      "readmodel" : owner : _ -> owner+      _ -> roleOwnerName role+ behaviorDrift :: [BehaviorRecordRow] -> [BehaviorRecordRow] -> ([BehaviorRecordRow], [BehaviorRecordRow]) behaviorDrift current previous =   ( [row | row <- sortOn behaviorRecordKey current, behaviorRecordKey row `Set.notMember` previousKeys],@@ -1049,8 +1256,8 @@                   else ExactGeneratedBannerMissing           pure [StaleModule fileKind path evidence] -currentRecord :: FilePath -> SourceLanguage -> Context -> CheckedService -> [ScaffoldModule] -> [BehaviorRecordRow] -> ScaffoldRecord-currentRecord specPath sourceLanguage ctx service modules currentBehavior =+currentRecord :: FilePath -> SourceLanguage -> Context -> CheckedService -> [ScaffoldModule] -> Bool -> [BehaviorRecordRow] -> SemanticImpactSnapshot -> ScaffoldRecord+currentRecord specPath sourceLanguage ctx service modules queryHistoryBaseline currentBehavior currentSemanticImpact =   ScaffoldRecord     { recSpecPath = T.pack specPath,       recModuleRoot = moduleRoot ctx,@@ -1060,14 +1267,17 @@       recNamingEdition = currentGeneratedHaskellNamingEdition,       recModuleRoles = [ScaffoldModuleRoleRow (moduleRole m) (kind m) (modulePath m) | m <- modules],       recFiles = [(kind m, modulePath m) | m <- modules],-      recMappings = consumerMappings (consumerPlan spec),+      recMappings = consumerMappings (consumerPlanForService service),       recIdDomains = idDomainIdentitiesForService service,       recNominalEqualities = nominalEqualityIdentitiesForService service,       recBindingObligations = either (const []) id (bindingHolesForService service),-      recBehaviorRequirements = currentBehavior+      recBehaviorRequirements = currentBehavior,+      recProjectionCatalogFacts = projectionCatalogFactsForService service,+      recQueryContractBaseline = queryHistoryBaseline,+      recQueryContracts = either (const []) id (queryContractIdentitiesForService service),+      recRouterSelections = routerSelectionSnapshots service,+      recSemanticImpact = Just currentSemanticImpact     }-  where-    spec = checkedSpec service  missingGeneratedBanners :: FilePath -> [ScaffoldModule] -> IO [FilePath] missingGeneratedBanners out modules = fmap concat $ mapM check generated@@ -1088,8 +1298,14 @@   createDirectoryIfMissing True (takeDirectory path)   case kind m of     Generated -> do-      TIO.writeFile path (moduleText m)-      pure (m, Overwritten)+      exists <- doesFileExist path+      if exists+        then do+          existing <- TIO.readFile path+          if existing == moduleText m+            then pure (m, Unchanged)+            else TIO.writeFile path (moduleText m) >> pure (m, Overwritten)+        else TIO.writeFile path (moduleText m) >> pure (m, Overwritten)     HoleStub -> do       exists <- doesFileExist path       if exists@@ -1135,6 +1351,16 @@     render (BehaviorRefusal errors) =       ["error: behavior obligations cannot be derived soundly -- refusing to scaffold; nothing was written"]         <> ["  " <> T.pack (show behaviorError) | behaviorError <- errors]+    render (BehaviorSourceRefusal failures) =+      ["error: behavior source map cannot be planned -- refusing to scaffold; nothing was written"]+        <> [ "  "+               <> T.pack (show (BehaviorSource.failureCode failure))+               <> " "+               <> Behavior.unBehaviorKey (BehaviorSource.failureKey failure)+               <> ": "+               <> BehaviorSource.failureMessage failure+           | failure <- failures+           ]     render (GeneratedNameInvariantViolation violations) =       ["error: generated Haskell name invariant violated -- refusing to scaffold; nothing was written"]         <> map ("  " <>) violations@@ -1192,6 +1418,71 @@         <> "  backup: "         <> T.pack (moveBackupPath move) +renderSemanticImpactReport :: SemanticImpactReport -> [Text]+renderSemanticImpactReport report = case semanticReportDeclarations report of+  [] -> []+  declarations ->+    ["semantic impact:"]+      <> case semanticReportPrevious report of+        Nothing ->+          ["  baseline: unavailable (legacy ledger)"]+            <> concatMap renderCurrent declarations+        Just _ -> concatMap renderDelta (semanticReportDeltas report)+  where+    renderCurrent declaration =+      [ "  " <> unMappedKey declaration,+        "    current aggregate consumers: " <> renderConsumers (Map.findWithDefault Set.empty declaration (snapshotMappedConsumers (semanticReportCurrent report))),+        "    current roots: " <> maybe "baseline unavailable" (renderEvidence . Map.findWithDefault Set.empty declaration) (snapshotMappedEvidence (semanticReportCurrent report)),+        "    current consequences: " <> maybe "baseline unavailable" (renderConsequences . Map.findWithDefault Set.empty declaration) (snapshotMappedConsequences (semanticReportCurrent report)),+        "    service-conformance: impacted"+      ]+    renderDelta delta =+      [ "  " <> unMappedKey (impactDeclaration delta),+        "    previous aggregate consumers: " <> renderConsumers (impactPreviousConsumers delta),+        "    current aggregate consumers:  " <> renderConsumers (impactCurrentConsumers delta),+        "    previous roots: " <> maybe "baseline unavailable" renderEvidence (impactPreviousEvidence delta),+        "    current roots:  " <> maybe "baseline unavailable" renderEvidence (impactCurrentEvidence delta),+        "    previous consequences: " <> maybe "baseline unavailable" renderConsequences (impactPreviousConsequences delta),+        "    current consequences:  " <> maybe "baseline unavailable" renderConsequences (impactCurrentConsequences delta),+        "    service-conformance: " <> if impactServiceConformance delta then "impacted" else "unchanged"+      ]+    renderConsumers aggregateConsumers = case map consumerName (Set.toAscList aggregateConsumers) of+      [] -> "(none)"+      names -> T.intercalate ", " names+    consumerName = mappedConsumerIdentity+    renderEvidence = renderSet renderRoot+    renderRoot evidence =+      T.intercalate "|" [mappedRootKindIdentity (evidenceRootKind evidence), mappedConsumerIdentity (evidenceConsumer evidence), evidencePath evidence]+        <> maybe "" ("|" <>) (evidenceOperation evidence)+    renderConsequences = renderSet mappedConsequenceIdentity+    renderSet render values = case map render (Set.toAscList values) of+      [] -> "(none)"+      rendered -> T.intercalate ", " rendered++renderGeneratedArtifactImpact :: SemanticImpactReport -> [GeneratedArtifactImpact] -> [Text]+renderGeneratedArtifactImpact _ [] = []+renderGeneratedArtifactImpact semanticReport impacts =+  "generated-artifact impact:" : map renderArtifact impacts+  where+    renderArtifact impact =+      "  "+        <> categoryLabel (artifactCategory impact)+        <> " "+        <> T.pack (artifactPath impact)+        <> " ("+        <> dispositionLabel (artifactDisposition impact)+        <> ")"+    categoryLabel AggregateGeneratedArtifact+      | null (semanticReportDeltas semanticReport) = "aggregate (generator or non-mapped drift; no mapped semantic impact)"+      | otherwise = "aggregate"+    categoryLabel ServiceStructuralConformanceArtifact = "service-conformance"+    categoryLabel BehaviorSourceMapArtifact = "behavior-source-map"+    categoryLabel OtherGeneratedArtifact = "generated"+    dispositionLabel Overwritten = "overwritten"+    dispositionLabel Created = "created"+    dispositionLabel Skipped = "skipped"+    dispositionLabel Unchanged = "unchanged"+ renderScaffoldReport :: ScaffoldReport -> [Text] renderScaffoldReport report =   [ "scaffold: " <> T.pack (reportSpecPath report) <> " -> " <> T.pack (reportOutDir report) <> " (module-root=" <> rootLabel <> ", layout=" <> layoutLabel <> ")"@@ -1207,7 +1498,13 @@     <> previousSpecNote     <> constraintSection     <> newHolesSection+    <> queryContractSection+    <> queryContractMigrationSection     <> mappingDriftSection+    <> renderSemanticImpactReport (reportSemanticImpact report)+    <> renderRouterSelectionDrift (reportRouterSelectionDrift report)+    <> maybe [] renderProjectionMappedImpact (reportProjectionMappedImpact report)+    <> renderGeneratedArtifactImpact (reportSemanticImpact report) (reportGeneratedArtifactImpact report)     <> sourceLanguageDriftSection     <> behaviorDriftSection     <> obsoleteOutputSection@@ -1259,6 +1556,40 @@     obligationLines hole =       [ "  " <> holeModule hole,         "    " <> holeSignature hole <> " (" <> obligationKindLabel (holeKind hole) <> ")"+      ]+    queryContractSection =+      [ "query contract history: baseline unavailable in the previous ledger; no legacy `()` API was inferred"+      | reportQueryContractBaselineUnavailable report+      ]+        <> case reportQueryContractDrift report of+          [] -> []+          drifts ->+            ["query contract drift: " <> tshow (length drifts) <> " input/result position(s) changed since the previous scaffold:"]+              <> concatMap queryDriftLines drifts+    queryDriftLines drift =+      [ "  " <> readModel <> " " <> queryPositionLabel position,+        "    previous: " <> maybe "(absent)" renderQueryIdentity (qcdPrevious drift),+        "    current:  " <> maybe "(absent)" renderQueryIdentity (qcdCurrent drift)+      ]+      where+        (readModel, position) = qcdKey drift+    renderQueryIdentity identity =+      qciTypeExpression identity+        <> " mapped=["+        <> T.intercalate ", " (qciMappedDependencies identity)+        <> "]"+    queryPositionLabel QueryInputConsumer = "input"+    queryPositionLabel QueryResultConsumer = "result"+    queryContractMigrationSection = case reportQueryContractMigrations report of+      [] -> []+      migrations ->+        ["query contract migration required: " <> tshow (length migrations) <> " hand-owned hole module(s)"]+          <> concatMap migrationLines migrations+    migrationLines migration =+      [ "  " <> qcmOwner migration,+        "    edit " <> T.pack (qcmHolePath migration),+        "    remove the local QueryInput/QueryResult type aliases",+        "    add " <> qcmRequiredImport migration       ]     previousSpecNote = case reportPreviousSpecPath report of       Just previous

src/Keiro/Dsl/SemanticContract.hs view

@@ -15,14 +15,21 @@     effectiveLanguageContract,     effectiveLanguageContractForVersion,     runtimeSemanticsFingerprintSegments,-    CheckedService (..),+    CheckedService,+    checkedLanguageContract,+    checkedSpec,+    checkedTypeGraph,+    checkedProjectionSupplies,+    checkedServiceWithSpec,     checkedSource,     checkedService,+    checkedServiceForContract,     legacyCheckedService,   ) where  import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=))+import Data.List.NonEmpty (NonEmpty) import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T@@ -45,6 +52,8 @@     runtimeProfileFoldSegments,     runtimeProfileIdentifier,   )+import Keiro.Dsl.ProjectionSupply (ProjectionSupplyAnalysis, analyzeProjectionSupplies)+import Keiro.Dsl.TypeGraph (TypeGraph, TypeGraphError, resolveTypeGraph)  -- | One effective released-language selection plus the runtime-semantics -- generation it selects. Versions 1 and 2 differ in grammar capabilities but@@ -70,11 +79,11 @@     (error "keiro-dsl internal invariant: effective contract selected an unregistered language version")     (languageSupportForVersion (effectiveContractLanguageVersion contract)) --- | One stderr line naming a non-stable effective contract. Stable sources--- stay silent so adopting the current contract does not add CLI noise.+-- | One stderr line naming a compatibility-only effective contract. Published+-- stable and active candidate sources stay silent. languageContractNotice :: FilePath -> Text -> EffectiveLanguageContract -> Maybe Text languageContractNotice subject sourceFormSummary contract-  | effectiveLanguageSupport contract == Stable = Nothing+  | effectiveLanguageSupport contract /= CompatibilityOnly = Nothing   | otherwise =       Just         ( T.pack subject@@ -90,7 +99,7 @@             <> languageVersionText currentStableLanguageVersion             <> " strict spec-surface validation is not applied — declare `language keiro-dsl "             <> languageVersionText currentStableLanguageVersion-            <> "` to adopt the stable contract"+            <> "` to adopt the published stable contract"         )  instance ToJSON EffectiveLanguageContract where@@ -150,11 +159,48 @@ -- it was checked. Member-level declared/legacy provenance intentionally stays -- on 'ParsedSource' or 'Keiro.Dsl.Workspace.WorkspaceMember'. data CheckedService = CheckedService-  { checkedLanguageContract :: !EffectiveLanguageContract,-    checkedSpec :: !Spec+  { serviceLanguageContract :: !EffectiveLanguageContract,+    serviceSpec :: !Spec,+    serviceTypeGraph :: Either (NonEmpty TypeGraphError) TypeGraph,+    serviceProjectionSupplies :: ProjectionSupplyAnalysis   }-  deriving stock (Eq, Show) +checkedLanguageContract :: CheckedService -> EffectiveLanguageContract+checkedLanguageContract = serviceLanguageContract++checkedSpec :: CheckedService -> Spec+checkedSpec = serviceSpec++-- | Shared, lazily forced resolution of 'checkedSpec'. This derived value is+-- never serialized and is deliberately excluded from Eq and Show.+checkedTypeGraph :: CheckedService -> Either (NonEmpty TypeGraphError) TypeGraph+checkedTypeGraph = serviceTypeGraph++-- | Shared, lazily forced projection-supply analysis of 'checkedSpec'. This+-- derived value is never serialized and is deliberately excluded from Eq and+-- Show.+checkedProjectionSupplies :: CheckedService -> ProjectionSupplyAnalysis+checkedProjectionSupplies = serviceProjectionSupplies++-- | Replace a service's spec while preserving its effective language contract+-- and rebuilding the lazy whole-spec analysis cache for the replacement.+checkedServiceWithSpec :: Spec -> CheckedService -> CheckedService+checkedServiceWithSpec spec service = checkedServiceForContract (checkedLanguageContract service) spec++instance Eq CheckedService where+  left == right =+    checkedLanguageContract left == checkedLanguageContract right+      && checkedSpec left == checkedSpec right++instance Show CheckedService where+  showsPrec precedence service =+    showParen (precedence >= 11) $+      showString "CheckedService {checkedLanguageContract = "+        . shows (checkedLanguageContract service)+        . showString ", checkedSpec = "+        . shows (checkedSpec service)+        . showString "}"+ -- | Construct the semantic input for one parsed source without losing the -- selected contract. checkedSource :: ParsedSource -> CheckedService@@ -166,9 +212,17 @@ -- same effective version. checkedService :: SourceLanguage -> Spec -> CheckedService checkedService sourceLanguage spec =+  checkedServiceForContract (effectiveLanguageContract sourceLanguage) spec++-- | Construct a checked service when composition has already selected and+-- verified the effective language contract.+checkedServiceForContract :: EffectiveLanguageContract -> Spec -> CheckedService+checkedServiceForContract languageContract spec =   CheckedService-    { checkedLanguageContract = effectiveLanguageContract sourceLanguage,-      checkedSpec = spec+    { serviceLanguageContract = languageContract,+      serviceSpec = spec,+      serviceTypeGraph = resolveTypeGraph spec,+      serviceProjectionSupplies = analyzeProjectionSupplies spec     }  -- | Compatibility bridge for callers that historically supplied only 'Spec'.

+ src/Keiro/Dsl/SemanticImpact.hs view

@@ -0,0 +1,923 @@+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}++-- | Checked semantic dependency impact for mapped declarations.+--+-- This module answers which aggregates can consume a mapped declaration. It+-- does not classify wire compatibility and it does not claim that finite+-- conformance fixtures prove a consumer binding for all values. Both the roots+-- and transitive declaration edges come from a resolved 'TypeGraph', so callers+-- must not reconstruct this relation from a raw specification.+module Keiro.Dsl.SemanticImpact+  ( DerivedMappedConsumer (..),+    UnsupportedProjectionSource (..),+    MappedQueryPosition (..),+    RouterSelectionPosition (..),+    MappedConsumer (..),+    MappedRootKind (..),+    MappedRoot (..),+    MappedRootEvidence (..),+    MappedConsequence (..),+    SemanticImpact (..),+    SemanticImpactSnapshot (..),+    MappedImpactDelta (..),+    SemanticImpactReport (..),+    semanticImpact,+    semanticImpactForService,+    semanticImpactSnapshot,+    diffSemanticImpact,+    mappedImpactForDeclarations,+    semanticImpactReport,+    mappedConsumerIdentity,+    mappedRootKindIdentity,+    mappedConsequenceIdentity,+    mappedSurfaceFactValues,+    aggregateMappedRoots,+    aggregateMappedClosure,+    mappedDeclarationConsumers,+    serviceMappedInventory,+  )+where++import Control.Monad (unless)+import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=))+import Data.Aeson.Types (Parser)+import Data.List (sort, sortOn)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (isJust)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import Keiro.Dsl.Grammar+import Keiro.Dsl.RouterSelection+import Keiro.Dsl.SemanticContract (CheckedService, checkedLanguageContract, checkedSpec)+import Keiro.Dsl.TypeGraph++-- | A checked generated consumer of mapped declarations. Projection consumers+-- are derived from an aggregate event authority rather than owning another+-- source type expression.+data MappedQueryPosition+  = MappedQueryInput+  | MappedQueryResult+  deriving stock (Eq, Ord, Show, Generic)++data RouterSelectionPosition+  = SelectionQueryInput+  | SelectionPredicate+  | SelectionRecipient+  | SelectionCommandField !Name+  deriving stock (Eq, Ord, Show, Generic)++data MappedConsumer+  = AggregateConsumer !Name+  | WorkqueueConsumer !Name+  | ReadModelQueryConsumer !Name !MappedQueryPosition+  | RouterSelectionConsumer !Name !RouterSelectionPosition+  | DerivedProjectionConsumer !DerivedMappedConsumer+  deriving stock (Eq, Ord, Show, Generic)++-- | The complete candidate mapped root vocabulary. Snapshot impact follows+-- 'MappedRegisterRoot' because snapshots cache aggregate registers; the other+-- kinds are distinct consumer-build or persisted-queue surfaces.+data MappedRootKind+  = MappedCommandFieldRoot+  | MappedEventFieldRoot+  | MappedRegisterRoot+  | MappedWorkqueueFieldRoot+  | MappedReadModelQueryInputRoot+  | MappedReadModelQueryResultRoot+  | MappedRouterSelectionQueryInputRoot+  | MappedRouterSelectionPredicateRoot+  | MappedRouterSelectionRecipientRoot+  | MappedRouterSelectionCommandFieldRoot+  | MappedProjectionEventRoot+  deriving stock (Eq, Ord, Show, Generic)++-- | One checked aggregate root before transitive declaration expansion.+data MappedRoot = MappedRoot+  { mappedRootConsumer :: !MappedConsumer,+    mappedRootKind :: !MappedRootKind,+    mappedRootUseSite :: !UseSite,+    mappedRootDeclaration :: !MappedKey+  }+  deriving stock (Eq, Ord, Show, Generic)++-- | A source-independent, surface-tagged path from one generated consumer to+-- one declaration. Unlike 'MappedRoot', this also represents transitive paths+-- and therefore is suitable for durable ledgers and exact conformance facts.+data MappedRootEvidence = MappedRootEvidence+  { evidenceConsumer :: !MappedConsumer,+    evidenceRootKind :: !MappedRootKind,+    evidencePath :: !Text,+    evidenceOperation :: !(Maybe Text)+  }+  deriving stock (Eq, Ord, Show, Generic)++-- | Orthogonal consequences of a mapped declaration. These deliberately do+-- not collapse persisted history, API/build impact, or projection rebuilds+-- into one severity.+data MappedConsequence+  = MappedConsumerBuild !MappedConsumer+  | MappedPrivateEventHistory !Name+  | MappedSnapshotHydration !Name+  | MappedWorkqueueHistory !Name+  | MappedQueryApi !Name !MappedQueryPosition+  | MappedRouterSelectionBuild !Name+  | MappedRouterSelectionCoordinationReview !Name+  | MappedProjectionHandlerReview !DerivedMappedConsumer+  | MappedProjectionRebuild !DerivedMappedConsumer !Name+  deriving stock (Eq, Ord, Show, Generic)++-- | One deterministic dependency projection over a checked 'TypeGraph'.+--+-- 'impactAggregateDeclarations' contains the union of every root declaration+-- and everything transitively reachable from it for each aggregate.+-- 'impactDeclarationConsumers' contains every service declaration, mapping an+-- intentionally unused declaration to the empty set. The service inventory is+-- declaration ownership for conformance; it is not another aggregate consumer.+data SemanticImpact = SemanticImpact+  { impactRoots :: ![MappedRoot],+    impactUsePaths :: !(Map MappedKey [UsePath]),+    impactAggregateDeclarations :: !(Map MappedConsumer (Set MappedKey)),+    impactDeclarationConsumers :: !(Map MappedKey (Set MappedConsumer)),+    impactDeclarationEvidence :: !(Map MappedKey (Set MappedRootEvidence)),+    impactDeclarationConsequences :: !(Map MappedKey (Set MappedConsequence)),+    impactServiceDeclarations :: !(Set MappedKey),+    impactDeclarationIdentities :: !(Map MappedKey Text),+    impactUnsupportedProjectionSources :: ![UnsupportedProjectionSource]+  }+  deriving stock (Eq, Show, Generic)++-- | Durable, source-independent evidence for the mapped consumer graph and+-- declaration identities. The map contains every service declaration,+-- including declarations with no aggregate consumer. The explicit service+-- inventory makes the declaration ownership boundary visible and leaves room+-- for future non-aggregate roots.+data SemanticImpactSnapshot = SemanticImpactSnapshot+  { snapshotMappedConsumers :: !(Map MappedKey (Set MappedConsumer)),+    snapshotMappedEvidence :: !(Maybe (Map MappedKey (Set MappedRootEvidence))),+    snapshotMappedConsequences :: !(Maybe (Map MappedKey (Set MappedConsequence))),+    snapshotServiceInventory :: !(Set MappedKey),+    snapshotDeclarationIdentities :: !(Map MappedKey Text)+  }+  deriving stock (Eq, Show, Generic)++-- | One declaration's before/after consumer explanation. Compatibility and+-- generated-file writes deliberately remain outside this type.+data MappedImpactDelta = MappedImpactDelta+  { impactDeclaration :: !MappedKey,+    impactPreviousConsumers :: !(Set MappedConsumer),+    impactCurrentConsumers :: !(Set MappedConsumer),+    impactPreviousEvidence :: !(Maybe (Set MappedRootEvidence)),+    impactCurrentEvidence :: !(Maybe (Set MappedRootEvidence)),+    impactPreviousConsequences :: !(Maybe (Set MappedConsequence)),+    impactCurrentConsequences :: !(Maybe (Set MappedConsequence)),+    impactServiceConformance :: !Bool+  }+  deriving stock (Eq, Show, Generic)++-- | Scaffold-facing evidence for the declarations whose mapping identities+-- changed. A missing previous snapshot means legacy history, not an empty old+-- graph; callers can still report the checked current consumers honestly.+data SemanticImpactReport = SemanticImpactReport+  { semanticReportPrevious :: !(Maybe SemanticImpactSnapshot),+    semanticReportCurrent :: !SemanticImpactSnapshot,+    semanticReportDeclarations :: ![MappedKey],+    semanticReportDeltas :: ![MappedImpactDelta]+  }+  deriving stock (Eq, Show, Generic)++-- JSON uses arrays rather than object keys so the on-disk representation does+-- not depend on aeson's map-key encoding. Parsers reject duplicate declaration+-- and consumer identities and require the two inventory projections to agree.+instance ToJSON SemanticImpactSnapshot where+  toJSON snapshot =+    object $+      [ "declarations"+          .= [ object+                 ( [ "declaration" .= unMappedKey declaration,+                     "consumers" .= map mappedConsumerIdentity (Set.toAscList declarationConsumers),+                     "identity" .= Map.findWithDefault "" declaration (snapshotDeclarationIdentities snapshot)+                   ]+                     <> maybe [] (\evidence -> ["consumerEvidence" .= Set.toAscList (Map.findWithDefault Set.empty declaration evidence)]) (snapshotMappedEvidence snapshot)+                     <> maybe [] (\consequences -> ["consequences" .= Set.toAscList (Map.findWithDefault Set.empty declaration consequences)]) (snapshotMappedConsequences snapshot)+                 )+             | (declaration, declarationConsumers) <- Map.toAscList (snapshotMappedConsumers snapshot)+             ],+        "serviceInventory" .= map unMappedKey (Set.toAscList (snapshotServiceInventory snapshot))+      ]+        <> [ "mappedSurfaceEvidenceVersion" .= (1 :: Int)+           | isJust (snapshotMappedEvidence snapshot)+               || isJust (snapshotMappedConsequences snapshot)+           ]++instance FromJSON SemanticImpactSnapshot where+  parseJSON = withObject "SemanticImpactSnapshot" $ \fields -> do+    declarations <- fields .: "declarations" >>= traverse parseDeclaration+    inventoryNames <- fields .: "serviceInventory"+    surfaceEvidenceVersion <- (fields .:? "mappedSurfaceEvidenceVersion" :: Parser (Maybe Int))+    let declarationNames = [declaration | (declaration, _, _, _, _) <- declarations]+        inventoryKeys = map MappedKey inventoryNames+        declarationMap = Map.fromList [(declaration, declarationConsumers) | (declaration, declarationConsumers, _, _, _) <- declarations]+        declarationIdentities = Map.fromList [(declaration, identity) | (declaration, _, identity, _, _) <- declarations]+        evidenceRows = [(declaration, value) | (declaration, _, _, value, _) <- declarations]+        consequenceRows = [(declaration, value) | (declaration, _, _, _, value) <- declarations]+        inventory = Set.fromList inventoryKeys+    unless (distinct declarationNames) (fail "duplicate semantic-impact declaration")+    unless (distinct inventoryKeys) (fail "duplicate semantic-impact service inventory declaration")+    unless (Map.keysSet declarationMap == inventory) (fail "semantic-impact declarations and service inventory differ")+    unless (Map.keysSet declarationIdentities == inventory) (fail "semantic-impact declaration identities and service inventory differ")+    parsedEvidence <- completeOptionalRows "consumer evidence" evidenceRows+    parsedConsequences <- completeOptionalRows "consequences" consequenceRows+    (evidence, consequences) <- case surfaceEvidenceVersion of+      Nothing -> do+        unless (isJust parsedEvidence == isJust parsedConsequences) (fail "semantic-impact root evidence and consequences must be present together")+        pure (parsedEvidence, parsedConsequences)+      Just 1 -> do+        currentEvidence <- requireCurrentRows "consumer evidence" parsedEvidence declarationMap+        currentConsequences <- requireCurrentRows "consequences" parsedConsequences declarationMap+        pure (Just currentEvidence, Just currentConsequences)+      Just version -> fail ("unsupported semantic-impact mappedSurfaceEvidenceVersion: " <> show version)+    unless (maybe True (evidenceAgrees declarationMap) evidence) (fail "semantic-impact consumer evidence and consumer inventory differ")+    unless (maybe True (consequencesAgree declarationMap) consequences) (fail "semantic-impact consequences and consumer inventory differ")+    pure+      SemanticImpactSnapshot+        { snapshotMappedConsumers = declarationMap,+          snapshotMappedEvidence = evidence,+          snapshotMappedConsequences = consequences,+          snapshotServiceInventory = inventory,+          snapshotDeclarationIdentities = declarationIdentities+        }+    where+      parseDeclaration = withObject "SemanticImpactDeclaration" $ \row -> do+        declarationName <- row .: "declaration"+        consumerNames <- row .: "consumers"+        identity <- row .: "identity"+        evidence <- row .:? "consumerEvidence"+        consequences <- row .:? "consequences"+        consumers <- traverse parseConsumerName consumerNames+        unless (distinct consumers) (fail "duplicate semantic-impact consumer")+        maybe (pure ()) (\values -> unless (distinct values) (fail "duplicate semantic-impact consumer evidence")) evidence+        maybe (pure ()) (\values -> unless (distinct values) (fail "duplicate semantic-impact consequence")) consequences+        unless (not (T.null identity)) (fail "empty semantic-impact declaration identity")+        pure (MappedKey declarationName, Set.fromList consumers, identity, Set.fromList <$> evidence, Set.fromList <$> consequences)+      distinct values = length values == Set.size (Set.fromList values)+      evidenceAgrees consumers evidence =+        and+          [ Set.map evidenceConsumer (Map.findWithDefault Set.empty declaration evidence) == declarationConsumers+              && all operationAgrees (Set.toList (Map.findWithDefault Set.empty declaration evidence))+          | (declaration, declarationConsumers) <- Map.toList consumers+          ]+      operationAgrees evidence = case evidenceRootKind evidence of+        MappedProjectionEventRoot -> maybe False (not . T.null) (evidenceOperation evidence)+        _ -> evidenceOperation evidence == Nothing+      consequencesAgree consumers consequences =+        and+          [ Set.fromList+              [ consumer+              | MappedConsumerBuild consumer <- Set.toList (Map.findWithDefault Set.empty declaration consequences)+              ]+              == declarationConsumers+          | (declaration, declarationConsumers) <- Map.toList consumers+          ]+      completeOptionalRows label rows+        | all (maybe True (const False) . snd) rows = pure Nothing+        | all (maybe False (const True) . snd) rows = pure (Just (Map.fromList [(key, value) | (key, Just value) <- rows]))+        | otherwise = fail ("semantic-impact " <> label <> " is present for only part of the service inventory")+      requireCurrentRows label rows declarations+        | Map.null declarations = pure (maybe Map.empty id rows)+        | otherwise = maybe (fail ("semantic-impact " <> label <> " is absent from a versioned current snapshot")) pure rows++instance ToJSON MappedRootEvidence where+  toJSON evidence =+    object+      [ "consumer" .= mappedConsumerIdentity (evidenceConsumer evidence),+        "surface" .= mappedRootKindIdentity (evidenceRootKind evidence),+        "path" .= evidencePath evidence,+        "operation" .= evidenceOperation evidence+      ]++instance FromJSON MappedRootEvidence where+  parseJSON = withObject "MappedRootEvidence" $ \fields ->+    MappedRootEvidence+      <$> (fields .: "consumer" >>= parseConsumerName)+      <*> (fields .: "surface" >>= parseMappedRootKind)+      <*> fields .: "path"+      <*> fields .:? "operation"++instance ToJSON MappedConsequence where+  toJSON consequence = case consequence of+    MappedConsumerBuild consumer -> object ["kind" .= ("consumer-build" :: Text), "consumer" .= mappedConsumerIdentity consumer]+    MappedPrivateEventHistory aggregate -> object ["kind" .= ("private-event-history" :: Text), "aggregate" .= aggregate]+    MappedSnapshotHydration aggregate -> object ["kind" .= ("snapshot-hydration" :: Text), "aggregate" .= aggregate]+    MappedWorkqueueHistory workqueue -> object ["kind" .= ("workqueue-history" :: Text), "workqueue" .= workqueue]+    MappedQueryApi readModel position -> object ["kind" .= ("query-api" :: Text), "readModel" .= readModel, "position" .= mappedQueryPositionIdentity position]+    MappedRouterSelectionBuild router -> object ["kind" .= ("router-selection-build" :: Text), "router" .= router]+    MappedRouterSelectionCoordinationReview router -> object ["kind" .= ("router-selection-coordination-review" :: Text), "router" .= router]+    MappedProjectionHandlerReview consumer -> object ["kind" .= ("projection-handler-review" :: Text), "consumer" .= mappedConsumerIdentity (DerivedProjectionConsumer consumer)]+    MappedProjectionRebuild consumer groupName -> object ["kind" .= ("projection-rebuild" :: Text), "consumer" .= mappedConsumerIdentity (DerivedProjectionConsumer consumer), "group" .= groupName]++instance FromJSON MappedConsequence where+  parseJSON = withObject "MappedConsequence" $ \fields -> do+    kind <- fields .: "kind"+    case (kind :: Text) of+      "consumer-build" -> MappedConsumerBuild <$> (fields .: "consumer" >>= parseConsumerName)+      "private-event-history" -> MappedPrivateEventHistory <$> fields .: "aggregate"+      "snapshot-hydration" -> MappedSnapshotHydration <$> fields .: "aggregate"+      "workqueue-history" -> MappedWorkqueueHistory <$> fields .: "workqueue"+      "query-api" -> MappedQueryApi <$> fields .: "readModel" <*> (fields .: "position" >>= parseMappedQueryPosition)+      "router-selection-build" -> MappedRouterSelectionBuild <$> fields .: "router"+      "router-selection-coordination-review" -> MappedRouterSelectionCoordinationReview <$> fields .: "router"+      "projection-handler-review" -> MappedProjectionHandlerReview <$> (fields .: "consumer" >>= parseDerivedConsumer)+      "projection-rebuild" -> MappedProjectionRebuild <$> (fields .: "consumer" >>= parseDerivedConsumer) <*> fields .: "group"+      _ -> fail "unknown semantic-impact consequence kind"++instance ToJSON MappedImpactDelta where+  toJSON delta =+    object+      [ "declaration" .= unMappedKey (impactDeclaration delta),+        "previousConsumers" .= map mappedConsumerIdentity (Set.toAscList (impactPreviousConsumers delta)),+        "currentConsumers" .= map mappedConsumerIdentity (Set.toAscList (impactCurrentConsumers delta)),+        "previousConsumerEvidence" .= fmap Set.toAscList (impactPreviousEvidence delta),+        "currentConsumerEvidence" .= fmap Set.toAscList (impactCurrentEvidence delta),+        "previousConsequences" .= fmap Set.toAscList (impactPreviousConsequences delta),+        "currentConsequences" .= fmap Set.toAscList (impactCurrentConsequences delta),+        "serviceConformance" .= impactServiceConformance delta+      ]++instance FromJSON MappedImpactDelta where+  parseJSON = withObject "MappedImpactDelta" $ \fields -> do+    declaration <- MappedKey <$> fields .: "declaration"+    previousNames <- fields .: "previousConsumers"+    currentNames <- fields .: "currentConsumers"+    previousEvidence <- fields .:? "previousConsumerEvidence"+    currentEvidence <- fields .:? "currentConsumerEvidence"+    previousConsequences <- fields .:? "previousConsequences"+    currentConsequences <- fields .:? "currentConsequences"+    serviceConformance <- fields .: "serviceConformance"+    previous <- traverse parseConsumerName previousNames+    current <- traverse parseConsumerName currentNames+    unless (distinct previous) (fail "duplicate previous semantic-impact consumer")+    unless (distinct current) (fail "duplicate current semantic-impact consumer")+    pure+      MappedImpactDelta+        { impactDeclaration = declaration,+          impactPreviousConsumers = Set.fromList previous,+          impactCurrentConsumers = Set.fromList current,+          impactPreviousEvidence = Set.fromList <$> previousEvidence,+          impactCurrentEvidence = Set.fromList <$> currentEvidence,+          impactPreviousConsequences = Set.fromList <$> previousConsequences,+          impactCurrentConsequences = Set.fromList <$> currentConsequences,+          impactServiceConformance = serviceConformance+        }+    where+      distinct values = length values == Set.size (Set.fromList values)++-- | Derive the single mapped-consumer dependency model from a checked graph.+-- Lists and query projections are sorted so source declaration and aggregate+-- order cannot affect the result.+semanticImpact :: TypeGraph -> SemanticImpact+semanticImpact graph =+  SemanticImpact+    { impactRoots = roots,+      impactUsePaths = pathsByDeclaration,+      impactAggregateDeclarations = aggregateDeclarations,+      impactDeclarationConsumers = declarationConsumers,+      impactDeclarationEvidence = declarationEvidence,+      impactDeclarationConsequences = Map.map (Set.unions . map consequencesForEvidence . Set.toAscList) declarationEvidence,+      impactServiceDeclarations = serviceDeclarations,+      impactDeclarationIdentities = Map.mapWithKey (declarationIdentity graph) (tgDeclarations graph),+      impactUnsupportedProjectionSources = tgUnsupportedProjectionSources graph+    }+  where+    directRoots = map mappedRootFromUseSite (tgUseSites graph)+    roots = sort (directRoots <> concatMap derivedRoots (tgDerivedMappedConsumers graph))+    derivedRoots consumer =+      [ MappedRoot+          { mappedRootConsumer = DerivedProjectionConsumer consumer,+            mappedRootKind = MappedProjectionEventRoot,+            mappedRootUseSite = site,+            mappedRootDeclaration = declaration+          }+      | site@(RootEventField aggregate _ _ declaration) <- tgUseSites graph,+        aggregate == derivedAuthority consumer+      ]+    aggregateDeclarations =+      Map.fromListWith+        Set.union+        [ (mappedRootConsumer root, declarationClosure graph (mappedRootDeclaration root))+        | root <- roots+        ]+    serviceDeclarations = Map.keysSet (tgDeclarations graph)+    pathsByDeclaration = Map.fromSet (sort . usePaths graph . unMappedKey) serviceDeclarations+    declarationConsumers =+      Map.unionWith+        Set.union+        (Map.fromSet (const Set.empty) serviceDeclarations)+        ( Map.fromListWith+            Set.union+            [ (declaration, Set.singleton consumer)+            | (consumer, declarations) <- Map.toList aggregateDeclarations,+              declaration <- Set.toList declarations+            ]+        )+    declarationEvidence =+      Map.mapWithKey+        (\_ paths -> Set.fromList (concatMap evidenceForPath paths))+        pathsByDeclaration+    evidenceForPath usePath =+      let directRoot = mappedRootFromUseSite (upRoot usePath)+          direct =+            MappedRootEvidence+              { evidenceConsumer = mappedRootConsumer directRoot,+                evidenceRootKind = mappedRootKind directRoot,+                evidencePath = renderUsePath usePath,+                evidenceOperation = Nothing+              }+          projections =+            [ MappedRootEvidence+                { evidenceConsumer = DerivedProjectionConsumer derived,+                  evidenceRootKind = MappedProjectionEventRoot,+                  evidencePath = renderUsePath usePath,+                  evidenceOperation = Map.lookup derived (tgProjectionOperationalIdentities graph)+                }+            | aggregate <- maybeToList (eventAuthority usePath),+              derived <- tgDerivedMappedConsumers graph,+              derivedAuthority derived == aggregate+            ]+       in direct : projections+    consequencesForEvidence = consequencesForMappedEvidence graph++-- | Add the checked declarative selection consumers to the ordinary type-graph+-- projection. The parser AST is intentionally absent: every expression path and+-- query root comes from 'CheckedRouterSelection'.+semanticImpactForService :: CheckedService -> TypeGraph -> SemanticImpact+semanticImpactForService service graph =+  base+    { impactRoots = sort (impactRoots base <> map selectionEvidenceRoot extraEvidence),+      impactAggregateDeclarations = Map.unionWith Set.union (impactAggregateDeclarations base) declarationsByConsumer,+      impactDeclarationConsumers = Map.unionWith Set.union (impactDeclarationConsumers base) consumersByDeclaration,+      impactDeclarationEvidence = Map.unionWith Set.union (impactDeclarationEvidence base) evidenceByDeclaration,+      impactDeclarationConsequences = Map.unionWith Set.union (impactDeclarationConsequences base) consequencesByDeclaration+    }+  where+    base = semanticImpact graph+    extraEvidence = concatMap checkedRouterEvidence checkedSelections+    checkedSelections =+      [ (rtId router, checked)+      | NRouter router <- specNodes (checkedSpec service),+        ResolveDeclarative {} <- [rvSource (rtResolve router)],+        let checked = case checkRouterSelection (checkedLanguageContract service) graph (checkedSpec service) router of+              Right value -> value+              Left failures -> error ("validated declarative router selection did not check: " <> show failures)+      ]+    declarationsByConsumer =+      Map.fromListWith+        Set.union+        [ (mappedRootConsumer root, declarationClosure graph (mappedRootDeclaration root))+        | SelectionEvidence root _ <- extraEvidence+        ]+    consumersByDeclaration =+      Map.fromListWith+        Set.union+        [ (declaration, Set.singleton (mappedRootConsumer root))+        | SelectionEvidence root _ <- extraEvidence,+          declaration <- Set.toList (declarationClosure graph (mappedRootDeclaration root))+        ]+    evidenceByDeclaration =+      Map.fromListWith+        Set.union+        [ ( declaration,+            Set.singleton+              MappedRootEvidence+                { evidenceConsumer = mappedRootConsumer root,+                  evidenceRootKind = mappedRootKind root,+                  evidencePath = path,+                  evidenceOperation = Nothing+                }+          )+        | SelectionEvidence root path <- extraEvidence,+          declaration <- Set.toList (declarationClosure graph (mappedRootDeclaration root))+        ]+    consequencesByDeclaration =+      Map.map+        (Set.unions . map (consequencesForMappedEvidence graph) . Set.toAscList)+        evidenceByDeclaration++data SelectionEvidence = SelectionEvidence+  { selectionEvidenceRoot :: !MappedRoot,+    selectionEvidencePath :: !Text+  }++checkedRouterEvidence :: (Name, CheckedRouterSelection) -> [SelectionEvidence]+checkedRouterEvidence (router, selection) = queryInputEvidence <> expressionEvidence+  where+    queryInputEvidence =+      [ selectionEvidence router SelectionQueryInput MappedRouterSelectionQueryInputRoot site ("router " <> router <> " selection query input")+      | site@RootReadModelQueryInput {} <- checkedUseSites selection+      ]+    expressionEvidence =+      checkedExpressionEvidence router selection SelectionPredicate MappedRouterSelectionPredicateRoot "predicate" (checkedPredicate selection)+        <> checkedExpressionEvidence router selection SelectionRecipient MappedRouterSelectionRecipientRoot "recipient" (checkedRecipient selection)+        <> concat+          [ checkedExpressionEvidence router selection (SelectionCommandField field) MappedRouterSelectionCommandFieldRoot ("command field " <> field) expression+          | (field, expression) <- Map.toAscList (checkedCommandFields selection)+          ]++checkedExpressionEvidence :: Name -> CheckedRouterSelection -> RouterSelectionPosition -> MappedRootKind -> Text -> CheckedScalarExpr -> [SelectionEvidence]+checkedExpressionEvidence router selection position rootKind label expression =+  [ selectionEvidence router position rootKind site ("router " <> router <> " selection " <> label <> " " <> renderCheckedPath root segments)+  | (root, segments@(_ : _)) <- checkedScalarPaths expression,+    site <- selectionRootSites root selection+  ]++selectionEvidence :: Name -> RouterSelectionPosition -> MappedRootKind -> UseSite -> Text -> SelectionEvidence+selectionEvidence router position rootKind site path =+  SelectionEvidence+    { selectionEvidenceRoot =+        MappedRoot+          { mappedRootConsumer = RouterSelectionConsumer router position,+            mappedRootKind = rootKind,+            mappedRootUseSite = site,+            mappedRootDeclaration = useSiteDeclaration site+          },+      selectionEvidencePath = path+    }++selectionRootSites :: SelectionRoot -> CheckedRouterSelection -> [UseSite]+selectionRootSites root selection =+  [ site+  | site <- checkedUseSites selection,+    case (root, site) of+      (SelectionInput, RootReadModelQueryInput {}) -> True+      (SelectionRow, RootReadModelQueryResult {}) -> True+      _ -> False+  ]++checkedScalarPaths :: CheckedScalarExpr -> [(SelectionRoot, [CheckedSelectionPathSegment])]+checkedScalarPaths expression = case checkedScalarNode expression of+  CheckedPath root segments -> [(root, segments)]+  CheckedTextLiteral _ -> []+  CheckedIntegralLiteral _ -> []+  CheckedBoolLiteral _ -> []+  CheckedCompare _ left right -> checkedScalarPaths left <> checkedScalarPaths right+  CheckedAnd left right -> checkedScalarPaths left <> checkedScalarPaths right+  CheckedOr left right -> checkedScalarPaths left <> checkedScalarPaths right++renderCheckedPath :: SelectionRoot -> [CheckedSelectionPathSegment] -> Text+renderCheckedPath root segments =+  rootLabel <> T.concat ["." <> checkedPathField segment <> wireLabel segment | segment <- segments]+  where+    rootLabel = case root of SelectionInput -> "input"; SelectionRow -> "row"+    wireLabel segment+      | checkedPathField segment == checkedPathWireKey segment = ""+      | otherwise = " as '" <> checkedPathWireKey segment <> "'"++useSiteDeclaration :: UseSite -> MappedKey+useSiteDeclaration = \case+  RootCommandField _ _ _ declaration -> declaration+  RootEventField _ _ _ declaration -> declaration+  RootRegister _ _ declaration -> declaration+  RootWorkqueueField _ _ declaration -> declaration+  RootReadModelQueryInput _ declaration -> declaration+  RootReadModelQueryResult _ declaration -> declaration++consequencesForMappedEvidence :: TypeGraph -> MappedRootEvidence -> Set MappedConsequence+consequencesForMappedEvidence graph evidence =+  Set.fromList (MappedConsumerBuild (evidenceConsumer evidence) : surfaceConsequences)+  where+    surfaceConsequences = case evidenceRootKind evidence of+      MappedCommandFieldRoot -> []+      MappedEventFieldRoot -> case evidenceConsumer evidence of+        AggregateConsumer aggregate -> [MappedPrivateEventHistory aggregate]+        _ -> []+      MappedRegisterRoot -> case evidenceConsumer evidence of+        AggregateConsumer aggregate -> [MappedSnapshotHydration aggregate]+        _ -> []+      MappedWorkqueueFieldRoot -> case evidenceConsumer evidence of+        WorkqueueConsumer workqueue -> [MappedWorkqueueHistory workqueue]+        _ -> []+      MappedReadModelQueryInputRoot -> case evidenceConsumer evidence of+        ReadModelQueryConsumer readModel MappedQueryInput -> [MappedQueryApi readModel MappedQueryInput]+        _ -> []+      MappedReadModelQueryResultRoot -> case evidenceConsumer evidence of+        ReadModelQueryConsumer readModel MappedQueryResult -> [MappedQueryApi readModel MappedQueryResult]+        _ -> []+      MappedRouterSelectionQueryInputRoot -> selectionConsequences+      MappedRouterSelectionPredicateRoot -> selectionConsequences+      MappedRouterSelectionRecipientRoot -> selectionConsequences+      MappedRouterSelectionCommandFieldRoot -> selectionConsequences+      MappedProjectionEventRoot -> case evidenceConsumer evidence of+        DerivedProjectionConsumer derived ->+          MappedProjectionHandlerReview derived+            : [MappedProjectionRebuild derived groupName | groupName <- maybeToList (Map.lookup derived (tgReplayableProjectionGroups graph))]+        _ -> []+    selectionConsequences = case evidenceConsumer evidence of+      RouterSelectionConsumer router _ -> [MappedRouterSelectionBuild router, MappedRouterSelectionCoordinationReview router]+      _ -> []++-- | Freeze the checked dependency projection in canonical map/set form.+semanticImpactSnapshot :: SemanticImpact -> SemanticImpactSnapshot+semanticImpactSnapshot impact =+  SemanticImpactSnapshot+    { snapshotMappedConsumers = impactDeclarationConsumers impact,+      snapshotMappedEvidence = Just (impactDeclarationEvidence impact),+      snapshotMappedConsequences = Just (impactDeclarationConsequences impact),+      snapshotServiceInventory = impactServiceDeclarations impact,+      snapshotDeclarationIdentities = impactDeclarationIdentities impact+    }++-- | Compare consumer membership, service-inventory membership, and canonical+-- source-independent declaration identities.+diffSemanticImpact :: SemanticImpactSnapshot -> SemanticImpactSnapshot -> [MappedImpactDelta]+diffSemanticImpact previous current =+  [ delta+  | delta <- mappedImpactForDeclarations allDeclarations previous current,+    impactPreviousConsumers delta /= impactCurrentConsumers delta+      || impactPreviousEvidence delta /= impactCurrentEvidence delta+      || impactPreviousConsequences delta /= impactCurrentConsequences delta+      || serviceMember previous (impactDeclaration delta) /= serviceMember current (impactDeclaration delta)+      || declarationIdentityAt previous (impactDeclaration delta) /= declarationIdentityAt current (impactDeclaration delta)+  ]+  where+    allDeclarations = Set.toAscList (snapshotServiceInventory previous <> snapshotServiceInventory current)++-- | Explain an authoritative set of changed mapped declarations. Keys are+-- sorted and deduplicated; a key absent from both inventories is ignored.+mappedImpactForDeclarations :: [MappedKey] -> SemanticImpactSnapshot -> SemanticImpactSnapshot -> [MappedImpactDelta]+mappedImpactForDeclarations declarations previous current =+  [ MappedImpactDelta+      { impactDeclaration = declaration,+        impactPreviousConsumers = snapshotConsumers previous declaration,+        impactCurrentConsumers = snapshotConsumers current declaration,+        impactPreviousEvidence = snapshotEvidence previous declaration,+        impactCurrentEvidence = snapshotEvidence current declaration,+        impactPreviousConsequences = snapshotConsequences previous declaration,+        impactCurrentConsequences = snapshotConsequences current declaration,+        impactServiceConformance = serviceMember previous declaration || serviceMember current declaration+      }+  | declaration <- Set.toAscList (Set.fromList declarations),+    serviceMember previous declaration || serviceMember current declaration+  ]++-- | Build the typed scaffold explanation. With legacy history the delta list+-- stays empty because the missing old row is unknown rather than empty.+semanticImpactReport :: Maybe SemanticImpactSnapshot -> SemanticImpactSnapshot -> [MappedKey] -> SemanticImpactReport+semanticImpactReport previous current declarations =+  SemanticImpactReport+    { semanticReportPrevious = previous,+      semanticReportCurrent = current,+      semanticReportDeclarations = canonicalDeclarations,+      semanticReportDeltas = maybe [] (\old -> mappedImpactForDeclarations canonicalDeclarations old current) previous+    }+  where+    canonicalDeclarations = Set.toAscList (Set.fromList declarations)++snapshotConsumers :: SemanticImpactSnapshot -> MappedKey -> Set MappedConsumer+snapshotConsumers snapshot declaration = Map.findWithDefault Set.empty declaration (snapshotMappedConsumers snapshot)++snapshotEvidence :: SemanticImpactSnapshot -> MappedKey -> Maybe (Set MappedRootEvidence)+snapshotEvidence snapshot declaration = (Map.findWithDefault Set.empty declaration) <$> snapshotMappedEvidence snapshot++snapshotConsequences :: SemanticImpactSnapshot -> MappedKey -> Maybe (Set MappedConsequence)+snapshotConsequences snapshot declaration = (Map.findWithDefault Set.empty declaration) <$> snapshotMappedConsequences snapshot++serviceMember :: SemanticImpactSnapshot -> MappedKey -> Bool+serviceMember snapshot declaration = declaration `Set.member` snapshotServiceInventory snapshot++declarationIdentityAt :: SemanticImpactSnapshot -> MappedKey -> Maybe Text+declarationIdentityAt snapshot declaration = Map.lookup declaration (snapshotDeclarationIdentities snapshot)++-- | Canonical identity for mapped declaration facts that 'MappedDiff' treats+-- as changes. Source locations and declaration order are deliberately absent.+declarationIdentity :: TypeGraph -> MappedKey -> ResolvedMappedDecl -> Text+declarationIdentity graph key declaration =+  T.intercalate "\x1f" $ case declaration of+    ResolvedStructural structural shape -> structuralParts structural shape+    ResolvedOpaque opaque -> opaqueParts opaque+  where+    structuralParts structural shape =+      [ "structural",+        sourceIdentity (sdHaskell structural),+        unQualifiedValueName (sdBinding structural),+        unBindingVersion (sdBindingVersion structural),+        unCanonicalTypeId (sdCanonical structural),+        unQualifiedValueName (sdFixtures structural),+        maybe "" unQualifiedValueName (sdInitial structural),+        wireFingerprint graph (unMappedKey key),+        structuralPresentation shape+      ]+    opaqueParts opaque =+      [ "opaque",+        sourceIdentity (odHaskell opaque),+        unCodecIdentity (odCodecIdentity opaque),+        unCodecVersion (odCodecVersion opaque),+        unQualifiedValueName (odFixtures opaque),+        maybe "" unQualifiedValueName (odInitial opaque),+        wireFingerprint graph (unMappedKey key)+      ]+    sourceIdentity source = T.intercalate ":" [hsPackage source, hsModule source, hsType source]+    structuralPresentation (RRecord constructor _ fields) =+      "record:" <> constructor <> ":" <> T.intercalate "," [rwfHaskell field <> "=" <> rwfKey field | field <- sortOn rwfKey fields]+    structuralPresentation (REnum entries) =+      "enum:" <> T.intercalate "," [weCtor entry <> "=" <> weTag entry | entry <- sortOn weTag entries]+    structuralPresentation (RUnion _ arms) =+      "union:" <> T.intercalate "," [rwaTag arm | arm <- sortOn rwaTag arms]++mappedConsumerIdentity :: MappedConsumer -> Name+mappedConsumerIdentity (AggregateConsumer aggregate) = aggregate+mappedConsumerIdentity (WorkqueueConsumer workqueue) = "workqueue:" <> workqueue+mappedConsumerIdentity (ReadModelQueryConsumer readModel position) =+  "read-model-query:" <> readModel <> ":" <> mappedQueryPositionIdentity position+mappedConsumerIdentity (RouterSelectionConsumer router position) =+  "router-selection:" <> router <> ":" <> routerSelectionPositionIdentity position+mappedConsumerIdentity (DerivedProjectionConsumer (AggregateInlineProjectionConsumer aggregate projection)) =+  "aggregate-projection:" <> aggregate <> ":" <> projection+mappedConsumerIdentity (DerivedProjectionConsumer (CatalogProjectionConsumer owner aggregate)) =+  "catalog-projection:" <> owner <> ":" <> aggregate++parseConsumerName :: (MonadFail m) => Text -> m MappedConsumer+parseConsumerName raw = case T.splitOn ":" raw of+  ["workqueue", workqueue] -> pure (WorkqueueConsumer workqueue)+  ["read-model", readModel] -> pure (ReadModelQueryConsumer readModel MappedQueryInput)+  ["read-model-query", readModel, position] -> ReadModelQueryConsumer readModel <$> parseMappedQueryPosition position+  ["router-selection", router, "query-input"] -> pure (RouterSelectionConsumer router SelectionQueryInput)+  ["router-selection", router, "predicate"] -> pure (RouterSelectionConsumer router SelectionPredicate)+  ["router-selection", router, "recipient"] -> pure (RouterSelectionConsumer router SelectionRecipient)+  ["router-selection", router, "command-field", field] -> pure (RouterSelectionConsumer router (SelectionCommandField field))+  ["aggregate-projection", aggregate, projection] ->+    pure (DerivedProjectionConsumer (AggregateInlineProjectionConsumer aggregate projection))+  ["catalog-projection", owner, aggregate] ->+    pure (DerivedProjectionConsumer (CatalogProjectionConsumer owner aggregate))+  [_] -> pure (AggregateConsumer raw)+  _ -> fail "invalid semantic-impact consumer identity"++parseDerivedConsumer :: (MonadFail m) => Text -> m DerivedMappedConsumer+parseDerivedConsumer raw = do+  consumer <- parseConsumerName raw+  case consumer of+    DerivedProjectionConsumer derived -> pure derived+    _ -> fail "semantic-impact projection consequence names a non-projection consumer"++mappedQueryPositionIdentity :: MappedQueryPosition -> Text+mappedQueryPositionIdentity MappedQueryInput = "input"+mappedQueryPositionIdentity MappedQueryResult = "result"++parseMappedQueryPosition :: (MonadFail m) => Text -> m MappedQueryPosition+parseMappedQueryPosition "input" = pure MappedQueryInput+parseMappedQueryPosition "result" = pure MappedQueryResult+parseMappedQueryPosition _ = fail "unknown semantic-impact read-model query position"++routerSelectionPositionIdentity :: RouterSelectionPosition -> Text+routerSelectionPositionIdentity SelectionQueryInput = "query-input"+routerSelectionPositionIdentity SelectionPredicate = "predicate"+routerSelectionPositionIdentity SelectionRecipient = "recipient"+routerSelectionPositionIdentity (SelectionCommandField field) = "command-field:" <> field++mappedRootKindIdentity :: MappedRootKind -> Text+mappedRootKindIdentity MappedCommandFieldRoot = "aggregate-command"+mappedRootKindIdentity MappedEventFieldRoot = "private-event-payload"+mappedRootKindIdentity MappedRegisterRoot = "snapshot-register"+mappedRootKindIdentity MappedWorkqueueFieldRoot = "workqueue-payload"+mappedRootKindIdentity MappedReadModelQueryInputRoot = "read-model-query-input"+mappedRootKindIdentity MappedReadModelQueryResultRoot = "read-model-query-result"+mappedRootKindIdentity MappedRouterSelectionQueryInputRoot = "router-selection-query-input"+mappedRootKindIdentity MappedRouterSelectionPredicateRoot = "router-selection-predicate"+mappedRootKindIdentity MappedRouterSelectionRecipientRoot = "router-selection-recipient"+mappedRootKindIdentity MappedRouterSelectionCommandFieldRoot = "router-selection-command-field"+mappedRootKindIdentity MappedProjectionEventRoot = "projection-event-consumer"++parseMappedRootKind :: (MonadFail m) => Text -> m MappedRootKind+parseMappedRootKind "aggregate-command" = pure MappedCommandFieldRoot+parseMappedRootKind "private-event-payload" = pure MappedEventFieldRoot+parseMappedRootKind "snapshot-register" = pure MappedRegisterRoot+parseMappedRootKind "workqueue-payload" = pure MappedWorkqueueFieldRoot+parseMappedRootKind "read-model-query-input" = pure MappedReadModelQueryInputRoot+parseMappedRootKind "read-model-query-result" = pure MappedReadModelQueryResultRoot+parseMappedRootKind "router-selection-query-input" = pure MappedRouterSelectionQueryInputRoot+parseMappedRootKind "router-selection-predicate" = pure MappedRouterSelectionPredicateRoot+parseMappedRootKind "router-selection-recipient" = pure MappedRouterSelectionRecipientRoot+parseMappedRootKind "router-selection-command-field" = pure MappedRouterSelectionCommandFieldRoot+parseMappedRootKind "projection-event-consumer" = pure MappedProjectionEventRoot+parseMappedRootKind _ = fail "unknown semantic-impact root surface"++mappedConsequenceIdentity :: MappedConsequence -> Text+mappedConsequenceIdentity consequence = case consequence of+  MappedConsumerBuild consumer -> "consumer-build:" <> mappedConsumerIdentity consumer+  MappedPrivateEventHistory aggregate -> "private-event-history:" <> aggregate+  MappedSnapshotHydration aggregate -> "snapshot-hydration:" <> aggregate+  MappedWorkqueueHistory workqueue -> "workqueue-history:" <> workqueue+  MappedQueryApi readModel position -> "query-api:" <> readModel <> ":" <> mappedQueryPositionIdentity position+  MappedRouterSelectionBuild router -> "router-selection-build:" <> router+  MappedRouterSelectionCoordinationReview router -> "router-selection-coordination-review:" <> router+  MappedProjectionHandlerReview consumer -> "projection-handler-review:" <> mappedConsumerIdentity (DerivedProjectionConsumer consumer)+  MappedProjectionRebuild consumer groupName -> "projection-rebuild:" <> mappedConsumerIdentity (DerivedProjectionConsumer consumer) <> ":" <> groupName++-- | Stable expected-fact inventory for the generated service facade. The key+-- contains the surface, typed consumer, declaration, and complete mapped path;+-- the value carries the consequence set, so stale or misattributed evidence is+-- rejected by the existing exact-set conformance package comparison.+mappedSurfaceFactValues :: SemanticImpact -> [(Text, Text)]+mappedSurfaceFactValues impact =+  [ ( T.intercalate+        "/"+        [ "mapped-surface",+          mappedRootKindIdentity (evidenceRootKind evidence),+          mappedConsumerIdentity (evidenceConsumer evidence),+          unMappedKey declaration,+          evidencePath evidence+        ],+      T.intercalate "," (map mappedConsequenceIdentity (Set.toAscList consequences))+        <> maybe "" (";projection-operation:" <>) (evidenceOperation evidence)+    )+  | (declaration, evidenceValues) <- Map.toAscList (impactDeclarationEvidence impact),+    evidence <- Set.toAscList evidenceValues,+    let consequences = Map.findWithDefault Set.empty declaration (impactDeclarationConsequences impact)+  ]++derivedAuthority :: DerivedMappedConsumer -> Name+derivedAuthority (AggregateInlineProjectionConsumer aggregate _) = aggregate+derivedAuthority (CatalogProjectionConsumer _ aggregate) = aggregate++-- | Return the checked roots owned by one aggregate in stable order.+aggregateMappedRoots :: SemanticImpact -> Name -> [MappedRoot]+aggregateMappedRoots impact aggregate =+  [ root+  | root <- impactRoots impact,+    mappedRootConsumer root == AggregateConsumer aggregate+  ]++-- | Return one aggregate's transitive mapped declaration closure in stable+-- declaration-key order.+aggregateMappedClosure :: SemanticImpact -> Name -> [MappedKey]+aggregateMappedClosure impact aggregate =+  maybe [] Set.toAscList (Map.lookup (AggregateConsumer aggregate) (impactAggregateDeclarations impact))++-- | Return every aggregate that can consume a declaration in stable order.+-- Unknown and intentionally unused declarations both have no consumers; use+-- 'serviceMappedInventory' to distinguish whether a declaration exists.+mappedDeclarationConsumers :: SemanticImpact -> MappedKey -> [MappedConsumer]+mappedDeclarationConsumers impact declaration =+  maybe [] Set.toAscList (Map.lookup declaration (impactDeclarationConsumers impact))++-- | Return every checked declaration, including declarations with no current+-- aggregate consumer, in stable order.+serviceMappedInventory :: SemanticImpact -> [MappedKey]+serviceMappedInventory = Set.toAscList . impactServiceDeclarations++declarationClosure :: TypeGraph -> MappedKey -> Set MappedKey+declarationClosure graph root =+  Set.insert root (Map.findWithDefault Set.empty root (tgReachability graph))++mappedRootFromUseSite :: UseSite -> MappedRoot+mappedRootFromUseSite site@(RootCommandField aggregate _ _ declaration) =+  MappedRoot+    { mappedRootConsumer = AggregateConsumer aggregate,+      mappedRootKind = MappedCommandFieldRoot,+      mappedRootUseSite = site,+      mappedRootDeclaration = declaration+    }+mappedRootFromUseSite site@(RootEventField aggregate _ _ declaration) =+  MappedRoot+    { mappedRootConsumer = AggregateConsumer aggregate,+      mappedRootKind = MappedEventFieldRoot,+      mappedRootUseSite = site,+      mappedRootDeclaration = declaration+    }+mappedRootFromUseSite site@(RootRegister aggregate _ declaration) =+  MappedRoot+    { mappedRootConsumer = AggregateConsumer aggregate,+      mappedRootKind = MappedRegisterRoot,+      mappedRootUseSite = site,+      mappedRootDeclaration = declaration+    }+mappedRootFromUseSite site@(RootWorkqueueField workqueue _ declaration) =+  MappedRoot+    { mappedRootConsumer = WorkqueueConsumer workqueue,+      mappedRootKind = MappedWorkqueueFieldRoot,+      mappedRootUseSite = site,+      mappedRootDeclaration = declaration+    }+mappedRootFromUseSite site@(RootReadModelQueryInput readModel declaration) =+  MappedRoot+    { mappedRootConsumer = ReadModelQueryConsumer readModel MappedQueryInput,+      mappedRootKind = MappedReadModelQueryInputRoot,+      mappedRootUseSite = site,+      mappedRootDeclaration = declaration+    }+mappedRootFromUseSite site@(RootReadModelQueryResult readModel declaration) =+  MappedRoot+    { mappedRootConsumer = ReadModelQueryConsumer readModel MappedQueryResult,+      mappedRootKind = MappedReadModelQueryResultRoot,+      mappedRootUseSite = site,+      mappedRootDeclaration = declaration+    }++eventAuthority :: UsePath -> Maybe Name+eventAuthority UsePath {upRoot = RootEventField aggregate _ _ _} = Just aggregate+eventAuthority _ = Nothing++maybeToList :: Maybe value -> [value]+maybeToList = maybe [] pure

src/Keiro/Dsl/ServiceHarness.hs view

@@ -14,9 +14,12 @@ import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.Grammar-import Keiro.Dsl.Harness (processHarnessFactValues, routerHarnessFactValues, workflowHarnessFactValues)+import Keiro.Dsl.Harness (processHarnessFactValues, routerHarnessFactValuesForService, workflowHarnessFactValues)+import Keiro.Dsl.LanguageVersion (LanguageFeature (MappedConsumerSurfaceSyntax), languageSupportsFeature) import Keiro.Dsl.Scaffold (Context, ModuleKind (Generated), ScaffoldModule (..), contextGeneratedPrefix, genPrefixFor, generatedBanner, pascal)-import Keiro.Dsl.SemanticContract (CheckedService (..))+import Keiro.Dsl.SemanticContract (CheckedService, checkedLanguageContract, checkedSpec, checkedTypeGraph, effectiveContractLanguageVersion)+import Keiro.Dsl.SemanticImpact (mappedSurfaceFactValues, semanticImpactForService)+import Keiro.Dsl.StructuralConformance (hasStructuralConformance, structuralConformanceModuleName) import Keiro.Dsl.Validate (nodeIdentity)  -- | A fully qualified process, router, or workflow fact key that would occur@@ -38,7 +41,7 @@ -- | The create-once expectation baseline for all facts-producing nodes. serviceConformanceFactValues :: CheckedService -> [(Text, Text)] serviceConformanceFactValues service =-  concatMap valuesForNode (serviceHarnessNodes service)+  surfaceFactValues service <> concatMap (valuesForNode service) (serviceHarnessNodes service)  -- | Emit exactly one facade, including an empty facade for a service with no -- harness-producing nodes. Duplicate normalized expectation keys are refused@@ -73,14 +76,18 @@     ]       <> importLines       <> [""]-      <> renderChecks checkSources+      <> renderChecks hasStructural checkSources       <> [""]-      <> renderFacts factSources+      <> renderFacts (surfaceFactValues service) factSources   where-    aliased = aliasNodes (serviceHarnessNodes service)+    hasStructural = hasStructuralConformance service+    aliased = aliasNodes hasStructural (serviceHarnessNodes service)     importLines-      | null aliased = []-      | otherwise = "" : map (renderImport ctx) aliased+      | null imports = []+      | otherwise = "" : imports+    imports =+      ["import " <> structuralConformanceModuleName ctx <> " qualified as StructuralConformance" | hasStructural]+        <> map (renderImport ctx) aliased     checkSources = [(node, alias) | (node, alias) <- aliased, producesChecks node]     factSources = [(node, alias) | (node, alias) <- aliased, producesFacts node] @@ -88,9 +95,10 @@ renderImport ctx (node, alias) =   "import " <> harnessModuleName ctx node <> " qualified as " <> alias -aliasNodes :: [Node] -> [(Node, Text)]-aliasNodes nodes = snd (mapAccumL assign Map.empty nodes)+aliasNodes :: Bool -> [Node] -> [(Node, Text)]+aliasNodes reservesStructural nodes = snd (mapAccumL assign initialCounts nodes)   where+    initialCounts = Map.fromList [("StructuralConformance", 1 :: Int) | reservesStructural]     assign counts node =       let base = aliasForNode node           occurrence = Map.findWithDefault 0 base counts + 1@@ -111,18 +119,23 @@   NWorkflow workflow -> genPrefixFor ctx (wfId workflow) <> ".WorkflowFacts"   node -> error ("service harness requested a module for unsupported node " <> show (nodeIdentity node)) -renderChecks :: [(Node, Text)] -> [Text]-renderChecks [] =+renderChecks :: Bool -> [(Node, Text)] -> [Text]+renderChecks False [] =   [ "runServiceConformanceChecks :: IO [(String, Bool)]",     "runServiceConformanceChecks = pure []"   ]-renderChecks sources =+renderChecks hasStructural sources =   [ "runServiceConformanceChecks :: IO [(String, Bool)]",     "runServiceConformanceChecks =",     "  pure ("   ]-    <> renderConcatenation (map checkExpression sources)+    <> renderConcatenation (structuralExpressions <> map checkExpression sources)     <> ["  )"]+  where+    structuralExpressions =+      [ "[(\"structural/\" <> fact, passed) | (fact, passed) <- StructuralConformance.structuralConformanceAssertions]"+      | hasStructural+      ]  checkExpression :: (Node, Text) -> Text checkExpression (node, alias) = case node of@@ -132,17 +145,25 @@     "[(\"readmodel/" <> rmName readModel <> "/\" <> fact, passed) | (fact, passed) <- " <> alias <> ".readModelFactResults]"   _ -> error "checkExpression called for a fact-only node" -renderFacts :: [(Node, Text)] -> [Text]-renderFacts [] =+renderFacts :: [(Text, Text)] -> [(Node, Text)] -> [Text]+renderFacts [] [] =   [ "serviceConformanceFacts :: [(String, String)]",     "serviceConformanceFacts = []"   ]-renderFacts sources =+renderFacts surfaceFacts sources =   [ "serviceConformanceFacts :: [(String, String)]",     "serviceConformanceFacts ="   ]-    <> renderConcatenation (map factExpression sources)+    <> renderConcatenation (surfaceExpression surfaceFacts <> map factExpression sources) +surfaceExpression :: [(Text, Text)] -> [Text]+surfaceExpression [] = []+surfaceExpression values =+  [ "[ " <> T.intercalate "\n    , " ["(" <> quoted key <> ", " <> quoted value <> ")" | (key, value) <- values] <> "\n    ]"+  ]+  where+    quoted = T.pack . show . T.unpack+ factExpression :: (Node, Text) -> Text factExpression (node, alias) =   "[(\"" <> kindName <> "/" <> nodeName <> "/\" <> fact, value) | (fact, value) <- " <> alias <> "." <> valueName <> "]"@@ -176,13 +197,25 @@ producesFacts NWorkflow {} = True producesFacts _ = False -valuesForNode :: Node -> [(Text, Text)]-valuesForNode node =+valuesForNode :: CheckedService -> Node -> [(Text, Text)]+valuesForNode service node =   [(kindName <> "/" <> nodeName <> "/" <> factName, value) | (factName, value) <- factValues]   where     (kindName, nodeName, _) = nodeIdentity node     factValues = case node of       NProcess process -> processHarnessFactValues process-      NRouter router -> routerHarnessFactValues router+      NRouter router -> routerHarnessFactValuesForService service router       NWorkflow workflow -> workflowHarnessFactValues workflow       _ -> []++surfaceFactValues :: CheckedService -> [(Text, Text)]+surfaceFactValues service+  | not+      ( languageSupportsFeature+          (effectiveContractLanguageVersion (checkedLanguageContract service))+          MappedConsumerSurfaceSyntax+      ) =+      []+  | otherwise = case checkedTypeGraph service of+      Left _ -> []+      Right graph -> mappedSurfaceFactValues (semanticImpactForService service graph)

src/Keiro/Dsl/Skeleton.hs view

@@ -15,7 +15,7 @@  import Data.Text (Text) import Data.Text qualified as T-import Keiro.Dsl.LanguageVersion (currentStableLanguageVersion, languageVersionText)+import Keiro.Dsl.LanguageVersion (currentAuthoringLanguageVersion, languageVersionText)  -- | The valid @new \<kind\>@ arguments, in help/listing order. skeletonKinds :: [Text]@@ -52,7 +52,7 @@     Left $       "unknown kind '" <> other <> "'. Valid kinds: " <> T.intercalate ", " skeletonKinds   where-    versioned source = "language keiro-dsl " <> languageVersionText currentStableLanguageVersion <> "\n" <> source+    versioned source = "language keiro-dsl " <> languageVersionText currentAuthoringLanguageVersion <> "\n" <> source  aggregateSkeleton :: Text aggregateSkeleton =@@ -262,29 +262,68 @@   T.unlines     [ "context my-service",       "",-      "readmodel acceptedTransferNeeds {",+      "target accepted_transfer_needs_rows {",+      "  schema = \"my_service\"",       "  table = \"accepted_transfer_needs\"",+      "  reset = clear",+      "}",+      "",+      "target transfer_decision_rows {",       "  schema = \"my_service\"",+      "  table = \"transfer_decisions\"",+      "  reset = clear",+      "}",+      "",+      "rebuild-group transfer_dispatch {",+      "  targets = [ accepted_transfer_needs_rows transfer_decision_rows ]",+      "  order = [ accepted_transfer_needs_rows transfer_decision_rows ]",+      "}",+      "",+      "projection-owner accepted_transfer_needs_writer {",+      "  source = category \"acceptedTransferNeeds\"",+      "  delivery = subscription",+      "  group = transfer_dispatch",+      "  targets = [ accepted_transfer_needs_rows ]",+      "  order = 10",+      "  subscription = \"accepted-transfer-needs\"",+      "  dedup = \"accepted-transfer-needs-v1\"",+      "  checkpoint-on-missing = from-beginning",+      "  replay = explicit",+      "}",+      "",+      "projection-owner transfer_decisions_writer {",+      "  source = category \"transferDecisions\"",+      "  delivery = subscription",+      "  group = transfer_dispatch",+      "  targets = [ transfer_decision_rows ]",+      "  order = 20",+      "  subscription = \"transfer-decisions\"",+      "  dedup = \"transfer-decisions-v1\"",+      "  checkpoint-on-missing = from-beginning",+      "  replay = explicit",+      "}",+      "",+      "readmodel acceptedTransferNeeds {",       "  columns {",       "    reservation_id text required",       "    hospital_id text required",       "  }",       "  version = 1",-      "  shape = \"fnv1a:fec517dae7760b8a\"",-      "  consistency = Eventual",-      "  feed = subscription",+      "  shape = \"fnv1a:5c91c3c0a3a2c01b\"",+      "  freshness = immediate",+      "  group = transfer_dispatch",+      "  targets = [ accepted_transfer_needs_rows ]",       "}",       "",       "readmodel transferDecisions {",-      "  table = \"transfer_decisions\"",-      "  schema = \"my_service\"",       "  columns {",       "    reservation_id text required",       "  }",       "  version = 1",-      "  shape = \"fnv1a:d44d218822582783\"",-      "  consistency = Eventual",-      "  feed = subscription",+      "  shape = \"fnv1a:660844a62fd3d5b2\"",+      "  freshness = immediate",+      "  group = transfer_dispatch",+      "  targets = [ transfer_decision_rows ]",       "}",       "",       "workqueue reservationWork {",

+ src/Keiro/Dsl/SourceIndex.hs view

@@ -0,0 +1,253 @@+{-# LANGUAGE NoFieldSelectors #-}++-- | Exact source provenance for semantic aggregate subjects.+--+-- The index deliberately lives beside 'Keiro.Dsl.Grammar.Spec'. Source+-- movement must not participate in semantic equality, fingerprints, diffs, or+-- generated output.+module Keiro.Dsl.SourceIndex+  ( TransitionOrdinal (..),+    SourceSubject (..),+    SourcePositionQuality (..),+    SemanticSourceIndex,+    ParsedSourceDocument (..),+    SourceIndexFailureCode (..),+    SourceIndexFailure (..),+    semanticSourceSubjects,+    exactSemanticSourceIndex,+    compatibilitySemanticSourceIndex,+    repathSemanticSourceIndex,+    unionSemanticSourceIndexes,+    emptySemanticSourceIndex,+    semanticSourceEntries,+    lookupSourceSpan,+  )+where++import Data.List (find, sort)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiro.Dsl.Grammar+  ( Aggregate (..),+    Loc (..),+    Name,+    Node (..),+    Spec (..),+    StateDecl (..),+    Transition (..),+  )+import Keiro.Dsl.LanguageVersion (ParsedSource)+import Keiro.Dsl.Source (SourcePoint (..), SourceSpan (..))++newtype TransitionOrdinal = TransitionOrdinal Int+  deriving stock (Eq, Ord, Show, Generic)++-- | A syntax subject whose location may change without changing semantics.+data SourceSubject+  = AggregateStateSubject !Name !Name+  | AggregateTransitionSubject !Name !TransitionOrdinal+  deriving stock (Eq, Ord, Show, Generic)++-- | Whether a position came from exact parsing or from a compatibility+-- projection over line-only semantic values.+data SourcePositionQuality+  = ExactSourcePosition+  | CompatibilityLineOnly+  deriving stock (Eq, Ord, Show, Generic)++data IndexedSourcePosition = IndexedSourcePosition+  { quality :: !SourcePositionQuality,+    span :: !SourceSpan+  }+  deriving stock (Eq, Show, Generic)++newtype SemanticSourceIndex = SemanticSourceIndex+  { positions :: Map SourceSubject IndexedSourcePosition+  }+  deriving stock (Eq, Show, Generic)++-- | The semantic parse result and its independently comparable source index.+data ParsedSourceDocument = ParsedSourceDocument+  { documentParsedSource :: !ParsedSource,+    documentSourceIndex :: !SemanticSourceIndex+  }+  deriving stock (Eq, Show, Generic)++data SourceIndexFailureCode+  = DuplicateSourceSubject+  | MissingSourceSubject+  | UnexpectedSourceSubject+  | SourceIndexFileMismatch+  deriving stock (Eq, Ord, Show, Generic)++data SourceIndexFailure = SourceIndexFailure+  { failureCode :: !SourceIndexFailureCode,+    failureSubject :: !(Maybe SourceSubject),+    failureSpan :: !(Maybe SourceSpan),+    failureMessage :: !Text+  }+  deriving stock (Eq, Show, Generic)++-- | The complete aggregate state and transition subject inventory of a+-- semantic graph, in semantic source order.+semanticSourceSubjects :: Spec -> [SourceSubject]+semanticSourceSubjects spec = concatMap aggregateSubjects aggregates+  where+    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]+    aggregateSubjects aggregate =+      [ AggregateStateSubject (aggName aggregate) (stName state)+      | state <- aggStates aggregate+      ]+        <> [ AggregateTransitionSubject (aggName aggregate) (TransitionOrdinal ordinal)+           | (ordinal, _) <- zip [0 ..] (aggTransitions aggregate)+           ]++-- | Construct a complete exact index for one parsed file. The expected+-- inventory comes from the just-lowered semantic graph, so missing and stale+-- surface anchors are refused at the lowering boundary.+exactSemanticSourceIndex ::+  FilePath ->+  [SourceSubject] ->+  [(SourceSubject, SourceSpan)] ->+  Either SourceIndexFailure SemanticSourceIndex+exactSemanticSourceIndex source expected entries = do+  case find ((/= source) . sourceOf . snd) entries of+    Just (subject, sourceSpan) ->+      Left+        SourceIndexFailure+          { failureCode = SourceIndexFileMismatch,+            failureSubject = Just subject,+            failureSpan = Just sourceSpan,+            failureMessage = "source-index span belongs to a different source file"+          }+    Nothing -> pure ()+  checkedIndex ExactSourcePosition expected entries+  where+    sourceOf SourceSpan {source = spanSource} = spanSource++-- | Derive an explicitly line-only index for a compatibility 'Spec'. The+-- synthetic column is never advertised as exact.+compatibilitySemanticSourceIndex :: FilePath -> Spec -> Either SourceIndexFailure SemanticSourceIndex+compatibilitySemanticSourceIndex source spec =+  checkedIndex CompatibilityLineOnly expected entries+  where+    expected = semanticSourceSubjects spec+    entries = concatMap aggregateEntries [aggregate | NAggregate aggregate <- specNodes spec]+    aggregateEntries aggregate =+      [ (AggregateStateSubject (aggName aggregate) (stName state), lineSpan (stLoc state))+      | state <- aggStates aggregate+      ]+        <> [ (AggregateTransitionSubject (aggName aggregate) (TransitionOrdinal ordinal), lineSpan (tLoc transition))+           | (ordinal, transition) <- zip [0 ..] (aggTransitions aggregate)+           ]+    lineSpan (Loc lineNumber) =+      SourceSpan+        { source,+          start = point,+          end = point+        }+      where+        point = SourcePoint {offset = 0, line = max 1 lineNumber, column = 1}++-- | Replace the one source name in an index after checking the caller's+-- expected name. Workspace composition uses this to turn loader paths into+-- canonical manifest-relative member paths without relocating points.+repathSemanticSourceIndex ::+  FilePath ->+  FilePath ->+  SemanticSourceIndex ->+  Either SourceIndexFailure SemanticSourceIndex+repathSemanticSourceIndex expected replacement (SemanticSourceIndex index) =+  case find ((/= expected) . sourceOf . spanOf . snd) (Map.toAscList index) of+    Just (subject, position) ->+      Left+        SourceIndexFailure+          { failureCode = SourceIndexFileMismatch,+            failureSubject = Just subject,+            failureSpan = Just (spanOf position),+            failureMessage = "source-index span does not match the workspace member source path"+          }+    Nothing ->+      Right+        ( SemanticSourceIndex+            (Map.map replaceSource index)+        )+  where+    spanOf IndexedSourcePosition {span = sourceSpan} = sourceSpan+    sourceOf SourceSpan {source} = source+    replaceSource position@IndexedSourcePosition {span = sourceSpan} =+      position {span = sourceSpan {source = replacement}}++-- | Union complete member indices, refusing any duplicate semantic subject.+unionSemanticSourceIndexes :: [SemanticSourceIndex] -> Either SourceIndexFailure SemanticSourceIndex+unionSemanticSourceIndexes indexes =+  checkedIndexWithPositions+    [ (subject, position)+    | SemanticSourceIndex index <- indexes,+      (subject, position) <- Map.toAscList index+    ]++emptySemanticSourceIndex :: SemanticSourceIndex+emptySemanticSourceIndex = SemanticSourceIndex Map.empty++semanticSourceEntries :: SemanticSourceIndex -> [(SourceSubject, SourcePositionQuality, SourceSpan)]+semanticSourceEntries (SemanticSourceIndex index) =+  [ (subject, quality, sourceSpan)+  | (subject, IndexedSourcePosition {quality, span = sourceSpan}) <- Map.toAscList index+  ]++lookupSourceSpan :: SourceSubject -> SemanticSourceIndex -> Maybe (SourcePositionQuality, SourceSpan)+lookupSourceSpan subject (SemanticSourceIndex index) = do+  IndexedSourcePosition {quality, span = sourceSpan} <- Map.lookup subject index+  pure (quality, sourceSpan)++checkedIndex ::+  SourcePositionQuality ->+  [SourceSubject] ->+  [(SourceSubject, SourceSpan)] ->+  Either SourceIndexFailure SemanticSourceIndex+checkedIndex quality expected entries = do+  index <- checkedIndexWithPositions [(subject, IndexedSourcePosition {quality, span = sourceSpan}) | (subject, sourceSpan) <- entries]+  let actualSubjects = Set.fromList [subject | (subject, _, _) <- semanticSourceEntries index]+      expectedSubjects = Set.fromList expected+  case Set.lookupMin (actualSubjects Set.\\ expectedSubjects) of+    Just subject ->+      Left+        SourceIndexFailure+          { failureCode = UnexpectedSourceSubject,+            failureSubject = Just subject,+            failureSpan = snd <$> find ((== subject) . fst) entries,+            failureMessage = "source index contains a subject absent from the semantic graph"+          }+    Nothing -> pure ()+  case Set.lookupMin (expectedSubjects Set.\\ actualSubjects) of+    Just subject ->+      Left+        SourceIndexFailure+          { failureCode = MissingSourceSubject,+            failureSubject = Just subject,+            failureSpan = Nothing,+            failureMessage = "semantic graph subject has no source-index entry"+          }+    Nothing -> Right index++checkedIndexWithPositions ::+  [(SourceSubject, IndexedSourcePosition)] ->+  Either SourceIndexFailure SemanticSourceIndex+checkedIndexWithPositions entries =+  case firstDuplicate (sort (map fst entries)) of+    Just duplicate ->+      Left+        SourceIndexFailure+          { failureCode = DuplicateSourceSubject,+            failureSubject = Just duplicate,+            failureSpan = spanOf <$> find ((== duplicate) . fst) entries,+            failureMessage = "source index contains more than one entry for a semantic subject"+          }+    Nothing -> Right (SemanticSourceIndex (Map.fromList entries))+  where+    firstDuplicate values = fst <$> find (uncurry (==)) (zip values (drop 1 values))+    spanOf (_, IndexedSourcePosition {span = sourceSpan}) = sourceSpan

+ src/Keiro/Dsl/StructuralConformance.hs view

@@ -0,0 +1,388 @@+-- | Generate the single context-owned conformance module for mapped+-- declarations. Declaration laws live here so aggregate harnesses need only+-- import evidence for declarations in their checked semantic closure.+module Keiro.Dsl.StructuralConformance+  ( StructuralConformanceFailure (..),+    structuralConformanceModuleName,+    hasStructuralConformance,+    structuralConformanceModule,+  )+where++import Data.List (find)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Keiro.Dsl.Grammar (HaskellSource (..), Name, Spec (..), WireEnum (..))+import Keiro.Dsl.HaskellImport+import Keiro.Dsl.Scaffold+  ( Context (..),+    ModuleKind (Generated),+    Placement (..),+    ScaffoldModule (..),+    StructuralProjection (..),+    generatedBanner,+    lowerFirst,+    pascalFromKebab,+    projectionSpecs,+    resolveProjectionModules,+  )+import Keiro.Dsl.SemanticContract (CheckedService, checkedSpec, checkedTypeGraph)+import Keiro.Dsl.SemanticImpact (semanticImpact, serviceMappedInventory)+import Keiro.Dsl.TypeGraph++-- | An inconsistency between a checked service and the resolved inventory used+-- to render its structural evidence. Source-authored mapping errors are normal+-- checker diagnostics and never use this type.+data StructuralConformanceFailure+  = StructuralConformanceGraphFailure !Text+  | StructuralConformanceInventoryMissing !MappedKey+  deriving stock (Eq, Show)++-- | The stable context-level module imported once by the service facade.+structuralConformanceModuleName :: Context -> Text+structuralConformanceModuleName ctx = contextStructuralPrefix ctx <> ".StructuralConformance"++-- | Whether the checked service owns any mapped declaration evidence.+hasStructuralConformance :: CheckedService -> Bool+hasStructuralConformance service = case checkedTypeGraph service of+  Left _ -> False+  Right graph -> not (null (serviceMappedInventory (semanticImpact graph)))++-- | Emit no module for an empty mapped inventory and exactly one generated+-- module otherwise.+structuralConformanceModule :: Context -> CheckedService -> Either [StructuralConformanceFailure] (Maybe ScaffoldModule)+structuralConformanceModule ctx service = do+  graph <- case checkedTypeGraph service of+    Left failures -> Left [StructuralConformanceGraphFailure (T.pack (show failures))]+    Right resolved -> Right resolved+  let inventory = serviceMappedInventory (semanticImpact graph)+      missing = [key | key <- inventory, Map.notMember key (tgDeclarations graph)]+  case missing of+    key : keys -> Left (map StructuralConformanceInventoryMissing (key : keys))+    [] -> case inventory of+      [] -> Right Nothing+      _ ->+        let rendering = conformanceRendering ctx graph inventory+            moduleName = structuralConformanceModuleName ctx+         in Right . Just $+              ScaffoldModule+                { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),+                  moduleText = renderStructuralConformance rendering,+                  kind = Generated,+                  origin = "context " <> specContext (checkedSpec service) <> " structural conformance"+                }++data ConformanceRendering = ConformanceRendering+  { renderingContext :: !Context,+    renderingGraph :: !TypeGraph,+    renderingDeclarations :: ![ResolvedMappedDecl],+    renderingProjections :: ![StructuralProjection],+    renderingImportPlan :: !HaskellImportPlan+  }++conformanceRendering :: Context -> TypeGraph -> [MappedKey] -> ConformanceRendering+conformanceRendering ctx graph inventory = rendering+  where+    declarations = [declaration | key <- inventory, Just declaration <- [Map.lookup key (tgDeclarations graph)]]+    projections = map (resolveProjectionModules ctx) (projectionSpecs graph)+    rendering =+      ConformanceRendering+        { renderingContext = ctx,+          renderingGraph = graph,+          renderingDeclarations = declarations,+          renderingProjections = projections,+          renderingImportPlan = conformanceImportPlan ctx declarations projections+        }++renderStructuralConformance :: ConformanceRendering -> Text+renderStructuralConformance rendering =+  T.unlines $+    [ generatedBanner,+      "module " <> structuralConformanceModuleName (renderingContext rendering),+      "  ( structuralConformanceAssertions",+      "  ) where",+      ""+    ]+      <> conformanceImports rendering+      <> [ "",+           "structuralConformanceAssertions :: [(String, Bool)]",+           "structuralConformanceAssertions =",+           "  concat",+           "    [ " <> T.intercalate "\n    , " assertionLists,+           "    ]",+           "",+           "validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool",+           "validFixtureLabels cases =",+           "  all (not . T.null) labels && length labels == length (nub labels)",+           "  where",+           "    labels = map fst (NonEmpty.toList cases)"+         ]+      <> concatMap (bindingAssertionDecl rendering) structural+      <> concatMap (opaqueAssertionDecl rendering) opaque+      <> concatMap (coverageDecl rendering) structural+      <> projectionAssertionDecls rendering structural+  where+    structural = [(declaration, shape) | ResolvedStructural declaration shape <- renderingDeclarations rendering]+    opaque = [declaration | ResolvedOpaque declaration <- renderingDeclarations rendering]+    assertionLists =+      [lowerFirst (sdName declaration) <> "BindingAssertions" | (declaration, _) <- structural]+        <> [lowerFirst (odName declaration) <> "OpaqueAssertions" | declaration <- opaque]+        <> [ "[(\"fixture coverage: "+               <> unCanonicalTypeId (sdCanonical declaration)+               <> "\", coverage"+               <> sdName declaration+               <> ")]"+           | (declaration, _) <- structural+           ]+        <> ["structuralProjectionAssertions" | not (null (renderingProjections rendering))]++conformanceImports :: ConformanceRendering -> [Text]+conformanceImports rendering =+  ["import Data.Aeson qualified as Aeson" | not (null opaque)]+    <> ["import Data.List (nub)", "import Data.List.NonEmpty qualified as NonEmpty"]+    <> ["import Data.Maybe (isJust, isNothing)" | any shapeUsesMaybe structural]+    <> ["import Data.Proxy (Proxy (..))" | not (null structural)]+    <> ["import Data.Text qualified as T"]+    <> ["import Keiki.Core (fieldWitnessAgrees)" | not (null projections)]+    <> ["import Keiki.Shape (CanonicalTypeName (..))" | not (null structural)]+    <> ["import Keiro.Codec.Structural (" <> T.intercalate ", " structuralCodecImports <> ")"]+    <> [ "import " <> structuralProjectionModuleName (renderingContext rendering) <> " qualified as StructuralProjections"+       | not (null projections)+       ]+    <> T.lines (renderPlannedImports (renderingImportPlan rendering))+  where+    declarations = renderingDeclarations rendering+    structural = [(declaration, shape) | ResolvedStructural declaration shape <- declarations]+    opaque = [declaration | ResolvedOpaque declaration <- declarations]+    projections = renderingProjections rendering+    structuralCodecImports =+      ["FixtureCases (..)"]+        <> if null structural then [] else ["bindingDomainRoundTrip", "bindingShapeRoundTrip", "bindingToShape"]+    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++conformanceImportPlan :: Context -> [ResolvedMappedDecl] -> [StructuralProjection] -> HaskellImportPlan+conformanceImportPlan ctx declarations projections =+  either+    (error . ("validated structural conformance import planning failed: " <>) . show)+    id+    ( planHaskellImports+        ImportEnvironment+          { targetModule = structuralConformanceModuleName ctx,+            localNames = Set.fromList ["structuralConformanceAssertions", "validFixtureLabels"],+            reservedQualifiers = Set.fromList ["Aeson", "NonEmpty", "StructuralProjections", "T"]+          }+        references+    )+  where+    declarationReferences =+      Set.fromList+        [ reference+        | declaration <- declarations,+          reference <- case declaration of+            ResolvedStructural structural _ ->+              conformanceTypeReference (sdHaskell structural)+                : map conformanceQualifiedValueReference [sdBinding structural, sdFixtures structural]+            ResolvedOpaque opaque -> [conformanceQualifiedValueReference (odFixtures opaque)]+        ]+    shapeReferences =+      Set.fromList+        [ reference+        | ResolvedStructural declaration shape <- declarations,+          reference <- structuralShapeReferences ctx declaration shape+        ]+    projectionReferences =+      Set.fromList+        [ HaskellReference shapeModule selector ValueNamespace RequireQualified+        | projection <- projections,+          (shapeModule, selector) <- spSelectors projection+        ]+    references = declarationReferences <> shapeReferences <> projectionReferences++conformanceTypeReference :: HaskellSource -> HaskellReference+conformanceTypeReference source =+  HaskellReference (hsModule source) (hsType source) TypeNamespace PreferUnqualified++conformanceQualifiedValueReference :: QualifiedValueName -> HaskellReference+conformanceQualifiedValueReference qualified =+  HaskellReference moduleName valueName ValueNamespace RequireQualified+  where+    (moduleName, valueName) = splitQualifiedValue (unQualifiedValueName qualified)++splitQualifiedValue :: Text -> (Text, Text)+splitQualifiedValue value =+  let (prefix, name) = T.breakOnEnd "." value+   in (T.dropEnd 1 prefix, name)++structuralShapeReferences :: Context -> StructuralDecl -> ResolvedMappedShape -> [HaskellReference]+structuralShapeReferences ctx declaration =+  foldMappedShape+    MappedShapeAlgebra+      { onRecord = \constructor _ fields -> constructorRef constructor : map (valueRef . rwfHaskell) fields,+        onEnum = map (constructorRef . weCtor),+        onUnion = \_ -> map (constructorRef . rwaCtor)+      }+  where+    moduleName = structuralShapeModuleName ctx (sdName declaration)+    constructorRef constructor = HaskellReference moduleName constructor ConstructorNamespace RequireQualified+    valueRef value = HaskellReference moduleName value ValueNamespace RequireQualified++renderReference :: ConformanceRendering -> HaskellReference -> Text+renderReference rendering reference =+  either+    (error . ("validated structural conformance reference failed: " <>) . show)+    id+    (renderPlannedReference (renderingImportPlan rendering) reference)++bindingAssertionDecl :: ConformanceRendering -> (StructuralDecl, ResolvedMappedShape) -> [Text]+bindingAssertionDecl rendering (declaration, _shape) =+  [ "",+    valueName <> " :: [(String, Bool)]",+    valueName <> " =",+    "  (\"fixture labels: " <> canonical <> "\", validFixtureLabels cases) :",+    "  (\"canonical identity: " <> canonical <> "\", canonicalTypeName (Proxy @" <> consumerType <> ") == " <> tshow canonical <> ") :",+    "  concat",+    "    [ [ (\"binding domain round-trip: " <> canonical <> "/\" <> T.unpack label, bindingDomainRoundTrip " <> binding <> " value)",+    "      , (\"binding shape round-trip: " <> canonical <> "/\" <> T.unpack label, bindingShapeRoundTrip " <> binding <> " (bindingToShape " <> binding <> " value))",+    "      ]",+    "    | (label, value) <- NonEmpty.toList cases",+    "    ]",+    "  where",+    "    cases = fixtureCases " <> fixtures+  ]+  where+    valueName = lowerFirst (sdName declaration) <> "BindingAssertions"+    canonical = unCanonicalTypeId (sdCanonical declaration)+    consumerType = renderReference rendering (conformanceTypeReference (sdHaskell declaration))+    binding = renderReference rendering (conformanceQualifiedValueReference (sdBinding declaration))+    fixtures = renderReference rendering (conformanceQualifiedValueReference (sdFixtures declaration))++opaqueAssertionDecl :: ConformanceRendering -> OpaqueDecl -> [Text]+opaqueAssertionDecl rendering declaration =+  [ "",+    valueName <> " :: [(String, Bool)]",+    valueName <> " =",+    "  (\"opaque boundary fixtures: " <> label <> "\", validFixtureLabels cases) :",+    "  [ (\"opaque codec round-trip: " <> label <> "/\" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False)",+    "  | (caseLabel, value) <- NonEmpty.toList cases",+    "  ]",+    "  where",+    "    cases = fixtureCases " <> fixtures+  ]+  where+    valueName = lowerFirst (odName declaration) <> "OpaqueAssertions"+    label = unCodecIdentity (odCodecIdentity declaration) <> "@" <> unCodecVersion (odCodecVersion declaration)+    fixtures = renderReference rendering (conformanceQualifiedValueReference (odFixtures declaration))++coverageDecl :: ConformanceRendering -> (StructuralDecl, ResolvedMappedShape) -> [Text]+coverageDecl rendering (declaration, shape) =+  [ "",+    "coverage" <> sdName declaration <> " :: Bool",+    "coverage" <> sdName declaration <> " = " <> coverageExpression rendering declaration shape+  ]++coverageExpression :: ConformanceRendering -> StructuralDecl -> ResolvedMappedShape -> Text+coverageExpression rendering declaration shape = case obligations of+  [] -> "True"+  _ -> T.intercalate " && " obligations <> "\n  where\n    shapes = map (bindingToShape " <> binding <> " . snd) (NonEmpty.toList (fixtureCases " <> fixtures <> "))"+  where+    shapeModule = structuralShapeModuleName (renderingContext rendering) (sdName declaration)+    binding = renderReference rendering (conformanceQualifiedValueReference (sdBinding declaration))+    fixtures = renderReference rendering (conformanceQualifiedValueReference (sdFixtures declaration))+    obligations = case shape of+      RRecord _ _ fields -> concatMap (recordFieldObligation rendering shapeModule) fields+      REnum entries ->+        [ "any (\\case " <> renderReference rendering (HaskellReference shapeModule (weCtor entry) ConstructorNamespace RequireQualified) <> " -> True; _ -> False) shapes"+        | entry <- entries+        ]+      RUnion _ arms -> concatMap (unionArmObligations rendering shapeModule) arms++recordFieldObligation :: ConformanceRendering -> Text -> ResolvedWireField -> [Text]+recordFieldObligation rendering shapeModule field = case rwfType field of+  ROptional _ ->+    [ "any (isNothing . " <> selector <> ") shapes",+      "any (isJust . " <> selector <> ") shapes"+    ]+  _ -> []+  where+    selector = renderReference rendering (HaskellReference shapeModule (rwfHaskell field) ValueNamespace RequireQualified)++unionArmObligations :: ConformanceRendering -> Text -> ResolvedWireArm -> [Text]+unionArmObligations rendering shapeModule arm =+  ["any (\\case " <> patternText <> " -> True; _ -> False) shapes"] <> optionalPayload+  where+    constructor = renderReference rendering (HaskellReference shapeModule (rwaCtor arm) ConstructorNamespace RequireQualified)+    patternText = constructor <> maybe "" (const "{}") (rwaPayload arm)+    optionalPayload = case rwaPayload arm of+      Just (ROptional _) ->+        [ "any (\\case " <> constructor <> " Nothing -> True; _ -> False) shapes",+          "any (\\case " <> constructor <> " (Just _) -> True; _ -> False) shapes"+        ]+      _ -> []++projectionAssertionDecls :: ConformanceRendering -> [(StructuralDecl, ResolvedMappedShape)] -> [Text]+projectionAssertionDecls rendering structural+  | null specs = []+  | otherwise =+      [ "",+        "structuralProjectionAssertions :: [(String, Bool)]",+        "structuralProjectionAssertions =",+        "  [ " <> T.intercalate "\n  , " (map assertion specs),+        "  ]"+      ]+  where+    specs = renderingProjections rendering+    assertion spec =+      "(\"projection witness agreement: "+        <> unCanonicalTypeId (spCanonical spec)+        <> spPointer spec+        <> "\", all (\\(_, owner) -> fieldWitnessAgrees StructuralProjections."+        <> spWitness spec+        <> " (\\referenceOwner -> "+        <> projectionGetter rendering "referenceOwner" spec+        <> ") owner) (NonEmpty.toList (fixtureCases "+        <> ownerFixtures spec+        <> ")))"+    ownerFixtures spec = case find (\(declaration, _) -> sdCanonical declaration == spCanonical spec) structural of+      Just (declaration, _) -> renderReference rendering (conformanceQualifiedValueReference (sdFixtures declaration))+      Nothing -> "error \"projection owner fixtures missing\""++projectionGetter :: ConformanceRendering -> Text -> StructuralProjection -> Text+projectionGetter rendering owner spec =+  foldl+    ( \value (shapeModule, selector) ->+        renderReference rendering (HaskellReference shapeModule selector ValueNamespace RequireQualified)+          <> " ("+          <> value+          <> ")"+    )+    ("bindingToShape " <> renderReference rendering (conformanceQualifiedValueReference (spBinding spec)) <> " " <> owner)+    (spSelectors spec)++structuralShapeModuleName :: Context -> Name -> Text+structuralShapeModuleName ctx name = case placement ctx of+  GeneratedPrefix -> root <> "Generated." <> contextSegment <> ".Structural.Shape." <> name+  CollocatedLeaf -> root <> contextSegment <> ".Generated.Structural.Shape." <> name+  where+    root = if T.null (moduleRoot ctx) then "" else moduleRoot ctx <> "."+    contextSegment = pascalFromKebab (contextName ctx)++structuralProjectionModuleName :: Context -> Text+structuralProjectionModuleName ctx = contextStructuralPrefix ctx <> ".StructuralProjections"++contextStructuralPrefix :: Context -> Text+contextStructuralPrefix ctx = case placement ctx of+  GeneratedPrefix -> root <> "Generated." <> contextSegment+  CollocatedLeaf -> root <> contextSegment <> ".Generated"+  where+    root = if T.null (moduleRoot ctx) then "" else moduleRoot ctx <> "."+    contextSegment = pascalFromKebab (contextName ctx)++tshow :: (Show value) => value -> Text+tshow = T.pack . show

src/Keiro/Dsl/Syntax.hs view

@@ -21,6 +21,7 @@     Expr,     IdDecl,     MappedDecl,+    Name,     Node,     NominalScalarDecl,     Placement,@@ -66,4 +67,6 @@ data SurfaceElement   = SurfaceField !Text   | SurfaceExpression !Expr+  | SurfaceAggregateState !Name !Name+  | SurfaceAggregateTransition !Name !Int   deriving stock (Eq, Show, Generic)

src/Keiro/Dsl/TypeGraph.hs view

@@ -27,11 +27,15 @@     ResolvedMappedShape (..),     ResolvedMappedDecl (..),     TypeGraphError (..),+    DerivedMappedConsumer (..),+    UnsupportedProjectionSource (..),     TypeGraph (..),     UseSite (..),     PathSeg (..),     UsePath (..),     resolveTypeGraph,+    resolveTypeExpression,+    useSiteSegments,     usePaths,     renderUsePath,     TypeExprAlgebra (..),@@ -49,11 +53,12 @@ import Data.Char (ord) import Data.Either (partitionEithers) import Data.Graph (SCC (..), stronglyConnComp)-import Data.List (sortOn)+import Data.List (sort, sortOn) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map+import Data.Maybe (catMaybes) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text)@@ -243,6 +248,7 @@   = TGDeclError !Name !MappedDeclError   | TGAmbiguousName !Name ![Text]   | TGUnresolvedRef !Name !Name !Loc+  | TGUnresolvedConsumerRef !Text !Name !Loc   | TGRecursive ![Name]   deriving stock (Eq, Show, Generic) @@ -250,6 +256,9 @@   = RootCommandField !Name !Name !Name !MappedKey   | RootEventField !Name !Name !Name !MappedKey   | RootRegister !Name !Name !MappedKey+  | RootWorkqueueField !Name !Name !MappedKey+  | RootReadModelQueryInput !Name !MappedKey+  | RootReadModelQueryResult !Name !MappedKey   deriving stock (Eq, Ord, Show, Generic)  data PathSeg@@ -267,10 +276,30 @@   }   deriving stock (Eq, Ord, Show, Generic) +-- | A projection consumer whose mapped dependencies are inherited from one+-- authoritative aggregate event union rather than spelled a second time.+data DerivedMappedConsumer+  = AggregateInlineProjectionConsumer !Name !Name+  | CatalogProjectionConsumer !Name !Name+  deriving stock (Eq, Ord, Show, Generic)++-- | A catalog boundary that deliberately has no single generated event type.+-- Keeping it in the checked graph makes the unsupported boundary visible+-- without fabricating a mapped declaration consumer.+data UnsupportedProjectionSource+  = UnsupportedCatalogCategory !Name !Text+  | UnsupportedCatalogAll !Name+  deriving stock (Eq, Ord, Show, Generic)+ data TypeGraph = TypeGraph   { tgDeclarations :: !(Map MappedKey ResolvedMappedDecl),     tgReachability :: !(Map MappedKey (Set MappedKey)),-    tgUseSites :: ![UseSite]+    tgUseSites :: ![UseSite],+    tgRootSegments :: !(Map UseSite [PathSeg]),+    tgDerivedMappedConsumers :: ![DerivedMappedConsumer],+    tgReplayableProjectionGroups :: !(Map DerivedMappedConsumer Name),+    tgProjectionOperationalIdentities :: !(Map DerivedMappedConsumer Text),+    tgUnsupportedProjectionSources :: ![UnsupportedProjectionSource]   }   deriving stock (Eq, Show, Generic) @@ -284,13 +313,87 @@   let declarations = Map.fromList resolvedPairs   rejectMany (cycleErrors declarations)   let reachability = Map.mapWithKey (reachableFrom declarations) declarations+      (rootErrors, rootSites) = partitionEithers (collectUseSites keyByName spec)+  rejectMany rootErrors   pure     TypeGraph       { tgDeclarations = declarations,         tgReachability = reachability,-        tgUseSites = collectUseSites keyByName spec+        tgUseSites = map fst (catMaybes rootSites),+        tgRootSegments = Map.fromList (catMaybes rootSites),+        tgDerivedMappedConsumers = sort (derivedMappedConsumers spec),+        tgReplayableProjectionGroups = replayableProjectionGroups spec,+        tgProjectionOperationalIdentities = projectionOperationalIdentities spec,+        tgUnsupportedProjectionSources = sort (unsupportedProjectionSources spec)       } +derivedMappedConsumers :: Spec -> [DerivedMappedConsumer]+derivedMappedConsumers spec =+  [ AggregateInlineProjectionConsumer (aggName aggregate) (projTable projection)+  | NAggregate aggregate <- specNodes spec,+    Just projection <- [aggProjection aggregate]+  ]+    <> [ CatalogProjectionConsumer (poName owner) aggregate+       | NProjectionOwner owner <- specNodes spec,+         CatalogAggregate aggregate <- poSources owner+       ]++replayableProjectionGroups :: Spec -> Map DerivedMappedConsumer Name+replayableProjectionGroups spec =+  Map.fromList+    [ (CatalogProjectionConsumer (poName owner) aggregate, poGroup owner)+    | NProjectionOwner owner <- specNodes spec,+      poReplay owner == ProjectionReplayExplicit,+      CatalogAggregate aggregate <- poSources owner+    ]++projectionOperationalIdentities :: Spec -> Map DerivedMappedConsumer Text+projectionOperationalIdentities spec =+  Map.fromList (inlineRows <> catalogRows)+  where+    readModels = [readModel | NReadModel readModel <- specNodes spec]+    inlineRows =+      [ ( AggregateInlineProjectionConsumer (aggName aggregate) (projTable projection),+          renderOperation Nothing [projTable projection] [rmName readModel | readModel <- readModels, rmName readModel == projTable projection] False+        )+      | NAggregate aggregate <- specNodes spec,+        Just projection <- [aggProjection aggregate]+      ]+    catalogRows =+      [ ( CatalogProjectionConsumer (poName owner) aggregate,+          renderOperation+            (Just (poGroup owner))+            (poTargets owner)+            [ rmName readModel+            | readModel <- readModels,+              rmGroup readModel == Just (poGroup owner),+              not (Set.disjoint (Set.fromList (rmObservedTargets readModel)) (Set.fromList (poTargets owner)))+            ]+            (poReplay owner == ProjectionReplayExplicit)+        )+      | NProjectionOwner owner <- specNodes spec,+        CatalogAggregate aggregate <- poSources owner+      ]+    renderOperation groupName targets observers canReplay =+      T.intercalate+        ";"+        [ "group=" <> maybe "(inline)" id groupName,+          "targets=" <> T.intercalate "," (sort targets),+          "read-models=" <> T.intercalate "," (sort observers),+          "replayable=" <> if canReplay then "yes" else "no"+        ]++unsupportedProjectionSources :: Spec -> [UnsupportedProjectionSource]+unsupportedProjectionSources spec =+  [ boundary+  | NProjectionOwner owner <- specNodes spec,+    source <- poSources owner,+    boundary <- case source of+      CatalogAggregate _ -> []+      CatalogCategory category -> [UnsupportedCatalogCategory (poName owner) category]+      CatalogAll -> [UnsupportedCatalogAll (poName owner)]+  ]+ collectChecked :: [MappedDecl] -> Either (NonEmpty TypeGraphError) [CheckedMappedDecl] collectChecked declarations =   let checked = [(rawName declaration, checkMappedDecl declaration) | declaration <- declarations]@@ -373,6 +476,14 @@ resolveExpr names owner loc (TRef name) =   maybe (Left (TGUnresolvedRef owner name loc)) (Right . RRef) (Map.lookup name names) +-- | Resolve a consumer-surface type expression against an already checked+-- graph. Emitters use this entry point instead of reconstructing declaration+-- lookup rules independently.+resolveTypeExpression :: TypeGraph -> Text -> Loc -> TypeExpr -> Either TypeGraphError ResolvedTypeExpr+resolveTypeExpression graph owner loc = resolveExpr keyByName owner loc+  where+    keyByName = Map.fromList [(unMappedKey key, key) | key <- Map.keys (tgDeclarations graph)]+ cycleErrors :: Map MappedKey ResolvedMappedDecl -> [TypeGraphError] cycleErrors declarations =   [ TGRecursive (map unMappedKey keys)@@ -428,25 +539,78 @@           let next = maybe [] (Set.toList . directRefs) (Map.lookup key declarations)            in go (Set.insert key visited) (next ++ rest) -collectUseSites :: Map Name MappedKey -> Spec -> [UseSite]-collectUseSites keyByName spec = concatMap aggregateSites [aggregate | NAggregate aggregate <- specNodes spec]+collectUseSites :: Map Name MappedKey -> Spec -> [Either TypeGraphError (Maybe (UseSite, [PathSeg]))]+collectUseSites keyByName spec =+  map (Right . Just) (concatMap aggregateSites aggregates)+    <> concatMap workqueueSites workqueues+    <> concatMap readModelSites readModels   where+    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]+    workqueues = [workqueue | NWorkqueue workqueue <- specNodes spec]+    readModels = [readModel | NReadModel readModel <- specNodes spec]     aggregateSites aggregate =-      [ RootCommandField (aggName aggregate) (cmdName command) (aggregateFieldName field) key+      [ (RootCommandField (aggName aggregate) (cmdName command) (aggregateFieldName field) key, [])       | command <- aggCommands aggregate,         field <- cmdFields command,         key <- maybeToList (aggregateFieldType field >>= typeRefName >>= (`Map.lookup` keyByName))       ]-        ++ [ RootEventField (aggName aggregate) (evName event) (aggregateFieldName field) key+        ++ [ (RootEventField (aggName aggregate) (evName event) (aggregateFieldName field) key, [])            | event <- aggEvents aggregate,              field <- eventFields aggregate event,              key <- maybeToList (aggregateFieldType field >>= typeRefName >>= (`Map.lookup` keyByName))            ]-        ++ [ RootRegister (aggName aggregate) (regName register) key+        ++ [ (RootRegister (aggName aggregate) (regName register) key, [])            | register <- aggRegs aggregate,              key <- maybeToList (typeRefName (regType register) >>= (`Map.lookup` keyByName))            ] +    workqueueSites workqueue =+      [ consumerSite+          ("workqueue '" <> wqName workqueue <> "' payload field '" <> wqfName field <> "'")+          (wqfLoc field)+          (RootWorkqueueField (wqName workqueue) (wqfName field))+          expression+      | field <- wqPayload workqueue,+        TypedQueueExpression expression <- [wqfType field]+      ]++    readModelSites readModel = case queryTypes readModel of+      Nothing -> []+      Just ReadModelQueryTypes {input, result, inputLoc, resultLoc} ->+        [ consumerSite+            ("readmodel '" <> rmName readModel <> "' query input")+            inputLoc+            (RootReadModelQueryInput (rmName readModel))+            input,+          consumerSite+            ("readmodel '" <> rmName readModel <> "' query result")+            resultLoc+            (RootReadModelQueryResult (rmName readModel))+            result+        ]++    consumerSite owner loc constructor expression =+      case resolveExpr keyByName owner loc expression of+        Left (TGUnresolvedRef _ missing _) -> Left (TGUnresolvedConsumerRef owner missing loc)+        Left other -> Left other+        Right resolved -> case rootReference resolved of+          Nothing -> Right Nothing+          Just (key, segments) -> Right (Just (constructor key, segments))++    rootReference = \case+      RText -> Nothing+      RInt -> Nothing+      RInteger -> Nothing+      RBool -> Nothing+      RNatural -> Nothing+      RTime -> Nothing+      RJson -> Nothing+      ROptional value -> prepend SegOptional (rootReference value)+      RList value -> prepend SegElem (rootReference value)+      RMap value -> prepend SegMapValue (rootReference value)+      RRef key -> Just (key, [])+    prepend segment = fmap (\(key, segments) -> (key, segment : segments))+     eventFields aggregate event = case evBody event of       EventFields fields -> fields       EventFromCommand commandName ->@@ -467,9 +631,11 @@   where     target = MappedKey targetName     sitePaths site-      | siteKey site == target = [[]]-      | otherwise = pathsFromDecl Set.empty (siteKey site)+      | siteKey site == target = [rootSegments site]+      | otherwise = map (rootSegments site <>) (pathsFromDecl Set.empty (siteKey site)) +    rootSegments = useSiteSegments graph+     pathsFromDecl visited current       | current `Set.member` visited = []       | otherwise = case Map.lookup current (tgDeclarations graph) of@@ -517,7 +683,15 @@ siteKey (RootCommandField _ _ _ key) = key siteKey (RootEventField _ _ _ key) = key siteKey (RootRegister _ _ key) = key+siteKey (RootWorkqueueField _ _ key) = key+siteKey (RootReadModelQueryInput _ key) = key+siteKey (RootReadModelQueryResult _ key) = key +-- | Container path segments attached to a consumer root before its first+-- mapped declaration reference.+useSiteSegments :: TypeGraph -> UseSite -> [PathSeg]+useSiteSegments graph site = Map.findWithDefault [] site (tgRootSegments graph)+ renderUsePath :: UsePath -> Text renderUsePath (UsePath root segments) = renderRoot root <> T.concat (map renderSegment segments)   where@@ -527,6 +701,12 @@       aggregate <> " event " <> event <> " ." <> field <> " : " <> unMappedKey key     renderRoot (RootRegister aggregate register key) =       aggregate <> " register " <> register <> " : " <> unMappedKey key+    renderRoot (RootWorkqueueField workqueue field key) =+      "workqueue " <> workqueue <> " payload ." <> field <> " : " <> unMappedKey key+    renderRoot (RootReadModelQueryInput readModel key) =+      "readmodel " <> readModel <> " query input : " <> unMappedKey key+    renderRoot (RootReadModelQueryResult readModel key) =+      "readmodel " <> readModel <> " query result : " <> unMappedKey key      renderSegment (SegField haskellName wireName)       | haskellName == wireName = " ." <> haskellName

src/Keiro/Dsl/Validate.hs view

@@ -28,3739 +28,4678 @@ where  import Data.Bits (xor)-import Data.Char (isControl, isSpace, ord)-import Data.List (sortOn)-import Data.List.NonEmpty qualified as NE-import Data.Map.Strict (Map)-import Data.Map.Strict qualified as Map-import Data.Set (Set)-import Data.Set qualified as Set-import Data.Text (Text)-import Data.Text qualified as T-import Data.TypeID qualified as TypeID-import Data.Word (Word64)-import Keiro.Dsl.AggregateType-import Keiro.Dsl.EventOutput-import Keiro.Dsl.Expression-import Keiro.Dsl.FieldIdentity-import Keiro.Dsl.Grammar-import Keiro.Dsl.HaskellName qualified as HaskellName-import Keiro.Dsl.IdDomain (contractIdDomainContractFor, idDomainContractFor)-import Keiro.Dsl.LanguageVersion (LanguageVersion, RuntimeCapability (..), SourceLanguage (..), effectiveLanguageVersion, languageVersionText, runtimeProfileHasCapability, sourceFormText)-import Keiro.Dsl.NominalType qualified as Nominal-import Keiro.Dsl.ReadModelShape (deriveShapeHash)-import Keiro.Dsl.RuntimePackage (isCabalPackageName)-import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveRuntimeProfile, legacyCheckedService)-import Keiro.Dsl.TypeGraph-import Keiro.Integration.Event qualified as Event-import Numeric (showHex)-import Text.Read (readMaybe)--data Severity = Error | Warning-  deriving stock (Eq, Show)--diagnosticCodeText :: DiagnosticCode -> Text-diagnosticCodeText = T.pack . show--parseDiagnosticCode :: Text -> Maybe DiagnosticCode-parseDiagnosticCode raw =-  case [diagnosticCode | diagnosticCode <- [minBound .. maxBound], diagnosticCodeText diagnosticCode == raw] of-    diagnosticCode : _ -> Just diagnosticCode-    [] -> Nothing---- | A machine-checkable code per rule, so tests match on the code, not prose.-data DiagnosticCode-  = UndeclaredCommand-  | UndeclaredEvent-  | UndeclaredState-  | UnreachableState-  | TerminalHasOutgoing-  | GuardAtomOutOfScope-  | StatusMapNotTotal-  | ClockSampled-  | -- EP-2 (evolution). These codes are shared by single-spec validation and-    -- the cross-spec diff path, so the enum remains the single registry of-    -- evolution rules.-    EvtVersionMissingUpcaster-  | UpcasterChainGap-  | DeprecatedEventReplayHazard-  | EventRetirementInProgress-  | DeprecatedEventStillEmitted-  | WireSchemaVersionMismatch-  | EvtFieldAddedWithoutBump-  | EvtRemovedNotDeprecated-  | -- EP-3 (process manager + durable timer).-    ProcessFireAtNotInjected-  | ProcessDispatchIdSupplied-  | ProcessUnresolvedRef-  | ProcessBenignInversion-  | SagaCategoryIllegal-  | -- EP-4 (integration intake / inbox disposition).-    DispositionIncomplete-  | DispositionDuplicateRetry-  | DispositionPreviouslyFailedRetry-  | DispositionDecodeUnboundedRetry-  | -- EP-4 (integration coupling).-    EmitSkipMissing-  | EmitUnresolvedContract-  | PublisherUnresolvedEmit-  | IntakeUnresolvedContract-  | -- EP-5 (pgmq workqueue/dispatch).-    WqPhysicalDivergence-  | WqStoreFailureNotRetry-  | WqDecodeFailureNotDeadLetter-  | WqDlqWithoutCeiling-  | WqGroupKeyMissing-  | WqGroupKeyWithoutFifo-  | WqGroupKeyUnresolved-  | WqUnloggedDurability-  | WqPartitionSpecEmpty-  | SnapshotIntervalInvalid-  | SnapshotCodecFixtureInvalid-  | DispatchEnqueueUnresolved-  | -- EP-6 (workflow/operation).-    AwaitSignalMismatch-  | RunWorkflowUnresolved-  | WorkflowPatchDuplicate-  | WorkflowPatchIdInvalid-  | WorkflowContinueAsNewNotTerminal-  | -- Diff-only (cross-spec) decode and identity evolution rules.-    EvtFieldTypeChanged-  | EvtFieldRemovedSameVersion-  | EvtVersionDecreased-  | EnumCtorRemoved-  | EnumWireSpellingChanged-  | WireSpecChanged-  | ContractEventRemoved-  | ContractFieldChanged-  | ContractDiscriminatorChanged-  | ContractTopicChanged-  | ContractSchemaVersionDecreased-  | WqPayloadFieldChanged-  | ProcessInputChanged-  | WorkflowShapeChanged-  | WorkflowBodyChanged-  | WorkflowStableNameChanged-  | WorkflowPatchRemoved-  | WorkflowContinueSeedChanged-  | WqOrderingChanged-  | WqProvisionChanged-  | WqGroupKeyChanged-  | IdPrefixChanged-  | DedupeIdentityChanged-  | DerivedIdentityChanged-  | QueueIdentityChanged-  | TimerWindowChanged-  | EmitMappingChanged-  | DecodePostureChanged-  | IntakePersistenceChanged-  | ProjectionChanged-  | PublisherPolicyChanged-  | DispatchRetargeted-  | ContractSchemaVersionBumped-  | EventUndeprecated-  | -- EP-104 (validator soundness).-    WorkflowDuplicateLabel-  | WorkflowSleepDelayUnresolved-  | WorkflowIdFieldUnresolved-  | RuleDomainUnresolved-  | RuleNotTotal-  | RuleCaseUnknownCtor-  | ProcessFieldBindingUnresolved-  | ProcessTimerCeilingInvalid-  | OperationUnresolvedRef-  | AwaitSignalValueMismatch-  | WqDispositionIncomplete-  | DispositionDuplicateOutcome-  | TopicAffinityMismatch-  | StatusMapDanglingKey-  | StatusMapDuplicateKey-  | WriteTargetNotRegister-  | RegisterInitialOutOfScope-  | DuplicateNodeName-  | DuplicateEnumCtor-  | DuplicateEnumWire-  | DuplicateIdPrefix-  | DuplicateCommandName-  | DuplicateEventName-  | WqDlqDivergence-  | WqTableDivergence-  | DispatchDedupQueueUnresolved-  | DispatchDedupFieldUnresolved-  | -- EP-105 (notation integrity and scaffold-safe names).-    VertexCtorCollision-  | IdentUnsafeNormalization-  | GeneratedOccurrenceReserved-  | GeneratedOccurrenceCollision-  | -- EP-107 (first-class read models).-    RmShapeHashDrift-  | RmStrongInlineOnly-  | RmScopeWithoutStrong-  | RmUnknownColumnType-  | RmInlineFeedUnreferenced-  | RmConsistencyConflict-  | RmProjectionWithoutNode-  | QueryUnresolvedReadModel-  | QueryConsistencyInvalid-  | DispatchReadModelUnresolved-  | DispatchReadModelFieldUnknown-  | -- EP-107 diff-only read-model evolution rules.-    ReadModelVersionDecreased-  | ReadModelShapeChangedWithoutBump-  | ReadModelFeedChanged-  | ReadModelConsistencyWeakened-  | -- EP-108 (router and worker-policy surfaces).-    RouterUnresolvedRef-  | RouterKeyFieldUnknown-  | RouterBindingUnscoped-  | RouterCommandUnknown-  | RouterReadModelUnverified-  | PolicyContradiction-  | PolicyDeadLetterUnused-  | AmbiguousMarkedBenign-  | AmbiguousFollowsRejectedPolicy-  | RouterStableNameChanged-  | -- Plan 143 (first-class replay-only transitions for guard evolution).-    -- The first two fire in single-spec @validateSpec@; the third is the-    -- diff-path guard-tightening advisory that prints the computed-    -- replay-only twin.-    ReplayOnlyEmitsNothing-  | ReplayOnlyCommandStillLive-  | AggGuardTightened-  | AggFoldSurfaceChanged-  | RouterDecideSurfaceChanged-  | ProcessDecideSurfaceChanged-  | ProcessTimerPayloadChanged-  | -- MasterPlan 25 / EP-5: append-only codes for findings that were-    -- formerly additive but uncoded.-    DeclarationAdded-  | VersionBumped-  | CompatibilityStrengthened-  | EnumCtorAdded-  | EventRetirementAbandoned-  | ContractEventAdded-  | ContractTopicAdded-  | WorkflowEvolutionGuardAdded-  | -- MasterPlan 25 / EP-149 (consumer-owned mapped types).-    MappedUnresolvedName-  | MappedAmbiguousName-  | MappedDuplicateFieldName-  | MappedDuplicateWireKey-  | MappedDuplicateArmName-  | MappedDuplicateWireTag-  | MappedNonInjectiveNullability-  | MappedRecursiveType-  | MappedUnsupportedEncoding-  | MappedMissingIngredient-  | MappedMissingInitialValue-  | MappedInvalidHaskellName-  | MappedInvalidIdentity-  | MappedImportConflict-  | MappedDefaultIllTyped-  | -- MasterPlan 25 / EP-149 mapped evolution codes.-    MappedFieldAddedWithDefault-  | MappedFieldAddedNoDefault-  | MappedFieldRemoved-  | MappedFieldTypeChanged-  | MappedPresenceChanged-  | MappedNullabilityChanged-  | MappedDefaultRemoved-  | MappedDefaultChanged-  | MappedWireKeyChanged-  | MappedUnionEncodingChanged-  | MappedArmAdded-  | MappedArmRemoved-  | MappedArmTagChanged-  | MappedEnumValueAdded-  | MappedEnumValueRemoved-  | MappedEnumSpellingChanged-  | MappedHaskellSourceChanged-  | MappedRecordConstructorChanged-  | MappedBindingChanged-  | MappedFixturesChanged-  | MappedInitialChanged-  | MappedCanonicalTypeChanged-  | MappedOpaqueCodecChanged-  | MappedModeCrossed-  | MappedDeclAdded-  | MappedDeclRemoved-  | -- MasterPlan 25 / EP-152 reporting and migration-evidence codes.-    CoverageOpaqueSurface-  | CoverageOpaqueBoundaryAdded-  | CoverageOpaqueGateExceeded-  | CodecCompareDifference-  | CodecCompareCoverageGap-  | CodecCompareInvalidInput-  | -- MasterPlan 26 / EP-153: whole-service composition refusals, emitted by-    -- "Keiro.Dsl.Workspace" when several @.keiro@ members are composed into-    -- one service graph. They live in this registry, not a parallel enum, so-    -- every gate stays correlatable by code (ADR 0004). Manifest syntax and-    -- structure errors deliberately have no code here: like a @.keiro@ parse-    -- error, they are refused before any graph exists to diagnose.-    WorkspaceMemberUnreadable-  | WorkspaceMemberParseFailed-  | WorkspaceContextMismatch-  | WorkspaceAuthorityConflict-  | WorkspaceDuplicateDeclaration-  | WorkspaceDuplicateNodeName-  | WorkspacePathCollision-  | -- MasterPlan 26 / EP-155: whole-workspace diff facts. These are-    -- advisory consumer-build obligations, distinct from wire evolution.-    OwnershipMoved-  | WorkspaceAuthorityChanged-  | -- EP-157: canonical aggregate type resolution and capabilities.-    AggregateTypeUnknown-  | AggregateTypeUnsupportedAtUse-  | AggregateRegisterInitialInvalid-  | AggregateGuardTypeMismatch-  | AggregateGuardCapabilityUnsupported-  | AggregateExpressionRootUnknown-  | AggregateExpressionRootAmbiguous-  | AggregateExpressionPathInvalid-  | AggregateExpressionPathUnsupported-  | AggregateExpressionLiteralNeedsType-  | AggregateExpressionLiteralInvalid-  | AggregateExpressionOperandTypeMismatch-  | AggregateExpressionOperatorUnsupported-  | AggregateExpressionBooleanRequired-  | AggregateExpressionGuardBoolRequired-  | AggregateExpressionWriteTargetUnknown-  | AggregateExpressionWriteTypeMismatch-  | AggregateTransitionOwnershipConflict-  | CollectionExpressionUnsupported-  | -- EP-160: append-only source-language composition and diff facts.-    WorkspaceLanguageVersionMismatch-  | SourceLanguageDeclarationChanged-  | -- EP-158: checked consumer-owned nominal IDs, enums, and scalars.-    NominalMissingIngredient-  | NominalInvalidHaskellSource-  | NominalInvalidQualifiedName-  | NominalInvalidIdentity-  | NominalInvalidIdPrefix-  | NominalUnsupportedRepresentation-  | NominalEmptyEnumRepresentation-  | NominalMissingInitialValue-  | NominalNameCollision-  | NominalBindingChanged-  | NominalFixturesChanged-  | NominalCanonicalTypeChanged-  | NominalInitialChanged-  | NominalRepresentationChanged-  | NominalIdDecoderTightened-  | -- ExecPlan 171 / IR-14: versioned prefix-bearing ID admission policy.-    IdDomainContractChanged-  | -- ExecPlan 159 / IR-13: @fields(Command)@ output authority.-    EventOutputCommandMismatch-  | AggregateEventlessStateChange-  | -- ExecPlan 178: language-4 integration contract TypeID admission.-    ContractInvalidTypeIdPrefix-  | ContractTypeIdDomainChanged-  | -- ExecPlan 180: accepted-but-unenforced spec surfaces.-    PublisherOrderingUnknown-  | PublisherBackoffInvalid-  | IntakeDedupePolicyUnknown-  | PublisherMaxAttemptsBelowMinimum-  | ContractSchemaVersionBelowMinimum-  | ReadModelVersionBelowMinimum-  | IntakeDecodeSchemaVersionBelowMinimum-  | AggregateDuplicateFieldName-  | ContractDuplicateFieldName-  | ContractFieldShadowsDiscriminator-  | TransitionDuplicateUnguarded-  | ContractDuplicateEvent-  | ContractDuplicateTopicAlias-  | AggregateDuplicateState-  | AggregateDuplicateRegister-  | NominalDuplicateDeclaration-  | EmitMapDuplicateCase-  | TransitionUnguardedSibling-  | RuntimeIdentityInvalid-  | RuntimeIdentityDuplicate-  | ContractTopicNameInvalid-  | ReadModelIdentifierInvalid-  | ReadModelDuplicateColumn-  | IntakeBindUnresolved-  | IntakeDedupeKeyUnresolved-  | IntakeEnvelopePolicyUnknown-  | IntakeDecodeSchemaVersionMismatch-  | ContractTopicAliasUnresolved-  | WireClauseUnsupported-  | -- ExecPlan 190: an unchanged semantic/external declaration now presents a-    -- different generated Haskell occurrence.-    GeneratedHaskellNameChanged-  | -- ExecPlan 192: resolved field wire identities are checked before lowering.-    FieldWireKeyCollision-  | FieldWireKeyInvalid-  | -- ExecPlan 192: changing an aggregate event field's resolved wire key-    -- changes the persisted event decode surface.-    EvtFieldWireKeyChanged-  | -- ExecPlan 193: a CI-required released language floor was not met.-    LanguageVersionBelowMinimum-  | -- ExecPlan 194: scaffold's empty-node refusals are reported by check at-    -- the owning declaration before planning begins.-    AggregateEmpty-  | ContractEmpty-  | -- ExecPlan 194: pure scaffold-planning gates share check's located,-    -- machine-readable diagnostic pipeline.-    GeneratedPathCollision-  | GeneratedImportCycle-  | BehaviorDerivationInvalid-  | ConformanceFactKeyCollision-  | GeneratedPlanningInvariantViolation-  | -- ExecPlan 197: accepted but currently inert spec surfaces are reported-    -- through the ordinary warning pipeline.-    IntakeBindFlagUnenforced-  | RmInlineSubscriptionIgnored-  | -- ExecPlan 197: process and router references close under language 4.-    ProcessKeyFieldUnknown-  | ProcessDispatchKeyUnresolved-  | ProcessBindingUnscoped-  | -- ExecPlan 197: remaining accepted surfaces close under language 4.-    WqPayloadTypeUnknown-  | WindowOutOfRange-  | TimerIdFieldNotCorrelation-  | AggProjectionKeyUnresolved-  | PublisherOutboxFieldUnresolved-  | RouterBenignInversion-  | -- ExecPlan 199: spellings the grammar accepts that no runtime implements.-    -- Each names one concrete runtime fact the declaration contradicts, warns on-    -- released languages below 4, and errors from language 4 on.-    DecodeBodyPostureUnsupported-  | DispatchOnAppendedUnsupported-  | TimerNotMineUnsupported-  | IntakeBindHeaderUnknown-  | -- ExecPlan 199: the surfaces ExecPlan 197 parked as descriptive-only, closed-    -- by checking the reference each one actually names.-    TimerDecodeStatusUnknown-  | TimerDeadLetterTextInvalid-  | PgmqFanoutFunctionInvalid-  deriving stock (Eq, Ord, Show, Enum, Bounded)---- | Which command pipeline can actually produce a given 'DiagnosticCode'.------ The registry exists so a CI warning policy cannot silently name a code the--- selected command never emits. Before ExecPlan 199, @keiro-dsl check --deny--- EvtFieldWireKeyChanged@ was accepted and then matched nothing forever,--- because that code is only reachable from @diff@'s cross-revision comparison.-data DiagnosticOrigin-  = -- | Reachable from @check@ on a single spec or a workspace. This includes-    -- the pure scaffold-planning gates that @check@ replays, and it is the-    -- default for any code not positively classified below.-    CheckDiagnostic-  | -- | Reachable only from the structural-coverage pass, which runs only when-    -- @--coverage-report@ is supplied.-    CoverageDiagnostic-  | -- | Reachable only from @diff@, which compares two revisions of a spec.-    -- Nothing in a single-revision @check@ can produce these.-    DiffDiagnostic-  | -- | Reachable only from the generated codec-comparison path, which no-    -- @check@ or @diff@ invocation runs.-    CodecCompareDiagnostic-  deriving stock (Eq, Ord, Show, Enum, Bounded)---- | Classify a code by the pipeline that emits it.------ Only codes proven non-@check@ are listed; everything else falls through to--- 'CheckDiagnostic'. The default is deliberately the permissive one: a--- misclassification here would reject a working CI invocation, whereas falling--- through merely preserves the pre-199 behavior of accepting the code.-diagnosticOrigin :: DiagnosticCode -> DiagnosticOrigin-diagnosticOrigin diagnosticCode = case diagnosticCode of-  -- Structural coverage, reachable from `check --coverage-report`.-  CoverageOpaqueSurface -> CoverageDiagnostic-  CoverageOpaqueGateExceeded -> CoverageDiagnostic-  -- Coverage delta, computed only against a previous revision.-  CoverageOpaqueBoundaryAdded -> DiffDiagnostic-  -- Generated codec comparison.-  CodecCompareDifference -> CodecCompareDiagnostic-  CodecCompareCoverageGap -> CodecCompareDiagnostic-  CodecCompareInvalidInput -> CodecCompareDiagnostic-  -- Cross-revision evolution facts.-  AggFoldSurfaceChanged -> DiffDiagnostic-  AggGuardTightened -> DiffDiagnostic-  CompatibilityStrengthened -> DiffDiagnostic-  ContractDiscriminatorChanged -> DiffDiagnostic-  ContractEventAdded -> DiffDiagnostic-  ContractEventRemoved -> DiffDiagnostic-  ContractFieldChanged -> DiffDiagnostic-  ContractSchemaVersionBumped -> DiffDiagnostic-  ContractSchemaVersionDecreased -> DiffDiagnostic-  ContractTopicAdded -> DiffDiagnostic-  ContractTopicChanged -> DiffDiagnostic-  ContractTypeIdDomainChanged -> DiffDiagnostic-  DeclarationAdded -> DiffDiagnostic-  DecodePostureChanged -> DiffDiagnostic-  DedupeIdentityChanged -> DiffDiagnostic-  DerivedIdentityChanged -> DiffDiagnostic-  DispatchRetargeted -> DiffDiagnostic-  EmitMappingChanged -> DiffDiagnostic-  EnumCtorAdded -> DiffDiagnostic-  EnumCtorRemoved -> DiffDiagnostic-  EnumWireSpellingChanged -> DiffDiagnostic-  EventRetirementAbandoned -> DiffDiagnostic-  EventUndeprecated -> DiffDiagnostic-  EvtFieldAddedWithoutBump -> DiffDiagnostic-  EvtFieldRemovedSameVersion -> DiffDiagnostic-  EvtFieldTypeChanged -> DiffDiagnostic-  EvtFieldWireKeyChanged -> DiffDiagnostic-  EvtRemovedNotDeprecated -> DiffDiagnostic-  EvtVersionDecreased -> DiffDiagnostic-  GeneratedHaskellNameChanged -> DiffDiagnostic-  IdDomainContractChanged -> DiffDiagnostic-  IdPrefixChanged -> DiffDiagnostic-  IntakePersistenceChanged -> DiffDiagnostic-  MappedArmAdded -> DiffDiagnostic-  MappedArmRemoved -> DiffDiagnostic-  MappedArmTagChanged -> DiffDiagnostic-  MappedBindingChanged -> DiffDiagnostic-  MappedCanonicalTypeChanged -> DiffDiagnostic-  MappedDeclAdded -> DiffDiagnostic-  MappedDeclRemoved -> DiffDiagnostic-  MappedDefaultChanged -> DiffDiagnostic-  MappedDefaultRemoved -> DiffDiagnostic-  MappedEnumSpellingChanged -> DiffDiagnostic-  MappedEnumValueAdded -> DiffDiagnostic-  MappedEnumValueRemoved -> DiffDiagnostic-  MappedFieldAddedNoDefault -> DiffDiagnostic-  MappedFieldAddedWithDefault -> DiffDiagnostic-  MappedFieldRemoved -> DiffDiagnostic-  MappedFieldTypeChanged -> DiffDiagnostic-  MappedFixturesChanged -> DiffDiagnostic-  MappedHaskellSourceChanged -> DiffDiagnostic-  MappedInitialChanged -> DiffDiagnostic-  MappedModeCrossed -> DiffDiagnostic-  MappedNullabilityChanged -> DiffDiagnostic-  MappedOpaqueCodecChanged -> DiffDiagnostic-  MappedPresenceChanged -> DiffDiagnostic-  MappedRecordConstructorChanged -> DiffDiagnostic-  MappedUnionEncodingChanged -> DiffDiagnostic-  MappedWireKeyChanged -> DiffDiagnostic-  NominalBindingChanged -> DiffDiagnostic-  NominalCanonicalTypeChanged -> DiffDiagnostic-  NominalFixturesChanged -> DiffDiagnostic-  NominalIdDecoderTightened -> DiffDiagnostic-  NominalInitialChanged -> DiffDiagnostic-  NominalRepresentationChanged -> DiffDiagnostic-  OwnershipMoved -> DiffDiagnostic-  ProcessDecideSurfaceChanged -> DiffDiagnostic-  ProcessInputChanged -> DiffDiagnostic-  ProcessTimerPayloadChanged -> DiffDiagnostic-  ProjectionChanged -> DiffDiagnostic-  PublisherPolicyChanged -> DiffDiagnostic-  QueueIdentityChanged -> DiffDiagnostic-  ReadModelConsistencyWeakened -> DiffDiagnostic-  ReadModelFeedChanged -> DiffDiagnostic-  ReadModelShapeChangedWithoutBump -> DiffDiagnostic-  ReadModelVersionDecreased -> DiffDiagnostic-  RouterDecideSurfaceChanged -> DiffDiagnostic-  RouterStableNameChanged -> DiffDiagnostic-  SourceLanguageDeclarationChanged -> DiffDiagnostic-  TimerWindowChanged -> DiffDiagnostic-  VersionBumped -> DiffDiagnostic-  WireSpecChanged -> DiffDiagnostic-  WorkflowBodyChanged -> DiffDiagnostic-  WorkflowContinueSeedChanged -> DiffDiagnostic-  WorkflowEvolutionGuardAdded -> DiffDiagnostic-  WorkflowPatchRemoved -> DiffDiagnostic-  WorkflowShapeChanged -> DiffDiagnostic-  WorkflowStableNameChanged -> DiffDiagnostic-  WorkspaceAuthorityChanged -> DiffDiagnostic-  WqGroupKeyChanged -> DiffDiagnostic-  WqOrderingChanged -> DiffDiagnostic-  WqPayloadFieldChanged -> DiffDiagnostic-  WqProvisionChanged -> DiffDiagnostic-  _ -> CheckDiagnostic---- | A line-numbered, structured diagnostic.-data Diagnostic = Diagnostic-  { line :: !Int,-    severity :: !Severity,-    code :: !DiagnosticCode,-    relatedLocations :: ![(Int, Text)],-    message :: !Text-  }-  deriving stock (Eq, Show)---- | Render a diagnostic in the conventional--- @\<file\>:\<line\>: error[\<code\>]: \<message\>@ form.-renderDiagnostic :: FilePath -> Diagnostic -> Text-renderDiagnostic file d =-  T.intercalate "\n" (primary : notes)-  where-    primary =-      T.pack file-        <> ":"-        <> T.pack (show (line d))-        <> ": "-        <> sev-        <> "["-        <> T.pack (show (code d))-        <> "]: "-        <> message d-    notes =-      [ "  " <> T.pack file <> ":" <> T.pack (show noteLine) <> ": note: " <> note-      | (noteLine, note) <- relatedLocations d-      ]-    sev = case severity d of Error -> "error"; Warning -> "warning"---- | Error diagnostics produced when the effective source language is below a--- CI-required released floor. A legacy source has no preamble, so line 1 is the--- actionable location where one should be added.-minimumLanguageDiagnostics :: LanguageVersion -> SourceLanguage -> [Diagnostic]-minimumLanguageDiagnostics floorVersion sourceLanguage-  | effectiveVersion >= floorVersion = []-  | otherwise =-      [ Diagnostic-          { line = sourceLanguageLine sourceLanguage,-            severity = Error,-            code = LanguageVersionBelowMinimum,-            relatedLocations = [],-            message =-              "effective language version "-                <> languageVersionText effectiveVersion-                <> " ("-                <> sourceFormText sourceLanguage-                <> ") is below the required minimum "-                <> languageVersionText floorVersion-                <> "; declare `language keiro-dsl "-                <> languageVersionText floorVersion-                <> "`"-          }-      ]-  where-    effectiveVersion = effectiveLanguageVersion sourceLanguage-    sourceLanguageLine LegacyUnversioned = 1-    sourceLanguageLine DeclaredLanguage {languageVersionLoc = Loc lineNumber} = lineNumber---- | Reserved wall-clock atom names. Sampling any of these inside a guard or--- write breaks deterministic replay: TIME IS INJECTED, NOT SAMPLED.-clockAtoms :: Set Name-clockAtoms = Set.fromList ["now", "currentTime", "wallClock", "today", "utcNow"]---- | Validate a whole service under its effective released semantic contract.--- An empty list means valid. Current released versions share this policy, but--- selecting it at this boundary prevents successor semantics from being lost.-validateService :: CheckedService -> [Diagnostic]-validateService service = validateCheckedSpec (checkedLanguageContract service) (checkedSpec service)---- | Compatibility wrapper for callers that have only a normalized graph. It--- explicitly selects legacy/version-1 semantics; production source/workspace--- routes use 'validateService'.-validateSpec :: Spec -> [Diagnostic]-validateSpec = validateService . legacyCheckedService--validateCheckedSpec :: EffectiveLanguageContract -> Spec -> [Diagnostic]-validateCheckedSpec languageContract spec =-  sortOn line (validateNames languageContract spec ++ validateMapped spec ++ validateNominal languageContract spec ++ validateAggregateTypes spec ++ specLevelRules languageContract spec ++ concatMap (validateNode languageContract spec) (specNodes spec))---- | Rules added before language 4 ships consult the effective semantic--- contract, not the numeric source spelling. Versions 1 through 3 retain their--- released acceptance; runtime semantics 3 is the unreleased tightening gate.-enforcesSpecSurfaceClosures :: EffectiveLanguageContract -> Bool-enforcesSpecSurfaceClosures languageContract =-  runtimeProfileHasCapability (effectiveRuntimeProfile languageContract) StrictSpecSurfaceValidation--validateNominal :: EffectiveLanguageContract -> Spec -> [Diagnostic]-validateNominal languageContract spec = domainErrors <> resolutionErrors-  where-    domainErrors =-      [ mkErr (locLine (idLoc declaration)) NominalInvalidIdPrefix $-          "id '" <> idName declaration <> "' has invalid TypeID prefix '" <> idPrefix declaration <> "': " <> T.pack (show reason)-      | declaration <- specIds spec,-        Just _ <- [idDomainContractFor languageContract (idPrefix declaration)],-        Just reason <- [TypeID.checkPrefix (idPrefix declaration)]-      ]-    resolutionErrors = case Nominal.resolveNominalTypes spec of-      Right _ -> []-      Left errors -> map nominalTypeDiagnostic (NE.toList errors)--nominalTypeDiagnostic :: Nominal.NominalTypeError -> Diagnostic-nominalTypeDiagnostic nominalError = case nominalError of-  Nominal.NominalMissingIngredient name loc ingredient ->-    problem loc NominalMissingIngredient $ "nominal declaration '" <> name <> "' is missing required " <> ingredient <> " provenance"-  Nominal.NominalInvalidHaskellSource name loc ingredient ->-    problem loc NominalInvalidHaskellSource $ "nominal declaration '" <> name <> "' has an invalid Haskell " <> ingredient <> " name"-  Nominal.NominalInvalidQualifiedValue name loc ingredient value ->-    problem loc NominalInvalidQualifiedName $-      "nominal declaration '" <> name <> "' has invalid " <> ingredient <> " symbol '" <> value <> "'; expected a module path plus a lower-initial value"-  Nominal.NominalInvalidIdentity name loc ingredient value ->-    problem loc NominalInvalidIdentity $ "nominal declaration '" <> name <> "' has invalid " <> ingredient <> " '" <> value <> "'"-  Nominal.NominalInvalidIdPrefix name loc prefix detail ->-    problem loc NominalInvalidIdPrefix $ "id '" <> name <> "' has invalid TypeID prefix '" <> prefix <> "': " <> detail-  Nominal.NominalUnsupportedScalar name loc representation ->-    problem loc NominalUnsupportedRepresentation $-      "nominal scalar '" <> name <> "' uses unsupported representation '" <> representation <> "'; supported representations are Text, Int, Natural, Bool, and Time"-  Nominal.NominalEmptyEnum name loc ->-    problem loc NominalEmptyEnumRepresentation $ "enum '" <> name <> "' must declare at least one closed representation constructor"-  Nominal.NominalMissingRegisterInitial name loc registerName ->-    problem loc NominalMissingInitialValue $-      "consumer-owned nominal type '" <> name <> "' is used by register '" <> registerName <> "' and must name an initial symbol"-  Nominal.NominalDeclarationCollision name loc categories ->-    problem loc NominalNameCollision $ "declaration name '" <> name <> "' collides across " <> T.intercalate ", " categories-  where-    problem loc diagnosticCode detail = mkErr (locLine loc) diagnosticCode (detail <> "; GHC and conformance validate consumer function bodies")---- | Resolve every direct aggregate type once at the earliest semantic gate.-validateAggregateTypes :: Spec -> [Diagnostic]-validateAggregateTypes spec = case Nominal.resolveNominalTypes spec of-  Left _ -> []-  Right _ -> concatMap aggregateRules aggregates-  where-    symbols = aggregateSymbols spec-    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]--    aggregateRules aggregate =-      concatMap commandRules (aggCommands aggregate)-        ++ concatMap eventRules (aggEvents aggregate)-        ++ concatMap registerRules (aggRegs aggregate)-        ++ concatMap (transitionRules aggregate) (aggTransitions aggregate)-      where-        commandRules command = concatMap (fieldRule aggregate CommandFieldUse) (cmdFields command)-        eventRules event = case evBody event of-          EventFields fields -> concatMap (fieldRule aggregate EventFieldUse) fields-          EventFromCommand _ -> []-        registerRules register = case resolveAggregateType symbols (regLoc register) RegisterUse (regType register) of-          Left typeError -> [aggregateTypeDiagnostic typeError]-          Right AggregateMapped {} -> []-          Right resolved -> case resolveRegisterInitial symbols (regLoc register) resolved (regInitial register) of-            Left initialError -> [aggregateTypeDiagnostic initialError]-            Right _ -> []--    fieldRule aggregate useSite field =-      either (pure . aggregateTypeDiagnostic) (const []) (inferAggregateFieldType symbols aggregate useSite field)--    transitionRules aggregate transition = case tImplementation transition of-      LegacyHoleImplementation ->-        concatMap (comparisonRule aggregate transition) (maybe [] comparisons (tGuard transition))-      GeneratedImplementation ->-        let environment = expressionEnvironment spec aggregate transition-         in maybe [] (expressionDiagnostics . resolveGuardExpr environment) (tGuard transition)-              ++ concatMap (expressionDiagnostics . uncurry (resolveWriteExpr environment)) (tWrites transition)-      HoleImplementation ->-        [ mkErr (locLine (tLoc transition)) AggregateTransitionOwnershipConflict $-            "transition '"-              <> tSource transition-              <> " -- "-              <> tCommand transition-              <> "' selects implementation hole and therefore cannot also declare guard or write clauses"-        | tGuard transition /= Nothing || not (null (tWrites transition))-        ]--    expressionDiagnostics = either (map expressionDiagnostic . NE.toList) (const [])--    expressionDiagnostic diagnostic =-      mkErr-        (locLine (expressionDiagnosticLoc diagnostic))-        (expressionCode (expressionDiagnosticCode diagnostic))-        (expressionDiagnosticMessage diagnostic)--    expressionCode = \case-      ScalarRootUnknown -> AggregateExpressionRootUnknown-      ScalarRootAmbiguous -> AggregateExpressionRootAmbiguous-      ScalarPathInvalid -> AggregateExpressionPathInvalid-      ScalarPathUnsupported -> AggregateExpressionPathUnsupported-      ScalarLiteralNeedsType -> AggregateExpressionLiteralNeedsType-      ScalarLiteralInvalid -> AggregateExpressionLiteralInvalid-      ScalarOperandTypeMismatch -> AggregateExpressionOperandTypeMismatch-      ScalarOperatorUnsupported -> AggregateExpressionOperatorUnsupported-      ScalarBooleanOperandRequired -> AggregateExpressionBooleanRequired-      ScalarGuardBoolRequired -> AggregateExpressionGuardBoolRequired-      ScalarWriteTargetUnknown -> AggregateExpressionWriteTargetUnknown-      ScalarWriteTypeMismatch -> AggregateExpressionWriteTypeMismatch--    comparisonRule aggregate transition (operator, left, right) =-      case (expressionType aggregate transition left, expressionType aggregate transition right) of-        (Right leftType, Right rightType)-          | leftType /= rightType ->-              [ mkErr (locLine (tLoc transition)) AggregateGuardTypeMismatch $-                  "comparison operands have different aggregate types '"-                    <> aggregateCanonicalName leftType-                    <> "' and '"-                    <> aggregateCanonicalName rightType-                    <> "'"-              ]-          | aggregateCapability useSite leftType == Unsupported ->-              [ mkErr (locLine (tLoc transition)) AggregateGuardCapabilityUnsupported $-                  renderAggregateUseSite useSite-                    <> " is unsupported for aggregate type '"-                    <> aggregateCanonicalName leftType-                    <> "'"-              ]-          | otherwise -> []-        _ -> []-      where-        useSite = case operator of-          OpEq -> EqualityGuardUse-          OpNeq -> EqualityGuardUse-          OpLt -> OrderingGuardUse-          OpLe -> OrderingGuardUse-          OpGt -> OrderingGuardUse-          OpGe -> OrderingGuardUse--    expressionType aggregate transition expression = case expression of-      EAtom (ABool _) -> pure AggregateBool-      EAtom (AName name) -> atomType aggregate transition name-      EOr {} -> pure AggregateBool-      EAnd {} -> pure AggregateBool-      ECmp {} -> pure AggregateBool-      EAdd _ left _ -> expressionType aggregate transition left-      ESubtract _ left _ -> expressionType aggregate transition left-      EMultiply _ left _ -> expressionType aggregate transition left-      EPath loc _ path -> case path of-        name : _ -> atomType aggregate transition name-        [] -> Left (AggregateTypeError loc EqualityGuardUse (UnknownAggregateType "<empty-path>"))-      ELiteral _ literal -> case literal of-        LiteralBool {} -> pure AggregateBool-        LiteralText {} -> pure AggregateText-        LiteralIntegral {} -> Left (AggregateTypeError (exprLoc expression) EqualityGuardUse (UnknownAggregateType "<contextual-integral-literal>"))-        LiteralQualified typeName _ -> resolveAggregateType symbols (exprLoc expression) EqualityGuardUse (TRef typeName)-        LiteralId typeName _ -> resolveAggregateType symbols (exprLoc expression) EqualityGuardUse (TRef typeName)--    atomType aggregate transition name = case [register | register <- aggRegs aggregate, regName register == name] of-      register : _ -> resolveAggregateType symbols (regLoc register) RegisterUse (regType register)-      [] -> case [field | command <- aggCommands aggregate, cmdName command == tCommand transition, field <- cmdFields command, aggregateFieldName field == name] of-        field : _ -> inferAggregateFieldType symbols aggregate CommandFieldUse field-        [] -> case [enumName declaration | declaration <- specEnums spec, name `elem` map fst (enumCtors declaration)] of-          enumType : _ -> resolveAggregateType symbols (tLoc transition) CommandFieldUse (TRef enumType)-          []-            | name `elem` map stName (aggStates aggregate) -> pure (AggregateVertex (aggName aggregate <> "Vertex"))-            | Just rule <- firstMatching ((== name) . ruleName) (specRules spec) ->-                resolveAggregateType symbols (ruleLoc rule) EqualityGuardUse (nameTypeExpr (ruleCodomain rule))-            | otherwise -> Left (AggregateTypeError (tLoc transition) EqualityGuardUse (UnknownAggregateType name))--    nameTypeExpr name = case name of-      "Text" -> TText-      "Int" -> TInt-      "Bool" -> TBool-      "Natural" -> TNatural-      "Time" -> TTime-      "UTCTime" -> TTime-      "Json" -> TJson-      _ -> TRef name--    comparisons expression = case expression of-      EOr left right -> comparisons left <> comparisons right-      EAnd left right -> comparisons left <> comparisons right-      ECmp operator left right -> (operator, left, right) : comparisons left <> comparisons right-      EAdd _ left right -> comparisons left <> comparisons right-      ESubtract _ left right -> comparisons left <> comparisons right-      EMultiply _ left right -> comparisons left <> comparisons right-      EPath {} -> []-      ELiteral {} -> []-      EAtom {} -> []--aggregateTypeDiagnostic :: AggregateTypeError -> Diagnostic-aggregateTypeDiagnostic aggregateError =-  mkErr (locLine (aggregateTypeErrorLoc aggregateError)) diagnosticCode diagnosticMessage-  where-    diagnosticCode = case aggregateTypeErrorReason aggregateError of-      UnknownAggregateType {} -> AggregateTypeUnknown-      UnsupportedAggregateShape {} -> AggregateTypeUnsupportedAtUse-      UnsupportedAggregateCapability {} -> case aggregateTypeErrorUseSite aggregateError of-        EqualityGuardUse -> AggregateGuardCapabilityUnsupported-        OrderingGuardUse -> AggregateGuardCapabilityUnsupported-        _ -> AggregateTypeUnsupportedAtUse-      InvalidRegisterInitial {} -> AggregateRegisterInitialInvalid-    diagnosticMessage = case aggregateTypeErrorReason aggregateError of-      UnknownAggregateType name ->-        "unknown aggregate type '" <> name <> "' at " <> renderAggregateUseSite (aggregateTypeErrorUseSite aggregateError)-      UnsupportedAggregateShape expression ->-        "direct aggregate type '"-          <> typeExprCanonicalName expression-          <> "' is unsupported at "-          <> renderAggregateUseSite (aggregateTypeErrorUseSite aggregateError)-          <> "; use a mapped structural declaration for Json or container shapes"-      UnsupportedAggregateCapability resolved ->-        renderAggregateUseSite (aggregateTypeErrorUseSite aggregateError)-          <> " is unsupported for aggregate type '"-          <> aggregateCanonicalName resolved-          <> "'"-      InvalidRegisterInitial resolved detail ->-        "invalid " <> aggregateCanonicalName resolved <> " register initial: " <> detail--renderAggregateUseSite :: AggregateUseSite -> Text-renderAggregateUseSite useSite = case useSite of-  CommandFieldUse -> "command field"-  EventFieldUse -> "event field"-  RegisterUse -> "register"-  EqualityGuardUse -> "equality guard"-  OrderingGuardUse -> "ordering guard"-  WholeValueWriteUse -> "whole-value write"-  CodecUse -> "JSON codec"-  SnapshotUse -> "snapshot"-  HarnessSampleUse -> "harness sample"-  HaskellLoweringUse -> "Haskell lowering"---- | Validate consumer-owned mapped declarations without inspecting consumer--- Haskell. Symbol-shaped facts are checked lexically here; GHC remains the--- authority for whether the named packages, modules, values, types, and--- instances actually exist with the promised types.-validateMapped :: Spec -> [Diagnostic]-validateMapped spec =-  mappedLexicalRules spec-    ++ mappedIdentityRules spec-    ++ mappedConflictRules spec-    ++ case resolveTypeGraph spec of-      Left errors -> concatMap (typeGraphDiagnostic spec) (NE.toList errors)-      Right graph -> mappedGraphRules spec graph--typeGraphDiagnostic :: Spec -> TypeGraphError -> [Diagnostic]-typeGraphDiagnostic spec = \case-  TGDeclError name declarationError ->-    [ mkErr (mappedLine spec name) diagnosticCode $-        "mapped declaration '" <> name <> "': " <> declarationErrorMessage declarationError-    ]-    where-      diagnosticCode = case declarationError of-        MissingHaskellSource {} -> MappedMissingIngredient-        MissingStructuralBinding {} -> MappedMissingIngredient-        MissingStructuralBindingVersion {} -> MappedMissingIngredient-        MissingCanonicalType {} -> MappedMissingIngredient-        MissingFixtureCases {} -> MappedMissingIngredient-        MissingOpaqueCodecIdentity {} -> MappedMissingIngredient-        MissingOpaqueCodecVersion {} -> MappedMissingIngredient-        EmptyQualifiedValueName {} -> MappedInvalidHaskellName-        EmptyCanonicalTypeId {} -> MappedInvalidIdentity-        EmptyBindingVersion {} -> MappedInvalidIdentity-        EmptyCodecIdentity {} -> MappedInvalidIdentity-        EmptyCodecVersion {} -> MappedInvalidIdentity-  TGAmbiguousName name origins ->-    [ mkErr (mappedLine spec name) MappedAmbiguousName $-        "type name '" <> name <> "' is ambiguous across " <> T.intercalate ", " origins-    ]-  TGUnresolvedRef owner missing loc ->-    [ mkErr (locLine loc) MappedUnresolvedName $-        "mapped declaration '" <> owner <> "' references unresolved mapped type '" <> missing <> "'"-    ]-  TGRecursive names ->-    [ mkErr (mappedLine spec (headOr "<mapped>" names)) MappedRecursiveType $-        "recursive structural mapping is unsupported: " <> T.intercalate " -> " (names <> take 1 names)-    ]--declarationErrorMessage :: MappedDeclError -> Text-declarationErrorMessage = \case-  MissingHaskellSource _ -> "missing complete haskell package/module/type ingredient"-  MissingStructuralBinding _ -> "missing binding ingredient; GHC will verify the named value and its type"-  MissingStructuralBindingVersion _ -> "missing binding-version ingredient"-  MissingCanonicalType _ -> "missing canonical-type ingredient"-  MissingFixtureCases _ -> "missing fixtures ingredient; GHC will verify the named FixtureCases value"-  MissingOpaqueCodecIdentity _ -> "missing opaque codec identity ingredient"-  MissingOpaqueCodecVersion _ -> "missing opaque codec version ingredient"-  EmptyQualifiedValueName _ -> "a binding, fixture, or initial symbol is empty; GHC will verify a syntactically valid qualified value"-  EmptyCanonicalTypeId _ -> "canonical-type must be non-empty"-  EmptyBindingVersion _ -> "binding-version must be non-empty"-  EmptyCodecIdentity _ -> "opaque codec identity must be non-empty"-  EmptyCodecVersion _ -> "opaque codec version must be non-empty"--mappedLine :: Spec -> Name -> Int-mappedLine spec name =-  maybe 1 (locLine . mappedLoc) (firstMatching ((== name) . mappedName) (specMapped spec))--mappedName :: MappedDecl -> Name-mappedName MappedStructural {msName = name} = name-mappedName MappedOpaque {moName = name} = name--mappedLoc :: MappedDecl -> Loc-mappedLoc MappedStructural {msLoc = loc} = loc-mappedLoc MappedOpaque {moLoc = loc} = loc--mappedHaskell :: MappedDecl -> Maybe HaskellSource-mappedHaskell MappedStructural {msHaskell = source} = source-mappedHaskell MappedOpaque {moHaskell = source} = source--mappedCanonical :: MappedDecl -> Maybe Text-mappedCanonical MappedStructural {msCanonical = canonical} = canonical-mappedCanonical MappedOpaque {} = Nothing--mappedLexicalRules :: Spec -> [Diagnostic]-mappedLexicalRules spec = concatMap declarationRules (specMapped spec)-  where-    declarationRules declaration =-      constructorRule "mapped declaration name" (mappedName declaration) declaration-        ++ maybe [] (haskellRules declaration) (mappedHaskell declaration)-        ++ qualifiedFacts declaration-        ++ shapeConstructorRules declaration--    haskellRules declaration source =-      [ invalid declaration $ "Haskell package '" <> hsPackage source <> "' does not follow Cabal package-name grammar"-      | not (isCabalPackageName (hsPackage source))-      ]-        ++ [ invalid declaration $ "Haskell module '" <> hsModule source <> "' must be dot-separated Upper identifiers"-           | not (moduleNameSafe (hsModule source))-           ]-        ++ [ invalid declaration $ "Haskell type '" <> hsType source <> "' must be an Upper identifier"-           | not (constructorSafe (hsType source))-           ]--    qualifiedFacts MappedStructural {msBinding = binding, msFixtures = fixtures, msInitial = initial, msLoc = loc} =-      concatMap (qualifiedRule loc) [("binding", binding), ("fixtures", fixtures), ("initial", initial)]-    qualifiedFacts MappedOpaque {moFixtures = fixtures, moInitial = initial, moLoc = loc} =-      concatMap (qualifiedRule loc) [("fixtures", fixtures), ("initial", initial)]--    qualifiedRule loc (category, value) = case value of-      Just symbol-        | not (T.null symbol) && not (qualifiedValueSafe symbol) ->-            [ mkErr (locLine loc) MappedInvalidHaskellName $-                category <> " symbol '" <> symbol <> "' must be a module path plus a lower-initial value; GHC will verify that it exists with the promised type"-            ]-      _ -> []--    shapeConstructorRules declaration = case declaration of-      MappedStructural {msShape = ShapeRecord constructor _ fields} ->-        constructorRule "record constructor" constructor declaration-          ++ [ invalidAt (wireFieldLoc field) $ "record selector '" <> wfHaskell field <> "' must be a lower-initial Haskell identifier"-             | field <- fields,-               not (lowerIdentifierSafe (wfHaskell field))-             ]-      MappedStructural {msShape = ShapeEnum entries} ->-        [ invalidAt (weLoc entry) $ "enum constructor '" <> weCtor entry <> "' must be an Upper identifier"-        | entry <- entries,-          not (constructorSafe (weCtor entry))-        ]-      MappedStructural {msShape = ShapeUnion _ arms} ->-        [ invalidAt (waLoc arm) $ "union constructor '" <> waCtor arm <> "' must be an Upper identifier"-        | arm <- arms,-          not (constructorSafe (waCtor arm))-        ]-      MappedOpaque {} -> []--    constructorRule category value declaration =-      [ invalid declaration $ category <> " '" <> value <> "' must be an Upper identifier"-      | not (constructorSafe value)-      ]-    invalid declaration detail = invalidAt (mappedLoc declaration) detail-    invalidAt loc detail =-      mkErr (locLine loc) MappedInvalidHaskellName (detail <> "; this is a syntax check only, and GHC will verify the consumer declaration")--mappedIdentityRules :: Spec -> [Diagnostic]-mappedIdentityRules spec =-  [ mkErr (locLine (mappedLoc declaration)) MappedInvalidIdentity $-      "mapped declaration '" <> mappedName declaration <> "' has an identity/version containing an ASCII control character"-  | declaration <- specMapped spec,-    value <- identityValues declaration,-    T.any asciiControl value-  ]-  where-    identityValues MappedStructural {msBindingVersion = bindingVersion, msCanonical = canonical} = present [bindingVersion, canonical]-    identityValues MappedOpaque {moCodecId = codecIdentity, moCodecVersion = codecVersion} = present [codecIdentity, codecVersion]-    present = foldr (maybe id (:)) []--mappedConflictRules :: Spec -> [Diagnostic]-mappedConflictRules spec = sourceCollisions ++ canonicalCollisions ++ packageCollisions-  where-    declarations = specMapped spec-    sourceFacts = [(declaration, source) | declaration <- declarations, source <- maybeToList (mappedHaskell declaration)]-    sourceCollisions =-      [ conflict declaration $-          "Haskell target '" <> hsModule source <> "." <> hsType source <> "' is claimed by more than one mapped declaration"-      | (declaration, source) <- duplicatesBy (\(_, value) -> (hsModule value, hsType value)) sourceFacts-      ]-    canonicalFacts = [(declaration, canonical) | declaration <- declarations, canonical <- maybeToList (mappedCanonical declaration), not (T.null canonical)]-    canonicalCollisions =-      [ conflict declaration $ "canonical-type '" <> canonical <> "' is claimed by more than one mapped declaration"-      | (declaration, canonical) <- duplicatesBy snd canonicalFacts-      ]-    moduleFacts = [(declaration, hsModule source, hsPackage source) | (declaration, source) <- sourceFacts]-    packageCollisions =-      [ conflict declaration $-          "Haskell module '" <> moduleName <> "' is declared from conflicting packages '" <> oldPackage <> "' and '" <> packageName <> "'"-      | (index, (declaration, moduleName, packageName)) <- zip [0 :: Int ..] moduleFacts,-        (_, oldModule, oldPackage) <- take index moduleFacts,-        oldModule == moduleName,-        oldPackage /= packageName-      ]-    conflict declaration detail = mkErr (locLine (mappedLoc declaration)) MappedImportConflict detail-    maybeToList = maybe [] pure--mappedGraphRules :: Spec -> TypeGraph -> [Diagnostic]-mappedGraphRules spec graph =-  concatMap declarationRules (Map.elems (tgDeclarations graph))-    ++ mappedRegisterInitialRules spec graph-  where-    declarationRules =-      foldMappedDecl-        MappedDeclAlgebra-          { onStructuralDecl = \declaration shape ->-              foldMappedShape (shapeRules declaration) shape,-            onOpaqueDecl = const []-          }--    shapeRules declaration =-      MappedShapeAlgebra-        { onRecord = \_ _ fields ->-            [ mappedError (rwfLoc field) MappedDuplicateFieldName declaration $-                "record selector '" <> rwfHaskell field <> "' is declared more than once"-            | field <- duplicatesBy rwfHaskell fields-            ]-              ++ [ mappedError (rwfLoc field) MappedDuplicateWireKey declaration $-                     "record wire key '" <> rwfKey field <> "' is declared more than once"-                 | field <- duplicatesBy rwfKey fields-                 ]-              ++ [ mappedError (rwfLoc field) MappedUnsupportedEncoding declaration "record wire keys must be non-empty"-                 | field <- fields,-                   T.null (rwfKey field)-                 ]-              ++ concatMap (fieldRules declaration) fields,-          onEnum = \entries ->-            [ mappedError (weLoc entry) MappedDuplicateArmName declaration $-                "enum constructor '" <> weCtor entry <> "' is declared more than once"-            | entry <- duplicatesBy weCtor entries-            ]-              ++ [ mappedError (weLoc entry) MappedDuplicateWireTag declaration $-                     "enum wire spelling '" <> weTag entry <> "' is declared more than once"-                 | entry <- duplicatesBy weTag entries-                 ]-              ++ [ mappedError (weLoc entry) MappedUnsupportedEncoding declaration "enum wire spellings must be non-empty"-                 | entry <- entries,-                   T.null (weTag entry)-                 ],-          onUnion = \encoding arms ->-            [ mappedError (sdLoc declaration) MappedUnsupportedEncoding declaration "tagged-object tag and contents keys must be distinct"-            | ueTagField encoding == ueContentsField encoding-            ]-              ++ [ mappedError (sdLoc declaration) MappedUnsupportedEncoding declaration "tagged-object tag and contents keys must be non-empty"-                 | T.null (ueTagField encoding) || T.null (ueContentsField encoding)-                 ]-              ++ [ mappedError (rwaLoc arm) MappedDuplicateArmName declaration $-                     "union constructor '" <> rwaCtor arm <> "' is declared more than once"-                 | arm <- duplicatesBy rwaCtor arms-                 ]-              ++ [ mappedError (rwaLoc arm) MappedDuplicateWireTag declaration $-                     "union wire tag '" <> rwaTag arm <> "' is declared more than once"-                 | arm <- duplicatesBy rwaTag arms-                 ]-              ++ [ mappedError (rwaLoc arm) MappedUnsupportedEncoding declaration "union wire tags must be non-empty"-                 | arm <- arms,-                   T.null (rwaTag arm)-                 ]-              ++ concatMap (armRules declaration) arms-        }--    fieldRules declaration field =-      defaultRules declaration field-        ++ [ mappedError (rwfLoc field) MappedNonInjectiveNullability declaration $-               "field '" <> rwfHaskell field <> "' contains Optional around a null-capable Json, Optional, or opaque mapped value"-           | hasNonInjectiveOptional graph (rwfType field)-           ]--    armRules declaration arm =-      [ mappedError (rwaLoc arm) MappedNonInjectiveNullability declaration $-          "union arm '" <> rwaCtor arm <> "' contains Optional around a null-capable Json, Optional, or opaque mapped value"-      | payload <- maybeToList (rwaPayload arm),-        hasNonInjectiveOptional graph payload-      ]--    defaultRules declaration field = case (rwfPresence field, rwfOnMissing field) of-      (PRequired, Just _) -> [illTyped "required fields cannot declare on-missing"]-      (POptional, Nothing) ->-        [ mappedError (rwfLoc field) MappedMissingIngredient declaration $-            "optional field '" <> rwfHaskell field <> "' is missing its on-missing policy"-        ]-      (POptional, Just value)-        | not (defaultMatches graph (rwfType field) value) -> [illTyped "on-missing value does not match the field type or numeric bounds"]-      _ -> []-      where-        illTyped detail =-          mappedError (rwfLoc field) MappedDefaultIllTyped declaration $-            "field '" <> rwfHaskell field <> "': " <> detail--    mappedError loc diagnosticCode declaration detail =-      mkErr (locLine loc) diagnosticCode $-        "mapped declaration '" <> sdName declaration <> "' " <> detail-    maybeToList = maybe [] pure--data DefaultType-  = DefaultText-  | DefaultInt-  | DefaultBool-  | DefaultNatural-  | DefaultOptional-  | DefaultList-  | DefaultMap-  | DefaultEnum !(Set Name)-  | DefaultOther--defaultMatches :: TypeGraph -> ResolvedTypeExpr -> OnMissing -> Bool-defaultMatches graph expression value = case (defaultType graph expression, value) of-  (DefaultText, OmText _) -> True-  (DefaultInt, OmInt integer) -> integer >= toInteger (minBound :: Int) && integer <= toInteger (maxBound :: Int)-  (DefaultBool, OmBool _) -> True-  (DefaultNatural, OmInt integer) -> integer >= 0-  (DefaultOptional, OmNull) -> True-  (DefaultList, OmEmptyList) -> True-  (DefaultMap, OmEmptyMap) -> True-  (DefaultEnum constructors, OmCtor constructor) -> constructor `Set.member` constructors-  _ -> False--defaultType :: TypeGraph -> ResolvedTypeExpr -> DefaultType-defaultType graph =-  foldTypeExpr-    TypeExprAlgebra-      { onText = DefaultText,-        onInt = DefaultInt,-        onInteger = DefaultInt,-        onBool = DefaultBool,-        onNatural = DefaultNatural,-        onTime = DefaultOther,-        onJson = DefaultOther,-        onOptional = const DefaultOptional,-        onList = const DefaultList,-        onMap = const DefaultMap,-        onRef = referencedDefaultType graph-      }--referencedDefaultType :: TypeGraph -> MappedKey -> DefaultType-referencedDefaultType graph key = case Map.lookup key (tgDeclarations graph) of-  Nothing -> DefaultOther-  Just declaration ->-    foldMappedDecl-      MappedDeclAlgebra-        { onStructuralDecl = \_ shape ->-            foldMappedShape-              MappedShapeAlgebra-                { onRecord = \_ _ _ -> DefaultOther,-                  onEnum = DefaultEnum . Set.fromList . map weCtor,-                  onUnion = \_ _ -> DefaultOther-                }-              shape,-          onOpaqueDecl = const DefaultOther-        }-      declaration--data NullabilityFacts = NullabilityFacts-  { nfTopNull :: !Bool,-    nfBadOptional :: !Bool-  }--hasNonInjectiveOptional :: TypeGraph -> ResolvedTypeExpr -> Bool-hasNonInjectiveOptional graph =-  nfBadOptional-    . foldTypeExpr-      TypeExprAlgebra-        { onText = nonNull,-          onInt = nonNull,-          onInteger = nonNull,-          onBool = nonNull,-          onNatural = nonNull,-          onTime = nonNull,-          onJson = nullable,-          onOptional = \child -> NullabilityFacts True (nfTopNull child || nfBadOptional child),-          onList = nestedNonNull,-          onMap = nestedNonNull,-          onRef = \key -> if mappedRefIsOpaque graph key then nullable else nonNull-        }-  where-    nonNull = NullabilityFacts False False-    nullable = NullabilityFacts True False-    nestedNonNull child = NullabilityFacts False (nfBadOptional child)--mappedRefIsOpaque :: TypeGraph -> MappedKey -> Bool-mappedRefIsOpaque graph key = case Map.lookup key (tgDeclarations graph) of-  Nothing -> False-  Just declaration ->-    foldMappedDecl-      MappedDeclAlgebra-        { onStructuralDecl = \_ _ -> False,-          onOpaqueDecl = const True-        }-      declaration--mappedRegisterInitialRules :: Spec -> TypeGraph -> [Diagnostic]-mappedRegisterInitialRules spec graph =-  concatMap aggregateRules [aggregate | NAggregate aggregate <- specNodes spec]-  where-    aggregateRules aggregate = concatMap registerRule (aggRegs aggregate)-    registerRule register = case regType register of-      TRef typeName -> case Map.lookup (MappedKey typeName) (tgDeclarations graph) of-        Nothing -> []-        Just declaration -> case regInitial register of-          RegInitBare "initial"-            | mappedInitial declaration == Nothing ->-                [ mkErr (locLine (regLoc register)) MappedMissingInitialValue $-                    "mapped register '" <> regName register <> "' requires declaration '" <> typeName <> "' to name an explicit initial value"-                ]-            | otherwise -> []-          _ ->-            [ mkErr (locLine (regLoc register)) RegisterInitialOutOfScope $-                "mapped register '" <> regName register <> "' must use the bare initial token; the declaration-owned symbol is verified by GHC"-            ]-      _ -> []-    mappedInitial =-      foldMappedDecl-        MappedDeclAlgebra-          { onStructuralDecl = \declaration _ -> sdInitial declaration,-            onOpaqueDecl = odInitial-          }--moduleNameSafe :: Text -> Bool-moduleNameSafe moduleName =-  not (null components) && all constructorSafe components-  where-    components = T.splitOn "." moduleName--qualifiedValueSafe :: Text -> Bool-qualifiedValueSafe qualified = case reverse (T.splitOn "." qualified) of-  value : reversedModule ->-    not (null reversedModule)-      && lowerIdentifierSafe value-      && all constructorSafe reversedModule-  [] -> False--lowerIdentifierSafe :: Text -> Bool-lowerIdentifierSafe name = case T.uncons name of-  Just (first, rest) -> asciiLower first && T.all asciiAlphaNumOrUnderscore rest && name `Set.notMember` HaskellName.haskellKeywords-  Nothing -> False--asciiControl :: Char -> Bool-asciiControl c = ord c < 32 || ord c == 127--firstMatching :: (a -> Bool) -> [a] -> Maybe a-firstMatching predicate = \case-  [] -> Nothing-  value : rest-    | predicate value -> Just value-    | otherwise -> firstMatching predicate rest--headOr :: a -> [a] -> a-headOr fallback = \case-  [] -> fallback-  value : _ -> value---- | Check every logical name before a renderer can turn it into Haskell.  The--- parser enforces the ASCII alphabet; 'HaskellName' owns word segmentation,--- casing, keywords, and normalized collision keys.-validateNames :: EffectiveLanguageContract -> Spec -> [Diagnostic]-validateNames languageContract spec =-  concat-    [ concatMap idNames (specIds spec),-      concatMap enumNames (specEnums spec),-      concatMap nominalNames (specNominalScalars spec),-      concatMap nodeNames (specNodes spec),-      normalizedCollisions-    ]-  where-    idNames declaration =-      constructorName "id name" (idName declaration) (idLoc declaration)--    enumNames declaration =-      constructorName "enum name" (enumName declaration) (enumLoc declaration)-        ++ concatMap-          (\(ctor, _) -> constructorName ("constructor of enum '" <> enumName declaration <> "'") ctor (enumLoc declaration))-          (enumCtors declaration)--    nominalNames declaration =-      constructorName "nominal scalar name" (nominalScalarName declaration) (nominalScalarLoc declaration)--    nodeNames = \case-      NAggregate aggregate -> aggregateNames aggregate-      NProcess process -> processNames process-      NRouter router -> routerNames router-      NContract contract ->-        pascalizedNodeName "contract" (ctrName contract) (ctrLoc contract)-          ++ concatMap-            (\event -> constructorName "contract event name" (ceName event) (ctrLoc contract) ++ concatMap contractFieldName (ceFields event))-            (ctrEvents contract)-      NIntake intake -> pascalizedNodeName "intake" (inkName intake) (inkLoc intake)-      NEmit emitNode -> pascalizedNodeName "emit" (emName emitNode) (emLoc emitNode)-      NPublisher publisher -> pascalizedNodeName "publisher" (pubName publisher) (pubLoc publisher)-      NWorkqueue workqueue ->-        pascalizedNodeName "workqueue" (wqName workqueue) (wqLoc workqueue)-          ++ constructorName "workqueue payload name" (wqPayloadName workqueue) (wqLoc workqueue)-          ++ concatMap (\field -> fieldNameRule "workqueue payload field" (wqfName field) (wqLoc workqueue)) (wqPayload workqueue)-      NPgmqDispatch dispatch -> pascalizedNodeName "dispatch" (pdName dispatch) (pdLoc dispatch)-      NReadModel readModel -> pascalizedNodeName "readmodel" (rmName readModel) (rmLoc readModel)-      NWorkflow workflow -> constructorName "workflow name" (wfId workflow) (workflowNodeLoc workflow)-      NOperation _ -> []--    aggregateNames aggregate =-      constructorName "aggregate name" (aggName aggregate) (aggLoc aggregate)-        ++ concatMap-          (\register -> fieldNameRule "register name" (regName register) (regLoc register))-          (aggRegs aggregate)-        ++ concatMap commandNames (aggCommands aggregate)-        ++ concatMap eventNames (aggEvents aggregate)-        ++ maybe [] (\projection -> fieldNameRule "projection key" (projKey projection) (projLoc projection)) (aggProjection aggregate)-        ++ vertexCollisions aggregate-      where-        commandNames command =-          constructorName "command name" (cmdName command) (cmdLoc command)-            ++ concatMap (aggregateFieldNameRule "command field") (cmdFields command)-        eventNames event =-          constructorName "event name" (evName event) (evLoc event)-            ++ case evBody event of-              EventFields fields -> concatMap (aggregateFieldNameRule "event field") fields-              EventFromCommand _ -> []--    processNames process =-      constructorName "process name" (procId process) (procLoc process)-        ++ constructorName "process input name" (inName input) (procLoc process)-        ++ concatMap (\field -> fieldNameRule "process input field" (fieldName field) (procLoc process)) (inFields input)-        ++ concatMap (bindingName "advance field binding" (procLoc process)) (advFields (hAdvance handle))-        ++ concatMap dispatchBindings (hDispatch handle)-        ++ concatMap (bindingName "timer payload field binding" (tmLoc timer)) (tmPayload timer)-        ++ concatMap (bindingName "timer fire field binding" (tmLoc timer)) (fireFields (tmFire timer))-      where-        input = procInput process-        handle = procHandle process-        timer = procTimer process-        dispatchBindings dispatch = concatMap (bindingName "dispatch field binding" (dispLoc dispatch)) (dispFields dispatch)--    routerNames router =-      constructorName "router name" (rtId router) (rtLoc router)-        ++ constructorName "router input name" (inName input) (rtLoc router)-        ++ concatMap (\field -> fieldNameRule "router input field" (fieldName field) (rtLoc router)) (inFields input)-        ++ concatMap (\field -> fieldNameRule "router resolve-row field" field (rvLoc resolve)) (rvRow resolve)-        ++ concatMap (bindingName "router dispatch field binding" (rdLoc dispatch)) (rdFields dispatch)-      where-        input = rtInput router-        resolve = rtResolve router-        dispatch = rtDispatch router--    bindingName category anchor binding = fieldNameRule category (fbName binding) anchor-    contractFieldName = contractFieldNameRule "contract field"--    aggregateFieldNameRule category field =-      case aggregateFieldSelector field of-        Nothing -> fieldNameRule category (aggregateFieldName field) (aggregateFieldLoc field)-        Just selector -> explicitFieldSelectorRule category (aggregateFieldName field) selector (aggregateFieldLoc field)--    contractFieldNameRule category field =-      case cfSelector field of-        Nothing -> fieldNameRule category (cfName field) (cfLoc field)-        Just selector -> explicitFieldSelectorRule category (cfName field) selector (cfLoc field)--    explicitFieldSelectorRule category dslName selector anchor =-      case HaskellName.checkedLowerOccurrence site selector of-        Right _ -> []-        Left nameError -> [nameErrorDiagnostic (category <> " selector") nameError]-      where-        site =-          HaskellName.NameSite-            { HaskellName.siteKind = HaskellName.GeneratedFieldSite,-              HaskellName.siteLogicalName = selector,-              HaskellName.siteOwner = category <> ":" <> dslName,-              HaskellName.siteLine = locLine anchor-            }--    constructorName category name anchor = checkedLogicalName HaskellName.GeneratedTypeSite category name anchor--    pascalizedNodeName category name anchor = checkedLogicalName HaskellName.NodeModuleSite (category <> " name") name anchor--    fieldNameRule category name anchor = checkedLogicalName HaskellName.GeneratedFieldSite category name anchor--    checkedLogicalName kind category name anchor =-      case deriveAt HaskellName.LogicalIdentifier kind category name anchor of-        Right _ -> []-        Left nameError -> [nameErrorDiagnostic category nameError]--    deriveAt source kind category name anchor =-      HaskellName.deriveHaskellName source (nameSite kind category name anchor)--    nameSite kind category name anchor =-      HaskellName.NameSite-        { HaskellName.siteKind = kind,-          HaskellName.siteLogicalName = name,-          HaskellName.siteOwner = category <> ":" <> name,-          HaskellName.siteLine = locLine anchor-        }--    nameErrorDiagnostic category = \case-      HaskellName.EmptyNameSegment site ->-        mkErr (HaskellName.siteLine site) IdentUnsafeNormalization $-          category <> " '" <> HaskellName.siteLogicalName site <> "' has an empty generated-Haskell word"-      HaskellName.UnsafeNameSeparator site reason ->-        mkErr (HaskellName.siteLine site) IdentUnsafeNormalization $-          category <> " '" <> HaskellName.siteLogicalName site <> "' cannot be normalized safely: " <> reason-      HaskellName.ReservedGeneratedOccurrence site occurrence ->-        mkErr (HaskellName.siteLine site) GeneratedOccurrenceReserved $-          category <> " '" <> HaskellName.siteLogicalName site <> "' normalizes to reserved Haskell occurrence '" <> occurrence <> "'"-      HaskellName.InvalidExplicitHaskellName site occurrence ->-        mkErr (HaskellName.siteLine site) IdentUnsafeNormalization $-          category <> " '" <> HaskellName.siteLogicalName site <> "' cannot become generated Haskell occurrence '" <> occurrence <> "'"-      collision@HaskellName.NormalizedNameCollision {} -> collisionDiagnostic collision--    normalizedCollisions = map collisionDiagnostic (HaskellName.detectNameCollisions collisionOccurrences)--    collisionOccurrences =-      nodeModuleOccurrences-        <> sharedTypeOccurrences-        <> concatMap aggregateFieldOccurrences aggregates-        <> concatMap aggregateHarnessOccurrences aggregates-        <> concatMap contractFieldOccurrences contracts--    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]-    contracts = [contract | NContract contract <- specNodes spec]--    contextSegment =-      case deriveAt HaskellName.LogicalWireWord HaskellName.ContextModuleSite "context" (specContext spec) (Loc 1) of-        Right derived -> HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)-        Left _ -> specContext spec--    nodeModuleOccurrences =-      [ HaskellName.plannedOccurrence contextSegment HaskellName.ModuleSpace "" rendered site-      | node <- specNodes spec,-        let (category, raw, anchor) = nodeNameAndLoc node,-        let site = nameSite HaskellName.NodeModuleSite category raw anchor,-        Right derived <- [HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site],-        let rendered = HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)-      ]--    sharedTypeOccurrences =-      [ HaskellName.plannedOccurrence ("Generated." <> contextSegment <> ".Nominals") HaskellName.TypeSpace "" rendered site-      | (category, raw, anchor) <--          [("id", idName declaration, idLoc declaration) | declaration <- specIds spec]-            <> [("enum", enumName declaration, enumLoc declaration) | declaration <- specEnums spec]-            <> [("nominal", nominalScalarName declaration, nominalScalarLoc declaration) | declaration <- specNominalScalars spec],-        let site = nameSite HaskellName.GeneratedTypeSite category raw anchor,-        Right derived <- [HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site],-        let rendered = HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)-      ]--    aggregateFieldOccurrences aggregate = commandFields <> eventFields-      where-        targetModule = "Generated." <> contextSegment <> "." <> normalizedUpper "aggregate" (aggName aggregate) (aggLoc aggregate) <> ".Domain"-        commandFields =-          [ fieldOccurrence targetModule (cmdName command) "command field" field-          | command <- aggCommands aggregate,-            field <- cmdFields command-          ]-        eventFields =-          [ fieldOccurrence targetModule (evName event) "event field" field-          | event <- aggEvents aggregate,-            field <- eventFieldsFor aggregate event-          ]--    eventFieldsFor aggregate event =-      case evBody event of-        EventFields fields -> fields-        EventFromCommand commandName ->-          [ field-          | command <- aggCommands aggregate,-            cmdName command == commandName,-            field <- cmdFields command-          ]--    -- The occurrence registered here must be the selector generation actually-    -- emits — 'resolveAggregateFieldIdentity', which falls back to the raw DSL-    -- name, not a camelized rendering of it. Registering the camelized form made-    -- the planner claim `foo_bar` "normalizes to" `fooBar`, which generation-    -- never does, and let two fields that generate distinct selectors be-    -- reported as colliding. A field whose raw name is not lowerCamelCase is-    -- still refused, by the generated-name audit that owns that rule and says so.-    fieldOccurrence targetModule scope category field =-      let identity = resolveAggregateFieldIdentity field-          site = nameSite HaskellName.GeneratedFieldSite category (fieldDslName identity) (aggregateFieldLoc field)-       in HaskellName.plannedOccurrence targetModule HaskellName.FieldSpace scope (fieldSelector identity) site--    aggregateHarnessOccurrences aggregate =-      transitionHelpers <> sampleConstants-      where-        transitionHelpers =-          concat-            [ [helperOccurrence "accept" ("accept" <> commandName) transition]-                <> [helperOccurrence "forward/replay" ("forwardReplay" <> commandName) transition | not (null (tEmits transition))]-            | transition <- aggTransitions aggregate,-              tSource transition == initialState,-              tMode transition == TmLive,-              let commandName = tCommand transition-            ]-        sampleConstants = map idSampleOccurrence generatedIds <> maybe [] (pure . timeSampleOccurrence) timeSample-        resolvedHarnessFields =-          [ (field, resolvedType)-          | (useSite, field) <- harnessFields aggregate,-            Right resolvedType <- [inferAggregateFieldType symbols aggregate useSite field]-          ]-        generatedIds =-          Map.elems . Map.fromList $-            [ (Nominal.resolvedNominalName nominal, nominal)-            | (_, AggregateNominal nominal) <- resolvedHarnessFields,-              Nominal.GeneratedNominal <- [Nominal.resolvedNominalOwnership nominal],-              Nominal.IdRepresentation prefix <- [Nominal.resolvedNominalRepresentation nominal],-              idDomainContractFor languageContract prefix /= Nothing-            ]-        timeFields = [field | (field, AggregateTime) <- resolvedHarnessFields]-        timeSample = case filter ((== "observedAt") . aggregateFieldName) timeFields of-          field : _ -> Just ("sampleObservedAt", field)-          [] -> case timeFields of-            field : _ -> Just ("sampleTime", field)-            [] -> Nothing-        initialState = case aggStates aggregate of-          state : _ -> stName state-          [] -> ""-        symbols = aggregateSymbols spec-        targetModule =-          "Generated."-            <> contextSegment-            <> "."-            <> normalizedUpper "aggregate" (aggName aggregate) (aggLoc aggregate)-            <> ".Harness"-        helperOccurrence helperKind rendered transition =-          HaskellName.plannedOccurrence targetModule HaskellName.ValueSpace "" rendered site-          where-            site =-              HaskellName.NameSite-                { HaskellName.siteKind = HaskellName.GeneratedHelperSite,-                  HaskellName.siteLogicalName = tCommand transition,-                  HaskellName.siteOwner = "aggregate:" <> aggName aggregate <> ":" <> helperKind <> ":line:" <> T.pack (show (locLine (tLoc transition))),-                  HaskellName.siteLine = locLine (tLoc transition)-                }-        idSampleOccurrence nominal =-          HaskellName.plannedOccurrence targetModule HaskellName.ValueSpace "" ("sample" <> nominalName) site-          where-            nominalName = Nominal.resolvedNominalName nominal-            nominalLoc = Nominal.resolvedNominalLoc nominal-            site =-              HaskellName.NameSite-                { HaskellName.siteKind = HaskellName.GeneratedHelperSite,-                  HaskellName.siteLogicalName = nominalName,-                  HaskellName.siteOwner = "aggregate:" <> aggName aggregate <> ":sample-id:" <> nominalName,-                  HaskellName.siteLine = locLine nominalLoc-                }-        timeSampleOccurrence (rendered, field) =-          HaskellName.plannedOccurrence targetModule HaskellName.ValueSpace "" rendered site-          where-            site =-              HaskellName.NameSite-                { HaskellName.siteKind = HaskellName.GeneratedHelperSite,-                  HaskellName.siteLogicalName = aggregateFieldName field,-                  HaskellName.siteOwner = "aggregate:" <> aggName aggregate <> ":sample-time",-                  HaskellName.siteLine = locLine (aggregateFieldLoc field)-                }--    harnessFields aggregate =-      [(CommandFieldUse, field) | command <- aggCommands aggregate, field <- cmdFields command]-        <> [ (EventFieldUse, field)-           | event <- aggEvents aggregate,-             field <- eventFieldsFor aggregate event-           ]--    contractFieldOccurrences contract =-      [ contractFieldOccurrence targetModule (ceName event <> "Data") field-      | event <- ctrEvents contract,-        field <- ceFields event-      ]-      where-        targetModule =-          "Generated."-            <> contextSegment-            <> "."-            <> normalizedUpper "contract" (ctrName contract) (ctrLoc contract)-            <> ".Contract"--    contractFieldOccurrence targetModule scope field =-      let identity = resolveContractFieldIdentity field-          site = nameSite HaskellName.GeneratedFieldSite "contract field" (fieldDslName identity) (fieldLoc identity)-          rendered = case cfSelector field of-            Just selector -> selector-            Nothing -> case HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site of-              Right derived -> HaskellName.renderLowerCamelName (HaskellName.lowerCamel derived)-              Left _ -> fieldSelector identity-       in HaskellName.plannedOccurrence targetModule HaskellName.FieldSpace scope rendered site--    normalizedUpper category raw anchor =-      case deriveAt HaskellName.LogicalIdentifier HaskellName.GeneratedTypeSite category raw anchor of-        Right derived -> HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)-        Left _ -> raw--    nodeNameAndLoc = \case-      NAggregate value -> ("aggregate", aggName value, aggLoc value)-      NProcess value -> ("process", procId value, procLoc value)-      NRouter value -> ("router", rtId value, rtLoc value)-      NContract value -> ("contract", ctrName value, ctrLoc value)-      NIntake value -> ("intake", inkName value, inkLoc value)-      NEmit value -> ("emit", emName value, emLoc value)-      NPublisher value -> ("publisher", pubName value, pubLoc value)-      NWorkqueue value -> ("workqueue", wqName value, wqLoc value)-      NPgmqDispatch value -> ("dispatch", pdName value, pdLoc value)-      NReadModel value -> ("readmodel", rmName value, rmLoc value)-      NWorkflow value -> ("workflow", wfId value, workflowNodeLoc value)-      NOperation value -> ("operation", opName value, opLoc value)--    collisionDiagnostic (HaskellName.NormalizedNameCollision key sites) =-      case reverse (NE.toList sites) of-        primary : reversedEarlier ->-          Diagnostic-            { line = HaskellName.siteLine primary,-              severity = Error,-              code = GeneratedOccurrenceCollision,-              relatedLocations =-                [ (HaskellName.siteLine site, "'" <> HaskellName.siteLogicalName site <> "' also normalizes here")-                | site <- reverse reversedEarlier-                ],-              message =-                "logical declarations "-                  <> T.intercalate ", " ["'" <> HaskellName.siteLogicalName site <> "'" | site <- NE.toList sites]-                  <> " normalize to the same Haskell occurrence '"-                  <> HaskellName.occurrenceName key-                  <> "' in "-                  <> HaskellName.occurrenceModule key-                  <> " ("-                  <> T.pack (show (HaskellName.occurrenceSpace key))-                  <> ")"-            }-        [] -> mkErr 1 GeneratedOccurrenceCollision "internal error: normalized collision without source sites"-    collisionDiagnostic nameError = nameErrorDiagnostic "generated declaration" nameError--    vertexCollisions aggregate =-      [ mkErr (locLine (aggLoc aggregate)) VertexCtorCollision $-          "aggregate '"-            <> aggName aggregate-            <> "' state '"-            <> stName state-            <> "' generates vertex constructor '"-            <> vertex-            <> "', which collides with "-            <> declarationKind-            <> " '"-            <> vertex-            <> "' in the generated Domain constructor namespace"-      | state <- aggStates aggregate,-        let vertex = normalizedUpper "aggregate" (aggName aggregate) (aggLoc aggregate) <> normalizedUpper "state" (stName state) (stLoc state),-        declarationKind <- collisionKinds aggregate vertex-      ]--    collisionKinds aggregate vertex =-      ["event" | vertex `elem` [normalizedUpper "event" (evName event) (evLoc event) | event <- aggEvents aggregate]]-        ++ ["command" | vertex `elem` [normalizedUpper "command" (cmdName command) (cmdLoc command) | command <- aggCommands aggregate]]-        ++ ["enum constructor" | vertex `elem` [normalizedUpper "enum constructor" ctor (enumLoc enum) | enum <- specEnums spec, (ctor, _) <- enumCtors enum]]---- Explicit consumer-owned Haskell references keep their spelling and use the--- historical lexical check. Generated names never call this helper.-constructorSafe :: Name -> Bool-constructorSafe name = case T.uncons name of-  Just (first, rest) -> asciiUpper first && T.all asciiAlphaNumOrUnderscore rest-  Nothing -> False--asciiUpper :: Char -> Bool-asciiUpper c = c >= 'A' && c <= 'Z'--asciiLower :: Char -> Bool-asciiLower c = c >= 'a' && c <= 'z'--asciiAlphaNumOrUnderscore :: Char -> Bool-asciiAlphaNumOrUnderscore c = asciiUpper c || asciiLower c || (c >= '0' && c <= '9') || c == '_'--kafkaTopicError :: Text -> Maybe Text-kafkaTopicError topic-  | T.null topic = Just "is empty"-  | T.length topic > 249 = Just "is longer than Kafka's 249-character limit"-  | topic == "." || topic == ".." = Just "is reserved by Kafka"-  | Just illegal <- T.find (not . kafkaTopicCharacter) topic =-      Just ("contains character " <> T.pack (show illegal) <> "; use only ASCII letters, digits, '.', '_', or '-'")-  | otherwise = Nothing-  where-    kafkaTopicCharacter character = asciiAlphaNumOrUnderscore character || character == '.' || character == '-'--validPostgresIdentifier :: Text -> Bool-validPostgresIdentifier identifier =-  T.length identifier <= 63-    && case T.uncons identifier of-      Nothing -> False-      Just (firstCharacter, rest) ->-        (asciiLower firstCharacter || firstCharacter == '_')-          && T.all (\character -> asciiLower character || (character >= '0' && character <= '9') || character == '_') rest---- | Rules over namespaces shared by the whole specification.-specLevelRules :: EffectiveLanguageContract -> Spec -> [Diagnostic]-specLevelRules languageContract spec = duplicateNodes ++ duplicateEnumMembers ++ duplicateIdPrefixes ++ duplicateDeclarations ++ runtimeIdentities ++ duplicateRuntimeIdentities ++ ruleDiagnostics-  where-    duplicateNodes =-      [ mkErr (locLine loc) DuplicateNodeName $-          "duplicate " <> kind <> " node name '" <> name <> "'"-      | node <- duplicatesBy nodeKey (specNodes spec),-        let (kind, name, loc) = nodeIdentity node-      ]-    nodeKey node = let (kind, name, _) = nodeIdentity node in (kind, name)-    duplicateEnumMembers = concatMap enumDuplicates (specEnums spec)-    enumDuplicates e =-      [ mkErr (locLine (enumLoc e)) DuplicateEnumCtor $-          "enum '" <> enumName e <> "' declares constructor '" <> ctor <> "' more than once"-      | (ctor, _) <- duplicatesBy fst (enumCtors e)-      ]-        ++ [ mkErr (locLine (enumLoc e)) DuplicateEnumWire $-               "enum '" <> enumName e <> "' declares wire spelling '" <> wire <> "' more than once"-           | (_, wire) <- duplicatesBy snd (enumCtors e)-           ]-    duplicateIdPrefixes =-      [ mkErr (locLine (idLoc d)) DuplicateIdPrefix $-          "id '" <> idName d <> "' reuses prefix '" <> idPrefix d <> "'"-      | d <- duplicatesBy idPrefix (specIds spec)-      ]-    duplicateDeclarations =-      [ mkErr (locLine loc) NominalDuplicateDeclaration $-          "duplicate " <> category <> " declaration '" <> name <> "'; the last declaration would silently replace the earlier one"-      | enforcesSpecSurfaceClosures languageContract,-        (category, name, loc) <- duplicatesBy (\(category, name, _) -> (category, name)) declarationOrigins-      ]-    declarationOrigins =-      [("id", idName value, idLoc value) | value <- specIds spec]-        <> [("enum", enumName value, enumLoc value) | value <- specEnums spec]-        <> [("nominal scalar", nominalScalarName value, nominalScalarLoc value) | value <- specNominalScalars spec]-        <> [("mapped", mappedName value, mappedLoc value) | value <- specMapped spec]-        <> [("rule", ruleName value, ruleLoc value) | value <- specRules spec]-    runtimeIdentities =-      [ mkErr (locLine loc) RuntimeIdentityInvalid $-          kind <> " stable identity " <> T.pack (show identity) <> " " <> reason-      | enforcesSpecSurfaceClosures languageContract,-        (kind, identity, loc) <- stableIdentityOrigins,-        Just reason <- [stableIdentityError identity]-      ]-    duplicateRuntimeIdentities =-      [ mkErr (locLine loc) RuntimeIdentityDuplicate $-          kind <> " stable identity " <> T.pack (show identity) <> " is already used by another workflow, process, or router"-      | enforcesSpecSurfaceClosures languageContract,-        (kind, identity, loc) <- duplicatesBy (\(_, identity, _) -> identity) stableIdentityOrigins-      ]-    stableIdentityOrigins =-      [("workflow", wfStable workflow, workflowNodeLoc workflow) | NWorkflow workflow <- specNodes spec]-        <> [("process", procName process, procLoc process) | NProcess process <- specNodes spec]-        <> [("router", rtName router, rtLoc router) | NRouter router <- specNodes spec]-    ruleDiagnostics = concatMap (validateRule spec) (specRules spec)--nodeIdentity :: Node -> (Text, Name, Loc)-nodeIdentity (NAggregate a) = ("aggregate", aggName a, aggLoc a)-nodeIdentity (NProcess p) = ("process", procId p, procLoc p)-nodeIdentity (NRouter r) = ("router", rtId r, rtLoc r)-nodeIdentity (NContract c) = ("contract", ctrName c, ctrLoc c)-nodeIdentity (NIntake i) = ("intake", inkName i, inkLoc i)-nodeIdentity (NEmit e) = ("emit", emName e, emLoc e)-nodeIdentity (NPublisher p) = ("publisher", pubName p, pubLoc p)-nodeIdentity (NWorkqueue w) = ("workqueue", wqName w, wqLoc w)-nodeIdentity (NPgmqDispatch d) = ("dispatch", pdName d, pdLoc d)-nodeIdentity (NReadModel r) = ("readmodel", rmName r, rmLoc r)-nodeIdentity (NWorkflow w) = ("workflow", wfId w, workflowNodeLoc w)-nodeIdentity (NOperation o) = ("operation", opName o, opLoc o)--validateNode :: EffectiveLanguageContract -> Spec -> Node -> [Diagnostic]-validateNode languageContract spec (NAggregate agg) = validateAggregate languageContract spec agg-validateNode languageContract spec (NProcess p) = validateProcess languageContract spec p-validateNode languageContract spec (NRouter router) = validateRouter languageContract spec router-validateNode languageContract _spec (NContract contract) = validateContract languageContract contract-validateNode languageContract spec (NIntake i) = validateIntake languageContract i ++ intakeCoupling languageContract spec i-validateNode languageContract spec (NEmit e) = validateEmit languageContract spec e-validateNode languageContract spec (NPublisher p) = validatePublisher languageContract spec p-validateNode languageContract _spec (NWorkqueue w) = validateWorkqueue languageContract w-validateNode languageContract spec (NPgmqDispatch d) = validatePgmqDispatch languageContract spec d-validateNode languageContract spec (NReadModel readModel) = validateReadModel languageContract spec readModel-validateNode _languageContract _spec (NWorkflow w) = validateWorkflow w-validateNode _languageContract spec (NOperation o) = validateOperation spec o--validateContract :: EffectiveLanguageContract -> ContractNode -> [Diagnostic]-validateContract languageContract contract =-  emptyContract-    <> typeIdPrefixErrors-    <> schemaVersionFloor-    <> topicNames-    <> duplicateEvents-    <> duplicateTopicAliases-    <> duplicateFields-    <> discriminatorShadows-    <> fieldWireKeyRules-    <> unresolvedTopicAliases-  where-    emptyContract =-      [ mkErr (locLine (ctrLoc contract)) ContractEmpty $-          "contract '"-            <> ctrName contract-            <> "' declares no events; scaffold cannot lower an empty contract -- declare at least one event"-      | null (ctrEvents contract)-      ]-    typeIdPrefixErrors =-      [ mkErr (locLine (cfLoc field)) ContractInvalidTypeIdPrefix $-          "contract '"-            <> ctrName contract-            <> "' event '"-            <> ceName event-            <> "' field '"-            <> cfName field-            <> "' has invalid TypeID prefix '"-            <> prefix-            <> "': "-            <> T.pack (show reason)-      | event <- ctrEvents contract,-        field <- ceFields event,-        CTypeId prefix <- [cfType field],-        Just _ <- [contractIdDomainContractFor languageContract prefix],-        Just reason <- [TypeID.checkPrefix prefix]-      ]-    schemaVersionFloor =-      [ mkErr (locLine (ctrLoc contract)) ContractSchemaVersionBelowMinimum $-          "contract '" <> ctrName contract <> "' schemaVersion must be at least 1"-      | enforcesSpecSurfaceClosures languageContract,-        ctrSchemaVersion contract < 1-      ]-    topicNames =-      [ mkErr (locLine (ctrLoc contract)) ContractTopicNameInvalid $-          "contract '" <> ctrName contract <> "' topic alias '" <> alias <> "' has invalid Kafka topic " <> T.pack (show topic) <> ": " <> reason-      | (alias, topic) <- ctrTopics contract,-        T.null topic || enforcesSpecSurfaceClosures languageContract,-        Just reason <- [kafkaTopicError topic]-      ]-    duplicateEvents =-      [ mkErr (locLine (ctrLoc contract)) ContractDuplicateEvent $-          "contract '" <> ctrName contract <> "' declares event '" <> ceName event <> "' more than once"-      | event <- duplicatesBy ceName (ctrEvents contract)-      ]-    duplicateTopicAliases =-      [ mkErr (locLine (ctrLoc contract)) ContractDuplicateTopicAlias $-          "contract '" <> ctrName contract <> "' declares topic alias '" <> alias <> "' more than once"-      | (alias, _) <- duplicatesBy fst (ctrTopics contract)-      ]-    duplicateFields =-      [ mkErr (locLine (cfLoc field)) ContractDuplicateFieldName $-          "contract '" <> ctrName contract <> "' event '" <> ceName event <> "' declares field '" <> cfName field <> "' more than once"-      | event <- ctrEvents contract,-        field <- duplicatesBy cfName (ceFields event)-      ]-    discriminatorShadows =-      [ mkErr (locLine (cfLoc field)) ContractFieldShadowsDiscriminator $-          "contract '"-            <> ctrName contract-            <> "' event '"-            <> ceName event-            <> "' field '"-            <> cfName field-            <> "' shadows the payload discriminator"-      | enforcesSpecSurfaceClosures languageContract,-        event <- ctrEvents contract,-        field <- ceFields event,-        fieldWireKey (resolveContractFieldIdentity field) == ctrDiscriminator contract-      ]-    fieldWireKeyRules =-      concat-        [ wireKeyRulesForRecord-            ("contract '" <> ctrName contract <> "' event '" <> ceName event <> "'")-            (Just (ctrDiscriminator contract, "payload discriminator"))-            (map resolveContractFieldIdentity (ceFields event))-        | event <- ctrEvents contract-        ]-    unresolvedTopicAliases =-      [ mkErr (locLine (ctrLoc contract)) ContractTopicAliasUnresolved $-          "contract '" <> ctrName contract <> "' event '" <> ceName event <> "' names undeclared topic alias '" <> ceTopic event <> "'"-      | enforcesSpecSurfaceClosures languageContract,-        event <- ctrEvents contract,-        ceTopic event `notElem` map fst (ctrTopics contract)-      ]---- | Workflow replay keys, patch guards, rotation, and injected inputs must be unambiguous.-validateWorkflow :: WorkflowNode -> [Diagnostic]-validateWorkflow w = duplicateLabels ++ sleepFields ++ patchDuplicates ++ patchIds ++ continuePositions ++ idField-  where-    inputFields = map fieldName (wfInputFields w)-    labelledItems = workflowLabelledItems (wfBody w)-    patchItems = workflowPatchItems (wfBody w)-    duplicateLabels =-      [ mkErr (locLine (wfBodyLoc item)) WorkflowDuplicateLabel $-          "workflow '" <> wfId w <> "' declares label '" <> label <> "' more than once; labels key deterministic replay, so a duplicate label replays the first occurrence's journaled result"-      | (label, item) <- duplicatesBy fst labelledItems-      ]-    sleepFields =-      [ mkErr (locLine loc) WorkflowSleepDelayUnresolved $-          "workflow '" <> wfId w <> "' sleep '" <> label <> "' references undeclared input field '" <> delay <> "'"-      | WfSleep label delay loc <- map snd labelledItems,-        delay `notElem` inputFields-      ]-    patchDuplicates =-      [ mkErr (locLine loc) WorkflowPatchDuplicate $-          "workflow '" <> wfId w <> "' declares patch id '" <> patchId <> "' more than once; patch decisions journal under one stable key"-      | (patchId, _, loc) <- duplicatesBy (\(patchId, _, _) -> patchId) patchItems-      ]-    patchIds =-      [ mkErr (locLine loc) WorkflowPatchIdInvalid $-          "workflow '" <> wfId w <> "' patch id '" <> patchId <> "' contains ':'; the runtime reserves that separator for the patch journal-key prefix"-      | (patchId, _, loc) <- patchItems,-        ":" `T.isInfixOf` patchId-      ]-    continuePositions =-      [ mkErr (locLine loc) WorkflowContinueAsNewNotTerminal $-          "workflow '" <> wfId w <> "' continueAsNew must be the last top-level body item and may not appear inside a patch"-      | (isTopLevelTerminal, loc) <- workflowContinueItems (wfBody w),-        not isTopLevelTerminal-      ]-    idField = case wfIdField w of-      Just field-        | field `notElem` inputFields ->-            [ mkErr (locLine (workflowNodeLoc w)) WorkflowIdFieldUnresolved $-                "workflow '" <> wfId w <> "' derives its id from undeclared input field '" <> field <> "'"-            ]-      _ -> []--wfBodyLoc :: WfBodyItem -> Loc-wfBodyLoc (WfStep _ _ loc) = loc-wfBodyLoc (WfAwait _ _ loc) = loc-wfBodyLoc (WfSleep _ _ loc) = loc-wfBodyLoc (WfChild _ _ _ loc) = loc-wfBodyLoc (WfPatch _ _ loc) = loc-wfBodyLoc (WfContinueAsNew _ loc) = loc--workflowLabelledItems :: [WfBodyItem] -> [(Name, WfBodyItem)]-workflowLabelledItems = concatMap go-  where-    go item@(WfStep label _ _) = [(label, item)]-    go item@(WfAwait label _ _) = [(label, item)]-    go item@(WfSleep label _ _) = [(label, item)]-    go item@(WfChild label _ _ _) = [(label, item)]-    go (WfPatch _ items _) = workflowLabelledItems items-    go WfContinueAsNew {} = []--workflowPatchItems :: [WfBodyItem] -> [(Name, [WfBodyItem], Loc)]-workflowPatchItems = concatMap go-  where-    go (WfPatch patchId items loc) = (patchId, items, loc) : workflowPatchItems items-    go _ = []---- | Pair every rotation with whether it is the final top-level item.-workflowContinueItems :: [WfBodyItem] -> [(Bool, Loc)]-workflowContinueItems items = topLevel ++ nested-  where-    topLevel =-      [ (index == length items - 1, loc)-      | (index, WfContinueAsNew _ loc) <- zip [0 ..] items-      ]-    nested =-      [ (False, loc)-      | WfPatch _ patchBody _ <- items,-        (_, loc) <- workflowContinueItems patchBody-      ]---- | A top-level rule is a total, clock-free function over one declared enum.-validateRule :: Spec -> RuleDecl -> [Diagnostic]-validateRule spec rule = case [e | e <- specEnums spec, enumName e == ruleDomain rule] of-  [] ->-    [ mkErr rl RuleDomainUnresolved $-        "rule '" <> ruleName rule <> "' has undeclared enum domain '" <> ruleDomain rule <> "'"-    ]-  (domain : _) -> totality domain ++ unknownCases domain ++ bodyDiagnostics-  where-    rl = locLine (ruleLoc rule)-    caseNames = map fst (ruleCases rule)-    allEnumCtors = Set.fromList [ctor | e <- specEnums spec, (ctor, _) <- enumCtors e]-    totality domain =-      let missing = [ctor | (ctor, _) <- enumCtors domain, ctor `notElem` caseNames]-       in [ mkErr rl RuleNotTotal $-              "rule '" <> ruleName rule <> "' is not total over enum '" <> enumName domain <> "'; missing cases {" <> T.intercalate ", " missing <> "}"-          | not (null missing)-          ]-    unknownCases domain =-      [ mkErr rl RuleCaseUnknownCtor $-          "rule '" <> ruleName rule <> "' has case '" <> ctor <> "' which is not a constructor of enum '" <> enumName domain <> "'"-      | (ctor, _) <- ruleCases rule,-        ctor `notElem` map fst (enumCtors domain)-      ]-    bodyDiagnostics = concatMap validateBody (ruleCases rule)-    validateBody (ctor, expr) =-      [ mkErr rl ClockSampled $-          "rule '" <> ruleName rule <> "' case '" <> ctor <> "' samples the wall clock via '" <> atom <> "'; rules must be deterministic"-      | atom <- dedup (exprNames expr),-        atom `Set.member` clockAtoms-      ]-        ++ [ mkErr rl GuardAtomOutOfScope $-               "atom '" <> atom <> "' in rule '" <> ruleName rule <> "' resolves to no enum constructor or boolean literal"-           | atom <- dedup (exprNames expr),-             atom `Set.notMember` clockAtoms,-             atom `Set.notMember` allEnumCtors-           ]---- | Operation rules resolve command aggregates, stream fields, projections,--- read models, workflow signal labels and value types, and run targets.-validateOperation :: Spec -> OperationNode -> [Diagnostic]-validateOperation spec o = case opShape o of-  CommandOp aggregate streamField _ projections ->-    aggregateRef aggregate streamField ++ projectionRefs projections-  QueryOp readModel _ _ consistency ->-    resolveReadModelRef QueryUnresolvedReadModel spec (opLoc o) ("query operation '" <> opName o <> "'") readModel-      ++ [ mkErr ol QueryConsistencyInvalid $-             "query operation '" <> opName o <> "' has unknown consistency '" <> consistency <> "'; expected Strong, Eventual, or PositionWait"-         | consistency `notElem` (["Strong", "Eventual", "PositionWait"] :: [Name])-         ]-  SignalOp lbl wf _ _ valueType ->-    case lookupWorkflow wf of-      Nothing ->-        [mkErr ol AwaitSignalMismatch ("signal operation '" <> opName o <> "' targets undeclared workflow '" <> wf <> "'")]-      Just w -> case [(resultType, loc) | (_, WfAwait label resultType loc) <- workflowLabelledItems (wfBody w), label == lbl] of-        [] ->-          [ mkErr ol AwaitSignalMismatch $-              "signal '" <> lbl <> "' of " <> wf <> " has no matching 'await' (workflow declares awaits {" <> T.intercalate ", " (awaitLabels w) <> "}); the deterministic awakeable id will not match and the workflow will wait forever"-          ]-        ((resultType, _) : _)-          | valueType == resultType -> []-          | otherwise ->-              [ mkErr ol AwaitSignalValueMismatch $-                  "signal '" <> lbl <> "' of " <> wf <> " carries value type '" <> valueType <> "' but the await expects '" <> resultType <> "'"-              ]-  RunOp wf _ _ ->-    [ mkErr ol RunWorkflowUnresolved ("run operation '" <> opName o <> "' targets undeclared workflow '" <> wf <> "'")-    | wf `notElem` map wfId workflows-    ]-  where-    ol = locLine (opLoc o)-    workflows = [w | NWorkflow w <- specNodes spec]-    aggregates = [a | NAggregate a <- specNodes spec]-    projectionTables = [projTable p | a <- aggregates, Just p <- [aggProjection a]]-    lookupWorkflow n = case [w | w <- workflows, wfId w == n] of (w : _) -> Just w; [] -> Nothing-    awaitLabels w = [l | (_, WfAwait l _ _) <- workflowLabelledItems (wfBody w)]-    aggregateRef name streamField = case [a | a <- aggregates, aggName a == name] of-      [] ->-        [ mkErr ol OperationUnresolvedRef $-            "command operation '" <> opName o <> "' targets undeclared aggregate '" <> name <> "'"-        ]-      (aggregate : _) ->-        [ mkErr ol OperationUnresolvedRef $-            "command operation '" <> opName o <> "' stream field '" <> streamField <> "' is not declared by any command of aggregate '" <> name <> "'"-        | streamField `notElem` [aggregateFieldName field | command <- aggCommands aggregate, field <- cmdFields command]-        ]-    projectionRefs projections =-      [ mkErr ol OperationUnresolvedRef $-          "command operation '" <> opName o <> "' references undeclared projection table '" <> projection <> "'"-      | projection <- projections,-        projection `notElem` projectionTables-      ]---- | Resolve a named read-model node using the caller's diagnostic code.-resolveReadModelRef :: DiagnosticCode -> Spec -> Loc -> Text -> Name -> [Diagnostic]-resolveReadModelRef diagnosticCode spec diagnosticLoc context name =-  [ mkErr (locLine diagnosticLoc) diagnosticCode $-      context <> " references undeclared readmodel '" <> name <> "'"-  | name `notElem` [rmName readModel | NReadModel readModel <- specNodes spec]-  ]---- | Validate captured identity, feed semantics, and the declared column surface.-validateReadModel :: EffectiveLanguageContract -> Spec -> ReadModelNode -> [Diagnostic]-validateReadModel languageContract spec readModel =-  shapeFixture ++ columnTypes ++ strongFeed ++ scopeMode ++ inlineSubscription ++ inlineReference ++ versionFloor ++ identifiers ++ runtimeIdentities ++ duplicateColumns-  where-    readModelLine = locLine (rmLoc readModel)-    expectedShape = deriveShapeHash readModel-    shapeFixture =-      [ mkErr readModelLine RmShapeHashDrift $-          "readmodel '"-            <> rmName readModel-            <> "': captured shape \""-            <> rmShape readModel-            <> "\" does not match the declared columns (expected \""-            <> expectedShape-            <> "\"); update the fixture AND bump version if the table shape really changed"-      | rmShape readModel /= expectedShape-      ]-    allowedColumnTypes = Set.fromList ["text", "int", "bigint", "bool", "timestamptz", "jsonb", "numeric"]-    columnTypes =-      [ mkErr readModelLine RmUnknownColumnType $-          "readmodel '" <> rmName readModel <> "' column '" <> rmcName columnDecl <> "' has unknown type '" <> rmcType columnDecl <> "'"-      | columnDecl <- rmColumns readModel,-        rmcType columnDecl `Set.notMember` allowedColumnTypes-      ]-    strongFeed =-      [ mkErr readModelLine RmStrongInlineOnly $-          "readmodel '"-            <> rmName readModel-            <> "': consistency = Strong with feed = inline; an inline-only model has no subscription worker to advance the cursor a Strong read waits on. Use consistency = Eventual, or feed = subscription"-      | rmFeed readModel == RmInline,-        rmConsistency readModel == Strong-      ]-    scopeMode =-      [ mkErr readModelLine RmScopeWithoutStrong $-          "readmodel '" <> rmName readModel <> "': scope is meaningful only with consistency = Strong"-      | rmScope readModel /= Nothing,-        rmConsistency readModel /= Strong-      ]-    inlineSubscription =-      [ Diagnostic-          { line = readModelLine,-            severity = Warning,-            code = RmInlineSubscriptionIgnored,-            relatedLocations = [],-            message = "readmodel '" <> rmName readModel <> "': subscription override is ignored when feed = inline; remove it or select feed = subscription"-          }-      | rmFeed readModel == RmInline,-        rmSubscription readModel /= Nothing-      ]-    inlineReference =-      [ mkErr readModelLine RmInlineFeedUnreferenced $-          "readmodel '" <> rmName readModel <> "' declares feed = inline but no aggregate projection references it"-      | rmFeed readModel == RmInline,-        rmName readModel `notElem` [projTable projection | NAggregate aggregate <- specNodes spec, Just projection <- [aggProjection aggregate]]-      ]-    versionFloor =-      [ mkErr readModelLine ReadModelVersionBelowMinimum $-          "readmodel '" <> rmName readModel <> "' version must be at least 1"-      | enforcesSpecSurfaceClosures languageContract,-        rmVersion readModel < 1-      ]-    identifiers =-      [ mkErr readModelLine ReadModelIdentifierInvalid $-          "readmodel '" <> rmName readModel <> "' " <> kind <> " " <> T.pack (show identifier) <> " is not a PostgreSQL unquoted identifier"-      | enforcesSpecSurfaceClosures languageContract,-        (kind, identifier) <--          [("schema", rmSchema readModel), ("table", rmTable readModel)]-            <> [("column", rmcName columnDecl) | columnDecl <- rmColumns readModel],-        not (validPostgresIdentifier identifier)-      ]-    runtimeIdentities =-      [ mkErr readModelLine RuntimeIdentityInvalid $-          "readmodel '" <> rmName readModel <> "' subscription " <> T.pack (show subscription) <> " " <> reason-      | enforcesSpecSurfaceClosures languageContract,-        Just subscription <- [rmSubscription readModel],-        Just reason <- [stableIdentityError subscription]-      ]-        ++ [ mkErr readModelLine RuntimeIdentityInvalid $-               "readmodel '" <> rmName readModel <> "' scope category " <> T.pack (show category) <> " " <> reason-           | enforcesSpecSurfaceClosures languageContract,-             Just (RmCategory category) <- [rmScope readModel],-             Just reason <- [runtimeIdentityError False category]-           ]-    duplicateColumns =-      [ mkErr readModelLine ReadModelDuplicateColumn $-          "readmodel '" <> rmName readModel <> "' declares column '" <> rmcName columnDecl <> "' more than once"-      | enforcesSpecSurfaceClosures languageContract,-        columnDecl <- duplicatesBy rmcName (rmColumns readModel)-      ]---- | EP-5 workqueue rules: the captured physical name must match the queueRef--- derivation; the disposition inversions (storeFailure transient => must retry;--- decodeFailure poison => must dead-letter); and dlq=on requires a retry ceiling.-validateWorkqueue :: EffectiveLanguageContract -> WorkqueueNode -> [Diagnostic]-validateWorkqueue languageContract w = concat [divergence, completeness, duplicateRows, inversions, retryCeiling, orderingRules, groupKeyRules, payloadTypes, windows, provisionRules]-  where-    wl = locLine (wqLoc w)-    rows = wqDisposition w-    (derivedPhysical, derivedDlq, derivedTable) = derivedQueueTrio (wqLogical w)-    divergence =-      [ mkErr wl WqPhysicalDivergence $-          "workqueue '" <> wqName w <> "': captured physical \"" <> wqPhysical w <> "\" diverges from queueRef(\"" <> wqLogical w <> "\") = \"" <> derivedPhysical <> "\""-      | wqPhysical w /= derivedPhysical-      ]-        ++ [ mkErr wl WqDlqDivergence $-               "workqueue '" <> wqName w <> "': captured dlq \"" <> wqDlq w <> "\" diverges from queueRef = \"" <> derivedDlq <> "\""-           | wqDlq w /= derivedDlq-           ]-        ++ [ mkErr wl WqTableDivergence $-               "workqueue '" <> wqName w <> "': captured table \"" <> wqTable w <> "\" diverges from queueRef table = \"" <> derivedTable <> "\""-           | wqTable w /= derivedTable-           ]-    requiredOutcomes = ["storeFailure", "commandRejected", "decodeFailure", "onCodecReject"]-    completeness =-      [ mkErr wl WqDispositionIncomplete $-          "workqueue '" <> wqName w <> "' disposition table is missing outcome '" <> outcome <> "'"-      | outcome <- requiredOutcomes,-        outcome `notElem` map wqdOutcome rows-      ]-    duplicateRows =-      [ mkErr (locLine (wqdLoc row)) DispositionDuplicateOutcome $-          "workqueue '" <> wqName w <> "' repeats disposition outcome '" <> wqdOutcome row <> "'; the first row would shadow this row"-      | row <- duplicatesBy wqdOutcome rows-      ]-    firstRow outcome = case [row | row <- rows, wqdOutcome row == outcome] of-      (row : _) -> Just row-      [] -> Nothing-    isRetry row = case wqdAction row of IRetry _ -> True; _ -> False-    isDeadLetter row = case wqdAction row of IDeadLetter _ -> True; _ -> False-    inversions =-      [ mkErr (locLine (wqdLoc row)) WqStoreFailureNotRetry ("workqueue '" <> wqName w <> "': 'storeFailure' is transient and MUST retry, not dead-letter")-      | Just row <- [firstRow "storeFailure"],-        isDeadLetter row-      ]-        ++ [ mkErr (locLine (wqdLoc row)) WqDecodeFailureNotDeadLetter ("workqueue '" <> wqName w <> "': 'decodeFailure' is poison and MUST dead-letter, not retry")-           | Just row <- [firstRow "decodeFailure"],-             isRetry row-           ]-    retryCeiling =-      [ mkErr wl WqDlqWithoutCeiling ("workqueue '" <> wqName w <> "': dlq=on requires maxRetries >= 1 (an absent ceiling never dead-letters)")-      | wqDlqOn w && wqMaxRetries w < 1-      ]-    fifo = wqOrdering w /= WqUnordered-    orderingRules =-      [ mkErr wl WqGroupKeyMissing $-          "workqueue '" <> wqName w <> "': FIFO delivery is per group, so ordering requires a 'group key' clause that makes enqueueToGroup deterministic"-      | fifo && wqGroupKey w == Nothing-      ]-        ++ [ mkErr wl WqGroupKeyWithoutFifo $-               "workqueue '" <> wqName w <> "': a group key with unordered reads would be ignored; declare a FIFO ordering or remove the key"-           | not fifo && wqGroupKey w /= Nothing-           ]-    groupKeyRules = case wqGroupKey w of-      Nothing -> []-      Just groupKey ->-        case [field | field <- wqPayload w, wqfName field == gkField groupKey] of-          [] ->-            [ mkErr wl WqGroupKeyUnresolved $-                "workqueue '" <> wqName w <> "': group key field '" <> gkField groupKey <> "' is not declared in its payload"-            ]-          field : _ ->-            [ mkErr wl WqGroupKeyUnresolved $-                "workqueue '" <> wqName w <> "': group key via raw requires a text payload field, but '" <> gkField groupKey <> "' has type '" <> wqfType field <> "'"-            | gkVia groupKey == "raw" && wqfType field /= "text"-            ]-              ++ [ mkErr wl WqGroupKeyUnresolved $-                     "workqueue '" <> wqName w <> "': opaque group-key derivation '" <> gkVia groupKey <> "' requires a captured fixture"-                 | gkVia groupKey /= "raw" && gkFixture groupKey == Nothing-                 ]-    payloadTypes =-      [ mkErr wl WqPayloadTypeUnknown $-          "workqueue '" <> wqName w <> "' payload field '" <> wqfName field <> "' has unknown type '" <> wqfType field <> "'; expected text, int, or bool"-      | enforcesSpecSurfaceClosures languageContract,-        field <- wqPayload w,-        wqfType field `Set.notMember` Set.fromList ["text", "int", "bool"]-      ]-    windows =-      windowRangeRule languageContract wl ("workqueue '" <> wqName w <> "' delay") (wqDelay w)-        ++ concat-          [ windowRangeRule languageContract (locLine (wqdLoc row)) ("workqueue '" <> wqName w <> "' retry") window-          | row <- rows,-            IRetry window <- [wqdAction row]-          ]-    provisionRules = case wqProvision w of-      WqStandard -> []-      WqUnlogged ->-        [ Diagnostic-            { line = wl,-              severity = Warning,-              code = WqUnloggedDurability,-              relatedLocations = [],-              message = "workqueue '" <> wqName w <> "': provision unlogged is truncated to empty on a database crash; use it only for transient, regenerable work"-            }-        ]-      WqPartitioned interval retention ->-        [ mkErr wl WqPartitionSpecEmpty $-            "workqueue '" <> wqName w <> "': partition interval and retention must be non-empty; they are create-time settings and the additive reconciler will not migrate an existing queue"-        | T.null interval || T.null retention-        ]---- | EP-5 dispatch rule: the @enqueue to@ target must resolve to a declared workqueue.-validatePgmqDispatch :: EffectiveLanguageContract -> Spec -> PgmqDispatchNode -> [Diagnostic]-validatePgmqDispatch languageContract spec d = enqueueRef ++ dedupQueueRef ++ sourceReadModelRef ++ sourceReadModelField ++ dedupReadModelRef ++ dedupReadModelField ++ dedupKeyField ++ fanoutFunctionName-  where-    dl = locLine (pdLoc d)-    -- The top-level `dedup key` is the logical value being deduped. Its two-    -- physical locations are already checked against the seenIn read model and-    -- queue; the key itself comes from the source read model's row, so it must-    -- be one of that model's generated selectors — exactly the rule `source key`-    -- already obeys. ExecPlan 197 parked this as descriptive-only.-    dedupKeyField = case [readModel | NReadModel readModel <- specNodes spec, rmName readModel == pdSourceReadModel d] of-      [] -> []-      readModel : _ ->-        [ mkSurfaceRefusal languageContract dl DispatchReadModelFieldUnknown $-            "dispatch '"-              <> pdName d-              <> "' dedup key '"-              <> pdDedupKey d-              <> "' is not a generated logical selector for a column of source readmodel '"-              <> pdSourceReadModel d-              <> "'"-        | pdDedupKey d `notElem` map (logicalFieldSelector . rmcName) (rmColumns readModel)-        ]--    -- `fanout body` names a hand-written function that expands one source row-    -- into queued jobs. A pgmq dispatch generates no module, so there is no-    -- typed namespace to resolve the name against — but a name that is not a-    -- legal Haskell value identifier cannot be the name of any function anyone-    -- could write, which is decidable here. ExecPlan 197 parked this too.-    fanoutFunctionName =-      [ mkSurfaceRefusal languageContract dl PgmqFanoutFunctionInvalid $-          "dispatch '"-            <> pdName d-            <> "' fanout body '"-            <> pdFanoutBody d-            <> "' cannot name a Haskell function; it must be a lowercase-initial identifier that is not a reserved word"-      | not (lowerIdentifierSafe (pdFanoutBody d))-      ]-    workqueues = [w | NWorkqueue w <- specNodes spec]-    enqueueRef =-      [ mkErr dl DispatchEnqueueUnresolved ("dispatch '" <> pdName d <> "' enqueues to undeclared workqueue '" <> pdEnqueueTo d <> "'")-      | pdEnqueueTo d `notElem` map wqName workqueues-      ]-    dedupQueueRef = case [w | w <- workqueues, wqName w == pdDedupQueue d] of-      [] ->-        [ mkErr dl DispatchDedupQueueUnresolved $-            "dispatch '" <> pdName d <> "' checks an undeclared dedup queue '" <> pdDedupQueue d <> "'"-        ]-      (queue : _) ->-        [ mkErr dl DispatchDedupFieldUnresolved $-            "dispatch '" <> pdName d <> "' dedup field '" <> pdDedupQueueField d <> "' is not a payload wire field of queue '" <> pdDedupQueue d <> "'"-        | pdDedupQueueField d `notElem` map wqfWire (wqPayload queue)-        ]-    sourceReadModelRef =-      resolveReadModelRef DispatchReadModelUnresolved spec (pdLoc d) ("dispatch '" <> pdName d <> "' source") (pdSourceReadModel d)-    sourceReadModelField = case [readModel | NReadModel readModel <- specNodes spec, rmName readModel == pdSourceReadModel d] of-      [] -> []-      readModel : _ ->-        [ mkErr dl DispatchReadModelFieldUnknown $-            "dispatch '" <> pdName d <> "' source key '" <> pdSourceKey d <> "' is not a generated logical selector for a column of readmodel '" <> pdSourceReadModel d <> "'"-        | enforcesSpecSurfaceClosures languageContract,-          pdSourceKey d `notElem` map (logicalFieldSelector . rmcName) (rmColumns readModel)-        ]-    dedupReadModelRef =-      resolveReadModelRef DispatchReadModelUnresolved spec (pdLoc d) ("dispatch '" <> pdName d <> "' dedup") (pdDedupReadModel d)-    dedupReadModelField = case [readModel | NReadModel readModel <- specNodes spec, rmName readModel == pdDedupReadModel d] of-      [] -> []-      (readModel : _) ->-        [ mkErr dl DispatchReadModelFieldUnknown $-            "dispatch '" <> pdName d <> "' dedup field '" <> pdDedupReadModelField d <> "' is not a declared column of readmodel '" <> pdDedupReadModel d <> "'"-        | pdDedupReadModelField d `notElem` map rmcName (rmColumns readModel)-        ]---- | The declared contracts in a spec, by name.-specContracts :: Spec -> [ContractNode]-specContracts spec = [c | NContract c <- specNodes spec]---- | EP-4 cross-node coupling: an intake's contract/topic/accepted-events resolve.-intakeCoupling :: EffectiveLanguageContract -> Spec -> IntakeNode -> [Diagnostic]-intakeCoupling languageContract spec i = bindFlagWarnings ++ bindHeaderNames ++ contractCoupling-  where-    -- The Kafka inbox reconstructs an envelope from the canonical header names-    -- in "Keiro.Integration.Event"; nothing reads a spec-declared header. A row-    -- naming a canonical header is descriptive and true, so it stays silent. A-    -- row naming any other header reads like remapping and silently is not.-    bindHeaderNames =-      [ mkSurfaceRefusal languageContract (locLine (inkLoc i)) IntakeBindHeaderUnknown $-          "intake '"-            <> inkName i-            <> "' binds '"-            <> brField binding-            <> "' from header "-            <> T.pack (show headerName)-            <> ", which is not one of keiro's canonical envelope headers; the Kafka inbox reads a fixed header set and cannot be remapped, so this row would not take effect. Use one of: "-            <> T.intercalate ", " (map (T.pack . show) canonicalEnvelopeHeaders)-      | binding <- inkBinds i,-        SrcHeader headerName <- [brSource binding],-        headerName `notElem` canonicalEnvelopeHeaders-      ]-    contractCoupling = case lookupContract (inkContract i) of-      Nothing ->-        [mkErr (locLine (inkLoc i)) IntakeUnresolvedContract ("intake '" <> inkName i <> "' references undeclared contract '" <> inkContract i <> "'")]-      Just c ->-        concat-          [ [ mkErr (locLine (inkLoc i)) IntakeUnresolvedContract ("intake '" <> inkName i <> "' topic '" <> inkTopic i <> "' is not a topic of contract '" <> inkContract i <> "'")-            | inkTopic i `notElem` map fst (ctrTopics c)-            ],-            [ mkErr (locLine (inkLoc i)) IntakeUnresolvedContract ("intake '" <> inkName i <> "' accepts event '" <> ev <> "' not declared in contract '" <> inkContract i <> "'")-            | ev <- inkAccept i,-              ev `notElem` map ceName (ctrEvents c)-            ],-            [ mkErr (locLine (inkLoc i)) TopicAffinityMismatch $-                "intake '" <> inkName i <> "' subscribes to topic '" <> inkTopic i <> "' but accepted event '" <> ceName event <> "' is declared on topic '" <> ceTopic event <> "'"-            | event <- ctrEvents c,-              ceName event `elem` inkAccept i,-              ceTopic event /= inkTopic i-            ],-            [ mkErr (locLine (inkLoc i)) IntakeBindUnresolved $-                "intake '" <> inkName i <> "' binds undeclared envelope or accepted-event field '" <> brField binding <> "'"-            | enforcesSpecSurfaceClosures languageContract,-              binding <- inkBinds i,-              brField binding `Set.notMember` resolvableFields c-            ],-            [ mkErr (locLine (inkLoc i)) IntakeDedupeKeyUnresolved $-                "intake '" <> inkName i <> "' dedupe key '" <> inkDedupeKey i <> "' is not an envelope or accepted-event field"-            | enforcesSpecSurfaceClosures languageContract,-              inkDedupeKey i `Set.notMember` resolvableFields c-            ],-            [ mkErr (locLine (inkLoc i)) IntakeDecodeSchemaVersionMismatch $-                "intake '"-                  <> inkName i-                  <> "' decode schemaVersion "-                  <> tInt (decBodySchemaVersion (inkDecode i))-                  <> " does not match contract '"-                  <> ctrName c-                  <> "' schemaVersion "-                  <> tInt (ctrSchemaVersion c)-            | enforcesSpecSurfaceClosures languageContract,-              decBodySchemaVersion (inkDecode i) /= ctrSchemaVersion c-            ]-          ]-    bindFlagWarnings =-      [ Diagnostic-          { line = locLine (inkLoc i),-            severity = Warning,-            code = IntakeBindFlagUnenforced,-            relatedLocations = [],-            message =-              "intake '"-                <> inkName i-                <> "' bind for '"-                <> brField binding-                <> "' declares "-                <> bindFlagText binding-                <> ", but generated code does not consume envelope bindings"-          }-      | binding <- inkBinds i,-        brRequired binding || brCrossCheck binding-      ]-    lookupContract n = case [c | c <- specContracts spec, ctrName c == n] of (c : _) -> Just c; [] -> Nothing-    resolvableFields contract =-      canonicalIntakeEnvelopeFields-        <> Set.fromList-          [ cfName field-          | event <- ctrEvents contract,-            ceName event `elem` inkAccept i,-            field <- ceFields event-          ]-    bindFlagText binding = case (brRequired binding, brCrossCheck binding) of-      (True, True) -> "'required' and 'cross-check body' flags"-      (True, False) -> "a 'required' flag"-      (False, True) -> "a 'cross-check body' flag"-      (False, False) -> "no enforcement flags"---- Note: @derive … hole@ is mandatory emit grammar, so a per-emit warning about--- it would fire on every emit node in every spec and carry no information. The--- fact that an emit generates no module is reported once, per scaffold run, by--- the report's inert-node line. See ExecPlan 199.-validateEmit :: EffectiveLanguageContract -> Spec -> EmitNode -> [Diagnostic]-validateEmit languageContract spec e = skipRule ++ duplicateCases ++ coupling-  where-    el = locLine (emLoc e)-    skipRule =-      [ mkErr el EmitSkipMissing ("emit '" <> emName e <> "' map must end with an explicit '_ => skip' catch-all (hole-kind 7 optionality)")-      | not (emSkip e)-      ]-    duplicateCases =-      [ mkErr (locLine (emrLoc row)) EmitMapDuplicateCase $-          "emit '" <> emName e <> "' repeats map discriminant '" <> emrValue row <> "'; the first row would shadow this row"-      | enforcesSpecSurfaceClosures languageContract,-        row <- duplicatesBy emrValue (emMap e)-      ]-    coupling = case [c | c <- specContracts spec, ctrName c == emContract e] of-      [] -> [mkErr el EmitUnresolvedContract ("emit '" <> emName e <> "' references undeclared contract '" <> emContract e <> "'")]-      (c : _) ->-        [ mkErr el EmitUnresolvedContract ("emit '" <> emName e <> "' topic '" <> emTopic e <> "' is not a topic of contract '" <> emContract e <> "'")-        | emTopic e `notElem` map fst (ctrTopics c)-        ]-          ++ [ mkErr (locLine (emrLoc r)) EmitUnresolvedContract ("emit '" <> emName e <> "' maps to event '" <> emrEvent r <> "' not declared in contract '" <> emContract e <> "'")-             | r <- emMap e,-               emrEvent r `notElem` map ceName (ctrEvents c)-             ]-          ++ [ mkErr (locLine (emrLoc row)) TopicAffinityMismatch $-                 "emit '" <> emName e <> "' publishes on topic '" <> emTopic e <> "' but mapped event '" <> emrEvent row <> "' is declared on topic '" <> ceTopic event <> "'"-             | row <- emMap e,-               event <- ctrEvents c,-               ceName event == emrEvent row,-               ceTopic event /= emTopic e-             ]--validatePublisher :: EffectiveLanguageContract -> Spec -> PublisherNode -> [Diagnostic]-validatePublisher languageContract spec p =-  unresolvedEmit ++ orderingVocabulary ++ backoffPolicy ++ attemptsFloor ++ outboxField ++ windows-  where-    publisherLine = locLine (pubLoc p)-    unresolvedEmit =-      [ mkErr publisherLine PublisherUnresolvedEmit ("publisher '" <> pubName p <> "' references undeclared emit '" <> pubEmit p <> "'")-      | pubEmit p `notElem` [emName e | NEmit e <- specNodes spec]-      ]-    orderingVocabulary =-      [ mkErr publisherLine PublisherOrderingUnknown $-          "publisher '"-            <> pubName p-            <> "' has unknown ordering '"-            <> pubOrdering p-            <> "'; expected PerKeyHeadOfLine, PerSourceStream, StopTheLine, or BestEffort"-      | pubOrdering p `Set.notMember` publisherOrderings-      ]-    backoffPolicy =-      [ mkErr publisherLine PublisherBackoffInvalid $-          "publisher '" <> pubName p <> "' has an invalid " <> problem-      | Just problem <- [backoffProblemMaybe (pubBackoff p)]-      ]-    attemptsFloor =-      [ mkErr publisherLine PublisherMaxAttemptsBelowMinimum $-          "publisher '" <> pubName p <> "' maxAttempts must be at least 1"-      | enforcesSpecSurfaceClosures languageContract,-        pubMaxAttempts p < 1-      ]-    outboxField = case [emitNode | NEmit emitNode <- specNodes spec, emName emitNode == pubEmit p] of-      [] -> []-      emitNode : _ ->-        [ mkErr publisherLine PublisherOutboxFieldUnresolved $-            "publisher '" <> pubName p <> "' outboxId field '" <> pubOutboxField p <> "' is not messageId, idempotencyKey, or a field of an event mapped by emit '" <> pubEmit p <> "'"-        | enforcesSpecSurfaceClosures languageContract,-          pubOutboxField p `Set.notMember` allowedOutboxFields emitNode-        ]-    allowedOutboxFields emitNode =-      Set.fromList ("messageId" : "idempotencyKey" : mappedContractFields emitNode)-    mappedContractFields emitNode =-      [ fieldDslName (resolveContractFieldIdentity field)-      | contract <- specContracts spec,-        ctrName contract == emContract emitNode,-        event <- ctrEvents contract,-        ceName event `elem` map emrEvent (emMap emitNode),-        field <- ceFields event-      ]-    windows =-      windowRangeRule languageContract publisherLine ("publisher '" <> pubName p <> "' backoff") (boWindow (pubBackoff p))-        ++ maybe [] (windowRangeRule languageContract publisherLine ("publisher '" <> pubName p <> "' maximum backoff")) (boMax (pubBackoff p))--publisherOrderings :: Set Name-publisherOrderings = Set.fromList ["PerKeyHeadOfLine", "PerSourceStream", "StopTheLine", "BestEffort"]--backoffProblemMaybe :: BackoffSpec -> Maybe Text-backoffProblemMaybe backoff = case boKind backoff of-  "constant" -> Nothing-  "exponential" -> case (boMax backoff, boMultiplier backoff) of-    (Just maximumWindow, Just multiplierText) ->-      case (validationWindowSeconds (boWindow backoff), validationWindowSeconds maximumWindow, readMaybe (T.unpack multiplierText) :: Maybe Double) of-        (Just initialSeconds, Just maximumSeconds, Just multiplier)-          | initialSeconds > 0 && maximumSeconds >= initialSeconds && multiplier >= 1 -> Nothing-        _ -> Just "exponential backoff; initial must be positive, max must be at least initial, and multiplier must be at least 1"-    _ -> Just "exponential backoff; both max and multiplier are required"-  other -> Just ("backoff kind '" <> other <> "'; expected constant or exponential")--validationWindowSeconds :: Text -> Maybe Int-validationWindowSeconds window = case T.unsnoc window of-  Just (digits, unit) -> do-    amount <- readMaybe (T.unpack digits)-    case unit of-      's' -> Just amount-      'm' -> Just (amount * 60)-      'h' -> Just (amount * 3600)-      _ -> Nothing-  Nothing -> Nothing--windowSecondsBounded :: Text -> Either Text Int-windowSecondsBounded window = case T.unsnoc window of-  Nothing -> Left "has no unit"-  Just (digits, unit) -> case readMaybe (T.unpack digits) :: Maybe Integer of-    Nothing -> Left "has invalid digits"-    Just amount -> case unitFactor unit of-      Nothing -> Left "has an unknown unit"-      Just factor-        | seconds > fromIntegral (maxBound :: Int) -> Left "exceeds the runtime Int seconds range"-        | otherwise -> Right (fromIntegral seconds)-        where-          seconds = amount * factor-  where-    unitFactor 's' = Just 1-    unitFactor 'm' = Just 60-    unitFactor 'h' = Just 3600-    unitFactor _ = Nothing--windowRangeRule :: EffectiveLanguageContract -> Int -> Text -> Text -> [Diagnostic]-windowRangeRule languageContract diagnosticLine context window =-  [ mkErr diagnosticLine WindowOutOfRange $-      context <> " window '" <> window <> "' " <> reason-  | enforcesSpecSurfaceClosures languageContract,-    Left reason <- [windowSecondsBounded window]-  ]---- | EP-4 inbox disposition rules: the table must be complete over the seven--- outcomes, and the three dangerous inversions must be stated the safe way.-validateIntake :: EffectiveLanguageContract -> IntakeNode -> [Diagnostic]-validateIntake languageContract i = concat [completeness, duplicateRows, inversions, dedupeVocabulary, decodeVersionFloor, envelopeVocabulary, decodePosture, windows]-  where-    il = locLine (inkLoc i)-    -- `decBodyStrict` reaches nothing but the pretty-printer: generated contract-    -- codecs decode every declared body field as required and admit no lenient-    -- mode, so `body strict` describes what happens and `body lenient` does not.-    decodePosture =-      [ mkSurfaceRefusal languageContract il DecodeBodyPostureUnsupported $-          "intake '"-            <> inkName i-            <> "' declares 'body lenient', but generated contract codecs decode a body strictly: every declared field is required and no lenient fallback is emitted. Write 'body strict' to describe what runs"-      | not (decBodyStrict (inkDecode i))-      ]-    rows = inkDisposition i-    requiredOutcomes =-      ["processed", "duplicate", "inProgress", "previouslyFailed", "decodeFailed", "dedupeFailed", "storeFailed"]-    completeness =-      [ mkErr il DispositionIncomplete $-          "intake '" <> inkName i <> "' disposition table is missing outcome '" <> o <> "'"-      | o <- requiredOutcomes,-        o `notElem` map drOutcome rows-      ]-    duplicateRows =-      [ mkErr (locLine (drLoc row)) DispositionDuplicateOutcome $-          "intake '" <> inkName i <> "' repeats disposition outcome '" <> drOutcome row <> "'; the first row would shadow this row"-      | row <- duplicatesBy drOutcome rows-      ]-    windows =-      concat-        [ windowRangeRule languageContract (locLine (drLoc row)) ("intake '" <> inkName i <> "' retry") window-        | row <- rows,-          IRetry window <- [drAction row]-        ]-    dedupeVocabulary =-      [ mkErr il IntakeDedupePolicyUnknown $-          "intake '"-            <> inkName i-            <> "' has unknown dedupe policy '"-            <> inkDedupePolicy i-            <> "'; expected PreferIntegrationMessageId, PreferSourceEventIdentity, or KafkaDeliveryIdentity"-      | inkDedupePolicy i `Set.notMember` intakeDedupePolicies-      ]-    decodeVersionFloor =-      [ mkErr il IntakeDecodeSchemaVersionBelowMinimum $-          "intake '" <> inkName i <> "' decode schemaVersion must be at least 1"-      | enforcesSpecSurfaceClosures languageContract,-        decBodySchemaVersion (inkDecode i) < 1-      ]-    envelopeVocabulary =-      [ mkErr il IntakeEnvelopePolicyUnknown $-          "intake '" <> inkName i <> "' has unsupported envelope policy " <> T.pack (show (decEnvelope (inkDecode i))) <> "; expected \"strict-required lenient-optional\""-      | enforcesSpecSurfaceClosures languageContract,-        decEnvelope (inkDecode i) /= "strict-required lenient-optional"-      ]-    firstRow outcome = case [row | row <- rows, drOutcome row == outcome] of-      (row : _) -> Just row-      [] -> Nothing-    isRetry row = case drAction row of IRetry _ -> True; _ -> False-    inversions =-      [ mkErr (locLine (drLoc row)) DispositionDuplicateRetry $-          "intake '" <> inkName i <> "': a 'duplicate' redelivery must be ackOk (success), not retry"-      | Just row <- [firstRow "duplicate"],-        isRetry row-      ]-        ++ [ mkErr (locLine (drLoc row)) DispositionPreviouslyFailedRetry $-               "intake '" <> inkName i <> "': 'previouslyFailed' must dead-letter, not retry (a prior failure won't succeed on replay)"-           | Just row <- [firstRow "previouslyFailed"],-             isRetry row-           ]-        ++ [ mkErr (locLine (drLoc row)) DispositionDecodeUnboundedRetry $-               "intake '" <> inkName i <> "': 'decodeFailed' must dead-letter (terminal), not retry unboundedly"-           | Just row <- [firstRow "decodeFailed"],-             isRetry row-           ]--intakeDedupePolicies :: Set Name-intakeDedupePolicies = Set.fromList ["PreferIntegrationMessageId", "PreferSourceEventIdentity", "KafkaDeliveryIdentity"]---- | The timer statuses a stored row can hold, mirroring @TimerStatus@ in--- @keiro@'s "Keiro.Timer.Schema". keiro-dsl deliberately does not depend on the--- runtime package, so the list is restated here; the conformance suite that does--- depend on @keiro@ asserts the two agree.-runtimeTimerStatuses :: [Text]-runtimeTimerStatuses = ["Scheduled", "Firing", "Fired", "Cancelled", "Dead"]---- | Every header name keiro's integration envelope actually uses on the wire,--- taken from the runtime's own definitions in "Keiro.Integration.Event" rather--- than restated here, so the two cannot drift apart.-canonicalEnvelopeHeaders :: [Text]-canonicalEnvelopeHeaders =-  [ Event.headerMessageId,-    Event.headerSource,-    Event.headerDestination,-    Event.headerEventType,-    Event.headerSchemaVersion,-    Event.headerContentType,-    Event.headerSchemaRegistry,-    Event.headerSchemaSubject,-    Event.headerSchemaVersionRef,-    Event.headerSchemaId,-    Event.headerSchemaFingerprint,-    Event.headerSourceEventId,-    Event.headerSourceGlobalPosition,-    Event.headerCausationId,-    Event.headerCorrelationId,-    Event.headerTraceParent,-    Event.headerTraceState,-    Event.headerOccurredAt,-    Event.headerAttributes-  ]--canonicalIntakeEnvelopeFields :: Set Name-canonicalIntakeEnvelopeFields =-  Set.fromList-    [ "messageId",-      "source",-      "destination",-      "key",-      "eventType",-      "schemaVersion",-      "contentType",-      "schemaReference",-      "sourceEventId",-      "sourceGlobalPosition",-      "payloadBytes",-      "occurredAt",-      "causationId",-      "correlationId",-      "traceContext",-      "attributes",-      "idempotencyKey"-    ]---- | EP-3 rules for a process manager + its nested timer.-validateProcess :: EffectiveLanguageContract -> Spec -> ProcessNode -> [Diagnostic]-validateProcess languageContract spec p =-  concat [sagaCategoryRule, noWallClock, runtimeOwnedDispatchId, crossNodeCoupling, strictSurfaceResolution, timerCeiling, policyRules, ambiguityRule, benignInversions, onAppendedArms, notMineArm, decodeUnknownStatus, deadLetterText]-  where-    -- Generated dispatch code appends and then acks; `Keiro.ProcessManager` has-    -- no branch that retries or dead-letters a *successful* append. Only AckOk-    -- describes what runs.-    onAppendedArms =-      [ mkSurfaceRefusal languageContract (locLine (dispLoc d)) DispatchOnAppendedUnsupported $-          "dispatch to '"-            <> dispTarget d-            <> "' maps on-appended => "-            <> dispText (onAppended (dispDisposition d))-            <> ", but a successful append is always acked: no runtime path retries or dead-letters an event it just appended. Write 'on-appended AckOk'"-      | d <- hDispatch (procHandle p),-        onAppended (dispDisposition d) /= DAckOk-      ]--    -- `decode unknown-status => X` names the status a row that fails to decode-    -- is read as. X must be a status the timer table actually has.-    decodeUnknownStatus =-      [ mkSurfaceRefusal languageContract (locLine (tmLoc timer)) TimerDecodeStatusUnknown $-          "timer '"-            <> tmName timer-            <> "' maps decode unknown-status => '"-            <> tmDecodeUnknown timer-            <> "', which is not a timer status; a stored timer row is one of: "-            <> T.intercalate ", " runtimeTimerStatuses-      | tmDecodeUnknown timer `notElem` runtimeTimerStatuses-      ]--    -- The dead-letter reason is a hand-owned obligation: `runTimerWorkerWith`-    -- composes its own message for the attempt ceiling, and the generated-    -- comment surfaces this text so an operator-written worker can pass it to-    -- `Keiro.Timer.deadLetterTimer`. Nothing can check what the prose says, but-    -- an empty or blank reason names no obligation at all.-    deadLetterText =-      [ mkSurfaceRefusal languageContract (locLine (tmLoc timer)) TimerDeadLetterTextInvalid $-          "timer '"-            <> tmName timer-            <> "' declares a blank dead-letter reason; the reason is the hand-owned text an operator-written timer worker passes to Keiro.Timer.deadLetterTimer, so it must say something"-      | T.null (T.strip (tmDeadLetter timer))-      ]--    -- The timer worker marks a timer Fired only when the fire action returns the-    -- id of an event it appended (`Keiro.Timer.runTimerWorkerWith`). A not-mine-    -- dispatch produces no such id, so the row is left Firing and requeued on a-    -- later pass — which is exactly Retry. Fired is not reachable.-    notMineArm =-      [ mkSurfaceRefusal languageContract (locLine (tmLoc timer)) TimerNotMineUnsupported $-          "timer '"-            <> tmName timer-            <> "' maps not-mine => Fired, but the timer worker marks a timer Fired only when the fire action returns the id of the event it appended; a dispatch that is not this timer's has no such id, so the row is requeued instead. Write 'not-mine Retry'"-      | notMine (fireDisposition (tmFire timer)) == OFired-      ]-    aggregates = [a | NAggregate a <- specNodes spec]-    aggNames = map aggName aggregates-    projectionTables = [projTable projection | aggregate <- aggregates, Just projection <- [aggProjection aggregate]]-    inputFields = map fieldName (inFields (procInput p))-    timeFields = [fieldName f | f <- inFields (procInput p), fieldType f == Just "Time"]-    timer = procTimer p-    pl = locLine (procLoc p)--    sagaCategoryRule =-      [ mkErr pl SagaCategoryIllegal $-          "saga category " <> T.pack (show (sagaCategory (procSaga p))) <> " " <> reason-      | Just reason <- [sagaCategoryError (sagaCategory (procSaga p))]-      ]--    -- TIME IS INJECTED, NOT SAMPLED: fireAt's field must be a declared :Time-    -- input field. (FireAtExpr has no clock-sampling constructor, so this is a-    -- field-resolution + typed-as-Time check.)-    noWallClock =-      let f = faField (tmFireAt timer)-       in if f `notElem` inputFields-            then-              [ mkErr (locLine (tmLoc timer)) ProcessFireAtNotInjected $-                  "timer '" <> tmName timer <> "' fireAt field '" <> f <> "' is not a field of input '" <> inName (procInput p) <> "'"-              ]-            else-              [ mkErr (locLine (tmLoc timer)) ProcessFireAtNotInjected $-                  "timer '" <> tmName timer <> "' fireAt references '" <> f <> "', which is not a declared :Time field of input '" <> inName (procInput p) <> "'"-              | f `notElem` timeFields-              ]--    -- Dispatched (and fired) command ids are runtime-owned; no field binding may-    -- supply a commandId/id.-    runtimeOwnedDispatchId =-      [ mkErr pl ProcessDispatchIdSupplied $-          "advance command '" <> advCommand advance <> "' supplies a runtime-owned id field '" <> fbName binding <> "'; remove it"-      | let advance = hAdvance (procHandle p),-        binding <- advFields advance,-        fbName binding `elem` (["commandId", "id"] :: [Name])-      ]-        ++ [ mkErr (locLine (dispLoc d)) ProcessDispatchIdSupplied $-               "dispatch to '" <> dispTarget d <> "' supplies a runtime-owned id field '" <> fbName b <> "'; remove it"-           | d <- hDispatch (procHandle p),-             b <- dispFields d,-             fbName b `elem` (["commandId", "id"] :: [Name])-           ]-        ++ [ mkErr (locLine (tmLoc timer)) ProcessDispatchIdSupplied $-               "timer fire supplies a runtime-owned id field '" <> fbName b <> "'; remove it"-           | b <- fireFields (tmFire timer),-             fbName b `elem` (["commandId", "id"] :: [Name])-           ]--    -- Aggregate, command, field, timer, and projection references must resolve.-    crossNodeCoupling =-      [ mkErr pl ProcessUnresolvedRef ("saga '" <> sagaAgg (procSaga p) <> "' does not resolve to a declared aggregate")-      | sagaAgg (procSaga p) `notElem` aggNames-      ]-        ++ [ mkErr pl ProcessUnresolvedRef ("target '" <> procTarget p <> "' does not resolve to a declared aggregate")-           | procTarget p `notElem` aggNames-           ]-        ++ [ mkErr (locLine (tmLoc timer)) ProcessUnresolvedRef ("timer fire target '" <> fireTarget (tmFire timer) <> "' must be the saga or the target aggregate")-           | fireTarget (tmFire timer) `notElem` [sagaAgg (procSaga p), procTarget p]-           ]-        ++ resolveCommand pl "advance" (sagaAgg (procSaga p)) (advCommand advance) (advFields advance)-        ++ concatMap resolveDispatch (hDispatch (procHandle p))-        ++ resolveCommand (locLine (tmLoc timer)) "timer fire" (fireTarget fire) (fireCommand fire) (fireFields fire)-        ++ [ mkErr pl ProcessUnresolvedRef $-               "process '" <> procId p <> "' schedules undeclared timer '" <> hSchedule (procHandle p) <> "'; declared timer is '" <> tmName timer <> "'"-           | hSchedule (procHandle p) /= tmName timer-           ]-        ++ [ mkErr pl ProcessUnresolvedRef $-               "process '" <> procId p <> "' references undeclared projection table '" <> projection <> "'"-           | projection <- procProjections p,-             projection `notElem` projectionTables-           ]-      where-        advance = hAdvance (procHandle p)-        fire = tmFire timer-        resolveDispatch dispatch =-          resolveCommand-            (locLine (dispLoc dispatch))-            "dispatch"-            (dispTarget dispatch)-            (dispCommand dispatch)-            (dispFields dispatch)-        resolveCommand diagnosticLine context target command bindings = case lookupAggregate target of-          Nothing -> []-          Just aggregate -> case [decl | decl <- aggCommands aggregate, cmdName decl == command] of-            [] ->-              [ mkErr diagnosticLine ProcessUnresolvedRef $-                  context <> " command '" <> command <> "' is not declared by aggregate '" <> target <> "'"-              ]-            (declaration : _) ->-              [ mkErr diagnosticLine ProcessFieldBindingUnresolved $-                  context <> " command '" <> command <> "' binds undeclared target field '" <> fbName binding <> "'"-              | binding <- bindings,-                fbName binding `notElem` map aggregateFieldName (cmdFields declaration)-              ]-        lookupAggregate name = case [aggregate | aggregate <- aggregates, aggName aggregate == name] of-          (aggregate : _) -> Just aggregate-          [] -> Nothing--    strictSurfaceResolution-      | not (enforcesSpecSurfaceClosures languageContract) = []-      | otherwise = correlateFieldRule ++ dispatchKeyRules ++ bindingScopeRules ++ idFieldRules ++ fireWindowRule--    correlateFieldRule =-      [ mkErr pl ProcessKeyFieldUnknown $-          "correlate references 'input." <> corrField (procCorrelate p) <> "' but input '" <> inName (procInput p) <> "' does not declare that field"-      | corrField (procCorrelate p) `notElem` inputFields-      ]--    dispatchKeyRules =-      [ mkErr (locLine (dispLoc dispatch)) ProcessDispatchKeyUnresolved $-          "dispatch to '" <> dispTarget dispatch <> "' uses unresolved key '" <> dispKey dispatch <> "'; expected correlationId or input.<declared-field>"-      | dispatch <- hDispatch (procHandle p),-        not (processKeyInScope (dispKey dispatch))-      ]-        ++ [ mkErr (locLine (tmLoc timer)) ProcessDispatchKeyUnresolved $-               "timer fire to '" <> fireTarget (tmFire timer) <> "' uses unresolved key '" <> fireKey (tmFire timer) <> "'; expected correlationId or input.<declared-field>"-           | not (processKeyInScope (fireKey (tmFire timer)))-           ]--    processKeyInScope value =-      value == "correlationId"-        || case T.stripPrefix "input." value of-          Just field -> field `elem` inputFields-          Nothing -> False--    bindingScopeRules =-      bindingRules pl "advance" inputFields (advFields (hAdvance (procHandle p)))-        ++ concatMap-          (\dispatch -> bindingRules (locLine (dispLoc dispatch)) "dispatch" inputFields (dispFields dispatch))-          (hDispatch (procHandle p))-        ++ bindingRules-          (locLine (tmLoc timer))-          "timer fire"-          (inputFields <> map fbName (tmPayload timer) <> ["timerId"])-          (fireFields (tmFire timer))--    bindingRules diagnosticLine context bareScope bindings =-      [ mkErr diagnosticLine ProcessBindingUnscoped $-          context <> " binding '" <> fbName binding <> maybe "" ("=" <>) (fbValue binding) <> "' is outside the process input and timer scopes"-      | binding <- bindings,-        not (bindingInScope bareScope binding)-      ]--    bindingInScope bareScope binding = case fbValue binding of-      Nothing -> fbName binding `elem` bareScope-      Just value-        | isQuoted value -> True-        | value == "timer.id" -> True-        | Just field <- T.stripPrefix "input." value -> field `elem` inputFields-        | otherwise -> value `elem` bareScope--    isQuoted value = T.length value >= 2 && T.head value == '"' && T.last value == '"'--    idFieldRules =-      [ mkErr (locLine (tmLoc timer)) TimerIdFieldNotCorrelation $-          "timer '" <> tmName timer <> "' " <> context <> " derives from '" <> ideField expression <> "'; only correlationId is implemented by generated runtime code"-      | (context, expression) <- [("id", tmId timer), ("fired-event-id", fireFiredEventId (tmFire timer))],-        ideField expression /= "correlationId"-      ]--    fireWindowRule =-      windowRangeRule languageContract (locLine (tmLoc timer)) ("timer '" <> tmName timer <> "' fireAt") (faWindow (tmFireAt timer))--    timerCeiling =-      [ mkErr (locLine (tmLoc timer)) ProcessTimerCeilingInvalid $-          "timer '" <> tmName timer <> "' max-attempts must be at least 1"-      | tmMaxAttempts timer < 1-      ]--    policyRules =-      policyConsistency-        (procId p)-        (procLoc p)-        (procRejected p)-        [ (dispCommand dispatch, dispLoc dispatch, dispDisposition dispatch)-        | dispatch <- hDispatch (procHandle p)-        ]--    ambiguityRule =-      [ mkErr (locLine (tmLoc timer)) AmbiguousMarkedBenign $-          "timer '" <> tmName timer <> "' maps on-ambiguous => Fired; CommandAmbiguous means multiple aggregate edges matched and is never a benign success. Use on-ambiguous Retry so the attempts ceiling dead-letters the definition bug"-      | onAmbiguous (fireDisposition (tmFire timer)) == OFired-      ]--    -- Surface the dangerous benign inversions the author confirmed (warnings).-    benignInversions =-      [ Diagnostic (locLine (tmLoc timer)) Warning ProcessBenignInversion [] $-          "timer '" <> tmName timer <> "' maps on-reject => Fired (a CommandRejected is treated as benign success)"-      | onReject (fireDisposition (tmFire timer)) == OFired-      ]-        ++ [ Diagnostic (locLine (dispLoc d)) Warning ProcessBenignInversion [] $-               "dispatch to '" <> dispTarget d <> "' maps on-duplicate => AckOk (a duplicate is treated as benign success)"-           | d <- hDispatch (procHandle p),-             onDuplicate (dispDisposition d) == DAckOk-           ]---- | Explain why a process saga category is illegal.  The first four cases--- mirror 'Keiro.Stream.category' without introducing a runtime dependency into--- the toolchain library.  The final @:@ case is deliberately stricter because--- that prefix is reserved for the @wf:<name>@ workflow stream family.-sagaCategoryError :: Text -> Maybe Text-sagaCategoryError = runtimeIdentityError False--stableIdentityError :: Text -> Maybe Text-stableIdentityError = runtimeIdentityError True--runtimeIdentityError :: Bool -> Text -> Maybe Text-runtimeIdentityError allowsHyphen identity-  | T.null identity = Just "is empty; use a non-empty stable name"-  | identity == "$all" = Just "is reserved by the event store; choose a service-owned stable name"-  | not allowsHyphen && T.isInfixOf "-" identity = Just "contains '-' (kiroku's category/id boundary); write compound categories in camelCase, for example \"hospitalSurge\""-  | Just illegal <- T.find (\character -> isSpace character || isControl character) identity =-      Just ("contains whitespace or control character " <> T.pack (show illegal) <> "; remove it and use camelCase")-  | T.isInfixOf ":" identity = Just "contains ':' which is reserved for runtime stream-family prefixes; choose a stable name without ':'"-  | otherwise = Nothing---- | The generated lower-camel selector for a logical field or SQL column.--- Read-model notation stores SQL names such as @responder_id@ while router--- resolve rows and dispatch keys use the generated selector @responderId@.-logicalFieldSelector :: Text -> Text-logicalFieldSelector raw =-  case HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site of-    Right derived -> HaskellName.renderLowerCamelName (HaskellName.lowerCamel derived)-    Left _ -> raw-  where-    site =-      HaskellName.NameSite-        { HaskellName.siteKind = HaskellName.GeneratedFieldSite,-          HaskellName.siteLogicalName = raw,-          HaskellName.siteOwner = "validation field resolution",-          HaskellName.siteLine = 0-        }---- | EP-108 rules for a stateless content-based router.-validateRouter :: EffectiveLanguageContract -> Spec -> RouterNode -> [Diagnostic]-validateRouter languageContract spec router =-  concat-    [ references,-      keyField,-      bindingScope,-      commandReference,-      readModelReference,-      policyRules,-      duplicateNotice,-      onAppendedArm-    ]-  where-    -- The process twin of this rule is in 'validateProcess'; both say the same-    -- thing because both runtimes do: a successful append is always acked.-    onAppendedArm =-      [ mkSurfaceRefusal languageContract dispatchLine DispatchOnAppendedUnsupported $-          "router dispatch '"-            <> rdCommand dispatch-            <> "' maps on-appended => "-            <> dispText (onAppended (rdDisposition dispatch))-            <> ", but a successful append is always acked: no runtime path retries or dead-letters an event it just appended. Write 'on-appended AckOk'"-      | onAppended (rdDisposition dispatch) /= DAckOk-      ]-    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]-    readModels = [readModel | NReadModel readModel <- specNodes spec]-    inputFields = map fieldName (inFields (rtInput router))-    resolvedFields = rvRow (rtResolve router)-    dispatch = rtDispatch router-    routerLine = locLine (rtLoc router)-    dispatchLine = locLine (rdLoc dispatch)--    targetAggregate = case [aggregate | aggregate <- aggregates, aggName aggregate == rtTarget router] of-      aggregate : _ -> Just aggregate-      [] -> Nothing--    projectionTables = [projTable projection | aggregate <- aggregates, Just projection <- [aggProjection aggregate]]--    references =-      [ mkErr routerLine RouterUnresolvedRef $-          "router '" <> rtId router <> "' targets aggregate '" <> rtTarget router <> "' but no such aggregate is declared"-      | targetAggregate == Nothing-      ]-        ++ [ mkErr routerLine RouterUnresolvedRef $-               "router '" <> rtId router <> "' references undeclared projection table '" <> projection <> "'"-           | projection <- rtProjections router,-             projection `notElem` projectionTables-           ]--    keyField =-      [ mkErr routerLine RouterKeyFieldUnknown $-          "key references 'input." <> corrField (rtKey router) <> "' but input '" <> inName (rtInput router) <> "' does not declare that field"-      | corrField (rtKey router) `notElem` inputFields-      ]--    bindingScope =-      [ mkErr dispatchLine RouterBindingUnscoped $-          "dispatch binding '" <> fbName binding <> maybe "" ("=" <>) (fbValue binding) <> "' is outside the router input and resolve-row scopes"-      | binding <- rdFields dispatch,-        not (bindingInScope binding)-      ]-      where-        bindingInScope binding = case fbValue binding of-          Nothing -> fbName binding `elem` inputFields-          Just value-            | isQuoted value -> True-            | Just field <- T.stripPrefix "input." value -> field `elem` inputFields-            | Just field <- T.stripPrefix "resolved." value -> field `elem` resolvedFields-            | otherwise -> False-        isQuoted value = T.length value >= 2 && T.head value == '"' && T.last value == '"'--    commandReference = case targetAggregate of-      Nothing -> []-      Just aggregate -> case [command | command <- aggCommands aggregate, cmdName command == rdCommand dispatch] of-        [] ->-          [ mkErr dispatchLine RouterCommandUnknown $-              "dispatch command '" <> rdCommand dispatch <> "' is not declared by aggregate '" <> aggName aggregate <> "'"-          ]-        command : _ ->-          [ mkErr dispatchLine RouterCommandUnknown $-              "dispatch command '" <> rdCommand dispatch <> "' binds undeclared target field '" <> fbName binding <> "'"-          | binding <- rdFields dispatch,-            fbName binding `notElem` map aggregateFieldName (cmdFields command)-          ]--    readModelReference = case rvSource (rtResolve router) of-      ResolveHole -> []-      ResolveReadModel name ->-        case [readModel | readModel <- readModels, rmName readModel == name] of-          [] ->-            [ mkErr (locLine (rvLoc (rtResolve router))) RouterUnresolvedRef $-                "router '" <> rtId router <> "' resolve names readmodel '" <> name <> "' but no such readmodel node is declared"-            ]-          readModel : _ ->-            [ mkErr (locLine (rvLoc (rtResolve router))) RouterReadModelUnverified $-                "router '" <> rtId router <> "' resolve row field '" <> column <> "' is not a declared column of readmodel '" <> name <> "'"-            | enforcesSpecSurfaceClosures languageContract,-              column <- rvRow (rtResolve router),-              column `notElem` map (logicalFieldSelector . rmcName) (rmColumns readModel)-            ]--    policyRules =-      policyConsistency-        (rtId router)-        (rtLoc router)-        (rtRejected router)-        [(rdCommand dispatch, rdLoc dispatch, rdDisposition dispatch)]--    duplicateNotice =-      [ Diagnostic dispatchLine Warning RouterBenignInversion [] $-          "router dispatch '" <> rdCommand dispatch <> "' maps on-duplicate => AckOk; Keiro.Router confirms the event id against the target stream before treating the duplicate as benign"-      | onDuplicate (rdDisposition dispatch) == DAckOk-      ]---- | Reconcile per-dispatch prose with the one node-level policy the runtime--- actually applies to a rejection-class failure group.-policyConsistency :: Name -> Loc -> PolicyChoice -> [(Name, Loc, DispatchDisposition)] -> [Diagnostic]-policyConsistency nodeName nodeLoc rejectedPolicy dispatches = contradictions ++ divergent ++ unused ++ ambiguityWarning-  where-    contradictions =-      [ mkErr (locLine dispatchLoc) PolicyContradiction $-          "dispatch '" <> command <> "' declares on-failed DeadLetter, but node '" <> nodeName <> "' does not declare rejected => deadLetter; align the dispatch story with the node-level RejectedCommandPolicy"-      | (command, dispatchLoc, disposition) <- dispatches,-        DDeadLetter _ <- [onFailed disposition],-        rejectedPolicy /= PolDeadLetter-      ]--    divergent = case dispatches of-      [] -> []-      (_, _, firstDisposition) : rest ->-        [ mkErr (locLine dispatchLoc) PolicyContradiction $-            "dispatch '" <> command <> "' has a different on-failed action from another dispatch in node '" <> nodeName <> "'; the runtime applies one RejectedCommandPolicy to the whole failure group"-        | (command, dispatchLoc, disposition) <- rest,-          not (sameFailureAction (onFailed disposition) (onFailed firstDisposition))-        ]--    unused =-      [ Diagnostic (locLine nodeLoc) Warning PolicyDeadLetterUnused [] $-          "node '" <> nodeName <> "' declares rejected => deadLetter but no dispatch on-failed arm says DeadLetter; the runtime policy is live, but the per-dispatch notation does not acknowledge it"-      | rejectedPolicy == PolDeadLetter,-        all (not . isDeadLetter . onFailed . third) dispatches-      ]--    ambiguityWarning =-      [ Diagnostic (locLine nodeLoc) Warning AmbiguousFollowsRejectedPolicy [] $-          "node '" <> nodeName <> "' acknowledges rejection-class failures; CommandAmbiguous follows the same rejected policy, and a dead-letter errorClass is the durable witness of that definition bug"-      | rejectedPolicy `elem` [PolDeadLetter, PolSkip]-      ]--    third (_, _, value) = value-    sameFailureAction DDeadLetter {} DDeadLetter {} = True-    sameFailureAction left right = left == right-    isDeadLetter DDeadLetter {} = True-    isDeadLetter _ = False--validateAggregate :: EffectiveLanguageContract -> Spec -> Aggregate -> [Diagnostic]-validateAggregate languageContract spec agg =-  concat-    [ emptyAggregate,-      duplicateMembers,-      declaredRefs,-      eventBodyRefs,-      outputMappingRules,-      registerInitialScope,-      reachability,-      terminalNoOutgoing,-      guardScope,-      clockFree,-      projectionKeyResolution,-      projectionSafety,-      statusMapTotality,-      evolutionRules,-      snapshotRules,-      replayOnlyRules,-      eventlessStateChangeRules,-      wirePolicyRules,-      fieldWireKeyRules-    ]-  where-    emptyAggregate =-      [ mkErr (locLine (aggLoc agg)) AggregateEmpty $-          "aggregate '"-            <> aggName agg-            <> "' declares "-            <> renderMissing missingAggregateParts-            <> "; scaffold cannot lower an empty aggregate -- declare at least one command, one event, and one transition"-      | not (null missingAggregateParts)-      ]-    missingAggregateParts =-      [ label-      | (isMissing, label) <--          [ (null (aggCommands agg), "no commands"),-            (null (aggEvents agg), "no events"),-            (null (aggTransitions agg), "no transitions")-          ],-        isMissing-      ]-    renderMissing [] = ""-    renderMissing [onlyPart] = onlyPart-    renderMissing [firstPart, secondPart] = firstPart <> " and " <> secondPart-    renderMissing parts = T.intercalate ", " (init parts) <> ", and " <> last parts--    states = Set.fromList (map stName (aggStates agg))-    terminals = Set.fromList [stName s | s <- aggStates agg, stTerminal s]-    commandFields :: Map Name [Name]-    commandFields = Map.fromList [(cmdName c, map aggregateFieldName (cmdFields c)) | c <- aggCommands agg]-    commandNames = Map.keysSet commandFields-    eventNames = Set.fromList (map evName (aggEvents agg))-    enumCtorNames = Set.fromList [c | e <- specEnums spec, (c, _) <- enumCtors e]-    ruleNames = Set.fromList (map ruleName (specRules spec))-    registerNames = Set.fromList (map regName (aggRegs agg))--    eventFieldsFor event =-      case evBody event of-        EventFields fields -> fields-        EventFromCommand commandName ->-          [ field-          | command <- aggCommands agg,-            cmdName command == commandName,-            field <- cmdFields command-          ]--    fieldWireKeyRules =-      concat-        [ wireKeyRulesForRecord-            ("aggregate '" <> aggName agg <> "' command '" <> cmdName command <> "'")-            Nothing-            (map resolveAggregateFieldIdentity (cmdFields command))-        | command <- aggCommands agg-        ]-        <> concat-          [ wireKeyRulesForRecord-              ("aggregate '" <> aggName agg <> "' event '" <> evName event <> "'")-              (Just ("kind", "event envelope key"))-              (map resolveAggregateFieldIdentity (eventFieldsFor event))-          | event <- aggEvents agg-          ]--    snapshotRules = case aggSnapshot agg of-      Nothing -> []-      Just snapshot ->-        [ mkErr (locLine (snapLoc snapshot)) SnapshotIntervalInvalid $-            "aggregate '" <> aggName agg <> "': snapshot every requires an interval of at least 1; non-positive runtime intervals silently disable snapshots"-        | SnapEvery interval <- [snapPolicy snapshot],-          interval < 1-        ]-          ++ [ mkErr (locLine (snapLoc snapshot)) SnapshotCodecFixtureInvalid $-                 "aggregate '" <> aggName agg <> "': snapshot state-codec version must be at least 1 and shape-hash must be non-empty"-             | snapCodecVersion snapshot < 1 || T.null (snapShapeHash snapshot)-             ]--    wirePolicyRules = case aggWire agg of-      Just wire-        | enforcesSpecSurfaceClosures languageContract,-          wireKind wire /= "ctorName" || wireFields wire /= "camelCase" ->-            [ mkErr (locLine (aggLoc agg)) WireClauseUnsupported $-                "aggregate '"-                  <> aggName agg-                  <> "' wire clause describes kind="-                  <> wireKind wire-                  <> " fields="-                  <> wireFields wire-                  <> "; generated bytes currently support only kind=ctorName fields=camelCase"-            ]-      _ -> []--    duplicateMembers =-      [ mkErr (locLine (cmdLoc c)) DuplicateCommandName $-          "aggregate '" <> aggName agg <> "' declares command '" <> cmdName c <> "' more than once"-      | c <- duplicatesBy cmdName (aggCommands agg)-      ]-        ++ [ mkErr (locLine (evLoc e)) DuplicateEventName $-               "aggregate '" <> aggName agg <> "' declares event '" <> evName e <> "' more than once"-           | e <- duplicatesBy evName (aggEvents agg)-           ]-        ++ [ mkErr (locLine (aggregateFieldLoc field)) AggregateDuplicateFieldName $-               "aggregate '" <> aggName agg <> "' command '" <> cmdName command <> "' declares field '" <> aggregateFieldName field <> "' more than once"-           | command <- aggCommands agg,-             field <- duplicatesBy aggregateFieldName (cmdFields command)-           ]-        ++ [ mkErr (locLine (aggregateFieldLoc field)) AggregateDuplicateFieldName $-               "aggregate '" <> aggName agg <> "' event '" <> evName event <> "' declares field '" <> aggregateFieldName field <> "' more than once"-           | event <- aggEvents agg,-             EventFields fields <- [evBody event],-             field <- duplicatesBy aggregateFieldName fields-           ]-        ++ [ mkErr (locLine (stLoc state)) AggregateDuplicateState $-               "aggregate '" <> aggName agg <> "' declares state '" <> stName state <> "' more than once"-           | state <- duplicatesBy stName (aggStates agg)-           ]-        ++ [ mkErr (locLine (regLoc register)) AggregateDuplicateRegister $-               "aggregate '" <> aggName agg <> "' declares register '" <> regName register <> "' more than once"-           | enforcesSpecSurfaceClosures languageContract,-             register <- duplicatesBy regName (aggRegs agg)-           ]-        ++ [ mkErr (locLine (tLoc transition)) TransitionDuplicateUnguarded $-               "aggregate '"-                 <> aggName agg-                 <> "' has more than one live unguarded transition for '"-                 <> tSource transition-                 <> " -- "-                 <> tCommand transition-                 <> "'; every matching command would be ambiguous"-           | group <- duplicateGroupsBy transitionKey unguardedTransitions,-             transition <- group-           ]-        ++ [ mkErr (locLine (tLoc guarded)) TransitionUnguardedSibling $-               "aggregate '"-                 <> aggName agg-                 <> "' guarded transition '"-                 <> tSource guarded-                 <> " -- "-                 <> tCommand guarded-                 <> "' overlaps an unguarded sibling at line "-                 <> tInt (locLine (tLoc unguarded))-           | enforcesSpecSurfaceClosures languageContract,-             guarded <- liveTransitions,-             tGuard guarded /= Nothing,-             unguarded : _ <- [[candidate | candidate <- unguardedTransitions, transitionKey candidate == transitionKey guarded]]-           ]-    liveTransitions = [transition | transition <- aggTransitions agg, tMode transition == TmLive]-    unguardedTransitions = [transition | transition <- liveTransitions, tGuard transition == Nothing]-    transitionKey transition = (tSource transition, tCommand transition)--    eventBodyRefs =-      [ mkErr (locLine (evLoc e)) UndeclaredCommand $-          "event '" <> evName e <> "' copies fields from undeclared command '" <> command <> "'"-      | e <- aggEvents agg,-        EventFromCommand command <- [evBody e],-        command `Set.notMember` commandNames-      ]--    outputMappingRules =-      [ mkErr (locLine (tLoc transition)) EventOutputCommandMismatch $-          "transition '"-            <> tSource transition-            <> " -- "-            <> consuming-            <> "' emits event '"-            <> eventName-            <> "' declared as fields("-            <> declared-            <> "); generated identity output is legal only when the transition consumes that same command"-      | transition <- aggTransitions agg,-        (emitIndex, eventName) <- zip [1 ..] (tEmits transition),-        Left OutputCommandMismatch {declaredSourceCommand = declared, consumingTransitionCommand = consuming} <- [eventOutputMapping spec agg transition emitIndex eventName]-      ]--    registerInitialScope = concatMap checkRegisterInitial (aggRegs agg)-    checkRegisterInitial r = case [e | e <- specEnums spec, TRef (enumName e) == regType r] of-      (e : _) -> case enumBinding e of-        Just _ ->-          [ outOfScope r "declaration-owned symbol selected by" "initial"-          | regInitialBare r /= Just "initial"-          ]-        Nothing ->-          [ outOfScope r "constructor of enum" (enumName e)-          | regInitialBare r `notElem` map (Just . fst) (enumCtors e)-          ]-      []-        | regType r == TRef (aggName agg <> "Vertex") ->-            [ outOfScope r "state of aggregate" (aggName agg)-            | maybe True (`Set.notMember` states) (regInitialBare r)-            ]-        | Just identifier <- firstMatching (\declaration -> regType r == TRef (idName declaration)) (specIds spec) -> case idBinding identifier of-            Just _ ->-              [ outOfScope r "declaration-owned symbol selected by" "initial"-              | regInitialBare r /= Just "initial"-              ]-            Nothing ->-              [ outOfScope r "literal" "placeholder"-              | regInitialBare r /= Just "placeholder"-              ]-        | otherwise -> []-    outOfScope r expected domain =-      mkErr (locLine (regLoc r)) RegisterInitialOutOfScope $-        "register '" <> regName r <> "' initial '" <> renderRegInitial (regInitial r) <> "' is not a " <> expected <> " '" <> domain <> "'"-    regInitialBare r = case regInitial r of-      RegInitBare value -> Just value-      RegInitText _ -> Nothing-    renderRegInitial = \case-      RegInitBare value -> value-      RegInitText value -> value--    -- Rule 1: declared-reference for command / emit / goto / source.-    declaredRefs =-      concatMap transitionRefs (aggTransitions agg)-    transitionRefs t =-      [ mkErr (locLine (tLoc t)) UndeclaredCommand $-          "transition references undeclared command '" <> tCommand t <> "'"-      | not (tCommand t `Set.member` commandNames)-      ]-        ++ [ mkErr (locLine (tLoc t)) UndeclaredState $-               "transition source '" <> tSource t <> "' is not a declared state"-           | not (tSource t `Set.member` states)-           ]-        ++ [ mkErr (locLine (tLoc t)) UndeclaredState $-               "transition goto '" <> tGoto t <> "' is not a declared state"-           | not (tGoto t `Set.member` states)-           ]-        ++ [ mkErr (locLine (tLoc t)) UndeclaredEvent $-               "emit references undeclared event '" <> ev <> "'"-           | ev <- tEmits t,-             not (ev `Set.member` eventNames)-           ]--    -- Rule 2: reachability of every non-terminal state from the initial state-    -- (the first state in the list).-    reachability = case map stName (aggStates agg) of-      [] -> []-      (initial : _) ->-        let reached = bfs (Set.singleton initial) [initial]-         in [ mkErr (locLine (stLoc s)) UnreachableState $-                "state '" <> stName s <> "' is not reachable from the initial state '" <> initial <> "'"-            | s <- aggStates agg,-              not (stTerminal s),-              not (stName s `Set.member` reached)-            ]-    edgesFrom src = [tGoto t | t <- aggTransitions agg, tSource t == src]-    bfs seen [] = seen-    bfs seen (x : xs) =-      let nexts = [n | n <- edgesFrom x, not (n `Set.member` seen)]-       in bfs (foldr Set.insert seen nexts) (xs ++ nexts)--    -- Rule 3: a terminal state has no outgoing transition.-    terminalNoOutgoing =-      [ mkErr (locLine (tLoc t)) TerminalHasOutgoing $-          "terminal state '" <> tSource t <> "' has an outgoing transition"-      | t <- aggTransitions agg,-        tSource t `Set.member` terminals-      ]--    -- Rule 4: every atom in a guard or write Expr resolves to a register, a-    -- field of the transition's command, an enum constructor, a rule, or a bool.-    guardScope = concatMap transitionScope (aggTransitions agg)-    transitionScope t =-      let inScope =-            registerNames-              `Set.union` Set.fromList (Map.findWithDefault [] (tCommand t) commandFields)-              `Set.union` enumCtorNames-              `Set.union` ruleNames-              -- State names are constructors of the implicit vertex enum, so a-              -- @write reservationState := Held@ references a state legitimately.-              `Set.union` states-          exprs = maybe [] pure (tGuard t) ++ map snd (tWrites t)-          badAtoms =-            [ n-            | e <- exprs,-              n <- exprNames e,-              not (n `Set.member` clockAtoms), -- clock atoms reported separately-              not (n `Set.member` inScope)-            ]-          badTargets = [target | (target, _) <- tWrites t, target `Set.notMember` registerNames]-       in [ mkErr (locLine (tLoc t)) WriteTargetNotRegister $-              "write target '" <> target <> "' is not a register of aggregate '" <> aggName agg <> "'"-          | target <- dedup badTargets-          ]-            ++ [ mkErr (locLine (tLoc t)) GuardAtomOutOfScope $-                   "atom '" <> n <> "' in transition '" <> tSource t <> " -- " <> tCommand t <> "' resolves to no register, command field, enum constructor, or rule"-               | n <- dedup badAtoms-               ]--    -- Rule 5 (cross-cutting): no guard or write Expr samples a wall clock.-    clockFree = concatMap transitionClock (aggTransitions agg)-    transitionClock t =-      let exprs = maybe [] pure (tGuard t) ++ map snd (tWrites t)-          sampled = [n | e <- exprs, n <- exprNames e, n `Set.member` clockAtoms]-       in [ mkErr (locLine (tLoc t)) ClockSampled $-              "transition '" <> tSource t <> " -- " <> tCommand t <> "' samples the wall clock via '" <> n <> "'; time must be an injected input field, not sampled"-          | n <- dedup sampled-          ]--    -- EP-107: a projection references a first-class read model when one exists.-    -- Legacy standalone projections remain legal, but are surfaced as warnings.-    projectionKeyResolution =-      [ mkErr (locLine (projLoc projection)) AggProjectionKeyUnresolved $-          "projection '" <> projTable projection <> "' key '" <> projKey projection <> "' is not a register, command field, or event field of aggregate '" <> aggName agg <> "'"-      | enforcesSpecSurfaceClosures languageContract,-        Just projection <- [aggProjection agg],-        projKey projection `Set.notMember` projectionFields-      ]-    projectionFields =-      registerNames-        `Set.union` Set.fromList [fieldDslName (resolveAggregateFieldIdentity field) | command <- aggCommands agg, field <- cmdFields command]-        `Set.union` Set.fromList [fieldDslName (resolveAggregateFieldIdentity field) | event <- aggEvents agg, field <- eventFieldsFor event]--    projectionSafety = case aggProjection agg of-      Nothing -> []-      Just projection -> case [readModel | NReadModel readModel <- specNodes spec, rmName readModel == projTable projection] of-        [] ->-          [ mkErr (locLine (projLoc projection)) RmStrongInlineOnly $-              "projection '" <> projTable projection <> "' declares consistency = Strong but has no readmodel node; a standalone projection is inline-only and has no subscription cursor"-          | projConsistency projection == Just Strong-          ]-            ++ [ Diagnostic-                   { line = locLine (projLoc projection),-                     severity = Warning,-                     code = RmProjectionWithoutNode,-                     relatedLocations = [],-                     message = "projection '" <> projTable projection <> "' has no readmodel node; registration, schema identity, consistency, and rebuild helpers are unavailable"-                   }-               ]-        (readModel : _) ->-          [ mkErr (locLine (projLoc projection)) RmConsistencyConflict $-              "projection '" <> projTable projection <> "' declares consistency " <> T.pack (show projectionConsistency) <> " but its readmodel node declares " <> T.pack (show (rmConsistency readModel))-          | Just projectionConsistency <- [projConsistency projection],-            projectionConsistency /= rmConsistency readModel-          ]--    -- Rule 6 (hole-kind 3, mapping): keys are exact event names, never suffixes;-    -- duplicates and dangling keys are errors, and non-partial maps are total.-    statusMapTotality = case aggProjection agg of-      Nothing -> []-      Just p ->-        let evs = map evName (aggEvents agg)-            pairs = maybe [] mapPairs (projStatusMap p)-            keys = map fst pairs-            partial = maybe False mapPartial (projStatusMap p)-            uncovered = [event | event <- evs, event `notElem` keys]-            dangling = [key | key <- keys, key `notElem` evs]-            duplicateKeys = map fst (duplicatesBy fst pairs)-         in [ mkErr (locLine (projLoc p)) StatusMapDanglingKey $-                "projection '" <> projTable p <> "' status-map key '" <> key <> "' is not an event name of aggregate '" <> aggName agg <> "'"-            | key <- dangling-            ]-              ++ [ mkErr (locLine (projLoc p)) StatusMapDuplicateKey $-                     "projection '" <> projTable p <> "' repeats status-map key '" <> key <> "'"-                 | key <- duplicateKeys-                 ]-              ++ [ mkErr (locLine (projLoc p)) StatusMapNotTotal $-                     "projection '" <> projTable p <> "' status-map is not total over events {" <> T.intercalate ", " uncovered <> "}"-                 | not partial,-                   not (null evs),-                   not (null uncovered)-                 ]--    -- EP-2 evolution rules (single-spec; the diff path adds the cross-spec ones).-    evolutionRules =-      versionUpcasterRule-        ++ upcasterChainGapRule-        ++ deprecatedEmitRule-        ++ eventRetirementRules-        ++ wireVersionRule-    -- Only live transitions are the write path: a replay-only transition can-    -- never fire forward, so its emits exist purely to invert stored events —-    -- which is exactly where a deprecated event is allowed to remain-    -- (plan 143; supersedes the guarded-but-inert retained-edge pattern).-    liveEmittedNames = Set.fromList (concatMap tEmits [t | t <- aggTransitions agg, tMode t == TmLive])-    replayEmittedNames = Set.fromList (concatMap tEmits [t | t <- aggTransitions agg, tMode t == TmReplayOnly])-    maxEventVersion = maximum (1 : map evVersion (aggEvents agg))-    upcasterSources =-      Set.fromList-        [ source-        | event <- aggEvents agg,-          Just (source, _) <- [evUpcastFrom event]-        ]--    -- A non-initial event version must carry a contiguous upcaster (from v-1).-    versionUpcasterRule =-      [ mkErr (locLine (evLoc e)) EvtVersionMissingUpcaster $-          "event '" <> evName e <> "' version " <> tInt (evVersion e) <> " has no 'upcast from v" <> tInt (evVersion e - 1) <> "' clause"-      | e <- aggEvents agg,-        evVersion e > 1,-        maybe True ((/= evVersion e - 1) . fst) (evUpcastFrom e)-      ]--    -- Aggregate schema stamps are global, so every source version below the-    -- current maximum needs a permanent rung regardless of which event owns it.-    upcasterChainGapRule =-      [ mkErr (locLine (aggLoc agg)) UpcasterChainGap $-          "no event declares 'upcast from v"-            <> tInt missing-            <> "'; stored payloads stamped v"-            <> tInt missing-            <> " can never reach v"-            <> tInt maxEventVersion-            <> " (GapInUpcasterChain at hydration). A rung, once shipped, must exist forever — restore the upcaster for v"-            <> tInt missing-            <> " (re-declare it on the event whose shape changed at v"-            <> tInt (missing + 1)-            <> ")"-      | missing <- [1 .. maxEventVersion - 1],-        missing `Set.notMember` upcasterSources-      ]--    -- A deprecated event must have left the write path.-    deprecatedEmitRule =-      [ mkErr (locLine (evLoc e)) DeprecatedEventStillEmitted $-          "deprecated event '" <> evName e <> "' is still emitted by a transition"-      | e <- aggEvents agg,-        evDeprecated e,-        evName e `Set.member` liveEmittedNames-      ]--    -- Retirement is a two-stage protocol. The pre-cutover marker keeps a live-    -- emitter. The deprecated stage removes that live emitter but retains a-    -- replay-only emitter until old payloads no longer need hydration.-    eventRetirementRules = concatMap eventRetirementRule (aggEvents agg)-    eventRetirementRule event-      | evRetiring event =-          [ mkErr (locLine (evLoc event)) EventRetirementInProgress $-              "retiring event '" <> evName event <> "' has no live emitting transition; keep it emitting while streams are terminalized or truncated, or cut over to 'deprecated event' with a replay-only emitting transition"-          | evName event `Set.notMember` liveEmittedNames-          ]-            ++ [ Diagnostic-                   { line = locLine (evLoc event),-                     severity = Warning,-                     code = EventRetirementInProgress,-                     relatedLocations = [],-                     message =-                       "event '" <> evName event <> "' is retiring: it stays fully live and replayable. Keep its live emitting transition until every affected stream is terminal or truncated; then flip it to 'deprecated event' and retain an equivalent replay-only emitting transition for as long as old payloads may be hydrated"-                   }-               | evName event `Set.member` liveEmittedNames-               ]-      | evDeprecated event =-          [ Diagnostic-              { line = locLine (evLoc event),-                severity = Warning,-                code = DeprecatedEventReplayHazard,-                relatedLocations = [],-                message =-                  "deprecated event '" <> evName event <> "' stays decodable but is not replayable: no replay-only transition emits it, so hydration of a live stream containing it fails with HydrationNoInvertingEdge. Restore an equivalent replay-only emitting transition, or terminalize/truncate every affected stream before deployment"-              }-          | any (not . stTerminal) (aggStates agg),-            evName event `Set.notMember` replayEmittedNames-          ]-            ++ [ Diagnostic-                   { line = locLine (evLoc event),-                     severity = Warning,-                     code = EventRetirementInProgress,-                     relatedLocations = [],-                     message =-                       "deprecated event '" <> evName event <> "' is off the live write path and remains replayable through a replay-only transition; retain that transition until every stream containing the event is terminal, truncated, or passes the replay audit"-                   }-               | evName event `Set.member` replayEmittedNames-               ]-      | otherwise = []--    -- The explicit `wire schemaVersion=` (if any) must equal the max event version.-    wireVersionRule = case aggWire agg of-      Just w-        | wireSchemaVersion w /= maxEventVersion ->-            [ Diagnostic-                { line = locLine (aggLoc agg),-                  severity = Warning,-                  code = WireSchemaVersionMismatch,-                  relatedLocations = [],-                  message =-                    "wire schemaVersion=" <> tInt (wireSchemaVersion w) <> " does not match the maximum event version " <> tInt maxEventVersion-                }-            ]-      _ -> []--    -- Plan 143: replay-only transition discipline. A replay-only transition-    -- exists to invert stored events, so one that emits nothing is dead-    -- weight (error); one whose (source, command) pair has no live sibling-    -- means the command is fully retired at that state — legitimate, but the-    -- fuller procedure is event retirement (docs/plans/139), so warn.-    replayOnlyRules = concatMap replayOnlyRule (aggTransitions agg)-    replayOnlyRule t-      | tMode t /= TmReplayOnly = []-      | otherwise =-          [ mkErr (locLine (tLoc t)) ReplayOnlyEmitsNothing $-              "replay-only transition '" <> tSource t <> " -- " <> tCommand t <> "' emits no event; a replay-only transition exists to invert stored events and is dead weight without an emit"-          | null (tEmits t)-          ]-            ++ [ Diagnostic-                   { line = locLine (tLoc t),-                     severity = Warning,-                     code = ReplayOnlyCommandStillLive,-                     relatedLocations = [],-                     message =-                       "replay-only transition '" <> tSource t <> " -- " <> tCommand t <> "' has no live sibling; command '" <> tCommand t <> "' is fully retired at state '" <> tSource t <> "' — if the intent is to retire its events too, follow the event-retirement procedure (docs/plans/139)"-                   }-               | not (any (\sibling -> tMode sibling == TmLive && tSource sibling == tSource t && tCommand sibling == tCommand t) (aggTransitions agg))-               ]--    eventlessStateChangeRules =-      [ mkErr (locLine (tLoc transition)) AggregateEventlessStateChange $-          "transition '"-            <> tSource transition-            <> " -- "-            <> tCommand transition-            <> "' emits no event but changes "-            <> changeDescription transition-            <> "; event-sourced state changes require persisted evidence, while a no-op must keep both vertex and registers unchanged"-      | transition <- aggTransitions agg,-        null (tEmits transition),-        tSource transition /= tGoto transition || not (null (tWrites transition))-      ]-    changeDescription transition-      | tSource transition /= tGoto transition && not (null (tWrites transition)) = "the target vertex and registers"-      | tSource transition /= tGoto transition = "the target vertex"-      | otherwise = "registers"+import Data.Char (isControl, isSpace, ord, toLower)+import Data.Graph (SCC (..), stronglyConnComp)+import Data.List (sortOn)+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.TypeID qualified as TypeID+import Data.Word (Word64)+import Keiro.Dsl.AggregateType+import Keiro.Dsl.EventOutput+import Keiro.Dsl.Expression+import Keiro.Dsl.FieldIdentity+import Keiro.Dsl.Grammar+import Keiro.Dsl.HaskellName qualified as HaskellName+import Keiro.Dsl.IdDomain (contractIdDomainContractFor, idDomainContractFor)+import Keiro.Dsl.LanguageVersion (LanguageVersion, RuntimeCapability (..), SourceLanguage (..), effectiveLanguageVersion, languageVersionText, runtimeProfileHasCapability, sourceFormText)+import Keiro.Dsl.NominalType qualified as Nominal+import Keiro.Dsl.ProjectionSupply+import Keiro.Dsl.ReadModelShape (deriveShapeHash)+import Keiro.Dsl.RouterSelection qualified as RouterSelection+import Keiro.Dsl.RuntimePackage (isCabalPackageName)+import Keiro.Dsl.SemanticContract (CheckedService, EffectiveLanguageContract, checkedLanguageContract, checkedProjectionSupplies, checkedSpec, checkedTypeGraph, effectiveRuntimeProfile, legacyCheckedService)+import Keiro.Dsl.TypeGraph+import Keiro.Integration.Event qualified as Event+import Numeric (showHex)+import Text.Read (readMaybe)++data Severity = Error | Warning+  deriving stock (Eq, Show)++diagnosticCodeText :: DiagnosticCode -> Text+diagnosticCodeText = T.pack . show++parseDiagnosticCode :: Text -> Maybe DiagnosticCode+parseDiagnosticCode raw =+  case [diagnosticCode | diagnosticCode <- [minBound .. maxBound], diagnosticCodeText diagnosticCode == raw] of+    diagnosticCode : _ -> Just diagnosticCode+    [] -> Nothing++-- | A machine-checkable code per rule, so tests match on the code, not prose.+data DiagnosticCode+  = UndeclaredCommand+  | UndeclaredEvent+  | UndeclaredState+  | UnreachableState+  | TerminalHasOutgoing+  | GuardAtomOutOfScope+  | StatusMapNotTotal+  | ClockSampled+  | -- EP-2 (evolution). These codes are shared by single-spec validation and+    -- the cross-spec diff path, so the enum remains the single registry of+    -- evolution rules.+    EvtVersionMissingUpcaster+  | UpcasterChainGap+  | DeprecatedEventReplayHazard+  | EventRetirementInProgress+  | DeprecatedEventStillEmitted+  | WireSchemaVersionMismatch+  | EvtFieldAddedWithoutBump+  | EvtRemovedNotDeprecated+  | -- EP-3 (process manager + durable timer).+    ProcessFireAtNotInjected+  | ProcessDispatchIdSupplied+  | ProcessUnresolvedRef+  | ProcessBenignInversion+  | SagaCategoryIllegal+  | -- EP-4 (integration intake / inbox disposition).+    DispositionIncomplete+  | DispositionDuplicateRetry+  | DispositionPreviouslyFailedRetry+  | DispositionDecodeUnboundedRetry+  | -- EP-4 (integration coupling).+    EmitSkipMissing+  | EmitUnresolvedContract+  | PublisherUnresolvedEmit+  | IntakeUnresolvedContract+  | -- EP-5 (pgmq workqueue/dispatch).+    WqPhysicalDivergence+  | WqStoreFailureNotRetry+  | WqDecodeFailureNotDeadLetter+  | WqDlqWithoutCeiling+  | WqGroupKeyMissing+  | WqGroupKeyWithoutFifo+  | WqGroupKeyUnresolved+  | WqUnloggedDurability+  | WqPartitionSpecEmpty+  | SnapshotIntervalInvalid+  | SnapshotCodecFixtureInvalid+  | DispatchEnqueueUnresolved+  | -- EP-6 (workflow/operation).+    AwaitSignalMismatch+  | RunWorkflowUnresolved+  | WorkflowPatchDuplicate+  | WorkflowPatchIdInvalid+  | WorkflowContinueAsNewNotTerminal+  | -- Diff-only (cross-spec) decode and identity evolution rules.+    EvtFieldTypeChanged+  | EvtFieldRemovedSameVersion+  | EvtVersionDecreased+  | EnumCtorRemoved+  | EnumWireSpellingChanged+  | WireSpecChanged+  | ContractEventRemoved+  | ContractFieldChanged+  | ContractDiscriminatorChanged+  | ContractTopicChanged+  | ContractSchemaVersionDecreased+  | WqPayloadFieldChanged+  | ProcessInputChanged+  | WorkflowShapeChanged+  | WorkflowBodyChanged+  | WorkflowStableNameChanged+  | WorkflowPatchRemoved+  | WorkflowContinueSeedChanged+  | WqOrderingChanged+  | WqProvisionChanged+  | WqGroupKeyChanged+  | IdPrefixChanged+  | DedupeIdentityChanged+  | DerivedIdentityChanged+  | QueueIdentityChanged+  | TimerWindowChanged+  | EmitMappingChanged+  | DecodePostureChanged+  | IntakePersistenceChanged+  | ProjectionChanged+  | PublisherPolicyChanged+  | DispatchRetargeted+  | ContractSchemaVersionBumped+  | EventUndeprecated+  | -- EP-104 (validator soundness).+    WorkflowDuplicateLabel+  | WorkflowSleepDelayUnresolved+  | WorkflowIdFieldUnresolved+  | RuleDomainUnresolved+  | RuleNotTotal+  | RuleCaseUnknownCtor+  | ProcessFieldBindingUnresolved+  | ProcessTimerCeilingInvalid+  | OperationUnresolvedRef+  | AwaitSignalValueMismatch+  | WqDispositionIncomplete+  | DispositionDuplicateOutcome+  | TopicAffinityMismatch+  | StatusMapDanglingKey+  | StatusMapDuplicateKey+  | WriteTargetNotRegister+  | RegisterInitialOutOfScope+  | DuplicateNodeName+  | DuplicateEnumCtor+  | DuplicateEnumWire+  | DuplicateIdPrefix+  | DuplicateCommandName+  | DuplicateEventName+  | WqDlqDivergence+  | WqTableDivergence+  | DispatchDedupQueueUnresolved+  | DispatchDedupFieldUnresolved+  | -- EP-105 (notation integrity and scaffold-safe names).+    VertexCtorCollision+  | IdentUnsafeNormalization+  | GeneratedOccurrenceReserved+  | GeneratedOccurrenceCollision+  | -- EP-107 (first-class read models).+    RmShapeHashDrift+  | RmStrongInlineOnly+  | RmScopeWithoutStrong+  | RmUnknownColumnType+  | RmInlineFeedUnreferenced+  | RmConsistencyConflict+  | RmProjectionWithoutNode+  | QueryUnresolvedReadModel+  | QueryConsistencyInvalid+  | DispatchReadModelUnresolved+  | DispatchReadModelFieldUnknown+  | -- MasterPlan 32 / EP-4 projection catalogs.+    CatalogTargetUnknown+  | CatalogGroupUnknown+  | CatalogGroupEmpty+  | CatalogGroupOrderMismatch+  | CatalogTargetUnowned+  | CatalogTargetMultiplyOwned+  | CatalogPhysicalTargetDuplicate+  | CatalogTargetDependencyUnknown+  | CatalogTargetDependencyOutsideGroup+  | CatalogTargetDependencyCycle+  | CatalogProjectionNoSource+  | CatalogProjectionNoTarget+  | CatalogProjectionTargetOutsideGroup+  | CatalogSourceUnresolved+  | CatalogSourceOverlap+  | CatalogAmbiguousSourceOrdering+  | CatalogAsyncIdentityMissing+  | CatalogAsyncQueryBindingMissing+  | CatalogInlineIdentityUnexpected+  | CatalogCheckpointPolicyMissing+  | CatalogCheckpointPolicyDuplicate+  | CatalogCheckpointPolicyUnexpected+  | CatalogCheckpointPolicyReplayUnsafe+  | CatalogClearTargetLiveOnly+  | CatalogDuplicateHandlerOrder+  | CatalogReadModelBindingMissing+  | CatalogReadModelTargetOutsideGroup+  | CatalogReadModelPhysicalOverride+  | CatalogReadModelBackingRequired+  | CatalogReadModelBackingUnobserved+  | CatalogReadModelSupplierMissing+  | CatalogReadModelMultipleSuppliers+  | CatalogReadModelLegacyProjectionConflict+  | CatalogQueryWaitWithoutCompatibleCursor+  | CatalogQueryWaitWithAmbiguousCursor+  | CatalogTargetAdded+  | CatalogTargetRemoved+  | CatalogTargetLocationChanged+  | CatalogTargetResetPolicyChanged+  | CatalogTargetDependencyChanged+  | CatalogGroupChanged+  | CatalogRevisionNoTarget+  | CatalogRevisionGroupUnknown+  | CatalogRevisionTargetUnknown+  | CatalogRevisionTargetSetMismatch+  | CatalogRevisionIdentityInvalid+  | CatalogRevisionDuplicateTarget+  | CatalogRevisionPromotionNameInvalid+  | CatalogProjectionRevisionChanged+  | CatalogProjectionRevisionRemoved+  | CatalogTargetSchemaChanged+  | CatalogExternalReadIdentityInvalid+  | CatalogExternalReadVersionInvalid+  | CatalogExternalReadQueryUnknown+  | CatalogExternalReadTargetCardinalityInvalid+  | CatalogExternalReadCompatibilityInvalid+  | CatalogExternalReadRevisionUnknown+  | CatalogExternalReadRevisionGroupMismatch+  | CatalogExternalReadSurfaceGenerationInvalid+  | CatalogExternalReadRetired+  | CatalogExternalReadVersionAdded+  | CatalogExternalReadCompatibilityChanged+  | CatalogExternalReadResultShapeChanged+  | CatalogExternalReadContractChanged+  | CatalogOwnerChanged+  | CatalogOwnerRemoved+  | CatalogHandlerOrderChanged+  | CatalogSourceChanged+  | CatalogFeedIdentityChanged+  | CatalogCheckpointPolicyChanged+  | CatalogReplayPolicyChanged+  | CatalogQueryBindingChanged+  | ProjectionDeliveryChanged+  | QueryFreshnessChanged+  | -- EP-107 diff-only read-model evolution rules.+    ReadModelVersionDecreased+  | ReadModelShapeChangedWithoutBump+  | ReadModelFeedChanged+  | ReadModelConsistencyWeakened+  | ReadModelQueryInputChanged+  | ReadModelQueryResultChanged+  | -- EP-108 (router and worker-policy surfaces).+    RouterUnresolvedRef+  | RouterKeyFieldUnknown+  | RouterBindingUnscoped+  | RouterCommandUnknown+  | RouterReadModelUnverified+  | PolicyContradiction+  | PolicyDeadLetterUnused+  | AmbiguousMarkedBenign+  | AmbiguousFollowsRejectedPolicy+  | RouterStableNameChanged+  | -- Plan 143 (first-class replay-only transitions for guard evolution).+    -- The first two fire in single-spec @validateSpec@; the third is the+    -- diff-path guard-tightening advisory that prints the computed+    -- replay-only twin.+    ReplayOnlyEmitsNothing+  | ReplayOnlyCommandStillLive+  | AggGuardTightened+  | AggFoldSurfaceChanged+  | RouterDecideSurfaceChanged+  | ProcessDecideSurfaceChanged+  | ProcessTimerPayloadChanged+  | -- MasterPlan 25 / EP-5: append-only codes for findings that were+    -- formerly additive but uncoded.+    DeclarationAdded+  | VersionBumped+  | CompatibilityStrengthened+  | EnumCtorAdded+  | EventRetirementAbandoned+  | ContractEventAdded+  | ContractTopicAdded+  | WorkflowEvolutionGuardAdded+  | -- MasterPlan 25 / EP-149 (consumer-owned mapped types).+    MappedUnresolvedName+  | MappedAmbiguousName+  | MappedDuplicateFieldName+  | MappedDuplicateWireKey+  | MappedDuplicateArmName+  | MappedDuplicateWireTag+  | MappedNonInjectiveNullability+  | MappedRecursiveType+  | MappedUnsupportedEncoding+  | MappedMissingIngredient+  | MappedMissingInitialValue+  | MappedInvalidHaskellName+  | MappedInvalidIdentity+  | MappedImportConflict+  | MappedDefaultIllTyped+  | -- MasterPlan 25 / EP-149 mapped evolution codes.+    MappedFieldAddedWithDefault+  | MappedFieldAddedNoDefault+  | MappedFieldRemoved+  | MappedFieldTypeChanged+  | MappedPresenceChanged+  | MappedNullabilityChanged+  | MappedDefaultRemoved+  | MappedDefaultChanged+  | MappedWireKeyChanged+  | MappedUnionEncodingChanged+  | MappedArmAdded+  | MappedArmRemoved+  | MappedArmTagChanged+  | MappedEnumValueAdded+  | MappedEnumValueRemoved+  | MappedEnumSpellingChanged+  | MappedHaskellSourceChanged+  | MappedRecordConstructorChanged+  | MappedBindingChanged+  | MappedFixturesChanged+  | MappedInitialChanged+  | MappedCanonicalTypeChanged+  | MappedOpaqueCodecChanged+  | MappedModeCrossed+  | MappedDeclAdded+  | MappedDeclRemoved+  | -- MasterPlan 25 / EP-152 reporting and migration-evidence codes.+    CoverageOpaqueSurface+  | CoverageOpaqueBoundaryAdded+  | CoverageOpaqueGateExceeded+  | CodecCompareDifference+  | CodecCompareCoverageGap+  | CodecCompareInvalidInput+  | -- MasterPlan 26 / EP-153: whole-service composition refusals, emitted by+    -- "Keiro.Dsl.Workspace" when several @.keiro@ members are composed into+    -- one service graph. They live in this registry, not a parallel enum, so+    -- every gate stays correlatable by code (ADR 0004). Manifest syntax and+    -- structure errors deliberately have no code here: like a @.keiro@ parse+    -- error, they are refused before any graph exists to diagnose.+    WorkspaceMemberUnreadable+  | WorkspaceMemberParseFailed+  | WorkspaceContextMismatch+  | WorkspaceAuthorityConflict+  | WorkspaceDuplicateDeclaration+  | WorkspaceDuplicateNodeName+  | WorkspacePathCollision+  | WorkspaceSourceIndexInvalid+  | -- MasterPlan 26 / EP-155: whole-workspace diff facts. These are+    -- advisory consumer-build obligations, distinct from wire evolution.+    OwnershipMoved+  | WorkspaceAuthorityChanged+  | -- EP-157: canonical aggregate type resolution and capabilities.+    AggregateTypeUnknown+  | AggregateTypeUnsupportedAtUse+  | AggregateRegisterInitialInvalid+  | AggregateGuardTypeMismatch+  | AggregateGuardCapabilityUnsupported+  | AggregateExpressionRootUnknown+  | AggregateExpressionRootAmbiguous+  | AggregateExpressionPathInvalid+  | AggregateExpressionPathUnsupported+  | AggregateExpressionLiteralNeedsType+  | AggregateExpressionLiteralInvalid+  | AggregateExpressionOperandTypeMismatch+  | AggregateExpressionOperatorUnsupported+  | AggregateExpressionBooleanRequired+  | AggregateExpressionGuardBoolRequired+  | AggregateExpressionWriteTargetUnknown+  | AggregateExpressionWriteTypeMismatch+  | AggregateTransitionOwnershipConflict+  | DomainOutcomeDeclarationMissing+  | DomainOutcomeDeclarationDuplicate+  | DomainOutcomeTypeUnresolved+  | DomainOutcomeClauseMissing+  | DomainOutcomeClauseDuplicate+  | DomainOutcomeReasonTypeMismatch+  | DomainOutcomeAcceptedWithoutEvents+  | DomainOutcomeSilentEmits+  | DomainOutcomeSilentWrites+  | DomainOutcomeSilentStateChange+  | DomainOutcomeReplayOnlyClause+  | DomainOutcomeTypesChanged+  | DomainTransitionOutcomeChanged+  | CollectionExpressionUnsupported+  | -- EP-160: append-only source-language composition and diff facts.+    WorkspaceLanguageVersionMismatch+  | SourceLanguageDeclarationChanged+  | -- EP-158: checked consumer-owned nominal IDs, enums, and scalars.+    NominalMissingIngredient+  | NominalInvalidHaskellSource+  | NominalInvalidQualifiedName+  | NominalInvalidIdentity+  | NominalInvalidIdPrefix+  | NominalUnsupportedRepresentation+  | NominalEmptyEnumRepresentation+  | NominalMissingInitialValue+  | NominalNameCollision+  | NominalBindingChanged+  | NominalFixturesChanged+  | NominalCanonicalTypeChanged+  | NominalInitialChanged+  | NominalRepresentationChanged+  | NominalIdDecoderTightened+  | -- ExecPlan 171 / IR-14: versioned prefix-bearing ID admission policy.+    IdDomainContractChanged+  | -- ExecPlan 159 / IR-13: @fields(Command)@ output authority.+    EventOutputCommandMismatch+  | AggregateEventlessStateChange+  | -- ExecPlan 178: language-4 integration contract TypeID admission.+    ContractInvalidTypeIdPrefix+  | ContractTypeIdDomainChanged+  | -- ExecPlan 180: accepted-but-unenforced spec surfaces.+    PublisherOrderingUnknown+  | PublisherBackoffInvalid+  | IntakeDedupePolicyUnknown+  | PublisherMaxAttemptsBelowMinimum+  | ContractSchemaVersionBelowMinimum+  | ReadModelVersionBelowMinimum+  | IntakeDecodeSchemaVersionBelowMinimum+  | AggregateDuplicateFieldName+  | ContractDuplicateFieldName+  | ContractFieldShadowsDiscriminator+  | TransitionDuplicateUnguarded+  | ContractDuplicateEvent+  | ContractDuplicateTopicAlias+  | AggregateDuplicateState+  | AggregateDuplicateRegister+  | NominalDuplicateDeclaration+  | EmitMapDuplicateCase+  | TransitionUnguardedSibling+  | RuntimeIdentityInvalid+  | RuntimeIdentityDuplicate+  | ContractTopicNameInvalid+  | ReadModelIdentifierInvalid+  | ReadModelDuplicateColumn+  | IntakeBindUnresolved+  | IntakeDedupeKeyUnresolved+  | IntakeEnvelopePolicyUnknown+  | IntakeDecodeSchemaVersionMismatch+  | ContractTopicAliasUnresolved+  | WireClauseUnsupported+  | -- ExecPlan 190: an unchanged semantic/external declaration now presents a+    -- different generated Haskell occurrence.+    GeneratedHaskellNameChanged+  | -- ExecPlan 192: resolved field wire identities are checked before lowering.+    FieldWireKeyCollision+  | FieldWireKeyInvalid+  | -- ExecPlan 192: changing an aggregate event field's resolved wire key+    -- changes the persisted event decode surface.+    EvtFieldWireKeyChanged+  | -- ExecPlan 193: a CI-required released language floor was not met.+    LanguageVersionBelowMinimum+  | -- ExecPlan 194: scaffold's empty-node refusals are reported by check at+    -- the owning declaration before planning begins.+    AggregateEmpty+  | ContractEmpty+  | -- ExecPlan 194: pure scaffold-planning gates share check's located,+    -- machine-readable diagnostic pipeline.+    GeneratedPathCollision+  | GeneratedImportCycle+  | BehaviorDerivationInvalid+  | BehaviorSourceAnchorMissing+  | BehaviorSourceAnchorInexact+  | BehaviorSourceAnchorCollision+  | ConformanceFactKeyCollision+  | GeneratedPlanningInvariantViolation+  | -- ExecPlan 197: accepted but currently inert spec surfaces are reported+    -- through the ordinary warning pipeline.+    IntakeBindFlagUnenforced+  | RmInlineSubscriptionIgnored+  | -- ExecPlan 197: process and router references close under language 4.+    ProcessKeyFieldUnknown+  | ProcessDispatchKeyUnresolved+  | ProcessBindingUnscoped+  | -- ExecPlan 197: remaining accepted surfaces close under language 4.+    WqPayloadTypeUnknown+  | WindowOutOfRange+  | TimerIdFieldNotCorrelation+  | AggProjectionKeyUnresolved+  | PublisherOutboxFieldUnresolved+  | RouterBenignInversion+  | -- ExecPlan 199: spellings the grammar accepts that no runtime implements.+    -- Each names one concrete runtime fact the declaration contradicts, warns on+    -- released languages below 4, and errors from language 4 on.+    DecodeBodyPostureUnsupported+  | DispatchOnAppendedUnsupported+  | TimerNotMineUnsupported+  | IntakeBindHeaderUnknown+  | -- ExecPlan 199: the surfaces ExecPlan 197 parked as descriptive-only, closed+    -- by checking the reference each one actually names.+    TimerDecodeStatusUnknown+  | TimerDeadLetterTextInvalid+  | PgmqFanoutFunctionInvalid+  | -- MasterPlan 35 / EP-1: candidate typed surfaces remain fail-closed until+    -- their complete lowering plans land.+    MappedQueueLoweringPending+  | MappedReadModelLoweringPending+  | RouterSelectionNotDeclarative+  | RouterSelectionCapabilityUnavailable+  | RouterSelectionIdentityEmpty+  | RouterSelectionVersionInvalid+  | RouterSelectionQueryUnknown+  | RouterSelectionQueryContractMissing+  | RouterSelectionQueryInputBindingInvalid+  | RouterSelectionQueryInputTypeMismatch+  | RouterSelectionQueryResultNotList+  | RouterSelectionQueryRowNotStructural+  | RouterSelectionExpressionRootUnknown+  | RouterSelectionExpressionFieldUnknown+  | RouterSelectionExpressionFieldOptional+  | RouterSelectionExpressionTypeMismatch+  | RouterSelectionPredicateNotBool+  | RouterSelectionRecipientNotText+  | RouterSelectionOperatorUnsupported+  | RouterSelectionRecipientLimitMissing+  | RouterSelectionRecipientLimitInvalid+  | RouterSelectionOrderUnsupported+  | RouterSelectionDedupeUnsupported+  | RouterSelectionFailureAckForbidden+  | RouterSelectionRedeliveryUnsupported+  | RouterSelectionPartialDispatchUnsupported+  | RouterSelectionTargetAmbiguous+  | RouterSelectionCommandUnknown+  | RouterSelectionCommandMappingDuplicate+  | RouterSelectionCommandMappingIncomplete+  | RouterSelectionCommandMappingTypeMismatch+  deriving stock (Eq, Ord, Show, Enum, Bounded)++-- | Which command pipeline can actually produce a given 'DiagnosticCode'.+--+-- The registry exists so a CI warning policy cannot silently name a code the+-- selected command never emits. Before ExecPlan 199, @keiro-dsl check --deny+-- EvtFieldWireKeyChanged@ was accepted and then matched nothing forever,+-- because that code is only reachable from @diff@'s cross-revision comparison.+data DiagnosticOrigin+  = -- | Reachable from @check@ on a single spec or a workspace. This includes+    -- the pure scaffold-planning gates that @check@ replays, and it is the+    -- default for any code not positively classified below.+    CheckDiagnostic+  | -- | Reachable only from the structural-coverage pass, which runs only when+    -- @--coverage-report@ is supplied.+    CoverageDiagnostic+  | -- | Reachable only from @diff@, which compares two revisions of a spec.+    -- Nothing in a single-revision @check@ can produce these.+    DiffDiagnostic+  | -- | Reachable only from the generated codec-comparison path, which no+    -- @check@ or @diff@ invocation runs.+    CodecCompareDiagnostic+  deriving stock (Eq, Ord, Show, Enum, Bounded)++-- | Classify a code by the pipeline that emits it.+--+-- Only codes proven non-@check@ are listed; everything else falls through to+-- 'CheckDiagnostic'. The default is deliberately the permissive one: a+-- misclassification here would reject a working CI invocation, whereas falling+-- through merely preserves the pre-199 behavior of accepting the code.+diagnosticOrigin :: DiagnosticCode -> DiagnosticOrigin+diagnosticOrigin diagnosticCode = case diagnosticCode of+  -- Structural coverage, reachable from `check --coverage-report`.+  CoverageOpaqueSurface -> CoverageDiagnostic+  CoverageOpaqueGateExceeded -> CoverageDiagnostic+  -- Coverage delta, computed only against a previous revision.+  CoverageOpaqueBoundaryAdded -> DiffDiagnostic+  -- Generated codec comparison.+  CodecCompareDifference -> CodecCompareDiagnostic+  CodecCompareCoverageGap -> CodecCompareDiagnostic+  CodecCompareInvalidInput -> CodecCompareDiagnostic+  -- Cross-revision evolution facts.+  AggFoldSurfaceChanged -> DiffDiagnostic+  AggGuardTightened -> DiffDiagnostic+  DomainOutcomeTypesChanged -> DiffDiagnostic+  DomainTransitionOutcomeChanged -> DiffDiagnostic+  CompatibilityStrengthened -> DiffDiagnostic+  ContractDiscriminatorChanged -> DiffDiagnostic+  ContractEventAdded -> DiffDiagnostic+  ContractEventRemoved -> DiffDiagnostic+  ContractFieldChanged -> DiffDiagnostic+  ContractSchemaVersionBumped -> DiffDiagnostic+  ContractSchemaVersionDecreased -> DiffDiagnostic+  ContractTopicAdded -> DiffDiagnostic+  ContractTopicChanged -> DiffDiagnostic+  ContractTypeIdDomainChanged -> DiffDiagnostic+  DeclarationAdded -> DiffDiagnostic+  DecodePostureChanged -> DiffDiagnostic+  DedupeIdentityChanged -> DiffDiagnostic+  DerivedIdentityChanged -> DiffDiagnostic+  DispatchRetargeted -> DiffDiagnostic+  EmitMappingChanged -> DiffDiagnostic+  EnumCtorAdded -> DiffDiagnostic+  EnumCtorRemoved -> DiffDiagnostic+  EnumWireSpellingChanged -> DiffDiagnostic+  EventRetirementAbandoned -> DiffDiagnostic+  EventUndeprecated -> DiffDiagnostic+  EvtFieldAddedWithoutBump -> DiffDiagnostic+  EvtFieldRemovedSameVersion -> DiffDiagnostic+  EvtFieldTypeChanged -> DiffDiagnostic+  EvtFieldWireKeyChanged -> DiffDiagnostic+  EvtRemovedNotDeprecated -> DiffDiagnostic+  EvtVersionDecreased -> DiffDiagnostic+  GeneratedHaskellNameChanged -> DiffDiagnostic+  IdDomainContractChanged -> DiffDiagnostic+  IdPrefixChanged -> DiffDiagnostic+  IntakePersistenceChanged -> DiffDiagnostic+  MappedArmAdded -> DiffDiagnostic+  MappedArmRemoved -> DiffDiagnostic+  MappedArmTagChanged -> DiffDiagnostic+  MappedBindingChanged -> DiffDiagnostic+  MappedCanonicalTypeChanged -> DiffDiagnostic+  MappedDeclAdded -> DiffDiagnostic+  MappedDeclRemoved -> DiffDiagnostic+  MappedDefaultChanged -> DiffDiagnostic+  MappedDefaultRemoved -> DiffDiagnostic+  MappedEnumSpellingChanged -> DiffDiagnostic+  MappedEnumValueAdded -> DiffDiagnostic+  MappedEnumValueRemoved -> DiffDiagnostic+  MappedFieldAddedNoDefault -> DiffDiagnostic+  MappedFieldAddedWithDefault -> DiffDiagnostic+  MappedFieldRemoved -> DiffDiagnostic+  MappedFieldTypeChanged -> DiffDiagnostic+  MappedFixturesChanged -> DiffDiagnostic+  MappedHaskellSourceChanged -> DiffDiagnostic+  MappedInitialChanged -> DiffDiagnostic+  MappedModeCrossed -> DiffDiagnostic+  MappedNullabilityChanged -> DiffDiagnostic+  MappedOpaqueCodecChanged -> DiffDiagnostic+  MappedPresenceChanged -> DiffDiagnostic+  MappedRecordConstructorChanged -> DiffDiagnostic+  MappedUnionEncodingChanged -> DiffDiagnostic+  MappedWireKeyChanged -> DiffDiagnostic+  NominalBindingChanged -> DiffDiagnostic+  NominalCanonicalTypeChanged -> DiffDiagnostic+  NominalFixturesChanged -> DiffDiagnostic+  NominalIdDecoderTightened -> DiffDiagnostic+  NominalInitialChanged -> DiffDiagnostic+  NominalRepresentationChanged -> DiffDiagnostic+  OwnershipMoved -> DiffDiagnostic+  ProcessDecideSurfaceChanged -> DiffDiagnostic+  ProcessInputChanged -> DiffDiagnostic+  ProcessTimerPayloadChanged -> DiffDiagnostic+  ProjectionChanged -> DiffDiagnostic+  PublisherPolicyChanged -> DiffDiagnostic+  QueueIdentityChanged -> DiffDiagnostic+  ReadModelConsistencyWeakened -> DiffDiagnostic+  ReadModelFeedChanged -> DiffDiagnostic+  ReadModelQueryInputChanged -> DiffDiagnostic+  ReadModelQueryResultChanged -> DiffDiagnostic+  ReadModelShapeChangedWithoutBump -> DiffDiagnostic+  ReadModelVersionDecreased -> DiffDiagnostic+  RouterDecideSurfaceChanged -> DiffDiagnostic+  RouterStableNameChanged -> DiffDiagnostic+  SourceLanguageDeclarationChanged -> DiffDiagnostic+  TimerWindowChanged -> DiffDiagnostic+  VersionBumped -> DiffDiagnostic+  WireSpecChanged -> DiffDiagnostic+  WorkflowBodyChanged -> DiffDiagnostic+  WorkflowContinueSeedChanged -> DiffDiagnostic+  WorkflowEvolutionGuardAdded -> DiffDiagnostic+  WorkflowPatchRemoved -> DiffDiagnostic+  WorkflowShapeChanged -> DiffDiagnostic+  WorkflowStableNameChanged -> DiffDiagnostic+  WorkspaceAuthorityChanged -> DiffDiagnostic+  WqGroupKeyChanged -> DiffDiagnostic+  WqOrderingChanged -> DiffDiagnostic+  WqPayloadFieldChanged -> DiffDiagnostic+  WqProvisionChanged -> DiffDiagnostic+  _ -> CheckDiagnostic++-- | A line-numbered, structured diagnostic.+data Diagnostic = Diagnostic+  { line :: !Int,+    severity :: !Severity,+    code :: !DiagnosticCode,+    relatedLocations :: ![(Int, Text)],+    message :: !Text+  }+  deriving stock (Eq, Show)++-- | Render a diagnostic in the conventional+-- @\<file\>:\<line\>: error[\<code\>]: \<message\>@ form.+renderDiagnostic :: FilePath -> Diagnostic -> Text+renderDiagnostic file d =+  T.intercalate "\n" (primary : notes)+  where+    primary =+      T.pack file+        <> ":"+        <> T.pack (show (line d))+        <> ": "+        <> sev+        <> "["+        <> T.pack (show (code d))+        <> "]: "+        <> message d+    notes =+      [ "  " <> T.pack file <> ":" <> T.pack (show noteLine) <> ": note: " <> note+      | (noteLine, note) <- relatedLocations d+      ]+    sev = case severity d of Error -> "error"; Warning -> "warning"++-- | Error diagnostics produced when the effective source language is below a+-- CI-required released floor. A legacy source has no preamble, so line 1 is the+-- actionable location where one should be added.+minimumLanguageDiagnostics :: LanguageVersion -> SourceLanguage -> [Diagnostic]+minimumLanguageDiagnostics floorVersion sourceLanguage+  | effectiveVersion >= floorVersion = []+  | otherwise =+      [ Diagnostic+          { line = sourceLanguageLine sourceLanguage,+            severity = Error,+            code = LanguageVersionBelowMinimum,+            relatedLocations = [],+            message =+              "effective language version "+                <> languageVersionText effectiveVersion+                <> " ("+                <> sourceFormText sourceLanguage+                <> ") is below the required minimum "+                <> languageVersionText floorVersion+                <> "; declare `language keiro-dsl "+                <> languageVersionText floorVersion+                <> "`"+          }+      ]+  where+    effectiveVersion = effectiveLanguageVersion sourceLanguage+    sourceLanguageLine LegacyUnversioned = 1+    sourceLanguageLine DeclaredLanguage {languageVersionLoc = Loc lineNumber} = lineNumber++-- | Reserved wall-clock atom names. Sampling any of these inside a guard or+-- write breaks deterministic replay: TIME IS INJECTED, NOT SAMPLED.+clockAtoms :: Set Name+clockAtoms = Set.fromList ["now", "currentTime", "wallClock", "today", "utcNow"]++-- | Validate a whole service under its effective released semantic contract.+-- An empty list means valid. Current released versions share this policy, but+-- selecting it at this boundary prevents successor semantics from being lost.+validateService :: CheckedService -> [Diagnostic]+validateService service =+  validateCheckedSpec+    (checkedLanguageContract service)+    (checkedTypeGraph service)+    (checkedProjectionSupplies service)+    (checkedSpec service)++-- | Compatibility wrapper for callers that have only a normalized graph. It+-- explicitly selects legacy/version-1 semantics; production source/workspace+-- routes use 'validateService'.+validateSpec :: Spec -> [Diagnostic]+validateSpec = validateService . legacyCheckedService++validateCheckedSpec :: EffectiveLanguageContract -> Either (NE.NonEmpty TypeGraphError) TypeGraph -> ProjectionSupplyAnalysis -> Spec -> [Diagnostic]+validateCheckedSpec languageContract typeGraphResult supplyAnalysis spec =+  sortOn line (validateNames languageContract typeGraphResult spec ++ validateMapped typeGraphResult spec ++ validateNominal languageContract spec ++ validateAggregateTypes typeGraphResult spec ++ specLevelRules languageContract supplyAnalysis spec ++ concatMap (validateNode languageContract typeGraphResult supplyAnalysis spec) (specNodes spec))++-- | Rules added before language 4 ships consult the effective semantic+-- contract, not the numeric source spelling. Versions 1 through 3 retain their+-- released acceptance; runtime semantics 3 is the unreleased tightening gate.+enforcesSpecSurfaceClosures :: EffectiveLanguageContract -> Bool+enforcesSpecSurfaceClosures languageContract =+  runtimeProfileHasCapability (effectiveRuntimeProfile languageContract) StrictSpecSurfaceValidation++hasProjectionCatalog :: EffectiveLanguageContract -> Bool+hasProjectionCatalog languageContract =+  runtimeProfileHasCapability (effectiveRuntimeProfile languageContract) ProjectionCatalogRuntime++hasSeparatedProjectionQueryPolicy :: EffectiveLanguageContract -> Bool+hasSeparatedProjectionQueryPolicy languageContract =+  runtimeProfileHasCapability (effectiveRuntimeProfile languageContract) SeparatedProjectionQueryPolicy++validateNominal :: EffectiveLanguageContract -> Spec -> [Diagnostic]+validateNominal languageContract spec = domainErrors <> resolutionErrors+  where+    domainErrors =+      [ mkErr (locLine (idLoc declaration)) NominalInvalidIdPrefix $+          "id '" <> idName declaration <> "' has invalid TypeID prefix '" <> idPrefix declaration <> "': " <> T.pack (show reason)+      | declaration <- specIds spec,+        Just _ <- [idDomainContractFor languageContract (idPrefix declaration)],+        Just reason <- [TypeID.checkPrefix (idPrefix declaration)]+      ]+    resolutionErrors = case Nominal.resolveNominalTypes spec of+      Right _ -> []+      Left errors -> map nominalTypeDiagnostic (NE.toList errors)++nominalTypeDiagnostic :: Nominal.NominalTypeError -> Diagnostic+nominalTypeDiagnostic nominalError = case nominalError of+  Nominal.NominalMissingIngredient name loc ingredient ->+    problem loc NominalMissingIngredient $ "nominal declaration '" <> name <> "' is missing required " <> ingredient <> " provenance"+  Nominal.NominalInvalidHaskellSource name loc ingredient ->+    problem loc NominalInvalidHaskellSource $ "nominal declaration '" <> name <> "' has an invalid Haskell " <> ingredient <> " name"+  Nominal.NominalInvalidQualifiedValue name loc ingredient value ->+    problem loc NominalInvalidQualifiedName $+      "nominal declaration '" <> name <> "' has invalid " <> ingredient <> " symbol '" <> value <> "'; expected a module path plus a lower-initial value"+  Nominal.NominalInvalidIdentity name loc ingredient value ->+    problem loc NominalInvalidIdentity $ "nominal declaration '" <> name <> "' has invalid " <> ingredient <> " '" <> value <> "'"+  Nominal.NominalInvalidIdPrefix name loc prefix detail ->+    problem loc NominalInvalidIdPrefix $ "id '" <> name <> "' has invalid TypeID prefix '" <> prefix <> "': " <> detail+  Nominal.NominalUnsupportedScalar name loc representation ->+    problem loc NominalUnsupportedRepresentation $+      "nominal scalar '" <> name <> "' uses unsupported representation '" <> representation <> "'; supported representations are Text, Int, Natural, Bool, and Time"+  Nominal.NominalEmptyEnum name loc ->+    problem loc NominalEmptyEnumRepresentation $ "enum '" <> name <> "' must declare at least one closed representation constructor"+  Nominal.NominalMissingRegisterInitial name loc registerName ->+    problem loc NominalMissingInitialValue $+      "consumer-owned nominal type '" <> name <> "' is used by register '" <> registerName <> "' and must name an initial symbol"+  Nominal.NominalDeclarationCollision name loc categories ->+    problem loc NominalNameCollision $ "declaration name '" <> name <> "' collides across " <> T.intercalate ", " categories+  where+    problem loc diagnosticCode detail = mkErr (locLine loc) diagnosticCode (detail <> "; GHC and conformance validate consumer function bodies")++-- | Resolve every direct aggregate type once at the earliest semantic gate.+validateAggregateTypes :: Either (NE.NonEmpty TypeGraphError) TypeGraph -> Spec -> [Diagnostic]+validateAggregateTypes typeGraphResult spec = case Nominal.resolveNominalTypes spec of+  Left _ -> []+  Right _ -> concatMap aggregateRules aggregates+  where+    symbols = aggregateSymbolsFromGraphResult typeGraphResult spec+    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]++    aggregateRules aggregate =+      outcomeTypeRules aggregate+        ++ concatMap commandRules (aggCommands aggregate)+        ++ concatMap eventRules (aggEvents aggregate)+        ++ concatMap registerRules (aggRegs aggregate)+        ++ concatMap (transitionRules aggregate) (aggTransitions aggregate)+      where+        commandRules command = concatMap (fieldRule aggregate CommandFieldUse) (cmdFields command)+        eventRules event = case evBody event of+          EventFields fields -> concatMap (fieldRule aggregate EventFieldUse) fields+          EventFromCommand _ -> []+        registerRules register = case resolveAggregateType symbols (regLoc register) RegisterUse (regType register) of+          Left typeError -> [aggregateTypeDiagnostic typeError]+          Right AggregateMapped {} -> []+          Right resolved -> case resolveRegisterInitial symbols (regLoc register) resolved (regInitial register) of+            Left initialError -> [aggregateTypeDiagnostic initialError]+            Right _ -> []++    fieldRule aggregate useSite field =+      either (pure . aggregateTypeDiagnostic) (const []) (inferAggregateFieldType symbols aggregate useSite field)++    outcomeTypeRules aggregate = case aggDomainOutcomeTypes aggregate of+      Nothing -> []+      Just declaration ->+        unresolved "rejection" (rejectionType declaration)+          ++ unresolved "no-op" (noOpType declaration)+        where+          unresolved label name = case resolveAggregateType symbols (outcomeTypesLoc declaration) HaskellLoweringUse (TRef name) of+            Right _ -> []+            Left _ ->+              [ mkErr (locLine (outcomeTypesLoc declaration)) DomainOutcomeTypeUnresolved $+                  "aggregate '" <> aggName aggregate <> "' declares unknown or unsupported " <> label <> " outcome type '" <> name <> "'"+              ]++    transitionRules aggregate transition = ownershipRules ++ outcomeExpressionRules+      where+        environment = expressionEnvironmentFromGraphResult typeGraphResult spec aggregate transition+        ownershipRules = case tImplementation transition of+          LegacyHoleImplementation ->+            concatMap (comparisonRule aggregate transition) (maybe [] comparisons (tGuard transition))+          GeneratedImplementation ->+            maybe [] (expressionDiagnostics . resolveGuardExpr environment) (tGuard transition)+              ++ concatMap (expressionDiagnostics . uncurry (resolveWriteExpr environment)) (tWrites transition)+          HoleImplementation ->+            [ mkErr (locLine (tLoc transition)) AggregateTransitionOwnershipConflict $+                "transition '"+                  <> tSource transition+                  <> " -- "+                  <> tCommand transition+                  <> "' selects implementation hole and therefore cannot also declare guard or write clauses"+            | tGuard transition /= Nothing || not (null (tWrites transition))+            ]+        outcomeExpressionRules = case (aggDomainOutcomeTypes aggregate, tOutcome transition) of+          (Just declaration, Just (OutcomeRejected expression _)) -> resolveReason "rejected" (rejectionType declaration) expression+          (Just declaration, Just (OutcomeNoOp expression _)) -> resolveReason "no-op" (noOpType declaration) expression+          _ -> []+        resolveReason label typeName expression =+          case resolveAggregateType symbols (outcomeTypesLoc declaration) HaskellLoweringUse (TRef typeName) of+            Left _ -> []+            Right expected ->+              case resolveScalarExpr environment (ExpectScalarType expected) expression of+                Right _ -> []+                Left diagnostics -> map (outcomeExpressionDiagnostic label . id) (NE.toList diagnostics)+          where+            declaration = case aggDomainOutcomeTypes aggregate of+              Just value -> value+              Nothing -> error "unreachable: outcome reason without declaration"++    outcomeExpressionDiagnostic label diagnostic =+      mkErr+        (locLine (expressionDiagnosticLoc diagnostic))+        ( if expressionDiagnosticCode diagnostic `elem` [ScalarOperandTypeMismatch, ScalarBooleanOperandRequired]+            then DomainOutcomeReasonTypeMismatch+            else expressionCode (expressionDiagnosticCode diagnostic)+        )+        ("typed " <> label <> " outcome reason is invalid: " <> expressionDiagnosticMessage diagnostic)++    expressionDiagnostics = either (map expressionDiagnostic . NE.toList) (const [])++    expressionDiagnostic diagnostic =+      mkErr+        (locLine (expressionDiagnosticLoc diagnostic))+        (expressionCode (expressionDiagnosticCode diagnostic))+        (expressionDiagnosticMessage diagnostic)++    expressionCode = \case+      ScalarRootUnknown -> AggregateExpressionRootUnknown+      ScalarRootAmbiguous -> AggregateExpressionRootAmbiguous+      ScalarPathInvalid -> AggregateExpressionPathInvalid+      ScalarPathUnsupported -> AggregateExpressionPathUnsupported+      ScalarLiteralNeedsType -> AggregateExpressionLiteralNeedsType+      ScalarLiteralInvalid -> AggregateExpressionLiteralInvalid+      ScalarOperandTypeMismatch -> AggregateExpressionOperandTypeMismatch+      ScalarOperatorUnsupported -> AggregateExpressionOperatorUnsupported+      ScalarBooleanOperandRequired -> AggregateExpressionBooleanRequired+      ScalarGuardBoolRequired -> AggregateExpressionGuardBoolRequired+      ScalarWriteTargetUnknown -> AggregateExpressionWriteTargetUnknown+      ScalarWriteTypeMismatch -> AggregateExpressionWriteTypeMismatch++    comparisonRule aggregate transition (operator, left, right) =+      case (expressionType aggregate transition left, expressionType aggregate transition right) of+        (Right leftType, Right rightType)+          | leftType /= rightType ->+              [ mkErr (locLine (tLoc transition)) AggregateGuardTypeMismatch $+                  "comparison operands have different aggregate types '"+                    <> aggregateCanonicalName leftType+                    <> "' and '"+                    <> aggregateCanonicalName rightType+                    <> "'"+              ]+          | aggregateCapability useSite leftType == Unsupported ->+              [ mkErr (locLine (tLoc transition)) AggregateGuardCapabilityUnsupported $+                  renderAggregateUseSite useSite+                    <> " is unsupported for aggregate type '"+                    <> aggregateCanonicalName leftType+                    <> "'"+              ]+          | otherwise -> []+        _ -> []+      where+        useSite = case operator of+          OpEq -> EqualityGuardUse+          OpNeq -> EqualityGuardUse+          OpLt -> OrderingGuardUse+          OpLe -> OrderingGuardUse+          OpGt -> OrderingGuardUse+          OpGe -> OrderingGuardUse++    expressionType aggregate transition expression = case expression of+      EAtom (ABool _) -> pure AggregateBool+      EAtom (AName name) -> atomType aggregate transition name+      EOr {} -> pure AggregateBool+      EAnd {} -> pure AggregateBool+      ECmp {} -> pure AggregateBool+      EAdd _ left _ -> expressionType aggregate transition left+      ESubtract _ left _ -> expressionType aggregate transition left+      EMultiply _ left _ -> expressionType aggregate transition left+      EPath loc _ path -> case path of+        name : _ -> atomType aggregate transition name+        [] -> Left (AggregateTypeError loc EqualityGuardUse (UnknownAggregateType "<empty-path>"))+      ELiteral _ literal -> case literal of+        LiteralBool {} -> pure AggregateBool+        LiteralText {} -> pure AggregateText+        LiteralIntegral {} -> Left (AggregateTypeError (exprLoc expression) EqualityGuardUse (UnknownAggregateType "<contextual-integral-literal>"))+        LiteralQualified typeName _ -> resolveAggregateType symbols (exprLoc expression) EqualityGuardUse (TRef typeName)+        LiteralId typeName _ -> resolveAggregateType symbols (exprLoc expression) EqualityGuardUse (TRef typeName)++    atomType aggregate transition name = case [register | register <- aggRegs aggregate, regName register == name] of+      register : _ -> resolveAggregateType symbols (regLoc register) RegisterUse (regType register)+      [] -> case [field | command <- aggCommands aggregate, cmdName command == tCommand transition, field <- cmdFields command, aggregateFieldName field == name] of+        field : _ -> inferAggregateFieldType symbols aggregate CommandFieldUse field+        [] -> case [enumName declaration | declaration <- specEnums spec, name `elem` map fst (enumCtors declaration)] of+          enumType : _ -> resolveAggregateType symbols (tLoc transition) CommandFieldUse (TRef enumType)+          []+            | name `elem` map stName (aggStates aggregate) -> pure (AggregateVertex (aggName aggregate <> "Vertex"))+            | Just rule <- firstMatching ((== name) . ruleName) (specRules spec) ->+                resolveAggregateType symbols (ruleLoc rule) EqualityGuardUse (nameTypeExpr (ruleCodomain rule))+            | otherwise -> Left (AggregateTypeError (tLoc transition) EqualityGuardUse (UnknownAggregateType name))++    nameTypeExpr name = case name of+      "Text" -> TText+      "Int" -> TInt+      "Bool" -> TBool+      "Natural" -> TNatural+      "Time" -> TTime+      "UTCTime" -> TTime+      "Json" -> TJson+      _ -> TRef name++    comparisons expression = case expression of+      EOr left right -> comparisons left <> comparisons right+      EAnd left right -> comparisons left <> comparisons right+      ECmp operator left right -> (operator, left, right) : comparisons left <> comparisons right+      EAdd _ left right -> comparisons left <> comparisons right+      ESubtract _ left right -> comparisons left <> comparisons right+      EMultiply _ left right -> comparisons left <> comparisons right+      EPath {} -> []+      ELiteral {} -> []+      EAtom {} -> []++aggregateTypeDiagnostic :: AggregateTypeError -> Diagnostic+aggregateTypeDiagnostic aggregateError =+  mkErr (locLine (aggregateTypeErrorLoc aggregateError)) diagnosticCode diagnosticMessage+  where+    diagnosticCode = case aggregateTypeErrorReason aggregateError of+      UnknownAggregateType {} -> AggregateTypeUnknown+      UnsupportedAggregateShape {} -> AggregateTypeUnsupportedAtUse+      UnsupportedAggregateCapability {} -> case aggregateTypeErrorUseSite aggregateError of+        EqualityGuardUse -> AggregateGuardCapabilityUnsupported+        OrderingGuardUse -> AggregateGuardCapabilityUnsupported+        _ -> AggregateTypeUnsupportedAtUse+      InvalidRegisterInitial {} -> AggregateRegisterInitialInvalid+    diagnosticMessage = case aggregateTypeErrorReason aggregateError of+      UnknownAggregateType name ->+        "unknown aggregate type '" <> name <> "' at " <> renderAggregateUseSite (aggregateTypeErrorUseSite aggregateError)+      UnsupportedAggregateShape expression ->+        "direct aggregate type '"+          <> typeExprCanonicalName expression+          <> "' is unsupported at "+          <> renderAggregateUseSite (aggregateTypeErrorUseSite aggregateError)+          <> "; use a mapped structural declaration for Json or container shapes"+      UnsupportedAggregateCapability resolved ->+        renderAggregateUseSite (aggregateTypeErrorUseSite aggregateError)+          <> " is unsupported for aggregate type '"+          <> aggregateCanonicalName resolved+          <> "'"+      InvalidRegisterInitial resolved detail ->+        "invalid " <> aggregateCanonicalName resolved <> " register initial: " <> detail++renderAggregateUseSite :: AggregateUseSite -> Text+renderAggregateUseSite useSite = case useSite of+  CommandFieldUse -> "command field"+  EventFieldUse -> "event field"+  RegisterUse -> "register"+  EqualityGuardUse -> "equality guard"+  OrderingGuardUse -> "ordering guard"+  WholeValueWriteUse -> "whole-value write"+  CodecUse -> "JSON codec"+  SnapshotUse -> "snapshot"+  HarnessSampleUse -> "harness sample"+  HaskellLoweringUse -> "Haskell lowering"++-- | Validate consumer-owned mapped declarations without inspecting consumer+-- Haskell. Symbol-shaped facts are checked lexically here; GHC remains the+-- authority for whether the named packages, modules, values, types, and+-- instances actually exist with the promised types.+validateMapped :: Either (NE.NonEmpty TypeGraphError) TypeGraph -> Spec -> [Diagnostic]+validateMapped typeGraphResult spec =+  mappedLexicalRules spec+    ++ mappedIdentityRules spec+    ++ mappedConflictRules spec+    ++ case typeGraphResult of+      Left errors -> concatMap (typeGraphDiagnostic spec) (NE.toList errors)+      Right graph -> mappedGraphRules spec graph++typeGraphDiagnostic :: Spec -> TypeGraphError -> [Diagnostic]+typeGraphDiagnostic spec = \case+  TGDeclError name declarationError ->+    [ mkErr (mappedLine spec name) diagnosticCode $+        "mapped declaration '" <> name <> "': " <> declarationErrorMessage declarationError+    ]+    where+      diagnosticCode = case declarationError of+        MissingHaskellSource {} -> MappedMissingIngredient+        MissingStructuralBinding {} -> MappedMissingIngredient+        MissingStructuralBindingVersion {} -> MappedMissingIngredient+        MissingCanonicalType {} -> MappedMissingIngredient+        MissingFixtureCases {} -> MappedMissingIngredient+        MissingOpaqueCodecIdentity {} -> MappedMissingIngredient+        MissingOpaqueCodecVersion {} -> MappedMissingIngredient+        EmptyQualifiedValueName {} -> MappedInvalidHaskellName+        EmptyCanonicalTypeId {} -> MappedInvalidIdentity+        EmptyBindingVersion {} -> MappedInvalidIdentity+        EmptyCodecIdentity {} -> MappedInvalidIdentity+        EmptyCodecVersion {} -> MappedInvalidIdentity+  TGAmbiguousName name origins ->+    [ mkErr (mappedLine spec name) MappedAmbiguousName $+        "type name '" <> name <> "' is ambiguous across " <> T.intercalate ", " origins+    ]+  TGUnresolvedRef owner missing loc ->+    [ mkErr (locLine loc) MappedUnresolvedName $+        "mapped declaration '" <> owner <> "' references unresolved mapped type '" <> missing <> "'"+    ]+  TGUnresolvedConsumerRef owner missing loc ->+    [ mkErr (locLine loc) MappedUnresolvedName $+        owner <> " references unresolved mapped type '" <> missing <> "'"+    ]+  TGRecursive names ->+    [ mkErr (mappedLine spec (headOr "<mapped>" names)) MappedRecursiveType $+        "recursive structural mapping is unsupported: " <> T.intercalate " -> " (names <> take 1 names)+    ]++declarationErrorMessage :: MappedDeclError -> Text+declarationErrorMessage = \case+  MissingHaskellSource _ -> "missing complete haskell package/module/type ingredient"+  MissingStructuralBinding _ -> "missing binding ingredient; GHC will verify the named value and its type"+  MissingStructuralBindingVersion _ -> "missing binding-version ingredient"+  MissingCanonicalType _ -> "missing canonical-type ingredient"+  MissingFixtureCases _ -> "missing fixtures ingredient; GHC will verify the named FixtureCases value"+  MissingOpaqueCodecIdentity _ -> "missing opaque codec identity ingredient"+  MissingOpaqueCodecVersion _ -> "missing opaque codec version ingredient"+  EmptyQualifiedValueName _ -> "a binding, fixture, or initial symbol is empty; GHC will verify a syntactically valid qualified value"+  EmptyCanonicalTypeId _ -> "canonical-type must be non-empty"+  EmptyBindingVersion _ -> "binding-version must be non-empty"+  EmptyCodecIdentity _ -> "opaque codec identity must be non-empty"+  EmptyCodecVersion _ -> "opaque codec version must be non-empty"++mappedLine :: Spec -> Name -> Int+mappedLine spec name =+  maybe 1 (locLine . mappedLoc) (firstMatching ((== name) . mappedName) (specMapped spec))++mappedName :: MappedDecl -> Name+mappedName MappedStructural {msName = name} = name+mappedName MappedOpaque {moName = name} = name++mappedLoc :: MappedDecl -> Loc+mappedLoc MappedStructural {msLoc = loc} = loc+mappedLoc MappedOpaque {moLoc = loc} = loc++mappedHaskell :: MappedDecl -> Maybe HaskellSource+mappedHaskell MappedStructural {msHaskell = source} = source+mappedHaskell MappedOpaque {moHaskell = source} = source++mappedCanonical :: MappedDecl -> Maybe Text+mappedCanonical MappedStructural {msCanonical = canonical} = canonical+mappedCanonical MappedOpaque {} = Nothing++mappedLexicalRules :: Spec -> [Diagnostic]+mappedLexicalRules spec = concatMap declarationRules (specMapped spec)+  where+    declarationRules declaration =+      constructorRule "mapped declaration name" (mappedName declaration) declaration+        ++ maybe [] (haskellRules declaration) (mappedHaskell declaration)+        ++ qualifiedFacts declaration+        ++ shapeConstructorRules declaration++    haskellRules declaration source =+      [ invalid declaration $ "Haskell package '" <> hsPackage source <> "' does not follow Cabal package-name grammar"+      | not (isCabalPackageName (hsPackage source))+      ]+        ++ [ invalid declaration $ "Haskell module '" <> hsModule source <> "' must be dot-separated Upper identifiers"+           | not (moduleNameSafe (hsModule source))+           ]+        ++ [ invalid declaration $ "Haskell type '" <> hsType source <> "' must be an Upper identifier"+           | not (constructorSafe (hsType source))+           ]++    qualifiedFacts MappedStructural {msBinding = binding, msFixtures = fixtures, msInitial = initial, msLoc = loc} =+      concatMap (qualifiedRule loc) [("binding", binding), ("fixtures", fixtures), ("initial", initial)]+    qualifiedFacts MappedOpaque {moFixtures = fixtures, moInitial = initial, moLoc = loc} =+      concatMap (qualifiedRule loc) [("fixtures", fixtures), ("initial", initial)]++    qualifiedRule loc (category, value) = case value of+      Just symbol+        | not (T.null symbol) && not (qualifiedValueSafe symbol) ->+            [ mkErr (locLine loc) MappedInvalidHaskellName $+                category <> " symbol '" <> symbol <> "' must be a module path plus a lower-initial value; GHC will verify that it exists with the promised type"+            ]+      _ -> []++    shapeConstructorRules declaration = case declaration of+      MappedStructural {msShape = ShapeRecord constructor _ fields} ->+        constructorRule "record constructor" constructor declaration+          ++ [ invalidAt (wireFieldLoc field) $ "record selector '" <> wfHaskell field <> "' must be a lower-initial Haskell identifier"+             | field <- fields,+               not (lowerIdentifierSafe (wfHaskell field))+             ]+      MappedStructural {msShape = ShapeEnum entries} ->+        [ invalidAt (weLoc entry) $ "enum constructor '" <> weCtor entry <> "' must be an Upper identifier"+        | entry <- entries,+          not (constructorSafe (weCtor entry))+        ]+      MappedStructural {msShape = ShapeUnion _ arms} ->+        [ invalidAt (waLoc arm) $ "union constructor '" <> waCtor arm <> "' must be an Upper identifier"+        | arm <- arms,+          not (constructorSafe (waCtor arm))+        ]+      MappedOpaque {} -> []++    constructorRule category value declaration =+      [ invalid declaration $ category <> " '" <> value <> "' must be an Upper identifier"+      | not (constructorSafe value)+      ]+    invalid declaration detail = invalidAt (mappedLoc declaration) detail+    invalidAt loc detail =+      mkErr (locLine loc) MappedInvalidHaskellName (detail <> "; this is a syntax check only, and GHC will verify the consumer declaration")++mappedIdentityRules :: Spec -> [Diagnostic]+mappedIdentityRules spec =+  [ mkErr (locLine (mappedLoc declaration)) MappedInvalidIdentity $+      "mapped declaration '" <> mappedName declaration <> "' has an identity/version containing an ASCII control character"+  | declaration <- specMapped spec,+    value <- identityValues declaration,+    T.any asciiControl value+  ]+  where+    identityValues MappedStructural {msBindingVersion = bindingVersion, msCanonical = canonical} = present [bindingVersion, canonical]+    identityValues MappedOpaque {moCodecId = codecIdentity, moCodecVersion = codecVersion} = present [codecIdentity, codecVersion]+    present = foldr (maybe id (:)) []++mappedConflictRules :: Spec -> [Diagnostic]+mappedConflictRules spec = sourceCollisions ++ canonicalCollisions ++ packageCollisions+  where+    declarations = specMapped spec+    sourceFacts = [(declaration, source) | declaration <- declarations, source <- maybeToList (mappedHaskell declaration)]+    sourceCollisions =+      [ conflict declaration $+          "Haskell target '" <> hsModule source <> "." <> hsType source <> "' is claimed by more than one mapped declaration"+      | (declaration, source) <- duplicatesBy (\(_, value) -> (hsModule value, hsType value)) sourceFacts+      ]+    canonicalFacts = [(declaration, canonical) | declaration <- declarations, canonical <- maybeToList (mappedCanonical declaration), not (T.null canonical)]+    canonicalCollisions =+      [ conflict declaration $ "canonical-type '" <> canonical <> "' is claimed by more than one mapped declaration"+      | (declaration, canonical) <- duplicatesBy snd canonicalFacts+      ]+    moduleFacts = [(declaration, hsModule source, hsPackage source) | (declaration, source) <- sourceFacts]+    packageCollisions =+      [ conflict declaration $+          "Haskell module '" <> moduleName <> "' is declared from conflicting packages '" <> oldPackage <> "' and '" <> packageName <> "'"+      | (index, (declaration, moduleName, packageName)) <- zip [0 :: Int ..] moduleFacts,+        (_, oldModule, oldPackage) <- take index moduleFacts,+        oldModule == moduleName,+        oldPackage /= packageName+      ]+    conflict declaration detail = mkErr (locLine (mappedLoc declaration)) MappedImportConflict detail+    maybeToList = maybe [] pure++mappedGraphRules :: Spec -> TypeGraph -> [Diagnostic]+mappedGraphRules spec graph =+  concatMap declarationRules (Map.elems (tgDeclarations graph))+    ++ mappedRegisterInitialRules spec graph+  where+    declarationRules =+      foldMappedDecl+        MappedDeclAlgebra+          { onStructuralDecl = \declaration shape ->+              foldMappedShape (shapeRules declaration) shape,+            onOpaqueDecl = const []+          }++    shapeRules declaration =+      MappedShapeAlgebra+        { onRecord = \_ _ fields ->+            [ mappedError (rwfLoc field) MappedDuplicateFieldName declaration $+                "record selector '" <> rwfHaskell field <> "' is declared more than once"+            | field <- duplicatesBy rwfHaskell fields+            ]+              ++ [ mappedError (rwfLoc field) MappedDuplicateWireKey declaration $+                     "record wire key '" <> rwfKey field <> "' is declared more than once"+                 | field <- duplicatesBy rwfKey fields+                 ]+              ++ [ mappedError (rwfLoc field) MappedUnsupportedEncoding declaration "record wire keys must be non-empty"+                 | field <- fields,+                   T.null (rwfKey field)+                 ]+              ++ concatMap (fieldRules declaration) fields,+          onEnum = \entries ->+            [ mappedError (weLoc entry) MappedDuplicateArmName declaration $+                "enum constructor '" <> weCtor entry <> "' is declared more than once"+            | entry <- duplicatesBy weCtor entries+            ]+              ++ [ mappedError (weLoc entry) MappedDuplicateWireTag declaration $+                     "enum wire spelling '" <> weTag entry <> "' is declared more than once"+                 | entry <- duplicatesBy weTag entries+                 ]+              ++ [ mappedError (weLoc entry) MappedUnsupportedEncoding declaration "enum wire spellings must be non-empty"+                 | entry <- entries,+                   T.null (weTag entry)+                 ],+          onUnion = \encoding arms ->+            [ mappedError (sdLoc declaration) MappedUnsupportedEncoding declaration "tagged-object tag and contents keys must be distinct"+            | ueTagField encoding == ueContentsField encoding+            ]+              ++ [ mappedError (sdLoc declaration) MappedUnsupportedEncoding declaration "tagged-object tag and contents keys must be non-empty"+                 | T.null (ueTagField encoding) || T.null (ueContentsField encoding)+                 ]+              ++ [ mappedError (rwaLoc arm) MappedDuplicateArmName declaration $+                     "union constructor '" <> rwaCtor arm <> "' is declared more than once"+                 | arm <- duplicatesBy rwaCtor arms+                 ]+              ++ [ mappedError (rwaLoc arm) MappedDuplicateWireTag declaration $+                     "union wire tag '" <> rwaTag arm <> "' is declared more than once"+                 | arm <- duplicatesBy rwaTag arms+                 ]+              ++ [ mappedError (rwaLoc arm) MappedUnsupportedEncoding declaration "union wire tags must be non-empty"+                 | arm <- arms,+                   T.null (rwaTag arm)+                 ]+              ++ concatMap (armRules declaration) arms+        }++    fieldRules declaration field =+      defaultRules declaration field+        ++ [ mappedError (rwfLoc field) MappedNonInjectiveNullability declaration $+               "field '" <> rwfHaskell field <> "' contains Optional around a null-capable Json, Optional, or opaque mapped value"+           | hasNonInjectiveOptional graph (rwfType field)+           ]++    armRules declaration arm =+      [ mappedError (rwaLoc arm) MappedNonInjectiveNullability declaration $+          "union arm '" <> rwaCtor arm <> "' contains Optional around a null-capable Json, Optional, or opaque mapped value"+      | payload <- maybeToList (rwaPayload arm),+        hasNonInjectiveOptional graph payload+      ]++    defaultRules declaration field = case (rwfPresence field, rwfOnMissing field) of+      (PRequired, Just _) -> [illTyped "required fields cannot declare on-missing"]+      (POptional, Nothing) ->+        [ mappedError (rwfLoc field) MappedMissingIngredient declaration $+            "optional field '" <> rwfHaskell field <> "' is missing its on-missing policy"+        ]+      (POptional, Just value)+        | not (defaultMatches graph (rwfType field) value) -> [illTyped "on-missing value does not match the field type or numeric bounds"]+      _ -> []+      where+        illTyped detail =+          mappedError (rwfLoc field) MappedDefaultIllTyped declaration $+            "field '" <> rwfHaskell field <> "': " <> detail++    mappedError loc diagnosticCode declaration detail =+      mkErr (locLine loc) diagnosticCode $+        "mapped declaration '" <> sdName declaration <> "' " <> detail+    maybeToList = maybe [] pure++data DefaultType+  = DefaultText+  | DefaultInt+  | DefaultBool+  | DefaultNatural+  | DefaultOptional+  | DefaultList+  | DefaultMap+  | DefaultEnum !(Set Name)+  | DefaultOther++defaultMatches :: TypeGraph -> ResolvedTypeExpr -> OnMissing -> Bool+defaultMatches graph expression value = case (defaultType graph expression, value) of+  (DefaultText, OmText _) -> True+  (DefaultInt, OmInt integer) -> integer >= toInteger (minBound :: Int) && integer <= toInteger (maxBound :: Int)+  (DefaultBool, OmBool _) -> True+  (DefaultNatural, OmInt integer) -> integer >= 0+  (DefaultOptional, OmNull) -> True+  (DefaultList, OmEmptyList) -> True+  (DefaultMap, OmEmptyMap) -> True+  (DefaultEnum constructors, OmCtor constructor) -> constructor `Set.member` constructors+  _ -> False++defaultType :: TypeGraph -> ResolvedTypeExpr -> DefaultType+defaultType graph =+  foldTypeExpr+    TypeExprAlgebra+      { onText = DefaultText,+        onInt = DefaultInt,+        onInteger = DefaultInt,+        onBool = DefaultBool,+        onNatural = DefaultNatural,+        onTime = DefaultOther,+        onJson = DefaultOther,+        onOptional = const DefaultOptional,+        onList = const DefaultList,+        onMap = const DefaultMap,+        onRef = referencedDefaultType graph+      }++referencedDefaultType :: TypeGraph -> MappedKey -> DefaultType+referencedDefaultType graph key = case Map.lookup key (tgDeclarations graph) of+  Nothing -> DefaultOther+  Just declaration ->+    foldMappedDecl+      MappedDeclAlgebra+        { onStructuralDecl = \_ shape ->+            foldMappedShape+              MappedShapeAlgebra+                { onRecord = \_ _ _ -> DefaultOther,+                  onEnum = DefaultEnum . Set.fromList . map weCtor,+                  onUnion = \_ _ -> DefaultOther+                }+              shape,+          onOpaqueDecl = const DefaultOther+        }+      declaration++data NullabilityFacts = NullabilityFacts+  { nfTopNull :: !Bool,+    nfBadOptional :: !Bool+  }++hasNonInjectiveOptional :: TypeGraph -> ResolvedTypeExpr -> Bool+hasNonInjectiveOptional graph =+  nfBadOptional+    . foldTypeExpr+      TypeExprAlgebra+        { onText = nonNull,+          onInt = nonNull,+          onInteger = nonNull,+          onBool = nonNull,+          onNatural = nonNull,+          onTime = nonNull,+          onJson = nullable,+          onOptional = \child -> NullabilityFacts True (nfTopNull child || nfBadOptional child),+          onList = nestedNonNull,+          onMap = nestedNonNull,+          onRef = \key -> if mappedRefIsOpaque graph key then nullable else nonNull+        }+  where+    nonNull = NullabilityFacts False False+    nullable = NullabilityFacts True False+    nestedNonNull child = NullabilityFacts False (nfBadOptional child)++mappedRefIsOpaque :: TypeGraph -> MappedKey -> Bool+mappedRefIsOpaque graph key = case Map.lookup key (tgDeclarations graph) of+  Nothing -> False+  Just declaration ->+    foldMappedDecl+      MappedDeclAlgebra+        { onStructuralDecl = \_ _ -> False,+          onOpaqueDecl = const True+        }+      declaration++mappedRegisterInitialRules :: Spec -> TypeGraph -> [Diagnostic]+mappedRegisterInitialRules spec graph =+  concatMap aggregateRules [aggregate | NAggregate aggregate <- specNodes spec]+  where+    aggregateRules aggregate = concatMap registerRule (aggRegs aggregate)+    registerRule register = case regType register of+      TRef typeName -> case Map.lookup (MappedKey typeName) (tgDeclarations graph) of+        Nothing -> []+        Just declaration -> case regInitial register of+          RegInitBare "initial"+            | mappedInitial declaration == Nothing ->+                [ mkErr (locLine (regLoc register)) MappedMissingInitialValue $+                    "mapped register '" <> regName register <> "' requires declaration '" <> typeName <> "' to name an explicit initial value"+                ]+            | otherwise -> []+          _ ->+            [ mkErr (locLine (regLoc register)) RegisterInitialOutOfScope $+                "mapped register '" <> regName register <> "' must use the bare initial token; the declaration-owned symbol is verified by GHC"+            ]+      _ -> []+    mappedInitial =+      foldMappedDecl+        MappedDeclAlgebra+          { onStructuralDecl = \declaration _ -> sdInitial declaration,+            onOpaqueDecl = odInitial+          }++moduleNameSafe :: Text -> Bool+moduleNameSafe moduleName =+  not (null components) && all constructorSafe components+  where+    components = T.splitOn "." moduleName++qualifiedValueSafe :: Text -> Bool+qualifiedValueSafe qualified = case reverse (T.splitOn "." qualified) of+  value : reversedModule ->+    not (null reversedModule)+      && lowerIdentifierSafe value+      && all constructorSafe reversedModule+  [] -> False++lowerIdentifierSafe :: Text -> Bool+lowerIdentifierSafe name = case T.uncons name of+  Just (first, rest) -> asciiLower first && T.all asciiAlphaNumOrUnderscore rest && name `Set.notMember` HaskellName.haskellKeywords+  Nothing -> False++asciiControl :: Char -> Bool+asciiControl c = ord c < 32 || ord c == 127++firstMatching :: (a -> Bool) -> [a] -> Maybe a+firstMatching predicate = \case+  [] -> Nothing+  value : rest+    | predicate value -> Just value+    | otherwise -> firstMatching predicate rest++headOr :: a -> [a] -> a+headOr fallback = \case+  [] -> fallback+  value : _ -> value++-- | Check every logical name before a renderer can turn it into Haskell.  The+-- parser enforces the ASCII alphabet; 'HaskellName' owns word segmentation,+-- casing, keywords, and normalized collision keys.+validateNames :: EffectiveLanguageContract -> Either (NE.NonEmpty TypeGraphError) TypeGraph -> Spec -> [Diagnostic]+validateNames languageContract typeGraphResult spec =+  concat+    [ concatMap idNames (specIds spec),+      concatMap enumNames (specEnums spec),+      concatMap nominalNames (specNominalScalars spec),+      concatMap nodeNames (specNodes spec),+      normalizedCollisions+    ]+  where+    idNames declaration =+      constructorName "id name" (idName declaration) (idLoc declaration)++    enumNames declaration =+      constructorName "enum name" (enumName declaration) (enumLoc declaration)+        ++ concatMap+          (\(ctor, _) -> constructorName ("constructor of enum '" <> enumName declaration <> "'") ctor (enumLoc declaration))+          (enumCtors declaration)++    nominalNames declaration =+      constructorName "nominal scalar name" (nominalScalarName declaration) (nominalScalarLoc declaration)++    nodeNames = \case+      NAggregate aggregate -> aggregateNames aggregate+      NProcess process -> processNames process+      NRouter router -> routerNames router+      NContract contract ->+        pascalizedNodeName "contract" (ctrName contract) (ctrLoc contract)+          ++ concatMap+            (\event -> constructorName "contract event name" (ceName event) (ctrLoc contract) ++ concatMap contractFieldName (ceFields event))+            (ctrEvents contract)+      NIntake intake -> pascalizedNodeName "intake" (inkName intake) (inkLoc intake)+      NEmit emitNode -> pascalizedNodeName "emit" (emName emitNode) (emLoc emitNode)+      NPublisher publisher -> pascalizedNodeName "publisher" (pubName publisher) (pubLoc publisher)+      NWorkqueue workqueue ->+        pascalizedNodeName "workqueue" (wqName workqueue) (wqLoc workqueue)+          ++ constructorName "workqueue payload name" (wqPayloadName workqueue) (wqLoc workqueue)+          ++ concatMap (\field -> fieldNameRule "workqueue payload field" (wqfName field) (wqLoc workqueue)) (wqPayload workqueue)+      NPgmqDispatch dispatch -> pascalizedNodeName "dispatch" (pdName dispatch) (pdLoc dispatch)+      NReadModel readModel -> pascalizedNodeName "readmodel" (rmName readModel) (rmLoc readModel)+      NProjectionTarget target -> pascalizedNodeName "target" (ptName target) (ptLoc target)+      NRebuildGroup groupNode -> pascalizedNodeName "rebuild group" (rgName groupNode) (rgLoc groupNode)+      NProjectionRevision revision -> pascalizedNodeName "projection revision" (prvName revision) (prvLoc revision)+      NExternalRead externalRead -> pascalizedNodeName "external read" (externalReadNodeIdentity externalRead) (erLoc externalRead)+      NProjectionOwner owner -> pascalizedNodeName "projection owner" (poName owner) (poLoc owner)+      NWorkflow workflow -> workflowNames workflow+      NOperation _ -> []++    aggregateNames aggregate =+      constructorName "aggregate name" (aggName aggregate) (aggLoc aggregate)+        ++ concatMap+          (\register -> fieldNameRule "register name" (regName register) (regLoc register))+          (aggRegs aggregate)+        ++ concatMap commandNames (aggCommands aggregate)+        ++ concatMap eventNames (aggEvents aggregate)+        ++ maybe [] (\projection -> fieldNameRule "projection key" (projKey projection) (projLoc projection)) (aggProjection aggregate)+        ++ vertexCollisions aggregate+      where+        commandNames command =+          constructorName "command name" (cmdName command) (cmdLoc command)+            ++ concatMap (aggregateFieldNameRule "command field") (cmdFields command)+        eventNames event =+          constructorName "event name" (evName event) (evLoc event)+            ++ case evBody event of+              EventFields fields -> concatMap (aggregateFieldNameRule "event field") fields+              EventFromCommand _ -> []++    processNames process =+      constructorName "process name" (procId process) (procLoc process)+        ++ constructorName "process input name" (inName input) (procLoc process)+        ++ concatMap (\field -> fieldNameRule "process input field" (fieldName field) (procLoc process)) (inFields input)+        ++ concatMap (bindingName "advance field binding" (procLoc process)) (advFields (hAdvance handle))+        ++ concatMap dispatchBindings (hDispatch handle)+        ++ concatMap (bindingName "timer payload field binding" (tmLoc timer)) (tmPayload timer)+        ++ concatMap (bindingName "timer fire field binding" (tmLoc timer)) (fireFields (tmFire timer))+      where+        input = procInput process+        handle = procHandle process+        timer = procTimer process+        dispatchBindings dispatch = concatMap (bindingName "dispatch field binding" (dispLoc dispatch)) (dispFields dispatch)++    routerNames router =+      constructorName "router name" (rtId router) (rtLoc router)+        ++ constructorName "router input name" (inName input) (rtLoc router)+        ++ concatMap (\field -> fieldNameRule "router input field" (fieldName field) (rtLoc router)) (inFields input)+        ++ concatMap (\field -> fieldNameRule "router resolve-row field" field (rvLoc resolve)) (rvRow resolve)+        ++ concatMap (bindingName "router dispatch field binding" (rdLoc dispatch)) (rdFields dispatch)+      where+        input = rtInput router+        resolve = rtResolve router+        dispatch = rtDispatch router++    bindingName category anchor binding = fieldNameRule category (fbName binding) anchor+    contractFieldName = contractFieldNameRule "contract field"++    aggregateFieldNameRule category field =+      case aggregateFieldSelector field of+        Nothing -> fieldNameRule category (aggregateFieldName field) (aggregateFieldLoc field)+        Just selector -> explicitFieldSelectorRule category (aggregateFieldName field) selector (aggregateFieldLoc field)++    contractFieldNameRule category field =+      case cfSelector field of+        Nothing -> fieldNameRule category (cfName field) (cfLoc field)+        Just selector -> explicitFieldSelectorRule category (cfName field) selector (cfLoc field)++    explicitFieldSelectorRule category dslName selector anchor =+      case HaskellName.checkedLowerOccurrence site selector of+        Right _ -> []+        Left nameError -> [nameErrorDiagnostic (category <> " selector") nameError]+      where+        site =+          HaskellName.NameSite+            { HaskellName.siteKind = HaskellName.GeneratedFieldSite,+              HaskellName.siteLogicalName = selector,+              HaskellName.siteOwner = category <> ":" <> dslName,+              HaskellName.siteLine = locLine anchor+            }++    constructorName category name anchor = checkedLogicalName HaskellName.GeneratedTypeSite category name anchor++    workflowNames workflow =+      constructorName "workflow name" (wfId workflow) (workflowNodeLoc workflow)+        <> concat+          [ case HaskellName.deriveLowerHelperName HaskellName.LogicalWireWord "Await" site of+              Right _ -> []+              Left nameError -> [nameErrorDiagnostic "workflow await binding" nameError]+          | (label, loc) <- workflowAwaits (wfBody workflow),+            let site = workflowAwaitBindingSite workflow label loc+          ]++    pascalizedNodeName category name anchor = checkedLogicalName HaskellName.NodeModuleSite (category <> " name") name anchor++    fieldNameRule category name anchor = checkedLogicalName HaskellName.GeneratedFieldSite category name anchor++    checkedLogicalName kind category name anchor =+      case deriveAt HaskellName.LogicalIdentifier kind category name anchor of+        Right _ -> []+        Left nameError -> [nameErrorDiagnostic category nameError]++    deriveAt source kind category name anchor =+      HaskellName.deriveHaskellName source (nameSite kind category name anchor)++    nameSite kind category name anchor =+      HaskellName.NameSite+        { HaskellName.siteKind = kind,+          HaskellName.siteLogicalName = name,+          HaskellName.siteOwner = category <> ":" <> name,+          HaskellName.siteLine = locLine anchor+        }++    nameErrorDiagnostic category = \case+      HaskellName.EmptyNameSegment site ->+        mkErr (HaskellName.siteLine site) IdentUnsafeNormalization $+          category <> " '" <> HaskellName.siteLogicalName site <> "' has an empty generated-Haskell word"+      HaskellName.UnsafeNameSeparator site reason ->+        mkErr (HaskellName.siteLine site) IdentUnsafeNormalization $+          category <> " '" <> HaskellName.siteLogicalName site <> "' cannot be normalized safely: " <> reason+      HaskellName.ReservedGeneratedOccurrence site occurrence ->+        mkErr (HaskellName.siteLine site) GeneratedOccurrenceReserved $+          category <> " '" <> HaskellName.siteLogicalName site <> "' normalizes to reserved Haskell occurrence '" <> occurrence <> "'"+      HaskellName.InvalidExplicitHaskellName site occurrence ->+        mkErr (HaskellName.siteLine site) IdentUnsafeNormalization $+          category <> " '" <> HaskellName.siteLogicalName site <> "' cannot become generated Haskell occurrence '" <> occurrence <> "'"+      collision@HaskellName.NormalizedNameCollision {} -> collisionDiagnostic collision++    normalizedCollisions = map collisionDiagnostic (HaskellName.detectNameCollisions collisionOccurrences)++    collisionOccurrences =+      nodeModuleOccurrences+        <> sharedTypeOccurrences+        <> concatMap aggregateFieldOccurrences aggregates+        <> concatMap aggregateHarnessOccurrences aggregates+        <> concatMap contractFieldOccurrences contracts+        <> concatMap workflowRuntimeOccurrences workflows++    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]+    contracts = [contract | NContract contract <- specNodes spec]+    workflows = [workflow | NWorkflow workflow <- specNodes spec]++    contextSegment =+      case deriveAt HaskellName.LogicalWireWord HaskellName.ContextModuleSite "context" (specContext spec) (Loc 1) of+        Right derived -> HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)+        Left _ -> specContext spec++    nodeModuleOccurrences =+      [ HaskellName.plannedOccurrence contextSegment HaskellName.ModuleSpace "" rendered site+      | node <- specNodes spec,+        let (category, raw, anchor) = nodeNameAndLoc node,+        let site = nameSite HaskellName.NodeModuleSite category raw anchor,+        Right derived <- [HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site],+        let rendered = HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)+      ]++    sharedTypeOccurrences =+      [ HaskellName.plannedOccurrence ("Generated." <> contextSegment <> ".Nominals") HaskellName.TypeSpace "" rendered site+      | (category, raw, anchor) <-+          [("id", idName declaration, idLoc declaration) | declaration <- specIds spec]+            <> [("enum", enumName declaration, enumLoc declaration) | declaration <- specEnums spec]+            <> [("nominal", nominalScalarName declaration, nominalScalarLoc declaration) | declaration <- specNominalScalars spec],+        let site = nameSite HaskellName.GeneratedTypeSite category raw anchor,+        Right derived <- [HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site],+        let rendered = HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)+      ]++    aggregateFieldOccurrences aggregate = commandFields <> eventFields+      where+        targetModule = "Generated." <> contextSegment <> "." <> normalizedUpper "aggregate" (aggName aggregate) (aggLoc aggregate) <> ".Domain"+        commandFields =+          [ fieldOccurrence targetModule (cmdName command) "command field" field+          | command <- aggCommands aggregate,+            field <- cmdFields command+          ]+        eventFields =+          [ fieldOccurrence targetModule (evName event) "event field" field+          | event <- aggEvents aggregate,+            field <- eventFieldsFor aggregate event+          ]++    eventFieldsFor aggregate event =+      case evBody event of+        EventFields fields -> fields+        EventFromCommand commandName ->+          [ field+          | command <- aggCommands aggregate,+            cmdName command == commandName,+            field <- cmdFields command+          ]++    -- The occurrence registered here must be the selector generation actually+    -- emits — 'resolveAggregateFieldIdentity', which falls back to the raw DSL+    -- name, not a camelized rendering of it. Registering the camelized form made+    -- the planner claim `foo_bar` "normalizes to" `fooBar`, which generation+    -- never does, and let two fields that generate distinct selectors be+    -- reported as colliding. A field whose raw name is not lowerCamelCase is+    -- still refused, by the generated-name audit that owns that rule and says so.+    fieldOccurrence targetModule scope category field =+      let identity = resolveAggregateFieldIdentity field+          site = nameSite HaskellName.GeneratedFieldSite category (fieldDslName identity) (aggregateFieldLoc field)+       in HaskellName.plannedOccurrence targetModule HaskellName.FieldSpace scope (fieldSelector identity) site++    aggregateHarnessOccurrences aggregate =+      transitionHelpers <> sampleConstants+      where+        transitionHelpers =+          concat+            [ [helperOccurrence "accept" ("accept" <> commandName) transition]+                <> [helperOccurrence "forward/replay" ("forwardReplay" <> commandName) transition | not (null (tEmits transition))]+            | transition <- aggTransitions aggregate,+              tSource transition == initialState,+              tMode transition == TmLive,+              let commandName = tCommand transition+            ]+        sampleConstants = map idSampleOccurrence generatedIds <> maybe [] (pure . timeSampleOccurrence) timeSample+        resolvedHarnessFields =+          [ (field, resolvedType)+          | (useSite, field) <- harnessFields aggregate,+            Right resolvedType <- [inferAggregateFieldType symbols aggregate useSite field]+          ]+        generatedIds =+          Map.elems . Map.fromList $+            [ (Nominal.resolvedNominalName nominal, nominal)+            | (_, AggregateNominal nominal) <- resolvedHarnessFields,+              Nominal.GeneratedNominal <- [Nominal.resolvedNominalOwnership nominal],+              Nominal.IdRepresentation prefix <- [Nominal.resolvedNominalRepresentation nominal],+              idDomainContractFor languageContract prefix /= Nothing+            ]+        timeFields = [field | (field, AggregateTime) <- resolvedHarnessFields]+        timeSample = case filter ((== "observedAt") . aggregateFieldName) timeFields of+          field : _ -> Just ("sampleObservedAt", field)+          [] -> case timeFields of+            field : _ -> Just ("sampleTime", field)+            [] -> Nothing+        initialState = case aggStates aggregate of+          state : _ -> stName state+          [] -> ""+        symbols = aggregateSymbolsFromGraphResult typeGraphResult spec+        targetModule =+          "Generated."+            <> contextSegment+            <> "."+            <> normalizedUpper "aggregate" (aggName aggregate) (aggLoc aggregate)+            <> ".Harness"+        helperOccurrence helperKind rendered transition =+          HaskellName.plannedOccurrence targetModule HaskellName.ValueSpace "" rendered site+          where+            site =+              HaskellName.NameSite+                { HaskellName.siteKind = HaskellName.GeneratedHelperSite,+                  HaskellName.siteLogicalName = tCommand transition,+                  HaskellName.siteOwner = "aggregate:" <> aggName aggregate <> ":" <> helperKind <> ":line:" <> T.pack (show (locLine (tLoc transition))),+                  HaskellName.siteLine = locLine (tLoc transition)+                }+        idSampleOccurrence nominal =+          HaskellName.plannedOccurrence targetModule HaskellName.ValueSpace "" ("sample" <> nominalName) site+          where+            nominalName = Nominal.resolvedNominalName nominal+            nominalLoc = Nominal.resolvedNominalLoc nominal+            site =+              HaskellName.NameSite+                { HaskellName.siteKind = HaskellName.GeneratedHelperSite,+                  HaskellName.siteLogicalName = nominalName,+                  HaskellName.siteOwner = "aggregate:" <> aggName aggregate <> ":sample-id:" <> nominalName,+                  HaskellName.siteLine = locLine nominalLoc+                }+        timeSampleOccurrence (rendered, field) =+          HaskellName.plannedOccurrence targetModule HaskellName.ValueSpace "" rendered site+          where+            site =+              HaskellName.NameSite+                { HaskellName.siteKind = HaskellName.GeneratedHelperSite,+                  HaskellName.siteLogicalName = aggregateFieldName field,+                  HaskellName.siteOwner = "aggregate:" <> aggName aggregate <> ":sample-time",+                  HaskellName.siteLine = locLine (aggregateFieldLoc field)+                }++    workflowRuntimeOccurrences workflow =+      [ HaskellName.plannedOccurrence targetModule HaskellName.ValueSpace "" rendered site+      | (label, loc) <- workflowAwaits (wfBody workflow),+        let site = workflowAwaitBindingSite workflow label loc,+        Right awaitName <- [HaskellName.deriveLowerHelperName HaskellName.LogicalWireWord "Await" site],+        let rendered = HaskellName.renderLowerCamelName awaitName+      ]+      where+        targetModule =+          "Generated."+            <> contextSegment+            <> "."+            <> normalizedUpper "workflow" (wfId workflow) (workflowNodeLoc workflow)+            <> ".WorkflowRuntime"++    workflowAwaitBindingSite workflow label loc =+      HaskellName.NameSite+        { HaskellName.siteKind = HaskellName.GeneratedValueSite,+          HaskellName.siteLogicalName = label,+          HaskellName.siteOwner = "workflow:" <> wfId workflow <> ":await:" <> label,+          HaskellName.siteLine = locLine loc+        }++    workflowAwaits = concatMap go+      where+        go (WfAwait label _ loc) = [(label, loc)]+        go (WfPatch _ items _) = workflowAwaits items+        go _ = []++    harnessFields aggregate =+      [(CommandFieldUse, field) | command <- aggCommands aggregate, field <- cmdFields command]+        <> [ (EventFieldUse, field)+           | event <- aggEvents aggregate,+             field <- eventFieldsFor aggregate event+           ]++    contractFieldOccurrences contract =+      [ contractFieldOccurrence targetModule (ceName event <> "Data") field+      | event <- ctrEvents contract,+        field <- ceFields event+      ]+      where+        targetModule =+          "Generated."+            <> contextSegment+            <> "."+            <> normalizedUpper "contract" (ctrName contract) (ctrLoc contract)+            <> ".Contract"++    contractFieldOccurrence targetModule scope field =+      let identity = resolveContractFieldIdentity field+          site = nameSite HaskellName.GeneratedFieldSite "contract field" (fieldDslName identity) (fieldLoc identity)+          rendered = case cfSelector field of+            Just selector -> selector+            Nothing -> case HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site of+              Right derived -> HaskellName.renderLowerCamelName (HaskellName.lowerCamel derived)+              Left _ -> fieldSelector identity+       in HaskellName.plannedOccurrence targetModule HaskellName.FieldSpace scope rendered site++    normalizedUpper category raw anchor =+      case deriveAt HaskellName.LogicalIdentifier HaskellName.GeneratedTypeSite category raw anchor of+        Right derived -> HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)+        Left _ -> raw++    nodeNameAndLoc = \case+      NAggregate value -> ("aggregate", aggName value, aggLoc value)+      NProcess value -> ("process", procId value, procLoc value)+      NRouter value -> ("router", rtId value, rtLoc value)+      NContract value -> ("contract", ctrName value, ctrLoc value)+      NIntake value -> ("intake", inkName value, inkLoc value)+      NEmit value -> ("emit", emName value, emLoc value)+      NPublisher value -> ("publisher", pubName value, pubLoc value)+      NWorkqueue value -> ("workqueue", wqName value, wqLoc value)+      NPgmqDispatch value -> ("dispatch", pdName value, pdLoc value)+      NReadModel value -> ("readmodel", rmName value, rmLoc value)+      NProjectionTarget value -> ("target", ptName value, ptLoc value)+      NRebuildGroup value -> ("rebuild-group", rgName value, rgLoc value)+      NProjectionRevision value -> ("projection-revision", prvName value, prvLoc value)+      NExternalRead value -> ("external-read", externalReadNodeIdentity value, erLoc value)+      NProjectionOwner value -> ("projection-owner", poName value, poLoc value)+      NWorkflow value -> ("workflow", wfId value, workflowNodeLoc value)+      NOperation value -> ("operation", opName value, opLoc value)++    collisionDiagnostic (HaskellName.NormalizedNameCollision key sites) =+      case reverse (NE.toList sites) of+        primary : reversedEarlier ->+          Diagnostic+            { line = HaskellName.siteLine primary,+              severity = Error,+              code = GeneratedOccurrenceCollision,+              relatedLocations =+                [ (HaskellName.siteLine site, "'" <> HaskellName.siteLogicalName site <> "' also normalizes here")+                | site <- reverse reversedEarlier+                ],+              message =+                "logical declarations "+                  <> T.intercalate ", " ["'" <> HaskellName.siteLogicalName site <> "'" | site <- NE.toList sites]+                  <> " normalize to the same Haskell occurrence '"+                  <> HaskellName.occurrenceName key+                  <> "' in "+                  <> HaskellName.occurrenceModule key+                  <> " ("+                  <> T.pack (show (HaskellName.occurrenceSpace key))+                  <> ")"+            }+        [] -> mkErr 1 GeneratedOccurrenceCollision "internal error: normalized collision without source sites"+    collisionDiagnostic nameError = nameErrorDiagnostic "generated declaration" nameError++    vertexCollisions aggregate =+      [ mkErr (locLine (aggLoc aggregate)) VertexCtorCollision $+          "aggregate '"+            <> aggName aggregate+            <> "' state '"+            <> stName state+            <> "' generates vertex constructor '"+            <> vertex+            <> "', which collides with "+            <> declarationKind+            <> " '"+            <> vertex+            <> "' in the generated Domain constructor namespace"+      | state <- aggStates aggregate,+        let vertex = normalizedUpper "aggregate" (aggName aggregate) (aggLoc aggregate) <> normalizedUpper "state" (stName state) (stLoc state),+        declarationKind <- collisionKinds aggregate vertex+      ]++    collisionKinds aggregate vertex =+      ["event" | vertex `elem` [normalizedUpper "event" (evName event) (evLoc event) | event <- aggEvents aggregate]]+        ++ ["command" | vertex `elem` [normalizedUpper "command" (cmdName command) (cmdLoc command) | command <- aggCommands aggregate]]+        ++ ["enum constructor" | vertex `elem` [normalizedUpper "enum constructor" ctor (enumLoc enum) | enum <- specEnums spec, (ctor, _) <- enumCtors enum]]++-- Explicit consumer-owned Haskell references keep their spelling and use the+-- historical lexical check. Generated names never call this helper.+constructorSafe :: Name -> Bool+constructorSafe name = case T.uncons name of+  Just (first, rest) -> asciiUpper first && T.all asciiAlphaNumOrUnderscore rest+  Nothing -> False++asciiUpper :: Char -> Bool+asciiUpper c = c >= 'A' && c <= 'Z'++asciiLower :: Char -> Bool+asciiLower c = c >= 'a' && c <= 'z'++asciiAlphaNumOrUnderscore :: Char -> Bool+asciiAlphaNumOrUnderscore c = asciiUpper c || asciiLower c || (c >= '0' && c <= '9') || c == '_'++kafkaTopicError :: Text -> Maybe Text+kafkaTopicError topic+  | T.null topic = Just "is empty"+  | T.length topic > 249 = Just "is longer than Kafka's 249-character limit"+  | topic == "." || topic == ".." = Just "is reserved by Kafka"+  | Just illegal <- T.find (not . kafkaTopicCharacter) topic =+      Just ("contains character " <> T.pack (show illegal) <> "; use only ASCII letters, digits, '.', '_', or '-'")+  | otherwise = Nothing+  where+    kafkaTopicCharacter character = asciiAlphaNumOrUnderscore character || character == '.' || character == '-'++validPostgresIdentifier :: Text -> Bool+validPostgresIdentifier identifier =+  T.length identifier <= 63+    && case T.uncons identifier of+      Nothing -> False+      Just (firstCharacter, rest) ->+        (asciiLower firstCharacter || firstCharacter == '_')+          && T.all (\character -> asciiLower character || (character >= '0' && character <= '9') || character == '_') rest++-- | Rules over namespaces shared by the whole specification.+specLevelRules :: EffectiveLanguageContract -> ProjectionSupplyAnalysis -> Spec -> [Diagnostic]+specLevelRules languageContract supplyAnalysis spec = duplicateNodes ++ duplicateEnumMembers ++ duplicateIdPrefixes ++ duplicateDeclarations ++ runtimeIdentities ++ duplicateRuntimeIdentities ++ catalogRules ++ ruleDiagnostics+  where+    duplicateNodes =+      [ mkErr (locLine loc) DuplicateNodeName $+          "duplicate " <> kind <> " node name '" <> name <> "'"+      | node <- duplicatesBy nodeKey (specNodes spec),+        let (kind, name, loc) = nodeIdentity node+      ]+    nodeKey node = let (kind, name, _) = nodeIdentity node in (kind, name)+    duplicateEnumMembers = concatMap enumDuplicates (specEnums spec)+    enumDuplicates e =+      [ mkErr (locLine (enumLoc e)) DuplicateEnumCtor $+          "enum '" <> enumName e <> "' declares constructor '" <> ctor <> "' more than once"+      | (ctor, _) <- duplicatesBy fst (enumCtors e)+      ]+        ++ [ mkErr (locLine (enumLoc e)) DuplicateEnumWire $+               "enum '" <> enumName e <> "' declares wire spelling '" <> wire <> "' more than once"+           | (_, wire) <- duplicatesBy snd (enumCtors e)+           ]+    duplicateIdPrefixes =+      [ mkErr (locLine (idLoc d)) DuplicateIdPrefix $+          "id '" <> idName d <> "' reuses prefix '" <> idPrefix d <> "'"+      | d <- duplicatesBy idPrefix (specIds spec)+      ]+    duplicateDeclarations =+      [ mkErr (locLine loc) NominalDuplicateDeclaration $+          "duplicate " <> category <> " declaration '" <> name <> "'; the last declaration would silently replace the earlier one"+      | enforcesSpecSurfaceClosures languageContract,+        (category, name, loc) <- duplicatesBy (\(category, name, _) -> (category, name)) declarationOrigins+      ]+    declarationOrigins =+      [("id", idName value, idLoc value) | value <- specIds spec]+        <> [("enum", enumName value, enumLoc value) | value <- specEnums spec]+        <> [("nominal scalar", nominalScalarName value, nominalScalarLoc value) | value <- specNominalScalars spec]+        <> [("mapped", mappedName value, mappedLoc value) | value <- specMapped spec]+        <> [("rule", ruleName value, ruleLoc value) | value <- specRules spec]+    runtimeIdentities =+      [ mkErr (locLine loc) RuntimeIdentityInvalid $+          kind <> " stable identity " <> T.pack (show identity) <> " " <> reason+      | enforcesSpecSurfaceClosures languageContract,+        (kind, identity, loc) <- stableIdentityOrigins,+        Just reason <- [stableIdentityError identity]+      ]+    duplicateRuntimeIdentities =+      [ mkErr (locLine loc) RuntimeIdentityDuplicate $+          kind <> " stable identity " <> T.pack (show identity) <> " is already used by another workflow, process, or router"+      | enforcesSpecSurfaceClosures languageContract,+        (kind, identity, loc) <- duplicatesBy (\(_, identity, _) -> identity) stableIdentityOrigins+      ]+    stableIdentityOrigins =+      [("workflow", wfStable workflow, workflowNodeLoc workflow) | NWorkflow workflow <- specNodes spec]+        <> [("process", procName process, procLoc process) | NProcess process <- specNodes spec]+        <> [("router", rtName router, rtLoc router) | NRouter router <- specNodes spec]+    catalogRules+      | hasProjectionCatalog languageContract = validateProjectionCatalogFleet supplyAnalysis spec+      | otherwise = []+    ruleDiagnostics = concatMap (validateRule spec) (specRules spec)++nodeIdentity :: Node -> (Text, Name, Loc)+nodeIdentity (NAggregate a) = ("aggregate", aggName a, aggLoc a)+nodeIdentity (NProcess p) = ("process", procId p, procLoc p)+nodeIdentity (NRouter r) = ("router", rtId r, rtLoc r)+nodeIdentity (NContract c) = ("contract", ctrName c, ctrLoc c)+nodeIdentity (NIntake i) = ("intake", inkName i, inkLoc i)+nodeIdentity (NEmit e) = ("emit", emName e, emLoc e)+nodeIdentity (NPublisher p) = ("publisher", pubName p, pubLoc p)+nodeIdentity (NWorkqueue w) = ("workqueue", wqName w, wqLoc w)+nodeIdentity (NPgmqDispatch d) = ("dispatch", pdName d, pdLoc d)+nodeIdentity (NReadModel r) = ("readmodel", rmName r, rmLoc r)+nodeIdentity (NProjectionTarget target) = ("target", ptName target, ptLoc target)+nodeIdentity (NRebuildGroup groupNode) = ("rebuild-group", rgName groupNode, rgLoc groupNode)+nodeIdentity (NProjectionRevision revision) = ("projection-revision", prvName revision, prvLoc revision)+nodeIdentity (NExternalRead externalRead) = ("external-read", externalReadNodeIdentity externalRead, erLoc externalRead)+nodeIdentity (NProjectionOwner owner) = ("projection-owner", poName owner, poLoc owner)+nodeIdentity (NWorkflow w) = ("workflow", wfId w, workflowNodeLoc w)+nodeIdentity (NOperation o) = ("operation", opName o, opLoc o)++validateNode :: EffectiveLanguageContract -> Either (NE.NonEmpty TypeGraphError) TypeGraph -> ProjectionSupplyAnalysis -> Spec -> Node -> [Diagnostic]+validateNode languageContract typeGraphResult _supplyAnalysis spec (NAggregate agg) = validateAggregate languageContract typeGraphResult spec agg+validateNode languageContract _typeGraphResult _supplyAnalysis spec (NProcess p) = validateProcess languageContract spec p+validateNode languageContract typeGraphResult _supplyAnalysis spec (NRouter router) = validateRouter languageContract typeGraphResult spec router+validateNode languageContract _typeGraphResult _supplyAnalysis _spec (NContract contract) = validateContract languageContract contract+validateNode languageContract _typeGraphResult _supplyAnalysis spec (NIntake i) = validateIntake languageContract i ++ intakeCoupling languageContract spec i+validateNode languageContract _typeGraphResult _supplyAnalysis spec (NEmit e) = validateEmit languageContract spec e+validateNode languageContract _typeGraphResult _supplyAnalysis spec (NPublisher p) = validatePublisher languageContract spec p+validateNode languageContract _typeGraphResult _supplyAnalysis _spec (NWorkqueue w) = validateWorkqueue languageContract w+validateNode languageContract _typeGraphResult _supplyAnalysis spec (NPgmqDispatch d) = validatePgmqDispatch languageContract spec d+validateNode languageContract _typeGraphResult supplyAnalysis spec (NReadModel readModel) = validateReadModel languageContract supplyAnalysis spec readModel+validateNode languageContract _typeGraphResult _supplyAnalysis _spec (NProjectionTarget target) = validateProjectionTarget languageContract target+validateNode languageContract _typeGraphResult _supplyAnalysis spec (NRebuildGroup groupNode) = validateRebuildGroup languageContract spec groupNode+validateNode languageContract _typeGraphResult _supplyAnalysis spec (NProjectionRevision revision) = validateProjectionRevision languageContract spec revision+validateNode languageContract _typeGraphResult _supplyAnalysis spec (NExternalRead externalRead) = validateExternalRead languageContract spec externalRead+validateNode languageContract _typeGraphResult supplyAnalysis spec (NProjectionOwner owner) = validateProjectionOwner languageContract supplyAnalysis spec owner+validateNode _languageContract _typeGraphResult _supplyAnalysis _spec (NWorkflow w) = validateWorkflow w+validateNode _languageContract _typeGraphResult _supplyAnalysis spec (NOperation o) = validateOperation spec o++validateContract :: EffectiveLanguageContract -> ContractNode -> [Diagnostic]+validateContract languageContract contract =+  emptyContract+    <> typeIdPrefixErrors+    <> schemaVersionFloor+    <> topicNames+    <> duplicateEvents+    <> duplicateTopicAliases+    <> duplicateFields+    <> discriminatorShadows+    <> fieldWireKeyRules+    <> unresolvedTopicAliases+  where+    emptyContract =+      [ mkErr (locLine (ctrLoc contract)) ContractEmpty $+          "contract '"+            <> ctrName contract+            <> "' declares no events; scaffold cannot lower an empty contract -- declare at least one event"+      | null (ctrEvents contract)+      ]+    typeIdPrefixErrors =+      [ mkErr (locLine (cfLoc field)) ContractInvalidTypeIdPrefix $+          "contract '"+            <> ctrName contract+            <> "' event '"+            <> ceName event+            <> "' field '"+            <> cfName field+            <> "' has invalid TypeID prefix '"+            <> prefix+            <> "': "+            <> T.pack (show reason)+      | event <- ctrEvents contract,+        field <- ceFields event,+        CTypeId prefix <- [cfType field],+        Just _ <- [contractIdDomainContractFor languageContract prefix],+        Just reason <- [TypeID.checkPrefix prefix]+      ]+    schemaVersionFloor =+      [ mkErr (locLine (ctrLoc contract)) ContractSchemaVersionBelowMinimum $+          "contract '" <> ctrName contract <> "' schemaVersion must be at least 1"+      | enforcesSpecSurfaceClosures languageContract,+        ctrSchemaVersion contract < 1+      ]+    topicNames =+      [ mkErr (locLine (ctrLoc contract)) ContractTopicNameInvalid $+          "contract '" <> ctrName contract <> "' topic alias '" <> alias <> "' has invalid Kafka topic " <> T.pack (show topic) <> ": " <> reason+      | (alias, topic) <- ctrTopics contract,+        T.null topic || enforcesSpecSurfaceClosures languageContract,+        Just reason <- [kafkaTopicError topic]+      ]+    duplicateEvents =+      [ mkErr (locLine (ctrLoc contract)) ContractDuplicateEvent $+          "contract '" <> ctrName contract <> "' declares event '" <> ceName event <> "' more than once"+      | event <- duplicatesBy ceName (ctrEvents contract)+      ]+    duplicateTopicAliases =+      [ mkErr (locLine (ctrLoc contract)) ContractDuplicateTopicAlias $+          "contract '" <> ctrName contract <> "' declares topic alias '" <> alias <> "' more than once"+      | (alias, _) <- duplicatesBy fst (ctrTopics contract)+      ]+    duplicateFields =+      [ mkErr (locLine (cfLoc field)) ContractDuplicateFieldName $+          "contract '" <> ctrName contract <> "' event '" <> ceName event <> "' declares field '" <> cfName field <> "' more than once"+      | event <- ctrEvents contract,+        field <- duplicatesBy cfName (ceFields event)+      ]+    discriminatorShadows =+      [ mkErr (locLine (cfLoc field)) ContractFieldShadowsDiscriminator $+          "contract '"+            <> ctrName contract+            <> "' event '"+            <> ceName event+            <> "' field '"+            <> cfName field+            <> "' shadows the payload discriminator"+      | enforcesSpecSurfaceClosures languageContract,+        event <- ctrEvents contract,+        field <- ceFields event,+        fieldWireKey (resolveContractFieldIdentity field) == ctrDiscriminator contract+      ]+    fieldWireKeyRules =+      concat+        [ wireKeyRulesForRecord+            ("contract '" <> ctrName contract <> "' event '" <> ceName event <> "'")+            (Just (ctrDiscriminator contract, "payload discriminator"))+            (map resolveContractFieldIdentity (ceFields event))+        | event <- ctrEvents contract+        ]+    unresolvedTopicAliases =+      [ mkErr (locLine (ctrLoc contract)) ContractTopicAliasUnresolved $+          "contract '" <> ctrName contract <> "' event '" <> ceName event <> "' names undeclared topic alias '" <> ceTopic event <> "'"+      | enforcesSpecSurfaceClosures languageContract,+        event <- ctrEvents contract,+        ceTopic event `notElem` map fst (ctrTopics contract)+      ]++-- | Workflow replay keys, patch guards, rotation, and injected inputs must be unambiguous.+validateWorkflow :: WorkflowNode -> [Diagnostic]+validateWorkflow w = duplicateLabels ++ sleepFields ++ patchDuplicates ++ patchIds ++ continuePositions ++ idField+  where+    inputFields = map fieldName (wfInputFields w)+    labelledItems = workflowLabelledItems (wfBody w)+    patchItems = workflowPatchItems (wfBody w)+    duplicateLabels =+      [ mkErr (locLine (wfBodyLoc item)) WorkflowDuplicateLabel $+          "workflow '" <> wfId w <> "' declares label '" <> label <> "' more than once; labels key deterministic replay, so a duplicate label replays the first occurrence's journaled result"+      | (label, item) <- duplicatesBy fst labelledItems+      ]+    sleepFields =+      [ mkErr (locLine loc) WorkflowSleepDelayUnresolved $+          "workflow '" <> wfId w <> "' sleep '" <> label <> "' references undeclared input field '" <> delay <> "'"+      | WfSleep label delay loc <- map snd labelledItems,+        delay `notElem` inputFields+      ]+    patchDuplicates =+      [ mkErr (locLine loc) WorkflowPatchDuplicate $+          "workflow '" <> wfId w <> "' declares patch id '" <> patchId <> "' more than once; patch decisions journal under one stable key"+      | (patchId, _, loc) <- duplicatesBy (\(patchId, _, _) -> patchId) patchItems+      ]+    patchIds =+      [ mkErr (locLine loc) WorkflowPatchIdInvalid $+          "workflow '" <> wfId w <> "' patch id '" <> patchId <> "' contains ':'; the runtime reserves that separator for the patch journal-key prefix"+      | (patchId, _, loc) <- patchItems,+        ":" `T.isInfixOf` patchId+      ]+    continuePositions =+      [ mkErr (locLine loc) WorkflowContinueAsNewNotTerminal $+          "workflow '" <> wfId w <> "' continueAsNew must be the last top-level body item and may not appear inside a patch"+      | (isTopLevelTerminal, loc) <- workflowContinueItems (wfBody w),+        not isTopLevelTerminal+      ]+    idField = case wfIdField w of+      Just field+        | field `notElem` inputFields ->+            [ mkErr (locLine (workflowNodeLoc w)) WorkflowIdFieldUnresolved $+                "workflow '" <> wfId w <> "' derives its id from undeclared input field '" <> field <> "'"+            ]+      _ -> []++wfBodyLoc :: WfBodyItem -> Loc+wfBodyLoc (WfStep _ _ loc) = loc+wfBodyLoc (WfAwait _ _ loc) = loc+wfBodyLoc (WfSleep _ _ loc) = loc+wfBodyLoc (WfChild _ _ _ loc) = loc+wfBodyLoc (WfPatch _ _ loc) = loc+wfBodyLoc (WfContinueAsNew _ loc) = loc++workflowLabelledItems :: [WfBodyItem] -> [(Name, WfBodyItem)]+workflowLabelledItems = concatMap go+  where+    go item@(WfStep label _ _) = [(label, item)]+    go item@(WfAwait label _ _) = [(label, item)]+    go item@(WfSleep label _ _) = [(label, item)]+    go item@(WfChild label _ _ _) = [(label, item)]+    go (WfPatch _ items _) = workflowLabelledItems items+    go WfContinueAsNew {} = []++workflowPatchItems :: [WfBodyItem] -> [(Name, [WfBodyItem], Loc)]+workflowPatchItems = concatMap go+  where+    go (WfPatch patchId items loc) = (patchId, items, loc) : workflowPatchItems items+    go _ = []++-- | Pair every rotation with whether it is the final top-level item.+workflowContinueItems :: [WfBodyItem] -> [(Bool, Loc)]+workflowContinueItems items = topLevel ++ nested+  where+    topLevel =+      [ (index == length items - 1, loc)+      | (index, WfContinueAsNew _ loc) <- zip [0 ..] items+      ]+    nested =+      [ (False, loc)+      | WfPatch _ patchBody _ <- items,+        (_, loc) <- workflowContinueItems patchBody+      ]++-- | A top-level rule is a total, clock-free function over one declared enum.+validateRule :: Spec -> RuleDecl -> [Diagnostic]+validateRule spec rule = case [e | e <- specEnums spec, enumName e == ruleDomain rule] of+  [] ->+    [ mkErr rl RuleDomainUnresolved $+        "rule '" <> ruleName rule <> "' has undeclared enum domain '" <> ruleDomain rule <> "'"+    ]+  (domain : _) -> totality domain ++ unknownCases domain ++ bodyDiagnostics+  where+    rl = locLine (ruleLoc rule)+    caseNames = map fst (ruleCases rule)+    allEnumCtors = Set.fromList [ctor | e <- specEnums spec, (ctor, _) <- enumCtors e]+    totality domain =+      let missing = [ctor | (ctor, _) <- enumCtors domain, ctor `notElem` caseNames]+       in [ mkErr rl RuleNotTotal $+              "rule '" <> ruleName rule <> "' is not total over enum '" <> enumName domain <> "'; missing cases {" <> T.intercalate ", " missing <> "}"+          | not (null missing)+          ]+    unknownCases domain =+      [ mkErr rl RuleCaseUnknownCtor $+          "rule '" <> ruleName rule <> "' has case '" <> ctor <> "' which is not a constructor of enum '" <> enumName domain <> "'"+      | (ctor, _) <- ruleCases rule,+        ctor `notElem` map fst (enumCtors domain)+      ]+    bodyDiagnostics = concatMap validateBody (ruleCases rule)+    validateBody (ctor, expr) =+      [ mkErr rl ClockSampled $+          "rule '" <> ruleName rule <> "' case '" <> ctor <> "' samples the wall clock via '" <> atom <> "'; rules must be deterministic"+      | atom <- dedup (exprNames expr),+        atom `Set.member` clockAtoms+      ]+        ++ [ mkErr rl GuardAtomOutOfScope $+               "atom '" <> atom <> "' in rule '" <> ruleName rule <> "' resolves to no enum constructor or boolean literal"+           | atom <- dedup (exprNames expr),+             atom `Set.notMember` clockAtoms,+             atom `Set.notMember` allEnumCtors+           ]++-- | Operation rules resolve command aggregates, stream fields, projections,+-- read models, workflow signal labels and value types, and run targets.+validateOperation :: Spec -> OperationNode -> [Diagnostic]+validateOperation spec o = case opShape o of+  CommandOp aggregate streamField _ projections ->+    aggregateRef aggregate streamField ++ projectionRefs projections+  QueryOp readModel _ _ consistency ->+    resolveReadModelRef QueryUnresolvedReadModel spec (opLoc o) ("query operation '" <> opName o <> "'") readModel+      ++ [ mkErr ol QueryConsistencyInvalid $+             "query operation '" <> opName o <> "' has unknown consistency '" <> consistency <> "'; expected Strong, Eventual, or PositionWait"+         | consistency `notElem` (["Strong", "Eventual", "PositionWait"] :: [Name])+         ]+  SignalOp lbl wf _ _ valueType ->+    case lookupWorkflow wf of+      Nothing ->+        [mkErr ol AwaitSignalMismatch ("signal operation '" <> opName o <> "' targets undeclared workflow '" <> wf <> "'")]+      Just w -> case [(resultType, loc) | (_, WfAwait label resultType loc) <- workflowLabelledItems (wfBody w), label == lbl] of+        [] ->+          [ mkErr ol AwaitSignalMismatch $+              "signal '" <> lbl <> "' of " <> wf <> " has no matching 'await' (workflow declares awaits {" <> T.intercalate ", " (awaitLabels w) <> "}); the deterministic awakeable id will not match and the workflow will wait forever"+          ]+        ((resultType, _) : _)+          | valueType == resultType -> []+          | otherwise ->+              [ mkErr ol AwaitSignalValueMismatch $+                  "signal '" <> lbl <> "' of " <> wf <> " carries value type '" <> valueType <> "' but the await expects '" <> resultType <> "'"+              ]+  RunOp wf _ _ ->+    [ mkErr ol RunWorkflowUnresolved ("run operation '" <> opName o <> "' targets undeclared workflow '" <> wf <> "'")+    | wf `notElem` map wfId workflows+    ]+  where+    ol = locLine (opLoc o)+    workflows = [w | NWorkflow w <- specNodes spec]+    aggregates = [a | NAggregate a <- specNodes spec]+    projectionTables = [projTable p | a <- aggregates, Just p <- [aggProjection a]]+    lookupWorkflow n = case [w | w <- workflows, wfId w == n] of (w : _) -> Just w; [] -> Nothing+    awaitLabels w = [l | (_, WfAwait l _ _) <- workflowLabelledItems (wfBody w)]+    aggregateRef name streamField = case [a | a <- aggregates, aggName a == name] of+      [] ->+        [ mkErr ol OperationUnresolvedRef $+            "command operation '" <> opName o <> "' targets undeclared aggregate '" <> name <> "'"+        ]+      (aggregate : _) ->+        [ mkErr ol OperationUnresolvedRef $+            "command operation '" <> opName o <> "' stream field '" <> streamField <> "' is not declared by any command of aggregate '" <> name <> "'"+        | streamField `notElem` [aggregateFieldName field | command <- aggCommands aggregate, field <- cmdFields command]+        ]+    projectionRefs projections =+      [ mkErr ol OperationUnresolvedRef $+          "command operation '" <> opName o <> "' references undeclared projection table '" <> projection <> "'"+      | projection <- projections,+        projection `notElem` projectionTables+      ]++-- | Resolve a named read-model node using the caller's diagnostic code.+resolveReadModelRef :: DiagnosticCode -> Spec -> Loc -> Text -> Name -> [Diagnostic]+resolveReadModelRef diagnosticCode spec diagnosticLoc context name =+  [ mkErr (locLine diagnosticLoc) diagnosticCode $+      context <> " references undeclared readmodel '" <> name <> "'"+  | name `notElem` [rmName readModel | NReadModel readModel <- specNodes spec]+  ]++validateProjectionCatalogFleet :: ProjectionSupplyAnalysis -> Spec -> [Diagnostic]+validateProjectionCatalogFleet supplyAnalysis spec = physicalDuplicates <> groupOwnership <> projectionOwnership <> targetDependencies <> handlerOrders <> sourceOrdering <> supplyDiagnostics+  where+    targets = [target | NProjectionTarget target <- specNodes spec]+    groups = [groupNode | NRebuildGroup groupNode <- specNodes spec]+    owners = [owner | NProjectionOwner owner <- specNodes spec]+    physicalDuplicates =+      [ mkErr (locLine (ptLoc target)) CatalogPhysicalTargetDuplicate $+          "target '" <> ptName target <> "' reuses physical table " <> ptSchema target <> "." <> ptTable target+      | target <- duplicatesBy (\target -> (ptSchema target, ptTable target)) targets+      ]+    targetClaims = [(targetName, rgName groupNode, rgLoc groupNode) | groupNode <- groups, targetName <- rgTargets groupNode]+    groupOwnership =+      [ mkErr (locLine (ptLoc target)) CatalogTargetUnowned $+          "target '" <> ptName target <> "' is not owned by any rebuild group"+      | target <- targets,+        null [() | (targetName, _, _) <- targetClaims, targetName == ptName target]+      ]+        <> [ mkErr (locLine claimLoc) CatalogTargetMultiplyOwned $+               "target '" <> targetName <> "' is owned by more than one rebuild group"+           | (targetName, _, claimLoc) <- duplicatesBy (\(targetName, _, _) -> targetName) targetClaims+           ]+    projectionClaims = [(targetName, poName owner, poLoc owner) | owner <- owners, targetName <- poTargets owner]+    projectionOwnership =+      [ mkErr (locLine (ptLoc target)) CatalogTargetUnowned $+          "target '" <> ptName target <> "' has no projection owner"+      | target <- targets,+        null [() | (targetName, _, _) <- projectionClaims, targetName == ptName target]+      ]+        <> [ mkErr (locLine claimLoc) CatalogTargetMultiplyOwned $+               "target '" <> targetName <> "' is claimed by more than one projection owner"+           | (targetName, _, claimLoc) <- duplicatesBy (\(targetName, _, _) -> targetName) projectionClaims+           ]+    groupForTarget = Map.fromList [(targetName, groupName) | (targetName, groupName, _) <- targetClaims]+    targetDependencies =+      [ mkErr (locLine (ptLoc target)) CatalogTargetDependencyUnknown $+          "target '" <> ptName target <> "' depends on undeclared target '" <> dependency <> "'"+      | target <- targets,+        dependency <- ptDependsOn target,+        dependency `notElem` map ptName targets+      ]+        <> [ mkErr (locLine (ptLoc target)) CatalogTargetDependencyOutsideGroup $+               "target '" <> ptName target <> "' depends on target '" <> dependency <> "' in another rebuild group"+           | target <- targets,+             dependency <- ptDependsOn target,+             Just ownerGroup <- [Map.lookup (ptName target) groupForTarget],+             Just dependencyGroup <- [Map.lookup dependency groupForTarget],+             ownerGroup /= dependencyGroup+           ]+        <> [ mkErr (locLine (ptLoc target)) CatalogTargetDependencyCycle $+               "target dependency cycle includes '" <> ptName target <> "'"+           | CyclicSCC cycleTargets <- stronglyConnComp [(target, ptName target, ptDependsOn target) | target <- targets],+             target <- cycleTargets+           ]+    handlerOrders =+      [ mkErr (locLine (poLoc owner)) CatalogDuplicateHandlerOrder $+          "projection owner '" <> poName owner <> "' reuses handler order " <> T.pack (show (poOrder owner)) <> " in group '" <> poGroup owner <> "'"+      | owner <- duplicatesBy (\owner -> (poGroup owner, poOrder owner)) owners+      ]+    sourceOrdering =+      [ Diagnostic+          { line = locLine (rgLoc groupNode),+            severity = Error,+            code = CatalogAmbiguousSourceOrdering,+            relatedLocations =+              [ (locLine (poLoc owner), "projection owner '" <> poName owner <> "' contributes " <> sourceScopeText owner <> " events")+              | owner <- groupOwners+              ],+            message =+              "rebuild group '"+                <> rgName groupNode+                <> "' cannot combine an all-stream source with category-scoped sources; split them into separate rebuild groups"+          }+      | groupNode <- groups,+        let groupOwners = sortOn poName [owner | owner <- owners, poGroup owner == rgName groupNode],+        any ownerUsesAllStreams groupOwners,+        any ownerUsesCategoryScope groupOwners+      ]+    ownerUsesAllStreams owner = CatalogAll `elem` poSources owner+    ownerUsesCategoryScope owner = any isCategoryScope (poSources owner)+    isCategoryScope CatalogAll = False+    isCategoryScope CatalogCategory {} = True+    isCategoryScope CatalogAggregate {} = True+    sourceScopeText owner+      | ownerUsesAllStreams owner = "all-stream"+      | otherwise = "category-scoped"+    supplyDiagnostics = concatMap projectionSupplyIssueDiagnostics (projectionSupplyIssues supplyAnalysis)++projectionSupplyIssueDiagnostics :: ProjectionSupplyIssue -> [Diagnostic]+projectionSupplyIssueDiagnostics = \case+  SupplyObservedTargetsEmpty readModel ->+    [ mkErr (locLine (rmLoc readModel)) CatalogReadModelBindingMissing $+        "readmodel '" <> rmName readModel <> "' must observe at least one target in its projection catalog group"+    ]+  SupplyObservedTargetUnknown readModel targetName ->+    [ mkErr (locLine (rmLoc readModel)) CatalogTargetUnknown $+        "readmodel '" <> rmName readModel <> "' observes undeclared target '" <> targetName <> "'"+    ]+  SupplyObservedTargetOutsideGroup readModel targetName ->+    [ mkErr (locLine (rmLoc readModel)) CatalogReadModelTargetOutsideGroup $+        "readmodel '" <> rmName readModel <> "' observes target '" <> targetName <> "' outside its bound group"+    ]+  SupplyObservedTargetWithoutOwner _ _ -> []+  SupplyObservedTargetWithMultipleOwners _ _ _ -> []+  SupplyOwnerGroupMismatch _ _ _ -> []+  SupplyQueryWithoutOwner readModel ->+    [ mkErr (locLine (rmLoc readModel)) CatalogReadModelSupplierMissing $+        "readmodel '" <> rmName readModel <> "' does not resolve to one projection owner through its observed targets"+    ]+  SupplyQueryWithMultipleOwners readModel owners ->+    [ Diagnostic+        { line = locLine (rmLoc readModel),+          severity = Error,+          code = CatalogReadModelMultipleSuppliers,+          relatedLocations =+            [ (locLine (poLoc owner), "projection owner '" <> poName owner <> "' supplies part of the observed target set")+            | owner <- sortOn poName owners+            ],+          message =+            "readmodel '"+              <> rmName readModel+              <> "' spans several projection owners ("+              <> T.intercalate ", " (map poName (sortOn poName owners))+              <> "); split the query or declare one owner for the complete observed target set"+        }+    ]+  SupplyLegacyProjectionConflict readModel aggregate projection ->+    [ Diagnostic+        { line = locLine (rmLoc readModel),+          severity = Error,+          code = CatalogReadModelLegacyProjectionConflict,+          relatedLocations =+            [ ( locLine (projLoc projection),+                "aggregate '" <> aggName aggregate <> "' also names this readmodel in its legacy projection clause"+              )+            ],+          message =+            "catalog-bound readmodel '"+              <> rmName readModel+              <> "' derives its supplier from projection-owner target ownership; remove the legacy aggregate projection clause"+        }+    ]++validateProjectionTarget :: EffectiveLanguageContract -> ProjectionTargetNode -> [Diagnostic]+validateProjectionTarget languageContract target =+  [ mkErr (locLine (ptLoc target)) ReadModelIdentifierInvalid $+      "target '" <> ptName target <> "' " <> kind <> " " <> T.pack (show identifier) <> " is not a PostgreSQL unquoted identifier"+  | hasProjectionCatalog languageContract,+    (kind, identifier) <- [("schema", ptSchema target), ("table", ptTable target)],+    not (validPostgresIdentifier identifier)+  ]++validateRebuildGroup :: EffectiveLanguageContract -> Spec -> RebuildGroupNode -> [Diagnostic]+validateRebuildGroup languageContract spec groupNode+  | not (hasProjectionCatalog languageContract) = []+  | otherwise = emptyTargets <> unknownTargets <> invalidOrder+  where+    targetNames = [ptName target | NProjectionTarget target <- specNodes spec]+    emptyTargets =+      [ mkErr (locLine (rgLoc groupNode)) CatalogGroupEmpty $+          "rebuild group '" <> rgName groupNode <> "' must own at least one target"+      | null (rgTargets groupNode)+      ]+    unknownTargets =+      [ mkErr (locLine (rgLoc groupNode)) CatalogTargetUnknown $+          "rebuild group '" <> rgName groupNode <> "' references undeclared target '" <> targetName <> "'"+      | targetName <- rgTargets groupNode,+        targetName `notElem` targetNames+      ]+    invalidOrder =+      [ mkErr (locLine (rgLoc groupNode)) CatalogGroupOrderMismatch $+          "rebuild group '" <> rgName groupNode <> "' order must contain each owned target exactly once"+      | Set.fromList (rgOrder groupNode) /= Set.fromList (rgTargets groupNode)+          || length (rgOrder groupNode) /= Set.size (Set.fromList (rgOrder groupNode))+          || length (rgTargets groupNode) /= Set.size (Set.fromList (rgTargets groupNode))+      ]++validateProjectionRevision :: EffectiveLanguageContract -> Spec -> ProjectionRevisionNode -> [Diagnostic]+validateProjectionRevision languageContract spec revisionNode+  | not (hasProjectionCatalog languageContract) = []+  | otherwise = noTargets <> unknownGroup <> unknownTargets <> duplicateTargets <> targetSetMismatch <> invalidIdentities <> invalidPromotionNames+  where+    declaredTargets = [ptName target | NProjectionTarget target <- specNodes spec]+    matchingGroups = [groupNode | NRebuildGroup groupNode <- specNodes spec, rgName groupNode == prvGroup revisionNode]+    revisionTargets = prvTargets revisionNode+    revisionTargetNames = map prtTarget revisionTargets+    noTargets =+      [ mkErr (locLine (prvLoc revisionNode)) CatalogRevisionNoTarget $+          "projection revision '" <> prvName revisionNode <> "' must declare every target in its rebuild group"+      | null revisionTargets+      ]+    unknownGroup =+      [ mkErr (locLine (prvLoc revisionNode)) CatalogRevisionGroupUnknown $+          "projection revision '" <> prvName revisionNode <> "' references undeclared rebuild group '" <> prvGroup revisionNode <> "'"+      | null matchingGroups+      ]+    unknownTargets =+      [ mkErr (locLine (prvLoc revisionNode)) CatalogRevisionTargetUnknown $+          "projection revision '" <> prvName revisionNode <> "' references undeclared target '" <> prtTarget revisionTarget <> "'"+      | revisionTarget <- revisionTargets,+        prtTarget revisionTarget `notElem` declaredTargets+      ]+    duplicateTargets =+      [ mkErr (locLine (prvLoc revisionNode)) CatalogRevisionDuplicateTarget $+          "projection revision '" <> prvName revisionNode <> "' declares target '" <> targetName <> "' more than once"+      | targetName <- duplicatesBy id revisionTargetNames+      ]+    targetSetMismatch =+      [ mkErr (locLine (prvLoc revisionNode)) CatalogRevisionTargetSetMismatch $+          "projection revision '" <> prvName revisionNode <> "' target set must equal rebuild group '" <> prvGroup revisionNode <> "'"+      | groupNode : _ <- [matchingGroups],+        Set.fromList revisionTargetNames /= Set.fromList (rgTargets groupNode)+          || length revisionTargetNames /= Set.size (Set.fromList revisionTargetNames)+      ]+    invalidIdentities =+      [ mkErr (locLine (prvLoc revisionNode)) CatalogRevisionIdentityInvalid $+          "projection revision '" <> prvName revisionNode <> "' target '" <> prtTarget revisionTarget <> "' has invalid " <> identityKind <> " identity/version"+      | revisionTarget <- revisionTargets,+        (identityKind, identity, version) <-+          [ ("schema", prtSchemaVersion revisionTarget, 1),+            ("provisioner", prtProvisioner revisionTarget, prtProvisionerVersion revisionTarget),+            ("expected-shape", prtExpectedShape revisionTarget, 1),+            ("validator", prtValidator revisionTarget, prtValidatorVersion revisionTarget)+          ],+        T.null identity || T.strip identity /= identity || version <= 0+      ]+    invalidPromotionNames =+      [ mkErr (locLine (prvLoc revisionNode)) CatalogRevisionPromotionNameInvalid $+          "projection revision '" <> prvName revisionNode <> "' target '" <> prtTarget revisionTarget <> "' promotion names must be valid, unique PostgreSQL identifiers"+      | revisionTarget <- revisionTargets,+        let objects = prtPromotionObjects revisionTarget+            names = concat [[rpoGenerationName object, rpoCanonicalName object] | object <- objects],+        any (not . validPostgresIdentifier) names+          || length names /= Set.size (Set.fromList names)+      ]++validateExternalRead :: EffectiveLanguageContract -> Spec -> ExternalReadNode -> [Diagnostic]+validateExternalRead languageContract spec externalRead+  | not (hasProjectionCatalog languageContract) = []+  | otherwise =+      invalidIdentity+        <> invalidVersion+        <> unknownQuery+        <> invalidTargetCardinality+        <> invalidCompatibility+        <> unknownRevisions+        <> revisionGroupMismatch+        <> invalidSurfaceGeneration+  where+    diagnosticLine = locLine (erLoc externalRead)+    readModels = [readModel | NReadModel readModel <- specNodes spec]+    revisions = [revision | NProjectionRevision revision <- specNodes spec]+    matchingReadModels = [readModel | readModel <- readModels, rmName readModel == erQueryModel externalRead]+    matchingGroup = case matchingReadModels of+      readModel : _ -> rmGroup readModel+      [] -> Nothing+    invalidIdentity =+      [ mkErr diagnosticLine CatalogExternalReadIdentityInvalid $+          "external-read '"+            <> erName externalRead+            <> "' requires lower-case PostgreSQL identifiers for its contract, result schema, and result type"+      | any+          (not . validPostgresIdentifier)+          [erName externalRead, erResultSchema externalRead, erResultType externalRead]+      ]+    invalidVersion =+      [ mkErr diagnosticLine CatalogExternalReadVersionInvalid $+          "external-read '" <> erName externalRead <> "' version must be at least 1"+      | erVersion externalRead <= 0+      ]+    unknownQuery =+      [ mkErr diagnosticLine CatalogExternalReadQueryUnknown $+          "external-read '" <> erName externalRead <> "' references undeclared readmodel '" <> erQueryModel externalRead <> "'"+      | null matchingReadModels+      ]+    invalidTargetCardinality =+      [ mkErr diagnosticLine CatalogExternalReadTargetCardinalityInvalid $+          "external-read '"+            <> erName externalRead+            <> "' is the bounded all-row form and its readmodel must observe exactly one target"+      | readModel <- take 1 matchingReadModels,+        length (rmObservedTargets readModel) /= 1+      ]+    compatibleRevisions = erCompatibleRevisions externalRead+    invalidCompatibility =+      [ mkErr diagnosticLine CatalogExternalReadCompatibilityInvalid $+          "external-read '" <> erName externalRead <> "' must name at least one compatible projection revision without duplicates"+      | null compatibleRevisions+          || length compatibleRevisions /= Set.size (Set.fromList compatibleRevisions)+      ]+    unknownRevisions =+      [ mkErr diagnosticLine CatalogExternalReadRevisionUnknown $+          "external-read '" <> erName externalRead <> "' references undeclared projection revision '" <> revisionName <> "'"+      | revisionName <- compatibleRevisions,+        revisionName `notElem` map prvName revisions+      ]+    revisionGroupMismatch =+      [ mkErr diagnosticLine CatalogExternalReadRevisionGroupMismatch $+          "external-read '"+            <> erName externalRead+            <> "' binds readmodel group '"+            <> queryGroup+            <> "' but compatible revision '"+            <> revisionName+            <> "' belongs to group '"+            <> prvGroup revision+            <> "'"+      | Just queryGroup <- [matchingGroup],+        revisionName <- compatibleRevisions,+        revision <- revisions,+        prvName revision == revisionName,+        prvGroup revision /= queryGroup+      ]+    invalidSurfaceGeneration =+      [ mkErr diagnosticLine CatalogExternalReadSurfaceGenerationInvalid $+          "external-read '" <> erName externalRead <> "' surface-generation must be at least 1"+      | erSurfaceGeneration externalRead <= 0+      ]++validateProjectionOwner :: EffectiveLanguageContract -> ProjectionSupplyAnalysis -> Spec -> ProjectionOwnerNode -> [Diagnostic]+validateProjectionOwner languageContract supplyAnalysis spec owner+  | not (hasProjectionCatalog languageContract) = []+  | otherwise = noSources <> noTargets <> unknownGroup <> outsideGroup <> sourceRules <> identityRules <> checkpointRules <> asyncQueryBinding <> replayRules+  where+    groups = [groupNode | NRebuildGroup groupNode <- specNodes spec]+    targets = [target | NProjectionTarget target <- specNodes spec]+    aggregates = [aggName aggregate | NAggregate aggregate <- specNodes spec]+    selectedGroupTargets = case [rgTargets groupNode | groupNode <- groups, rgName groupNode == poGroup owner] of+      groupTargets : _ -> groupTargets+      [] -> []+    noSources =+      [mkErr (locLine (poLoc owner)) CatalogProjectionNoSource ("projection owner '" <> poName owner <> "' must declare at least one source") | null (poSources owner)]+    noTargets =+      [mkErr (locLine (poLoc owner)) CatalogProjectionNoTarget ("projection owner '" <> poName owner <> "' must declare at least one target") | null (poTargets owner)]+    unknownGroup =+      [ mkErr (locLine (poLoc owner)) CatalogGroupUnknown $+          "projection owner '" <> poName owner <> "' references undeclared rebuild group '" <> poGroup owner <> "'"+      | poGroup owner `notElem` map rgName groups+      ]+    outsideGroup =+      [ mkErr (locLine (poLoc owner)) CatalogProjectionTargetOutsideGroup $+          "projection owner '" <> poName owner <> "' writes target '" <> targetName <> "' outside group '" <> poGroup owner <> "'"+      | targetName <- poTargets owner,+        targetName `notElem` selectedGroupTargets+      ]+    sourceRules =+      [ mkErr (locLine (poLoc owner)) CatalogSourceUnresolved $+          "projection owner '" <> poName owner <> "' references undeclared aggregate source '" <> aggregateName <> "'"+      | CatalogAggregate aggregateName <- poSources owner,+        aggregateName `notElem` aggregates+      ]+        <> [ mkErr (locLine (poLoc owner)) CatalogSourceOverlap $+               "projection owner '" <> poName owner <> "' must select exactly one typed replay source; split independent sources into separate owners"+           | length (poSources owner) > 1+           ]+        <> [ mkErr (locLine (poLoc owner)) RuntimeIdentityInvalid $+               "projection owner '" <> poName owner <> "' category source " <> T.pack (show categoryName) <> " " <> reason+           | CatalogCategory categoryName <- poSources owner,+             Just reason <- [runtimeIdentityError False categoryName]+           ]+    identityRules = case poDelivery owner of+      DeliverySubscription ->+        [ mkErr (locLine (poLoc owner)) CatalogAsyncIdentityMissing $+            "projection owner '" <> poName owner <> "' with subscription delivery requires both subscription and dedup identities"+        | poSubscription owner == Nothing || poDedup owner == Nothing+        ]+      DeliveryInline ->+        [ mkErr (locLine (poLoc owner)) CatalogInlineIdentityUnexpected $+            "projection owner '" <> poName owner <> "' with inline delivery cannot declare subscription or dedup identities"+        | poSubscription owner /= Nothing || poDedup owner /= Nothing+        ]+    checkpointRules = case poDelivery owner of+      DeliverySubscription ->+        [ mkErr (locLine (poLoc owner)) CatalogCheckpointPolicyMissing $+            "projection owner '" <> poName owner <> "' with subscription delivery requires exactly one checkpoint-on-missing policy"+        | null (poCheckpointOnMissing owner)+        ]+          <> [ mkErr (locLine (poLoc owner)) CatalogCheckpointPolicyDuplicate $+                 "projection owner '" <> poName owner <> "' declares checkpoint-on-missing more than once; choose exactly one of from-beginning, from-current-head, or fail"+             | length (poCheckpointOnMissing owner) > 1+             ]+      DeliveryInline ->+        [ mkErr (locLine (poLoc owner)) CatalogCheckpointPolicyUnexpected $+            "projection owner '" <> poName owner <> "' with inline delivery cannot declare checkpoint-on-missing because inline delivery has no durable subscription checkpoint"+        | not (null (poCheckpointOnMissing owner))+        ]+    asyncQueryBinding =+      [ mkErr (locLine (poLoc owner)) CatalogAsyncQueryBindingMissing $+          "projection owner '" <> poName owner <> "' has no query model in group '" <> poGroup owner <> "' observing one of its targets"+      | poDelivery owner == DeliverySubscription,+        null+          [ ()+          | supply <- resolvedProjectionSupplies supplyAnalysis,+            supplyProjectionOwner supply == poName owner+          ]+      ]+    replayRules =+      [ mkErr (locLine (poLoc owner)) CatalogClearTargetLiveOnly $+          "projection owner '" <> poName owner <> "' is live-only but writes a clear-before-replay target"+      | ProjectionLiveOnly _ <- [poReplay owner],+        target <- targets,+        ptName target `elem` poTargets owner,+        ptReset target == TargetClear+      ]+        <> [ mkErr (locLine (poLoc owner)) CatalogCheckpointPolicyReplayUnsafe $+               "projection owner '" <> poName owner <> "' uses from-current-head for subscription '" <> fromMaybe "" (poSubscription owner) <> "' while replayable target '" <> ptName target <> "' is cleared before replay; use from-beginning or fail"+           | poDelivery owner == DeliverySubscription,+             poCheckpointOnMissing owner == [CheckpointFromCurrentHead],+             poReplay owner == ProjectionReplayExplicit,+             target <- targets,+             ptName target `elem` poTargets owner,+             ptReset target == TargetClear+           ]++-- | Validate captured identity, feed semantics, and the declared column surface.+validateReadModel :: EffectiveLanguageContract -> ProjectionSupplyAnalysis -> Spec -> ReadModelNode -> [Diagnostic]+validateReadModel languageContract supplyAnalysis spec readModel =+  shapeFixture ++ columnTypes ++ strongFeed ++ scopeMode ++ inlineSubscription ++ inlineReference ++ freshnessCapability ++ versionFloor ++ identifiers ++ runtimeIdentities ++ duplicateColumns ++ catalogBinding+  where+    readModelLine = locLine (rmLoc readModel)+    expectedShape = deriveShapeHash readModel+    shapeFixture =+      [ mkErr readModelLine RmShapeHashDrift $+          "readmodel '"+            <> rmName readModel+            <> "': captured shape \""+            <> rmShape readModel+            <> "\" does not match the declared columns (expected \""+            <> expectedShape+            <> "\"); update the fixture AND bump version if the table shape really changed"+      | rmShape readModel /= expectedShape+      ]+    allowedColumnTypes = Set.fromList ["text", "int", "bigint", "bool", "timestamptz", "jsonb", "numeric"]+    columnTypes =+      [ mkErr readModelLine RmUnknownColumnType $+          "readmodel '" <> rmName readModel <> "' column '" <> rmcName columnDecl <> "' has unknown type '" <> rmcType columnDecl <> "'"+      | columnDecl <- rmColumns readModel,+        rmcType columnDecl `Set.notMember` allowedColumnTypes+      ]+    strongFeed =+      [ mkErr readModelLine RmStrongInlineOnly $+          "readmodel '"+            <> rmName readModel+            <> "': consistency = Strong with feed = inline; an inline-only model has no subscription worker to advance the cursor a Strong read waits on. Use consistency = Eventual, or feed = subscription"+      | legacyReadModelFeed readModel == Just RmInline,+        legacyReadModelConsistency readModel == Just Strong+      ]+    scopeMode =+      [ mkErr readModelLine RmScopeWithoutStrong $+          "readmodel '" <> rmName readModel <> "': scope is meaningful only with consistency = Strong"+      | legacyReadModelScope readModel /= Nothing,+        legacyReadModelConsistency readModel /= Just Strong+      ]+    inlineSubscription =+      [ Diagnostic+          { line = readModelLine,+            severity = Warning,+            code = RmInlineSubscriptionIgnored,+            relatedLocations = [],+            message = "readmodel '" <> rmName readModel <> "': subscription override is ignored when feed = inline; remove it or select feed = subscription"+          }+      | legacyReadModelFeed readModel == Just RmInline,+        legacyReadModelSubscription readModel /= Nothing+      ]+    inlineReference+      | hasProjectionCatalog languageContract,+        rmGroup readModel /= Nothing =+          []+      | otherwise =+          [ mkErr readModelLine RmInlineFeedUnreferenced $+              "readmodel '" <> rmName readModel <> "' declares feed = inline but no aggregate projection references it"+          | legacyReadModelFeed readModel == Just RmInline,+            rmName readModel `notElem` [projTable projection | NAggregate aggregate <- specNodes spec, Just projection <- [aggProjection aggregate]]+          ]+    freshnessCapability+      | not (hasSeparatedProjectionQueryPolicy languageContract) = []+      | otherwise = case rmFreshness readModel of+          FreshnessImmediate -> []+          requested@(FreshnessWaitForHead requestedScope) ->+            case resolvedOwner of+              Nothing+                | not (null implicitProjectionOwners) ->+                    [ waitError+                        CatalogQueryWaitWithoutCompatibleCursor+                        requested+                        "implicit aggregate projection"+                        "inline"+                        []+                        "move the projection into a subscription projection-owner or use freshness = immediate"+                    ]+                | otherwise -> []+              Just owner ->+                case compatibleCursorCandidates requestedScope owner of+                  [] ->+                    [ waitError+                        CatalogQueryWaitWithoutCompatibleCursor+                        requested+                        ("projection-owner '" <> poName owner <> "'")+                        (deliveryText (poDelivery owner))+                        (allCursorCandidates owner)+                        "use freshness = immediate or give the supplying owner one compatible subscription cursor"+                    ]+                  [_] -> []+                  candidates ->+                    [ waitError+                        CatalogQueryWaitWithAmbiguousCursor+                        requested+                        ("projection-owner '" <> poName owner <> "'")+                        (deliveryText (poDelivery owner))+                        candidates+                        "leave exactly one compatible subscription cursor or use freshness = immediate"+                    ]+      where+        resolvedOwner = do+          ownerName <- case [ supplyProjectionOwner supply+                            | supply <- resolvedProjectionSupplies supplyAnalysis,+                              supplyQueryModel supply == rmName readModel+                            ] of+            [name] -> Just name+            _ -> Nothing+          case [owner | NProjectionOwner owner <- specNodes spec, poName owner == ownerName] of+            [owner] -> Just owner+            _ -> Nothing+        implicitProjectionOwners =+          [ aggregate+          | NAggregate aggregate <- specNodes spec,+            Just projection <- [aggProjection aggregate],+            projTable projection == rmName readModel+          ]+        compatibleCursorCandidates scope owner+          | poDelivery owner /= DeliverySubscription = []+          | not (any (sourceReaches scope) (poSources owner)) = []+          | otherwise = allCursorCandidates owner+        allCursorCandidates owner = case poSubscription owner of+          Just subscription -> [subscription]+          Nothing -> []+        sourceReaches RmEntireLog CatalogAll = True+        sourceReaches RmEntireLog _ = False+        sourceReaches (RmCategory _) CatalogAll = True+        sourceReaches (RmCategory wanted) (CatalogCategory actual) = wanted == actual+        sourceReaches (RmCategory wanted) (CatalogAggregate aggregateName) = wanted == lowerInitial aggregateName+        lowerInitial value = case T.uncons value of+          Nothing -> value+          Just (first, rest) -> T.cons (toLower first) rest+        deliveryText DeliveryInline = "inline"+        deliveryText DeliverySubscription = "subscription"+        freshnessText FreshnessImmediate = "immediate"+        freshnessText (FreshnessWaitForHead RmEntireLog) = "wait-for-head entire-log"+        freshnessText (FreshnessWaitForHead (RmCategory category)) = "wait-for-head category " <> T.pack (show category)+        waitError diagnosticCode requested ownerText delivery candidates remedy =+          mkErr readModelLine diagnosticCode $+            "readmodel '"+              <> rmName readModel+              <> "' requests "+              <> freshnessText requested+              <> " but its supplying "+              <> ownerText+              <> " has delivery capabilities "+              <> delivery+              <> " and compatible cursor candidates "+              <> (if null candidates then "none" else T.intercalate ", " (sortOn id candidates))+              <> "; remedy: "+              <> remedy+    versionFloor =+      [ mkErr readModelLine ReadModelVersionBelowMinimum $+          "readmodel '" <> rmName readModel <> "' version must be at least 1"+      | enforcesSpecSurfaceClosures languageContract,+        rmVersion readModel < 1+      ]+    identifiers =+      [ mkErr readModelLine ReadModelIdentifierInvalid $+          "readmodel '" <> rmName readModel <> "' " <> kind <> " " <> T.pack (show identifier) <> " is not a PostgreSQL unquoted identifier"+      | enforcesSpecSurfaceClosures languageContract,+        (kind, identifier) <-+          [ (kind, identifier)+          | rmGroup readModel == Nothing,+            (kind, identifier) <- [("schema", rmSchema readModel), ("table", rmTable readModel)]+          ]+            <> [("column", rmcName columnDecl) | columnDecl <- rmColumns readModel],+        not (validPostgresIdentifier identifier)+      ]+    runtimeIdentities =+      [ mkErr readModelLine RuntimeIdentityInvalid $+          "readmodel '" <> rmName readModel <> "' subscription " <> T.pack (show subscription) <> " " <> reason+      | enforcesSpecSurfaceClosures languageContract,+        Just subscription <- [legacyReadModelSubscription readModel],+        Just reason <- [stableIdentityError subscription]+      ]+        ++ [ mkErr readModelLine RuntimeIdentityInvalid $+               "readmodel '" <> rmName readModel <> "' scope category " <> T.pack (show category) <> " " <> reason+           | enforcesSpecSurfaceClosures languageContract,+             Just (RmCategory category) <- [readModelScopeForIdentity readModel],+             Just reason <- [runtimeIdentityError False category]+           ]+    readModelScopeForIdentity model = case rmSupply model of+      LegacyReadModelSupply {legacyScope} -> legacyScope+      OwnerDerivedSupply -> case rmFreshness model of+        FreshnessImmediate -> Nothing+        FreshnessWaitForHead scope -> Just scope+    duplicateColumns =+      [ mkErr readModelLine ReadModelDuplicateColumn $+          "readmodel '" <> rmName readModel <> "' declares column '" <> rmcName columnDecl <> "' more than once"+      | enforcesSpecSurfaceClosures languageContract,+        columnDecl <- duplicatesBy rmcName (rmColumns readModel)+      ]+    catalogBinding+      | not (hasProjectionCatalog languageContract) = []+      | otherwise = missingGroup <> unknownGroup <> physicalOverride <> backingRequired <> backingUnobserved+      where+        groups = [groupNode | NRebuildGroup groupNode <- specNodes spec]+        missingGroup =+          [ mkErr readModelLine CatalogReadModelBindingMissing $+              "readmodel '" <> rmName readModel <> "' must bind to a projection catalog group or be referenced by one legacy aggregate projection"+          | rmGroup readModel == Nothing,+            null+              [ ()+              | NAggregate aggregate <- specNodes spec,+                Just projection <- [aggProjection aggregate],+                projTable projection == rmName readModel+              ]+          ]+        unknownGroup =+          [ mkErr readModelLine CatalogGroupUnknown $+              "readmodel '" <> rmName readModel <> "' references undeclared rebuild group '" <> groupName <> "'"+          | Just groupName <- [rmGroup readModel],+            groupName `notElem` map rgName groups+          ]+        physicalOverride =+          [ mkErr readModelLine CatalogReadModelPhysicalOverride $+              "readmodel '"+                <> rmName readModel+                <> "' binds to group '"+                <> groupName+                <> "' but declares explicit table/schema; physical coordinates belong to the target declaration — remove table/schema and name the intended target in 'targets' (and 'backing' when observing several)"+          | Just groupName <- [rmGroup readModel],+            rmTable readModel /= "" || rmSchema readModel /= ""+          ]+        backingRequired =+          [ mkErr readModelLine CatalogReadModelBackingRequired $+              "readmodel '"+                <> rmName readModel+                <> "' observes "+                <> T.pack (show (length (rmObservedTargets readModel)))+                <> " targets; name the physical backing target with 'backing = <target>'"+          | rmGroup readModel /= Nothing,+            length (rmObservedTargets readModel) > 1,+            rmBackingTarget readModel == Nothing+          ]+        backingUnobserved =+          [ mkErr readModelLine CatalogReadModelBackingUnobserved $+              "readmodel '"+                <> rmName readModel+                <> "' names backing target '"+                <> backingTarget+                <> "' but does not observe it"+          | Just backingTarget <- [rmBackingTarget readModel],+            backingTarget `notElem` rmObservedTargets readModel+          ]++-- | EP-5 workqueue rules: the captured physical name must match the queueRef+-- derivation; the disposition inversions (storeFailure transient => must retry;+-- decodeFailure poison => must dead-letter); and dlq=on requires a retry ceiling.+validateWorkqueue :: EffectiveLanguageContract -> WorkqueueNode -> [Diagnostic]+validateWorkqueue languageContract w = concat [divergence, completeness, duplicateRows, inversions, retryCeiling, orderingRules, groupKeyRules, payloadTypes, windows, provisionRules]+  where+    wl = locLine (wqLoc w)+    rows = wqDisposition w+    (derivedPhysical, derivedDlq, derivedTable) = derivedQueueTrio (wqLogical w)+    divergence =+      [ mkErr wl WqPhysicalDivergence $+          "workqueue '" <> wqName w <> "': captured physical \"" <> wqPhysical w <> "\" diverges from queueRef(\"" <> wqLogical w <> "\") = \"" <> derivedPhysical <> "\""+      | wqPhysical w /= derivedPhysical+      ]+        ++ [ mkErr wl WqDlqDivergence $+               "workqueue '" <> wqName w <> "': captured dlq \"" <> wqDlq w <> "\" diverges from queueRef = \"" <> derivedDlq <> "\""+           | wqDlq w /= derivedDlq+           ]+        ++ [ mkErr wl WqTableDivergence $+               "workqueue '" <> wqName w <> "': captured table \"" <> wqTable w <> "\" diverges from queueRef table = \"" <> derivedTable <> "\""+           | wqTable w /= derivedTable+           ]+    requiredOutcomes = ["storeFailure", "commandRejected", "decodeFailure", "onCodecReject"]+    completeness =+      [ mkErr wl WqDispositionIncomplete $+          "workqueue '" <> wqName w <> "' disposition table is missing outcome '" <> outcome <> "'"+      | outcome <- requiredOutcomes,+        outcome `notElem` map wqdOutcome rows+      ]+    duplicateRows =+      [ mkErr (locLine (wqdLoc row)) DispositionDuplicateOutcome $+          "workqueue '" <> wqName w <> "' repeats disposition outcome '" <> wqdOutcome row <> "'; the first row would shadow this row"+      | row <- duplicatesBy wqdOutcome rows+      ]+    firstRow outcome = case [row | row <- rows, wqdOutcome row == outcome] of+      (row : _) -> Just row+      [] -> Nothing+    isRetry row = case wqdAction row of IRetry _ -> True; _ -> False+    isDeadLetter row = case wqdAction row of IDeadLetter _ -> True; _ -> False+    inversions =+      [ mkErr (locLine (wqdLoc row)) WqStoreFailureNotRetry ("workqueue '" <> wqName w <> "': 'storeFailure' is transient and MUST retry, not dead-letter")+      | Just row <- [firstRow "storeFailure"],+        isDeadLetter row+      ]+        ++ [ mkErr (locLine (wqdLoc row)) WqDecodeFailureNotDeadLetter ("workqueue '" <> wqName w <> "': 'decodeFailure' is poison and MUST dead-letter, not retry")+           | Just row <- [firstRow "decodeFailure"],+             isRetry row+           ]+    retryCeiling =+      [ mkErr wl WqDlqWithoutCeiling ("workqueue '" <> wqName w <> "': dlq=on requires maxRetries >= 1 (an absent ceiling never dead-letters)")+      | wqDlqOn w && wqMaxRetries w < 1+      ]+    fifo = wqOrdering w /= WqUnordered+    orderingRules =+      [ mkErr wl WqGroupKeyMissing $+          "workqueue '" <> wqName w <> "': FIFO delivery is per group, so ordering requires a 'group key' clause that makes enqueueToGroup deterministic"+      | fifo && wqGroupKey w == Nothing+      ]+        ++ [ mkErr wl WqGroupKeyWithoutFifo $+               "workqueue '" <> wqName w <> "': a group key with unordered reads would be ignored; declare a FIFO ordering or remove the key"+           | not fifo && wqGroupKey w /= Nothing+           ]+    groupKeyRules = case wqGroupKey w of+      Nothing -> []+      Just groupKey ->+        case [field | field <- wqPayload w, wqfName field == gkField groupKey] of+          [] ->+            [ mkErr wl WqGroupKeyUnresolved $+                "workqueue '" <> wqName w <> "': group key field '" <> gkField groupKey <> "' is not declared in its payload"+            ]+          field : _ ->+            [ mkErr wl WqGroupKeyUnresolved $+                "workqueue '" <> wqName w <> "': group key via raw requires a text payload field, but '" <> gkField groupKey <> "' has type '" <> queuePayloadTypeText (wqfType field) <> "'"+            | gkVia groupKey == "raw" && not (isDirectText (wqfType field))+            ]+              ++ [ mkErr wl WqGroupKeyUnresolved $+                     "workqueue '" <> wqName w <> "': opaque group-key derivation '" <> gkVia groupKey <> "' requires a captured fixture"+                 | gkVia groupKey /= "raw" && gkFixture groupKey == Nothing+                 ]+    payloadTypes =+      [ mkErr wl WqPayloadTypeUnknown $+          "workqueue '" <> wqName w <> "' payload field '" <> wqfName field <> "' has unknown type '" <> queueScalarName scalar <> "'; expected text, int, or bool"+      | enforcesSpecSurfaceClosures languageContract,+        field <- wqPayload w,+        LegacyQueueScalar scalar@(QueueOther _) <- [wqfType field]+      ]+    isDirectText (LegacyQueueScalar QueueText) = True+    isDirectText (TypedQueueExpression TText) = True+    isDirectText _ = False+    queuePayloadTypeText (LegacyQueueScalar scalar) = queueScalarName scalar+    queuePayloadTypeText (TypedQueueExpression _) = "mapped expression"+    windows =+      windowRangeRule languageContract wl ("workqueue '" <> wqName w <> "' delay") (wqDelay w)+        ++ concat+          [ windowRangeRule languageContract (locLine (wqdLoc row)) ("workqueue '" <> wqName w <> "' retry") window+          | row <- rows,+            IRetry window <- [wqdAction row]+          ]+    provisionRules = case wqProvision w of+      WqStandard -> []+      WqUnlogged ->+        [ Diagnostic+            { line = wl,+              severity = Warning,+              code = WqUnloggedDurability,+              relatedLocations = [],+              message = "workqueue '" <> wqName w <> "': provision unlogged is truncated to empty on a database crash; use it only for transient, regenerable work"+            }+        ]+      WqPartitioned interval retention ->+        [ mkErr wl WqPartitionSpecEmpty $+            "workqueue '" <> wqName w <> "': partition interval and retention must be non-empty; they are create-time settings and the additive reconciler will not migrate an existing queue"+        | T.null interval || T.null retention+        ]++-- | EP-5 dispatch rule: the @enqueue to@ target must resolve to a declared workqueue.+validatePgmqDispatch :: EffectiveLanguageContract -> Spec -> PgmqDispatchNode -> [Diagnostic]+validatePgmqDispatch languageContract spec d = enqueueRef ++ dedupQueueRef ++ sourceReadModelRef ++ sourceReadModelField ++ dedupReadModelRef ++ dedupReadModelField ++ dedupKeyField ++ fanoutFunctionName+  where+    dl = locLine (pdLoc d)+    -- The top-level `dedup key` is the logical value being deduped. Its two+    -- physical locations are already checked against the seenIn read model and+    -- queue; the key itself comes from the source read model's row, so it must+    -- be one of that model's generated selectors — exactly the rule `source key`+    -- already obeys. ExecPlan 197 parked this as descriptive-only.+    dedupKeyField = case [readModel | NReadModel readModel <- specNodes spec, rmName readModel == pdSourceReadModel d] of+      [] -> []+      readModel : _ ->+        [ mkSurfaceRefusal languageContract dl DispatchReadModelFieldUnknown $+            "dispatch '"+              <> pdName d+              <> "' dedup key '"+              <> pdDedupKey d+              <> "' is not a generated logical selector for a column of source readmodel '"+              <> pdSourceReadModel d+              <> "'"+        | pdDedupKey d `notElem` map (logicalFieldSelector . rmcName) (rmColumns readModel)+        ]++    -- `fanout body` names a hand-written function that expands one source row+    -- into queued jobs. A pgmq dispatch generates no module, so there is no+    -- typed namespace to resolve the name against — but a name that is not a+    -- legal Haskell value identifier cannot be the name of any function anyone+    -- could write, which is decidable here. ExecPlan 197 parked this too.+    fanoutFunctionName =+      [ mkSurfaceRefusal languageContract dl PgmqFanoutFunctionInvalid $+          "dispatch '"+            <> pdName d+            <> "' fanout body '"+            <> pdFanoutBody d+            <> "' cannot name a Haskell function; it must be a lowercase-initial identifier that is not a reserved word"+      | not (lowerIdentifierSafe (pdFanoutBody d))+      ]+    workqueues = [w | NWorkqueue w <- specNodes spec]+    enqueueRef =+      [ mkErr dl DispatchEnqueueUnresolved ("dispatch '" <> pdName d <> "' enqueues to undeclared workqueue '" <> pdEnqueueTo d <> "'")+      | pdEnqueueTo d `notElem` map wqName workqueues+      ]+    dedupQueueRef = case [w | w <- workqueues, wqName w == pdDedupQueue d] of+      [] ->+        [ mkErr dl DispatchDedupQueueUnresolved $+            "dispatch '" <> pdName d <> "' checks an undeclared dedup queue '" <> pdDedupQueue d <> "'"+        ]+      (queue : _) ->+        [ mkErr dl DispatchDedupFieldUnresolved $+            "dispatch '" <> pdName d <> "' dedup field '" <> pdDedupQueueField d <> "' is not a payload wire field of queue '" <> pdDedupQueue d <> "'"+        | pdDedupQueueField d `notElem` map wqfWire (wqPayload queue)+        ]+    sourceReadModelRef =+      resolveReadModelRef DispatchReadModelUnresolved spec (pdLoc d) ("dispatch '" <> pdName d <> "' source") (pdSourceReadModel d)+    sourceReadModelField = case [readModel | NReadModel readModel <- specNodes spec, rmName readModel == pdSourceReadModel d] of+      [] -> []+      readModel : _ ->+        [ mkErr dl DispatchReadModelFieldUnknown $+            "dispatch '" <> pdName d <> "' source key '" <> pdSourceKey d <> "' is not a generated logical selector for a column of readmodel '" <> pdSourceReadModel d <> "'"+        | enforcesSpecSurfaceClosures languageContract,+          pdSourceKey d `notElem` map (logicalFieldSelector . rmcName) (rmColumns readModel)+        ]+    dedupReadModelRef =+      resolveReadModelRef DispatchReadModelUnresolved spec (pdLoc d) ("dispatch '" <> pdName d <> "' dedup") (pdDedupReadModel d)+    dedupReadModelField = case [readModel | NReadModel readModel <- specNodes spec, rmName readModel == pdDedupReadModel d] of+      [] -> []+      (readModel : _) ->+        [ mkErr dl DispatchReadModelFieldUnknown $+            "dispatch '" <> pdName d <> "' dedup field '" <> pdDedupReadModelField d <> "' is not a declared column of readmodel '" <> pdDedupReadModel d <> "'"+        | pdDedupReadModelField d `notElem` map rmcName (rmColumns readModel)+        ]++-- | The declared contracts in a spec, by name.+specContracts :: Spec -> [ContractNode]+specContracts spec = [c | NContract c <- specNodes spec]++-- | EP-4 cross-node coupling: an intake's contract/topic/accepted-events resolve.+intakeCoupling :: EffectiveLanguageContract -> Spec -> IntakeNode -> [Diagnostic]+intakeCoupling languageContract spec i = bindFlagWarnings ++ bindHeaderNames ++ contractCoupling+  where+    -- The Kafka inbox reconstructs an envelope from the canonical header names+    -- in "Keiro.Integration.Event"; nothing reads a spec-declared header. A row+    -- naming a canonical header is descriptive and true, so it stays silent. A+    -- row naming any other header reads like remapping and silently is not.+    bindHeaderNames =+      [ mkSurfaceRefusal languageContract (locLine (inkLoc i)) IntakeBindHeaderUnknown $+          "intake '"+            <> inkName i+            <> "' binds '"+            <> brField binding+            <> "' from header "+            <> T.pack (show headerName)+            <> ", which is not one of keiro's canonical envelope headers; the Kafka inbox reads a fixed header set and cannot be remapped, so this row would not take effect. Use one of: "+            <> T.intercalate ", " (map (T.pack . show) canonicalEnvelopeHeaders)+      | binding <- inkBinds i,+        SrcHeader headerName <- [brSource binding],+        headerName `notElem` canonicalEnvelopeHeaders+      ]+    contractCoupling = case lookupContract (inkContract i) of+      Nothing ->+        [mkErr (locLine (inkLoc i)) IntakeUnresolvedContract ("intake '" <> inkName i <> "' references undeclared contract '" <> inkContract i <> "'")]+      Just c ->+        concat+          [ [ mkErr (locLine (inkLoc i)) IntakeUnresolvedContract ("intake '" <> inkName i <> "' topic '" <> inkTopic i <> "' is not a topic of contract '" <> inkContract i <> "'")+            | inkTopic i `notElem` map fst (ctrTopics c)+            ],+            [ mkErr (locLine (inkLoc i)) IntakeUnresolvedContract ("intake '" <> inkName i <> "' accepts event '" <> ev <> "' not declared in contract '" <> inkContract i <> "'")+            | ev <- inkAccept i,+              ev `notElem` map ceName (ctrEvents c)+            ],+            [ mkErr (locLine (inkLoc i)) TopicAffinityMismatch $+                "intake '" <> inkName i <> "' subscribes to topic '" <> inkTopic i <> "' but accepted event '" <> ceName event <> "' is declared on topic '" <> ceTopic event <> "'"+            | event <- ctrEvents c,+              ceName event `elem` inkAccept i,+              ceTopic event /= inkTopic i+            ],+            [ mkErr (locLine (inkLoc i)) IntakeBindUnresolved $+                "intake '" <> inkName i <> "' binds undeclared envelope or accepted-event field '" <> brField binding <> "'"+            | enforcesSpecSurfaceClosures languageContract,+              binding <- inkBinds i,+              brField binding `Set.notMember` resolvableFields c+            ],+            [ mkErr (locLine (inkLoc i)) IntakeDedupeKeyUnresolved $+                "intake '" <> inkName i <> "' dedupe key '" <> inkDedupeKey i <> "' is not an envelope or accepted-event field"+            | enforcesSpecSurfaceClosures languageContract,+              inkDedupeKey i `Set.notMember` resolvableFields c+            ],+            [ mkErr (locLine (inkLoc i)) IntakeDecodeSchemaVersionMismatch $+                "intake '"+                  <> inkName i+                  <> "' decode schemaVersion "+                  <> tInt (decBodySchemaVersion (inkDecode i))+                  <> " does not match contract '"+                  <> ctrName c+                  <> "' schemaVersion "+                  <> tInt (ctrSchemaVersion c)+            | enforcesSpecSurfaceClosures languageContract,+              decBodySchemaVersion (inkDecode i) /= ctrSchemaVersion c+            ]+          ]+    bindFlagWarnings =+      [ Diagnostic+          { line = locLine (inkLoc i),+            severity = Warning,+            code = IntakeBindFlagUnenforced,+            relatedLocations = [],+            message =+              "intake '"+                <> inkName i+                <> "' bind for '"+                <> brField binding+                <> "' declares "+                <> bindFlagText binding+                <> ", but generated code does not consume envelope bindings"+          }+      | binding <- inkBinds i,+        brRequired binding || brCrossCheck binding+      ]+    lookupContract n = case [c | c <- specContracts spec, ctrName c == n] of (c : _) -> Just c; [] -> Nothing+    resolvableFields contract =+      canonicalIntakeEnvelopeFields+        <> Set.fromList+          [ cfName field+          | event <- ctrEvents contract,+            ceName event `elem` inkAccept i,+            field <- ceFields event+          ]+    bindFlagText binding = case (brRequired binding, brCrossCheck binding) of+      (True, True) -> "'required' and 'cross-check body' flags"+      (True, False) -> "a 'required' flag"+      (False, True) -> "a 'cross-check body' flag"+      (False, False) -> "no enforcement flags"++-- Note: @derive … hole@ is mandatory emit grammar, so a per-emit warning about+-- it would fire on every emit node in every spec and carry no information. The+-- fact that an emit generates no module is reported once, per scaffold run, by+-- the report's inert-node line. See ExecPlan 199.+validateEmit :: EffectiveLanguageContract -> Spec -> EmitNode -> [Diagnostic]+validateEmit languageContract spec e = skipRule ++ duplicateCases ++ coupling+  where+    el = locLine (emLoc e)+    skipRule =+      [ mkErr el EmitSkipMissing ("emit '" <> emName e <> "' map must end with an explicit '_ => skip' catch-all (hole-kind 7 optionality)")+      | not (emSkip e)+      ]+    duplicateCases =+      [ mkErr (locLine (emrLoc row)) EmitMapDuplicateCase $+          "emit '" <> emName e <> "' repeats map discriminant '" <> emrValue row <> "'; the first row would shadow this row"+      | enforcesSpecSurfaceClosures languageContract,+        row <- duplicatesBy emrValue (emMap e)+      ]+    coupling = case [c | c <- specContracts spec, ctrName c == emContract e] of+      [] -> [mkErr el EmitUnresolvedContract ("emit '" <> emName e <> "' references undeclared contract '" <> emContract e <> "'")]+      (c : _) ->+        [ mkErr el EmitUnresolvedContract ("emit '" <> emName e <> "' topic '" <> emTopic e <> "' is not a topic of contract '" <> emContract e <> "'")+        | emTopic e `notElem` map fst (ctrTopics c)+        ]+          ++ [ mkErr (locLine (emrLoc r)) EmitUnresolvedContract ("emit '" <> emName e <> "' maps to event '" <> emrEvent r <> "' not declared in contract '" <> emContract e <> "'")+             | r <- emMap e,+               emrEvent r `notElem` map ceName (ctrEvents c)+             ]+          ++ [ mkErr (locLine (emrLoc row)) TopicAffinityMismatch $+                 "emit '" <> emName e <> "' publishes on topic '" <> emTopic e <> "' but mapped event '" <> emrEvent row <> "' is declared on topic '" <> ceTopic event <> "'"+             | row <- emMap e,+               event <- ctrEvents c,+               ceName event == emrEvent row,+               ceTopic event /= emTopic e+             ]++validatePublisher :: EffectiveLanguageContract -> Spec -> PublisherNode -> [Diagnostic]+validatePublisher languageContract spec p =+  unresolvedEmit ++ orderingVocabulary ++ backoffPolicy ++ attemptsFloor ++ outboxField ++ windows+  where+    publisherLine = locLine (pubLoc p)+    unresolvedEmit =+      [ mkErr publisherLine PublisherUnresolvedEmit ("publisher '" <> pubName p <> "' references undeclared emit '" <> pubEmit p <> "'")+      | pubEmit p `notElem` [emName e | NEmit e <- specNodes spec]+      ]+    orderingVocabulary =+      [ mkErr publisherLine PublisherOrderingUnknown $+          "publisher '"+            <> pubName p+            <> "' has unknown ordering '"+            <> pubOrdering p+            <> "'; expected PerKeyHeadOfLine, PerSourceStream, StopTheLine, or BestEffort"+      | pubOrdering p `Set.notMember` publisherOrderings+      ]+    backoffPolicy =+      [ mkErr publisherLine PublisherBackoffInvalid $+          "publisher '" <> pubName p <> "' has an invalid " <> problem+      | Just problem <- [backoffProblemMaybe (pubBackoff p)]+      ]+    attemptsFloor =+      [ mkErr publisherLine PublisherMaxAttemptsBelowMinimum $+          "publisher '" <> pubName p <> "' maxAttempts must be at least 1"+      | enforcesSpecSurfaceClosures languageContract,+        pubMaxAttempts p < 1+      ]+    outboxField = case [emitNode | NEmit emitNode <- specNodes spec, emName emitNode == pubEmit p] of+      [] -> []+      emitNode : _ ->+        [ mkErr publisherLine PublisherOutboxFieldUnresolved $+            "publisher '" <> pubName p <> "' outboxId field '" <> pubOutboxField p <> "' is not messageId, idempotencyKey, or a field of an event mapped by emit '" <> pubEmit p <> "'"+        | enforcesSpecSurfaceClosures languageContract,+          pubOutboxField p `Set.notMember` allowedOutboxFields emitNode+        ]+    allowedOutboxFields emitNode =+      Set.fromList ("messageId" : "idempotencyKey" : mappedContractFields emitNode)+    mappedContractFields emitNode =+      [ fieldDslName (resolveContractFieldIdentity field)+      | contract <- specContracts spec,+        ctrName contract == emContract emitNode,+        event <- ctrEvents contract,+        ceName event `elem` map emrEvent (emMap emitNode),+        field <- ceFields event+      ]+    windows =+      windowRangeRule languageContract publisherLine ("publisher '" <> pubName p <> "' backoff") (boWindow (pubBackoff p))+        ++ maybe [] (windowRangeRule languageContract publisherLine ("publisher '" <> pubName p <> "' maximum backoff")) (boMax (pubBackoff p))++publisherOrderings :: Set Name+publisherOrderings = Set.fromList ["PerKeyHeadOfLine", "PerSourceStream", "StopTheLine", "BestEffort"]++backoffProblemMaybe :: BackoffSpec -> Maybe Text+backoffProblemMaybe backoff = case boKind backoff of+  "constant" -> Nothing+  "exponential" -> case (boMax backoff, boMultiplier backoff) of+    (Just maximumWindow, Just multiplierText) ->+      case (validationWindowSeconds (boWindow backoff), validationWindowSeconds maximumWindow, readMaybe (T.unpack multiplierText) :: Maybe Double) of+        (Just initialSeconds, Just maximumSeconds, Just multiplier)+          | initialSeconds > 0 && maximumSeconds >= initialSeconds && multiplier >= 1 -> Nothing+        _ -> Just "exponential backoff; initial must be positive, max must be at least initial, and multiplier must be at least 1"+    _ -> Just "exponential backoff; both max and multiplier are required"+  other -> Just ("backoff kind '" <> other <> "'; expected constant or exponential")++validationWindowSeconds :: Text -> Maybe Int+validationWindowSeconds window = case T.unsnoc window of+  Just (digits, unit) -> do+    amount <- readMaybe (T.unpack digits)+    case unit of+      's' -> Just amount+      'm' -> Just (amount * 60)+      'h' -> Just (amount * 3600)+      _ -> Nothing+  Nothing -> Nothing++windowSecondsBounded :: Text -> Either Text Int+windowSecondsBounded window = case T.unsnoc window of+  Nothing -> Left "has no unit"+  Just (digits, unit) -> case readMaybe (T.unpack digits) :: Maybe Integer of+    Nothing -> Left "has invalid digits"+    Just amount -> case unitFactor unit of+      Nothing -> Left "has an unknown unit"+      Just factor+        | seconds > fromIntegral (maxBound :: Int) -> Left "exceeds the runtime Int seconds range"+        | otherwise -> Right (fromIntegral seconds)+        where+          seconds = amount * factor+  where+    unitFactor 's' = Just 1+    unitFactor 'm' = Just 60+    unitFactor 'h' = Just 3600+    unitFactor _ = Nothing++windowRangeRule :: EffectiveLanguageContract -> Int -> Text -> Text -> [Diagnostic]+windowRangeRule languageContract diagnosticLine context window =+  [ mkErr diagnosticLine WindowOutOfRange $+      context <> " window '" <> window <> "' " <> reason+  | enforcesSpecSurfaceClosures languageContract,+    Left reason <- [windowSecondsBounded window]+  ]++-- | EP-4 inbox disposition rules: the table must be complete over the seven+-- outcomes, and the three dangerous inversions must be stated the safe way.+validateIntake :: EffectiveLanguageContract -> IntakeNode -> [Diagnostic]+validateIntake languageContract i = concat [completeness, duplicateRows, inversions, dedupeVocabulary, decodeVersionFloor, envelopeVocabulary, decodePosture, windows]+  where+    il = locLine (inkLoc i)+    -- `decBodyStrict` reaches nothing but the pretty-printer: generated contract+    -- codecs decode every declared body field as required and admit no lenient+    -- mode, so `body strict` describes what happens and `body lenient` does not.+    decodePosture =+      [ mkSurfaceRefusal languageContract il DecodeBodyPostureUnsupported $+          "intake '"+            <> inkName i+            <> "' declares 'body lenient', but generated contract codecs decode a body strictly: every declared field is required and no lenient fallback is emitted. Write 'body strict' to describe what runs"+      | not (decBodyStrict (inkDecode i))+      ]+    rows = inkDisposition i+    requiredOutcomes =+      ["processed", "duplicate", "inProgress", "previouslyFailed", "decodeFailed", "dedupeFailed", "storeFailed"]+    completeness =+      [ mkErr il DispositionIncomplete $+          "intake '" <> inkName i <> "' disposition table is missing outcome '" <> o <> "'"+      | o <- requiredOutcomes,+        o `notElem` map drOutcome rows+      ]+    duplicateRows =+      [ mkErr (locLine (drLoc row)) DispositionDuplicateOutcome $+          "intake '" <> inkName i <> "' repeats disposition outcome '" <> drOutcome row <> "'; the first row would shadow this row"+      | row <- duplicatesBy drOutcome rows+      ]+    windows =+      concat+        [ windowRangeRule languageContract (locLine (drLoc row)) ("intake '" <> inkName i <> "' retry") window+        | row <- rows,+          IRetry window <- [drAction row]+        ]+    dedupeVocabulary =+      [ mkErr il IntakeDedupePolicyUnknown $+          "intake '"+            <> inkName i+            <> "' has unknown dedupe policy '"+            <> inkDedupePolicy i+            <> "'; expected PreferIntegrationMessageId, PreferSourceEventIdentity, or KafkaDeliveryIdentity"+      | inkDedupePolicy i `Set.notMember` intakeDedupePolicies+      ]+    decodeVersionFloor =+      [ mkErr il IntakeDecodeSchemaVersionBelowMinimum $+          "intake '" <> inkName i <> "' decode schemaVersion must be at least 1"+      | enforcesSpecSurfaceClosures languageContract,+        decBodySchemaVersion (inkDecode i) < 1+      ]+    envelopeVocabulary =+      [ mkErr il IntakeEnvelopePolicyUnknown $+          "intake '" <> inkName i <> "' has unsupported envelope policy " <> T.pack (show (decEnvelope (inkDecode i))) <> "; expected \"strict-required lenient-optional\""+      | enforcesSpecSurfaceClosures languageContract,+        decEnvelope (inkDecode i) /= "strict-required lenient-optional"+      ]+    firstRow outcome = case [row | row <- rows, drOutcome row == outcome] of+      (row : _) -> Just row+      [] -> Nothing+    isRetry row = case drAction row of IRetry _ -> True; _ -> False+    inversions =+      [ mkErr (locLine (drLoc row)) DispositionDuplicateRetry $+          "intake '" <> inkName i <> "': a 'duplicate' redelivery must be ackOk (success), not retry"+      | Just row <- [firstRow "duplicate"],+        isRetry row+      ]+        ++ [ mkErr (locLine (drLoc row)) DispositionPreviouslyFailedRetry $+               "intake '" <> inkName i <> "': 'previouslyFailed' must dead-letter, not retry (a prior failure won't succeed on replay)"+           | Just row <- [firstRow "previouslyFailed"],+             isRetry row+           ]+        ++ [ mkErr (locLine (drLoc row)) DispositionDecodeUnboundedRetry $+               "intake '" <> inkName i <> "': 'decodeFailed' must dead-letter (terminal), not retry unboundedly"+           | Just row <- [firstRow "decodeFailed"],+             isRetry row+           ]++intakeDedupePolicies :: Set Name+intakeDedupePolicies = Set.fromList ["PreferIntegrationMessageId", "PreferSourceEventIdentity", "KafkaDeliveryIdentity"]++-- | The timer statuses a stored row can hold, mirroring @TimerStatus@ in+-- @keiro@'s "Keiro.Timer.Schema". keiro-dsl deliberately does not depend on the+-- runtime package, so the list is restated here; the conformance suite that does+-- depend on @keiro@ asserts the two agree.+runtimeTimerStatuses :: [Text]+runtimeTimerStatuses = ["Scheduled", "Firing", "Fired", "Cancelled", "Dead"]++-- | Every header name keiro's integration envelope actually uses on the wire,+-- taken from the runtime's own definitions in "Keiro.Integration.Event" rather+-- than restated here, so the two cannot drift apart.+canonicalEnvelopeHeaders :: [Text]+canonicalEnvelopeHeaders =+  [ Event.headerMessageId,+    Event.headerSource,+    Event.headerDestination,+    Event.headerEventType,+    Event.headerSchemaVersion,+    Event.headerContentType,+    Event.headerSchemaRegistry,+    Event.headerSchemaSubject,+    Event.headerSchemaVersionRef,+    Event.headerSchemaId,+    Event.headerSchemaFingerprint,+    Event.headerSourceEventId,+    Event.headerSourceGlobalPosition,+    Event.headerCausationId,+    Event.headerCorrelationId,+    Event.headerTraceParent,+    Event.headerTraceState,+    Event.headerOccurredAt,+    Event.headerAttributes+  ]++canonicalIntakeEnvelopeFields :: Set Name+canonicalIntakeEnvelopeFields =+  Set.fromList+    [ "messageId",+      "source",+      "destination",+      "key",+      "eventType",+      "schemaVersion",+      "contentType",+      "schemaReference",+      "sourceEventId",+      "sourceGlobalPosition",+      "payloadBytes",+      "occurredAt",+      "causationId",+      "correlationId",+      "traceContext",+      "attributes",+      "idempotencyKey"+    ]++-- | EP-3 rules for a process manager + its nested timer.+validateProcess :: EffectiveLanguageContract -> Spec -> ProcessNode -> [Diagnostic]+validateProcess languageContract spec p =+  concat [sagaCategoryRule, noWallClock, runtimeOwnedDispatchId, crossNodeCoupling, strictSurfaceResolution, timerCeiling, policyRules, ambiguityRule, benignInversions, onAppendedArms, notMineArm, decodeUnknownStatus, deadLetterText]+  where+    -- Generated dispatch code appends and then acks; `Keiro.ProcessManager` has+    -- no branch that retries or dead-letters a *successful* append. Only AckOk+    -- describes what runs.+    onAppendedArms =+      [ mkSurfaceRefusal languageContract (locLine (dispLoc d)) DispatchOnAppendedUnsupported $+          "dispatch to '"+            <> dispTarget d+            <> "' maps on-appended => "+            <> dispText (onAppended (dispDisposition d))+            <> ", but a successful append is always acked: no runtime path retries or dead-letters an event it just appended. Write 'on-appended AckOk'"+      | d <- hDispatch (procHandle p),+        onAppended (dispDisposition d) /= DAckOk+      ]++    -- `decode unknown-status => X` names the status a row that fails to decode+    -- is read as. X must be a status the timer table actually has.+    decodeUnknownStatus =+      [ mkSurfaceRefusal languageContract (locLine (tmLoc timer)) TimerDecodeStatusUnknown $+          "timer '"+            <> tmName timer+            <> "' maps decode unknown-status => '"+            <> tmDecodeUnknown timer+            <> "', which is not a timer status; a stored timer row is one of: "+            <> T.intercalate ", " runtimeTimerStatuses+      | tmDecodeUnknown timer `notElem` runtimeTimerStatuses+      ]++    -- The dead-letter reason is a hand-owned obligation: `runTimerWorkerWith`+    -- composes its own message for the attempt ceiling, and the generated+    -- comment surfaces this text so an operator-written worker can pass it to+    -- `Keiro.Timer.deadLetterTimer`. Nothing can check what the prose says, but+    -- an empty or blank reason names no obligation at all.+    deadLetterText =+      [ mkSurfaceRefusal languageContract (locLine (tmLoc timer)) TimerDeadLetterTextInvalid $+          "timer '"+            <> tmName timer+            <> "' declares a blank dead-letter reason; the reason is the hand-owned text an operator-written timer worker passes to Keiro.Timer.deadLetterTimer, so it must say something"+      | T.null (T.strip (tmDeadLetter timer))+      ]++    -- The timer worker marks a timer Fired only when the fire action returns the+    -- id of an event it appended (`Keiro.Timer.runTimerWorkerWith`). A not-mine+    -- dispatch produces no such id, so the row is left Firing and requeued on a+    -- later pass — which is exactly Retry. Fired is not reachable.+    notMineArm =+      [ mkSurfaceRefusal languageContract (locLine (tmLoc timer)) TimerNotMineUnsupported $+          "timer '"+            <> tmName timer+            <> "' maps not-mine => Fired, but the timer worker marks a timer Fired only when the fire action returns the id of the event it appended; a dispatch that is not this timer's has no such id, so the row is requeued instead. Write 'not-mine Retry'"+      | notMine (fireDisposition (tmFire timer)) == OFired+      ]+    aggregates = [a | NAggregate a <- specNodes spec]+    aggNames = map aggName aggregates+    projectionTables = [projTable projection | aggregate <- aggregates, Just projection <- [aggProjection aggregate]]+    inputFields = map fieldName (inFields (procInput p))+    timeFields = [fieldName f | f <- inFields (procInput p), fieldType f == Just "Time"]+    timer = procTimer p+    pl = locLine (procLoc p)++    sagaCategoryRule =+      [ mkErr pl SagaCategoryIllegal $+          "saga category " <> T.pack (show (sagaCategory (procSaga p))) <> " " <> reason+      | Just reason <- [sagaCategoryError (sagaCategory (procSaga p))]+      ]++    -- TIME IS INJECTED, NOT SAMPLED: fireAt's field must be a declared :Time+    -- input field. (FireAtExpr has no clock-sampling constructor, so this is a+    -- field-resolution + typed-as-Time check.)+    noWallClock =+      let f = faField (tmFireAt timer)+       in if f `notElem` inputFields+            then+              [ mkErr (locLine (tmLoc timer)) ProcessFireAtNotInjected $+                  "timer '" <> tmName timer <> "' fireAt field '" <> f <> "' is not a field of input '" <> inName (procInput p) <> "'"+              ]+            else+              [ mkErr (locLine (tmLoc timer)) ProcessFireAtNotInjected $+                  "timer '" <> tmName timer <> "' fireAt references '" <> f <> "', which is not a declared :Time field of input '" <> inName (procInput p) <> "'"+              | f `notElem` timeFields+              ]++    -- Dispatched (and fired) command ids are runtime-owned; no field binding may+    -- supply a commandId/id.+    runtimeOwnedDispatchId =+      [ mkErr pl ProcessDispatchIdSupplied $+          "advance command '" <> advCommand advance <> "' supplies a runtime-owned id field '" <> fbName binding <> "'; remove it"+      | let advance = hAdvance (procHandle p),+        binding <- advFields advance,+        fbName binding `elem` (["commandId", "id"] :: [Name])+      ]+        ++ [ mkErr (locLine (dispLoc d)) ProcessDispatchIdSupplied $+               "dispatch to '" <> dispTarget d <> "' supplies a runtime-owned id field '" <> fbName b <> "'; remove it"+           | d <- hDispatch (procHandle p),+             b <- dispFields d,+             fbName b `elem` (["commandId", "id"] :: [Name])+           ]+        ++ [ mkErr (locLine (tmLoc timer)) ProcessDispatchIdSupplied $+               "timer fire supplies a runtime-owned id field '" <> fbName b <> "'; remove it"+           | b <- fireFields (tmFire timer),+             fbName b `elem` (["commandId", "id"] :: [Name])+           ]++    -- Aggregate, command, field, timer, and projection references must resolve.+    crossNodeCoupling =+      [ mkErr pl ProcessUnresolvedRef ("saga '" <> sagaAgg (procSaga p) <> "' does not resolve to a declared aggregate")+      | sagaAgg (procSaga p) `notElem` aggNames+      ]+        ++ [ mkErr pl ProcessUnresolvedRef ("target '" <> procTarget p <> "' does not resolve to a declared aggregate")+           | procTarget p `notElem` aggNames+           ]+        ++ [ mkErr (locLine (tmLoc timer)) ProcessUnresolvedRef ("timer fire target '" <> fireTarget (tmFire timer) <> "' must be the saga or the target aggregate")+           | fireTarget (tmFire timer) `notElem` [sagaAgg (procSaga p), procTarget p]+           ]+        ++ resolveCommand pl "advance" (sagaAgg (procSaga p)) (advCommand advance) (advFields advance)+        ++ concatMap resolveDispatch (hDispatch (procHandle p))+        ++ resolveCommand (locLine (tmLoc timer)) "timer fire" (fireTarget fire) (fireCommand fire) (fireFields fire)+        ++ [ mkErr pl ProcessUnresolvedRef $+               "process '" <> procId p <> "' schedules undeclared timer '" <> hSchedule (procHandle p) <> "'; declared timer is '" <> tmName timer <> "'"+           | hSchedule (procHandle p) /= tmName timer+           ]+        ++ [ mkErr pl ProcessUnresolvedRef $+               "process '" <> procId p <> "' references undeclared projection table '" <> projection <> "'"+           | projection <- procProjections p,+             projection `notElem` projectionTables+           ]+      where+        advance = hAdvance (procHandle p)+        fire = tmFire timer+        resolveDispatch dispatch =+          resolveCommand+            (locLine (dispLoc dispatch))+            "dispatch"+            (dispTarget dispatch)+            (dispCommand dispatch)+            (dispFields dispatch)+        resolveCommand diagnosticLine context target command bindings = case lookupAggregate target of+          Nothing -> []+          Just aggregate -> case [decl | decl <- aggCommands aggregate, cmdName decl == command] of+            [] ->+              [ mkErr diagnosticLine ProcessUnresolvedRef $+                  context <> " command '" <> command <> "' is not declared by aggregate '" <> target <> "'"+              ]+            (declaration : _) ->+              [ mkErr diagnosticLine ProcessFieldBindingUnresolved $+                  context <> " command '" <> command <> "' binds undeclared target field '" <> fbName binding <> "'"+              | binding <- bindings,+                fbName binding `notElem` map aggregateFieldName (cmdFields declaration)+              ]+        lookupAggregate name = case [aggregate | aggregate <- aggregates, aggName aggregate == name] of+          (aggregate : _) -> Just aggregate+          [] -> Nothing++    strictSurfaceResolution+      | not (enforcesSpecSurfaceClosures languageContract) = []+      | otherwise = correlateFieldRule ++ dispatchKeyRules ++ bindingScopeRules ++ idFieldRules ++ fireWindowRule++    correlateFieldRule =+      [ mkErr pl ProcessKeyFieldUnknown $+          "correlate references 'input." <> corrField (procCorrelate p) <> "' but input '" <> inName (procInput p) <> "' does not declare that field"+      | corrField (procCorrelate p) `notElem` inputFields+      ]++    dispatchKeyRules =+      [ mkErr (locLine (dispLoc dispatch)) ProcessDispatchKeyUnresolved $+          "dispatch to '" <> dispTarget dispatch <> "' uses unresolved key '" <> dispKey dispatch <> "'; expected correlationId or input.<declared-field>"+      | dispatch <- hDispatch (procHandle p),+        not (processKeyInScope (dispKey dispatch))+      ]+        ++ [ mkErr (locLine (tmLoc timer)) ProcessDispatchKeyUnresolved $+               "timer fire to '" <> fireTarget (tmFire timer) <> "' uses unresolved key '" <> fireKey (tmFire timer) <> "'; expected correlationId or input.<declared-field>"+           | not (processKeyInScope (fireKey (tmFire timer)))+           ]++    processKeyInScope value =+      value == "correlationId"+        || case T.stripPrefix "input." value of+          Just field -> field `elem` inputFields+          Nothing -> False++    bindingScopeRules =+      bindingRules pl "advance" inputFields (advFields (hAdvance (procHandle p)))+        ++ concatMap+          (\dispatch -> bindingRules (locLine (dispLoc dispatch)) "dispatch" inputFields (dispFields dispatch))+          (hDispatch (procHandle p))+        ++ bindingRules+          (locLine (tmLoc timer))+          "timer fire"+          (inputFields <> map fbName (tmPayload timer) <> ["timerId"])+          (fireFields (tmFire timer))++    bindingRules diagnosticLine context bareScope bindings =+      [ mkErr diagnosticLine ProcessBindingUnscoped $+          context <> " binding '" <> fbName binding <> maybe "" ("=" <>) (fbValue binding) <> "' is outside the process input and timer scopes"+      | binding <- bindings,+        not (bindingInScope bareScope binding)+      ]++    bindingInScope bareScope binding = case fbValue binding of+      Nothing -> fbName binding `elem` bareScope+      Just value+        | isQuoted value -> True+        | value == "timer.id" -> True+        | Just field <- T.stripPrefix "input." value -> field `elem` inputFields+        | otherwise -> value `elem` bareScope++    isQuoted value = T.length value >= 2 && T.head value == '"' && T.last value == '"'++    idFieldRules =+      [ mkErr (locLine (tmLoc timer)) TimerIdFieldNotCorrelation $+          "timer '" <> tmName timer <> "' " <> context <> " derives from '" <> ideField expression <> "'; only correlationId is implemented by generated runtime code"+      | (context, expression) <- [("id", tmId timer), ("fired-event-id", fireFiredEventId (tmFire timer))],+        ideField expression /= "correlationId"+      ]++    fireWindowRule =+      windowRangeRule languageContract (locLine (tmLoc timer)) ("timer '" <> tmName timer <> "' fireAt") (faWindow (tmFireAt timer))++    timerCeiling =+      [ mkErr (locLine (tmLoc timer)) ProcessTimerCeilingInvalid $+          "timer '" <> tmName timer <> "' max-attempts must be at least 1"+      | tmMaxAttempts timer < 1+      ]++    policyRules =+      policyConsistency+        (procId p)+        (procLoc p)+        (procRejected p)+        [ (dispCommand dispatch, dispLoc dispatch, dispDisposition dispatch)+        | dispatch <- hDispatch (procHandle p)+        ]++    ambiguityRule =+      [ mkErr (locLine (tmLoc timer)) AmbiguousMarkedBenign $+          "timer '" <> tmName timer <> "' maps on-ambiguous => Fired; CommandAmbiguous means multiple aggregate edges matched and is never a benign success. Use on-ambiguous Retry so the attempts ceiling dead-letters the definition bug"+      | onAmbiguous (fireDisposition (tmFire timer)) == OFired+      ]++    -- Surface the dangerous benign inversions the author confirmed (warnings).+    benignInversions =+      [ Diagnostic (locLine (tmLoc timer)) Warning ProcessBenignInversion [] $+          "timer '" <> tmName timer <> "' maps on-reject => Fired (a CommandRejected is treated as benign success)"+      | onReject (fireDisposition (tmFire timer)) == OFired+      ]+        ++ [ Diagnostic (locLine (dispLoc d)) Warning ProcessBenignInversion [] $+               "dispatch to '" <> dispTarget d <> "' maps on-duplicate => AckOk (a duplicate is treated as benign success)"+           | d <- hDispatch (procHandle p),+             onDuplicate (dispDisposition d) == DAckOk+           ]++-- | Explain why a process saga category is illegal.  The first four cases+-- mirror 'Keiro.Stream.category' without introducing a runtime dependency into+-- the toolchain library.  The final @:@ case is deliberately stricter because+-- that prefix is reserved for the @wf:<name>@ workflow stream family.+sagaCategoryError :: Text -> Maybe Text+sagaCategoryError = runtimeIdentityError False++stableIdentityError :: Text -> Maybe Text+stableIdentityError = runtimeIdentityError True++runtimeIdentityError :: Bool -> Text -> Maybe Text+runtimeIdentityError allowsHyphen identity+  | T.null identity = Just "is empty; use a non-empty stable name"+  | identity == "$all" = Just "is reserved by the event store; choose a service-owned stable name"+  | not allowsHyphen && T.isInfixOf "-" identity = Just "contains '-' (kiroku's category/id boundary); write compound categories in camelCase, for example \"hospitalSurge\""+  | Just illegal <- T.find (\character -> isSpace character || isControl character) identity =+      Just ("contains whitespace or control character " <> T.pack (show illegal) <> "; remove it and use camelCase")+  | T.isInfixOf ":" identity = Just "contains ':' which is reserved for runtime stream-family prefixes; choose a stable name without ':'"+  | otherwise = Nothing++-- | The generated lower-camel selector for a logical field or SQL column.+-- Read-model notation stores SQL names such as @responder_id@ while router+-- resolve rows and dispatch keys use the generated selector @responderId@.+logicalFieldSelector :: Text -> Text+logicalFieldSelector raw =+  case HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site of+    Right derived -> HaskellName.renderLowerCamelName (HaskellName.lowerCamel derived)+    Left _ -> raw+  where+    site =+      HaskellName.NameSite+        { HaskellName.siteKind = HaskellName.GeneratedFieldSite,+          HaskellName.siteLogicalName = raw,+          HaskellName.siteOwner = "validation field resolution",+          HaskellName.siteLine = 0+        }++-- | EP-108 rules for a stateless content-based router.+validateRouter :: EffectiveLanguageContract -> Either (NE.NonEmpty TypeGraphError) TypeGraph -> Spec -> RouterNode -> [Diagnostic]+validateRouter languageContract typeGraphResult spec router =+  concat+    [ references,+      keyField,+      bindingScope,+      commandReference,+      readModelReference,+      selectionChecks,+      policyRules,+      duplicateNotice,+      onAppendedArm+    ]+  where+    -- The process twin of this rule is in 'validateProcess'; both say the same+    -- thing because both runtimes do: a successful append is always acked.+    onAppendedArm =+      [ mkSurfaceRefusal languageContract dispatchLine DispatchOnAppendedUnsupported $+          "router dispatch '"+            <> rdCommand dispatch+            <> "' maps on-appended => "+            <> dispText (onAppended (rdDisposition dispatch))+            <> ", but a successful append is always acked: no runtime path retries or dead-letters an event it just appended. Write 'on-appended AckOk'"+      | onAppended (rdDisposition dispatch) /= DAckOk+      ]+    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]+    readModels = [readModel | NReadModel readModel <- specNodes spec]+    inputFields = map fieldName (inFields (rtInput router))+    resolvedFields = rvRow (rtResolve router)+    dispatch = rtDispatch router+    routerLine = locLine (rtLoc router)+    dispatchLine = locLine (rdLoc dispatch)++    targetAggregate = case [aggregate | aggregate <- aggregates, aggName aggregate == rtTarget router] of+      aggregate : _ -> Just aggregate+      [] -> Nothing++    projectionTables = [projTable projection | aggregate <- aggregates, Just projection <- [aggProjection aggregate]]++    references =+      [ mkErr routerLine RouterUnresolvedRef $+          "router '" <> rtId router <> "' targets aggregate '" <> rtTarget router <> "' but no such aggregate is declared"+      | targetAggregate == Nothing+      ]+        ++ [ mkErr routerLine RouterUnresolvedRef $+               "router '" <> rtId router <> "' references undeclared projection table '" <> projection <> "'"+           | projection <- rtProjections router,+             projection `notElem` projectionTables+           ]++    keyField = case rvSource (rtResolve router) of+      ResolveDeclarative {} -> []+      _ ->+        [ mkErr routerLine RouterKeyFieldUnknown $+            "key references 'input." <> corrField (rtKey router) <> "' but input '" <> inName (rtInput router) <> "' does not declare that field"+        | corrField (rtKey router) `notElem` inputFields+        ]++    bindingScope = case rvSource (rtResolve router) of+      ResolveDeclarative {} -> []+      _ ->+        [ mkErr dispatchLine RouterBindingUnscoped $+            "dispatch binding '" <> fbName binding <> maybe "" ("=" <>) (fbValue binding) <> "' is outside the router input and resolve-row scopes"+        | binding <- rdFields dispatch,+          not (bindingInScope binding)+        ]+      where+        bindingInScope binding = case fbValue binding of+          Nothing -> fbName binding `elem` inputFields+          Just value+            | isQuoted value -> True+            | Just field <- T.stripPrefix "input." value -> field `elem` inputFields+            | Just field <- T.stripPrefix "resolved." value -> field `elem` resolvedFields+            | otherwise -> False+        isQuoted value = T.length value >= 2 && T.head value == '"' && T.last value == '"'++    commandReference = case targetAggregate of+      Nothing -> []+      Just aggregate -> case [command | command <- aggCommands aggregate, cmdName command == rdCommand dispatch] of+        [] ->+          [ mkErr dispatchLine RouterCommandUnknown $+              "dispatch command '" <> rdCommand dispatch <> "' is not declared by aggregate '" <> aggName aggregate <> "'"+          ]+        command : _ ->+          [ mkErr dispatchLine RouterCommandUnknown $+              "dispatch command '" <> rdCommand dispatch <> "' binds undeclared target field '" <> fbName binding <> "'"+          | binding <- rdFields dispatch,+            fbName binding `notElem` map aggregateFieldName (cmdFields command)+          ]++    readModelReference = case rvSource (rtResolve router) of+      ResolveHole -> []+      ResolveDeclarative {} -> []+      ResolveReadModel name ->+        case [readModel | readModel <- readModels, rmName readModel == name] of+          [] ->+            [ mkErr (locLine (rvLoc (rtResolve router))) RouterUnresolvedRef $+                "router '" <> rtId router <> "' resolve names readmodel '" <> name <> "' but no such readmodel node is declared"+            ]+          readModel : _ ->+            [ mkErr (locLine (rvLoc (rtResolve router))) RouterReadModelUnverified $+                "router '" <> rtId router <> "' resolve row field '" <> column <> "' is not a declared column of readmodel '" <> name <> "'"+            | enforcesSpecSurfaceClosures languageContract,+              column <- rvRow (rtResolve router),+              column `notElem` map (logicalFieldSelector . rmcName) (rmColumns readModel)+            ]++    selectionChecks = case rvSource (rtResolve router) of+      ResolveDeclarative {} -> case typeGraphResult of+        Left _ -> []+        Right graph -> case RouterSelection.checkRouterSelection languageContract graph spec router of+          Right _ -> []+          Left diagnostics -> map routerSelectionDiagnostic (NE.toList diagnostics)+      _ -> []++    policyRules =+      policyConsistency+        (rtId router)+        (rtLoc router)+        (rtRejected router)+        [(rdCommand dispatch, rdLoc dispatch, rdDisposition dispatch)]++    duplicateNotice =+      [ Diagnostic dispatchLine Warning RouterBenignInversion [] $+          "router dispatch '" <> rdCommand dispatch <> "' maps on-duplicate => AckOk; Keiro.Router confirms the event id against the target stream before treating the duplicate as benign"+      | onDuplicate (rdDisposition dispatch) == DAckOk+      ]++routerSelectionDiagnostic :: RouterSelection.RouterSelectionDiagnostic -> Diagnostic+routerSelectionDiagnostic diagnostic =+  mkErr+    (locLine (RouterSelection.selectionDiagnosticLoc diagnostic))+    (routerSelectionDiagnosticCode (RouterSelection.selectionDiagnosticCode diagnostic))+    (RouterSelection.selectionDiagnosticMessage diagnostic)++routerSelectionDiagnosticCode :: RouterSelection.RouterSelectionDiagnosticCode -> DiagnosticCode+routerSelectionDiagnosticCode = \case+  RouterSelection.SelectionNotDeclarative -> RouterSelectionNotDeclarative+  RouterSelection.SelectionCapabilityUnavailable -> RouterSelectionCapabilityUnavailable+  RouterSelection.SelectionIdentityEmpty -> RouterSelectionIdentityEmpty+  RouterSelection.SelectionVersionInvalid -> RouterSelectionVersionInvalid+  RouterSelection.SelectionQueryUnknown -> RouterSelectionQueryUnknown+  RouterSelection.SelectionQueryContractMissing -> RouterSelectionQueryContractMissing+  RouterSelection.SelectionQueryInputBindingInvalid -> RouterSelectionQueryInputBindingInvalid+  RouterSelection.SelectionQueryInputTypeMismatch -> RouterSelectionQueryInputTypeMismatch+  RouterSelection.SelectionQueryResultNotList -> RouterSelectionQueryResultNotList+  RouterSelection.SelectionQueryRowNotStructural -> RouterSelectionQueryRowNotStructural+  RouterSelection.SelectionExpressionRootUnknown -> RouterSelectionExpressionRootUnknown+  RouterSelection.SelectionExpressionFieldUnknown -> RouterSelectionExpressionFieldUnknown+  RouterSelection.SelectionExpressionFieldOptional -> RouterSelectionExpressionFieldOptional+  RouterSelection.SelectionExpressionTypeMismatch -> RouterSelectionExpressionTypeMismatch+  RouterSelection.SelectionPredicateNotBool -> RouterSelectionPredicateNotBool+  RouterSelection.SelectionRecipientNotText -> RouterSelectionRecipientNotText+  RouterSelection.SelectionOperatorUnsupported -> RouterSelectionOperatorUnsupported+  RouterSelection.SelectionRecipientLimitMissing -> RouterSelectionRecipientLimitMissing+  RouterSelection.SelectionRecipientLimitInvalid -> RouterSelectionRecipientLimitInvalid+  RouterSelection.SelectionOrderUnsupported -> RouterSelectionOrderUnsupported+  RouterSelection.SelectionDedupeUnsupported -> RouterSelectionDedupeUnsupported+  RouterSelection.SelectionFailureAckForbidden -> RouterSelectionFailureAckForbidden+  RouterSelection.SelectionRedeliveryUnsupported -> RouterSelectionRedeliveryUnsupported+  RouterSelection.SelectionPartialDispatchUnsupported -> RouterSelectionPartialDispatchUnsupported+  RouterSelection.SelectionTargetAmbiguous -> RouterSelectionTargetAmbiguous+  RouterSelection.SelectionCommandUnknown -> RouterSelectionCommandUnknown+  RouterSelection.SelectionCommandMappingDuplicate -> RouterSelectionCommandMappingDuplicate+  RouterSelection.SelectionCommandMappingIncomplete -> RouterSelectionCommandMappingIncomplete+  RouterSelection.SelectionCommandMappingTypeMismatch -> RouterSelectionCommandMappingTypeMismatch++-- | Reconcile per-dispatch prose with the one node-level policy the runtime+-- actually applies to a rejection-class failure group.+policyConsistency :: Name -> Loc -> PolicyChoice -> [(Name, Loc, DispatchDisposition)] -> [Diagnostic]+policyConsistency nodeName nodeLoc rejectedPolicy dispatches = contradictions ++ divergent ++ unused ++ ambiguityWarning+  where+    contradictions =+      [ mkErr (locLine dispatchLoc) PolicyContradiction $+          "dispatch '" <> command <> "' declares on-failed DeadLetter, but node '" <> nodeName <> "' does not declare rejected => deadLetter; align the dispatch story with the node-level RejectedCommandPolicy"+      | (command, dispatchLoc, disposition) <- dispatches,+        DDeadLetter _ <- [onFailed disposition],+        rejectedPolicy /= PolDeadLetter+      ]++    divergent = case dispatches of+      [] -> []+      (_, _, firstDisposition) : rest ->+        [ mkErr (locLine dispatchLoc) PolicyContradiction $+            "dispatch '" <> command <> "' has a different on-failed action from another dispatch in node '" <> nodeName <> "'; the runtime applies one RejectedCommandPolicy to the whole failure group"+        | (command, dispatchLoc, disposition) <- rest,+          not (sameFailureAction (onFailed disposition) (onFailed firstDisposition))+        ]++    unused =+      [ Diagnostic (locLine nodeLoc) Warning PolicyDeadLetterUnused [] $+          "node '" <> nodeName <> "' declares rejected => deadLetter but no dispatch on-failed arm says DeadLetter; the runtime policy is live, but the per-dispatch notation does not acknowledge it"+      | rejectedPolicy == PolDeadLetter,+        all (not . isDeadLetter . onFailed . third) dispatches+      ]++    ambiguityWarning =+      [ Diagnostic (locLine nodeLoc) Warning AmbiguousFollowsRejectedPolicy [] $+          "node '" <> nodeName <> "' acknowledges rejection-class failures; CommandAmbiguous follows the same rejected policy, and a dead-letter errorClass is the durable witness of that definition bug"+      | rejectedPolicy `elem` [PolDeadLetter, PolSkip]+      ]++    third (_, _, value) = value+    sameFailureAction DDeadLetter {} DDeadLetter {} = True+    sameFailureAction left right = left == right+    isDeadLetter DDeadLetter {} = True+    isDeadLetter _ = False++validateAggregate :: EffectiveLanguageContract -> Either (NE.NonEmpty TypeGraphError) TypeGraph -> Spec -> Aggregate -> [Diagnostic]+validateAggregate languageContract typeGraphResult spec agg =+  concat+    [ emptyAggregate,+      duplicateMembers,+      declaredRefs,+      eventBodyRefs,+      outputMappingRules,+      registerInitialScope,+      reachability,+      terminalNoOutgoing,+      guardScope,+      clockFree,+      projectionKeyResolution,+      projectionSafety,+      statusMapTotality,+      evolutionRules,+      snapshotRules,+      replayOnlyRules,+      eventlessStateChangeRules,+      domainOutcomeRules,+      wirePolicyRules,+      fieldWireKeyRules+    ]+  where+    emptyAggregate =+      [ mkErr (locLine (aggLoc agg)) AggregateEmpty $+          "aggregate '"+            <> aggName agg+            <> "' declares "+            <> renderMissing missingAggregateParts+            <> "; scaffold cannot lower an empty aggregate -- declare at least one command, one event, and one transition"+      | not (null missingAggregateParts)+      ]+    missingAggregateParts =+      [ label+      | (isMissing, label) <-+          [ (null (aggCommands agg), "no commands"),+            (null (aggEvents agg), "no events"),+            (null (aggTransitions agg), "no transitions")+          ],+        isMissing+      ]+    renderMissing [] = ""+    renderMissing [onlyPart] = onlyPart+    renderMissing [firstPart, secondPart] = firstPart <> " and " <> secondPart+    renderMissing parts = T.intercalate ", " (init parts) <> ", and " <> last parts++    states = Set.fromList (map stName (aggStates agg))+    terminals = Set.fromList [stName s | s <- aggStates agg, stTerminal s]+    commandFields :: Map Name [Name]+    commandFields = Map.fromList [(cmdName c, map aggregateFieldName (cmdFields c)) | c <- aggCommands agg]+    commandNames = Map.keysSet commandFields+    eventNames = Set.fromList (map evName (aggEvents agg))+    enumCtorNames = Set.fromList [c | e <- specEnums spec, (c, _) <- enumCtors e]+    ruleNames = Set.fromList (map ruleName (specRules spec))+    registerNames = Set.fromList (map regName (aggRegs agg))++    eventFieldsFor event =+      case evBody event of+        EventFields fields -> fields+        EventFromCommand commandName ->+          [ field+          | command <- aggCommands agg,+            cmdName command == commandName,+            field <- cmdFields command+          ]++    fieldWireKeyRules =+      concat+        [ wireKeyRulesForRecord+            ("aggregate '" <> aggName agg <> "' command '" <> cmdName command <> "'")+            Nothing+            (map resolveAggregateFieldIdentity (cmdFields command))+        | command <- aggCommands agg+        ]+        <> concat+          [ wireKeyRulesForRecord+              ("aggregate '" <> aggName agg <> "' event '" <> evName event <> "'")+              (Just ("kind", "event envelope key"))+              (map resolveAggregateFieldIdentity (eventFieldsFor event))+          | event <- aggEvents agg+          ]++    snapshotRules = case aggSnapshot agg of+      Nothing -> []+      Just snapshot ->+        [ mkErr (locLine (snapLoc snapshot)) SnapshotIntervalInvalid $+            "aggregate '" <> aggName agg <> "': snapshot every requires an interval of at least 1; non-positive runtime intervals silently disable snapshots"+        | SnapEvery interval <- [snapPolicy snapshot],+          interval < 1+        ]+          ++ [ mkErr (locLine (snapLoc snapshot)) SnapshotCodecFixtureInvalid $+                 "aggregate '" <> aggName agg <> "': snapshot state-codec version must be at least 1 and shape-hash must be non-empty"+             | snapCodecVersion snapshot < 1 || T.null (snapShapeHash snapshot)+             ]++    wirePolicyRules = case aggWire agg of+      Just wire+        | enforcesSpecSurfaceClosures languageContract,+          wireKind wire /= "ctorName" || wireFields wire /= "camelCase" ->+            [ mkErr (locLine (aggLoc agg)) WireClauseUnsupported $+                "aggregate '"+                  <> aggName agg+                  <> "' wire clause describes kind="+                  <> wireKind wire+                  <> " fields="+                  <> wireFields wire+                  <> "; generated bytes currently support only kind=ctorName fields=camelCase"+            ]+      _ -> []++    duplicateMembers =+      [ mkErr (locLine (cmdLoc c)) DuplicateCommandName $+          "aggregate '" <> aggName agg <> "' declares command '" <> cmdName c <> "' more than once"+      | c <- duplicatesBy cmdName (aggCommands agg)+      ]+        ++ [ mkErr (locLine (evLoc e)) DuplicateEventName $+               "aggregate '" <> aggName agg <> "' declares event '" <> evName e <> "' more than once"+           | e <- duplicatesBy evName (aggEvents agg)+           ]+        ++ [ mkErr (locLine (aggregateFieldLoc field)) AggregateDuplicateFieldName $+               "aggregate '" <> aggName agg <> "' command '" <> cmdName command <> "' declares field '" <> aggregateFieldName field <> "' more than once"+           | command <- aggCommands agg,+             field <- duplicatesBy aggregateFieldName (cmdFields command)+           ]+        ++ [ mkErr (locLine (aggregateFieldLoc field)) AggregateDuplicateFieldName $+               "aggregate '" <> aggName agg <> "' event '" <> evName event <> "' declares field '" <> aggregateFieldName field <> "' more than once"+           | event <- aggEvents agg,+             EventFields fields <- [evBody event],+             field <- duplicatesBy aggregateFieldName fields+           ]+        ++ [ mkErr (locLine (stLoc state)) AggregateDuplicateState $+               "aggregate '" <> aggName agg <> "' declares state '" <> stName state <> "' more than once"+           | state <- duplicatesBy stName (aggStates agg)+           ]+        ++ [ mkErr (locLine (regLoc register)) AggregateDuplicateRegister $+               "aggregate '" <> aggName agg <> "' declares register '" <> regName register <> "' more than once"+           | enforcesSpecSurfaceClosures languageContract,+             register <- duplicatesBy regName (aggRegs agg)+           ]+        ++ [ mkErr (locLine (tLoc transition)) TransitionDuplicateUnguarded $+               "aggregate '"+                 <> aggName agg+                 <> "' has more than one live unguarded transition for '"+                 <> tSource transition+                 <> " -- "+                 <> tCommand transition+                 <> "'; every matching command would be ambiguous"+           | group <- duplicateGroupsBy transitionKey unguardedTransitions,+             transition <- group+           ]+        ++ [ mkErr (locLine (tLoc guarded)) TransitionUnguardedSibling $+               "aggregate '"+                 <> aggName agg+                 <> "' guarded transition '"+                 <> tSource guarded+                 <> " -- "+                 <> tCommand guarded+                 <> "' overlaps an unguarded sibling at line "+                 <> tInt (locLine (tLoc unguarded))+           | enforcesSpecSurfaceClosures languageContract,+             guarded <- liveTransitions,+             tGuard guarded /= Nothing,+             unguarded : _ <- [[candidate | candidate <- unguardedTransitions, transitionKey candidate == transitionKey guarded]]+           ]+    liveTransitions = [transition | transition <- aggTransitions agg, tMode transition == TmLive]+    unguardedTransitions = [transition | transition <- liveTransitions, tGuard transition == Nothing]+    transitionKey transition = (tSource transition, tCommand transition)++    eventBodyRefs =+      [ mkErr (locLine (evLoc e)) UndeclaredCommand $+          "event '" <> evName e <> "' copies fields from undeclared command '" <> command <> "'"+      | e <- aggEvents agg,+        EventFromCommand command <- [evBody e],+        command `Set.notMember` commandNames+      ]++    outputMappingRules =+      [ mkErr (locLine (tLoc transition)) EventOutputCommandMismatch $+          "transition '"+            <> tSource transition+            <> " -- "+            <> consuming+            <> "' emits event '"+            <> eventName+            <> "' declared as fields("+            <> declared+            <> "); generated identity output is legal only when the transition consumes that same command"+      | transition <- aggTransitions agg,+        (emitIndex, eventName) <- zip [1 ..] (tEmits transition),+        Left OutputCommandMismatch {declaredSourceCommand = declared, consumingTransitionCommand = consuming} <- [eventOutputMappingFromGraphResult typeGraphResult spec agg transition emitIndex eventName]+      ]++    registerInitialScope = concatMap checkRegisterInitial (aggRegs agg)+    checkRegisterInitial r = case [e | e <- specEnums spec, TRef (enumName e) == regType r] of+      (e : _) -> case enumBinding e of+        Just _ ->+          [ outOfScope r "declaration-owned symbol selected by" "initial"+          | regInitialBare r /= Just "initial"+          ]+        Nothing ->+          [ outOfScope r "constructor of enum" (enumName e)+          | regInitialBare r `notElem` map (Just . fst) (enumCtors e)+          ]+      []+        | regType r == TRef (aggName agg <> "Vertex") ->+            [ outOfScope r "state of aggregate" (aggName agg)+            | maybe True (`Set.notMember` states) (regInitialBare r)+            ]+        | Just identifier <- firstMatching (\declaration -> regType r == TRef (idName declaration)) (specIds spec) -> case idBinding identifier of+            Just _ ->+              [ outOfScope r "declaration-owned symbol selected by" "initial"+              | regInitialBare r /= Just "initial"+              ]+            Nothing ->+              [ outOfScope r "literal" "placeholder"+              | regInitialBare r /= Just "placeholder"+              ]+        | otherwise -> []+    outOfScope r expected domain =+      mkErr (locLine (regLoc r)) RegisterInitialOutOfScope $+        "register '" <> regName r <> "' initial '" <> renderRegInitial (regInitial r) <> "' is not a " <> expected <> " '" <> domain <> "'"+    regInitialBare r = case regInitial r of+      RegInitBare value -> Just value+      RegInitText _ -> Nothing+    renderRegInitial = \case+      RegInitBare value -> value+      RegInitText value -> value++    -- Rule 1: declared-reference for command / emit / goto / source.+    declaredRefs =+      concatMap transitionRefs (aggTransitions agg)+    transitionRefs t =+      [ mkErr (locLine (tLoc t)) UndeclaredCommand $+          "transition references undeclared command '" <> tCommand t <> "'"+      | not (tCommand t `Set.member` commandNames)+      ]+        ++ [ mkErr (locLine (tLoc t)) UndeclaredState $+               "transition source '" <> tSource t <> "' is not a declared state"+           | not (tSource t `Set.member` states)+           ]+        ++ [ mkErr (locLine (tLoc t)) UndeclaredState $+               "transition goto '" <> tGoto t <> "' is not a declared state"+           | not (tGoto t `Set.member` states)+           ]+        ++ [ mkErr (locLine (tLoc t)) UndeclaredEvent $+               "emit references undeclared event '" <> ev <> "'"+           | ev <- tEmits t,+             not (ev `Set.member` eventNames)+           ]++    -- Rule 2: reachability of every non-terminal state from the initial state+    -- (the first state in the list).+    reachability = case map stName (aggStates agg) of+      [] -> []+      (initial : _) ->+        let reached = bfs (Set.singleton initial) [initial]+         in [ mkErr (locLine (stLoc s)) UnreachableState $+                "state '" <> stName s <> "' is not reachable from the initial state '" <> initial <> "'"+            | s <- aggStates agg,+              not (stTerminal s),+              not (stName s `Set.member` reached)+            ]+    edgesFrom src = [tGoto t | t <- aggTransitions agg, tSource t == src]+    bfs seen [] = seen+    bfs seen (x : xs) =+      let nexts = [n | n <- edgesFrom x, not (n `Set.member` seen)]+       in bfs (foldr Set.insert seen nexts) (xs ++ nexts)++    -- Rule 3: a terminal state has no outgoing transition.+    terminalNoOutgoing =+      [ mkErr (locLine (tLoc t)) TerminalHasOutgoing $+          "terminal state '" <> tSource t <> "' has an outgoing transition"+      | t <- aggTransitions agg,+        tSource t `Set.member` terminals+      ]++    -- Rule 4: every atom in a guard or write Expr resolves to a register, a+    -- field of the transition's command, an enum constructor, a rule, or a bool.+    guardScope = concatMap transitionScope (aggTransitions agg)+    transitionScope t =+      let inScope =+            registerNames+              `Set.union` Set.fromList (Map.findWithDefault [] (tCommand t) commandFields)+              `Set.union` enumCtorNames+              `Set.union` ruleNames+              -- State names are constructors of the implicit vertex enum, so a+              -- @write reservationState := Held@ references a state legitimately.+              `Set.union` states+          exprs = maybe [] pure (tGuard t) ++ map snd (tWrites t)+          badAtoms =+            [ n+            | e <- exprs,+              n <- exprNames e,+              not (n `Set.member` clockAtoms), -- clock atoms reported separately+              not (n `Set.member` inScope)+            ]+          badTargets = [target | (target, _) <- tWrites t, target `Set.notMember` registerNames]+       in [ mkErr (locLine (tLoc t)) WriteTargetNotRegister $+              "write target '" <> target <> "' is not a register of aggregate '" <> aggName agg <> "'"+          | target <- dedup badTargets+          ]+            ++ [ mkErr (locLine (tLoc t)) GuardAtomOutOfScope $+                   "atom '" <> n <> "' in transition '" <> tSource t <> " -- " <> tCommand t <> "' resolves to no register, command field, enum constructor, or rule"+               | n <- dedup badAtoms+               ]++    -- Rule 5 (cross-cutting): no guard or write Expr samples a wall clock.+    clockFree = concatMap transitionClock (aggTransitions agg)+    transitionClock t =+      let exprs = maybe [] pure (tGuard t) ++ map snd (tWrites t)+          sampled = [n | e <- exprs, n <- exprNames e, n `Set.member` clockAtoms]+       in [ mkErr (locLine (tLoc t)) ClockSampled $+              "transition '" <> tSource t <> " -- " <> tCommand t <> "' samples the wall clock via '" <> n <> "'; time must be an injected input field, not sampled"+          | n <- dedup sampled+          ]++    -- EP-107: a projection references a first-class read model when one exists.+    -- Legacy standalone projections remain legal, but are surfaced as warnings.+    projectionKeyResolution =+      [ mkErr (locLine (projLoc projection)) AggProjectionKeyUnresolved $+          "projection '" <> projTable projection <> "' key '" <> projKey projection <> "' is not a register, command field, or event field of aggregate '" <> aggName agg <> "'"+      | enforcesSpecSurfaceClosures languageContract,+        Just projection <- [aggProjection agg],+        projKey projection `Set.notMember` projectionFields+      ]+    projectionFields =+      registerNames+        `Set.union` Set.fromList [fieldDslName (resolveAggregateFieldIdentity field) | command <- aggCommands agg, field <- cmdFields command]+        `Set.union` Set.fromList [fieldDslName (resolveAggregateFieldIdentity field) | event <- aggEvents agg, field <- eventFieldsFor event]++    projectionSafety = case aggProjection agg of+      Nothing -> []+      Just projection -> case [readModel | NReadModel readModel <- specNodes spec, rmName readModel == projTable projection] of+        [] ->+          [ mkErr (locLine (projLoc projection)) RmStrongInlineOnly $+              "projection '" <> projTable projection <> "' declares consistency = Strong but has no readmodel node; a standalone projection is inline-only and has no subscription cursor"+          | projConsistency projection == Just Strong+          ]+            ++ [ Diagnostic+                   { line = locLine (projLoc projection),+                     severity = Warning,+                     code = RmProjectionWithoutNode,+                     relatedLocations = [],+                     message = "projection '" <> projTable projection <> "' has no readmodel node; registration, schema identity, consistency, and rebuild helpers are unavailable"+                   }+               ]+        (readModel : _) ->+          [ mkErr (locLine (projLoc projection)) RmConsistencyConflict $+              "projection '" <> projTable projection <> "' declares consistency " <> T.pack (show projectionConsistency) <> " but its readmodel node declares " <> T.pack (show readModelConsistency)+          | Just projectionConsistency <- [projConsistency projection],+            Just readModelConsistency <- [legacyReadModelConsistency readModel],+            projectionConsistency /= readModelConsistency+          ]++    -- Rule 6 (hole-kind 3, mapping): keys are exact event names, never suffixes;+    -- duplicates and dangling keys are errors, and non-partial maps are total.+    statusMapTotality = case aggProjection agg of+      Nothing -> []+      Just p ->+        let evs = map evName (aggEvents agg)+            pairs = maybe [] mapPairs (projStatusMap p)+            keys = map fst pairs+            partial = maybe False mapPartial (projStatusMap p)+            uncovered = [event | event <- evs, event `notElem` keys]+            dangling = [key | key <- keys, key `notElem` evs]+            duplicateKeys = map fst (duplicatesBy fst pairs)+         in [ mkErr (locLine (projLoc p)) StatusMapDanglingKey $+                "projection '" <> projTable p <> "' status-map key '" <> key <> "' is not an event name of aggregate '" <> aggName agg <> "'"+            | key <- dangling+            ]+              ++ [ mkErr (locLine (projLoc p)) StatusMapDuplicateKey $+                     "projection '" <> projTable p <> "' repeats status-map key '" <> key <> "'"+                 | key <- duplicateKeys+                 ]+              ++ [ mkErr (locLine (projLoc p)) StatusMapNotTotal $+                     "projection '" <> projTable p <> "' status-map is not total over events {" <> T.intercalate ", " uncovered <> "}"+                 | not partial,+                   not (null evs),+                   not (null uncovered)+                 ]++    -- EP-2 evolution rules (single-spec; the diff path adds the cross-spec ones).+    evolutionRules =+      versionUpcasterRule+        ++ upcasterChainGapRule+        ++ deprecatedEmitRule+        ++ eventRetirementRules+        ++ wireVersionRule+    -- Only live transitions are the write path: a replay-only transition can+    -- never fire forward, so its emits exist purely to invert stored events —+    -- which is exactly where a deprecated event is allowed to remain+    -- (plan 143; supersedes the guarded-but-inert retained-edge pattern).+    liveEmittedNames = Set.fromList (concatMap tEmits [t | t <- aggTransitions agg, tMode t == TmLive])+    replayEmittedNames = Set.fromList (concatMap tEmits [t | t <- aggTransitions agg, tMode t == TmReplayOnly])+    maxEventVersion = maximum (1 : map evVersion (aggEvents agg))+    upcasterSources =+      Set.fromList+        [ source+        | event <- aggEvents agg,+          Just (source, _) <- [evUpcastFrom event]+        ]++    -- A non-initial event version must carry a contiguous upcaster (from v-1).+    versionUpcasterRule =+      [ mkErr (locLine (evLoc e)) EvtVersionMissingUpcaster $+          "event '" <> evName e <> "' version " <> tInt (evVersion e) <> " has no 'upcast from v" <> tInt (evVersion e - 1) <> "' clause"+      | e <- aggEvents agg,+        evVersion e > 1,+        maybe True ((/= evVersion e - 1) . fst) (evUpcastFrom e)+      ]++    -- Aggregate schema stamps are global, so every source version below the+    -- current maximum needs a permanent rung regardless of which event owns it.+    upcasterChainGapRule =+      [ mkErr (locLine (aggLoc agg)) UpcasterChainGap $+          "no event declares 'upcast from v"+            <> tInt missing+            <> "'; stored payloads stamped v"+            <> tInt missing+            <> " can never reach v"+            <> tInt maxEventVersion+            <> " (GapInUpcasterChain at hydration). A rung, once shipped, must exist forever — restore the upcaster for v"+            <> tInt missing+            <> " (re-declare it on the event whose shape changed at v"+            <> tInt (missing + 1)+            <> ")"+      | missing <- [1 .. maxEventVersion - 1],+        missing `Set.notMember` upcasterSources+      ]++    -- A deprecated event must have left the write path.+    deprecatedEmitRule =+      [ mkErr (locLine (evLoc e)) DeprecatedEventStillEmitted $+          "deprecated event '" <> evName e <> "' is still emitted by a transition"+      | e <- aggEvents agg,+        evDeprecated e,+        evName e `Set.member` liveEmittedNames+      ]++    -- Retirement is a two-stage protocol. The pre-cutover marker keeps a live+    -- emitter. The deprecated stage removes that live emitter but retains a+    -- replay-only emitter until old payloads no longer need hydration.+    eventRetirementRules = concatMap eventRetirementRule (aggEvents agg)+    eventRetirementRule event+      | evRetiring event =+          [ mkErr (locLine (evLoc event)) EventRetirementInProgress $+              "retiring event '" <> evName event <> "' has no live emitting transition; keep it emitting while streams are terminalized or truncated, or cut over to 'deprecated event' with a replay-only emitting transition"+          | evName event `Set.notMember` liveEmittedNames+          ]+            ++ [ Diagnostic+                   { line = locLine (evLoc event),+                     severity = Warning,+                     code = EventRetirementInProgress,+                     relatedLocations = [],+                     message =+                       "event '" <> evName event <> "' is retiring: it stays fully live and replayable. Keep its live emitting transition until every affected stream is terminal or truncated; then flip it to 'deprecated event' and retain an equivalent replay-only emitting transition for as long as old payloads may be hydrated"+                   }+               | evName event `Set.member` liveEmittedNames+               ]+      | evDeprecated event =+          [ Diagnostic+              { line = locLine (evLoc event),+                severity = Warning,+                code = DeprecatedEventReplayHazard,+                relatedLocations = [],+                message =+                  "deprecated event '" <> evName event <> "' stays decodable but is not replayable: no replay-only transition emits it, so hydration of a live stream containing it fails with HydrationNoInvertingEdge. Restore an equivalent replay-only emitting transition, or terminalize/truncate every affected stream before deployment"+              }+          | any (not . stTerminal) (aggStates agg),+            evName event `Set.notMember` replayEmittedNames+          ]+            ++ [ Diagnostic+                   { line = locLine (evLoc event),+                     severity = Warning,+                     code = EventRetirementInProgress,+                     relatedLocations = [],+                     message =+                       "deprecated event '" <> evName event <> "' is off the live write path and remains replayable through a replay-only transition; retain that transition until every stream containing the event is terminal, truncated, or passes the replay audit"+                   }+               | evName event `Set.member` replayEmittedNames+               ]+      | otherwise = []++    -- The explicit `wire schemaVersion=` (if any) must equal the max event version.+    wireVersionRule = case aggWire agg of+      Just w+        | wireSchemaVersion w /= maxEventVersion ->+            [ Diagnostic+                { line = locLine (aggLoc agg),+                  severity = Warning,+                  code = WireSchemaVersionMismatch,+                  relatedLocations = [],+                  message =+                    "wire schemaVersion=" <> tInt (wireSchemaVersion w) <> " does not match the maximum event version " <> tInt maxEventVersion+                }+            ]+      _ -> []++    -- Plan 143: replay-only transition discipline. A replay-only transition+    -- exists to invert stored events, so one that emits nothing is dead+    -- weight (error); one whose (source, command) pair has no live sibling+    -- means the command is fully retired at that state — legitimate, but the+    -- fuller procedure is event retirement (docs/plans/139), so warn.+    replayOnlyRules = concatMap replayOnlyRule (aggTransitions agg)+    replayOnlyRule t+      | tMode t /= TmReplayOnly = []+      | otherwise =+          [ mkErr (locLine (tLoc t)) ReplayOnlyEmitsNothing $+              "replay-only transition '" <> tSource t <> " -- " <> tCommand t <> "' emits no event; a replay-only transition exists to invert stored events and is dead weight without an emit"+          | null (tEmits t)+          ]+            ++ [ Diagnostic+                   { line = locLine (tLoc t),+                     severity = Warning,+                     code = ReplayOnlyCommandStillLive,+                     relatedLocations = [],+                     message =+                       "replay-only transition '" <> tSource t <> " -- " <> tCommand t <> "' has no live sibling; command '" <> tCommand t <> "' is fully retired at state '" <> tSource t <> "' — if the intent is to retire its events too, follow the event-retirement procedure (docs/plans/139)"+                   }+               | not (any (\sibling -> tMode sibling == TmLive && tSource sibling == tSource t && tCommand sibling == tCommand t) (aggTransitions agg))+               ]++    eventlessStateChangeRules =+      [ mkErr (locLine (tLoc transition)) AggregateEventlessStateChange $+          "transition '"+            <> tSource transition+            <> " -- "+            <> tCommand transition+            <> "' emits no event but changes "+            <> changeDescription transition+            <> "; event-sourced state changes require persisted evidence, while a no-op must keep both vertex and registers unchanged"+      | transition <- aggTransitions agg,+        null (tEmits transition),+        tSource transition /= tGoto transition || not (null (tWrites transition))+      ]+    changeDescription transition+      | tSource transition /= tGoto transition && not (null (tWrites transition)) = "the target vertex and registers"+      | tSource transition /= tGoto transition = "the target vertex"+      | otherwise = "registers"++    domainOutcomeRules =+      declarationRules+        ++ concatMap transitionOutcomeRules (aggTransitions agg)+      where+        declarationRules =+          [ mkErr (locLine loc) DomainOutcomeDeclarationDuplicate $+              "aggregate '" <> aggName agg <> "' declares domain-outcomes more than once"+          | loc <- aggDomainOutcomeDuplicateLocs agg+          ]+            ++ case aggDomainOutcomeTypes agg of+              Nothing ->+                [ mkErr (locLine (transitionOutcomeLoc outcome)) DomainOutcomeDeclarationMissing $+                    "transition '" <> tSource transition <> " -- " <> tCommand transition <> "' declares an outcome but aggregate '" <> aggName agg <> "' has no domain-outcomes declaration"+                | transition <- aggTransitions agg,+                  Just outcome <- [tOutcome transition]+                ]+              Just _ -> []++        transitionOutcomeRules transition =+          [ mkErr (locLine loc) DomainOutcomeClauseDuplicate $+              "transition '" <> tSource transition <> " -- " <> tCommand transition <> "' declares outcome more than once"+          | loc <- tOutcomeDuplicateLocs transition+          ]+            ++ case (aggDomainOutcomeTypes agg, tMode transition, tOutcome transition) of+              (Just _, TmLive, Nothing) ->+                [ mkErr (locLine (tLoc transition)) DomainOutcomeClauseMissing $+                    "live transition '" <> tSource transition <> " -- " <> tCommand transition <> "' is missing its required outcome clause"+                ]+              (Just _, TmReplayOnly, Just outcome) ->+                [ mkErr (locLine (transitionOutcomeLoc outcome)) DomainOutcomeReplayOnlyClause $+                    "replay-only transition '" <> tSource transition <> " -- " <> tCommand transition <> "' cannot declare a forward command outcome"+                ]+              (Just _, TmLive, Just (OutcomeAccepted loc)) ->+                [ mkErr (locLine loc) DomainOutcomeAcceptedWithoutEvents $+                    "accepted transition '" <> tSource transition <> " -- " <> tCommand transition <> "' must emit at least one event"+                | null (tEmits transition)+                ]+              (Just _, TmLive, Just outcome@OutcomeRejected {}) -> silentRules outcome+              (Just _, TmLive, Just outcome@OutcomeNoOp {}) -> silentRules outcome+              _ -> []+          where+            silentRules outcome =+              [ mkErr (locLine (transitionOutcomeLoc outcome)) DomainOutcomeSilentEmits $+                  "silent transition '" <> tSource transition <> " -- " <> tCommand transition <> "' cannot emit events"+              | not (null (tEmits transition))+              ]+                ++ [ mkErr (locLine (transitionOutcomeLoc outcome)) DomainOutcomeSilentWrites $+                       "silent transition '" <> tSource transition <> " -- " <> tCommand transition <> "' cannot write aggregate registers"+                   | not (null (tWrites transition))+                   ]+                ++ [ mkErr (locLine (transitionOutcomeLoc outcome)) DomainOutcomeSilentStateChange $+                       "silent transition '" <> tSource transition <> " -- " <> tCommand transition <> "' must preserve its source state"+                   | tGoto transition /= tSource transition+                   ]  -- | The validator's re-derivation of the live -- 'Keiro.PGMQ.Runtime.queueRef' trio: physical queue, dead-letter queue, and

src/Keiro/Dsl/Workspace.hs view

@@ -65,8 +65,10 @@     composeWorkspace,     oneMemberWorkspace,     oneMemberParsedWorkspace,+    oneMemberParsedDocumentWorkspace,     checkedWorkspace,     checkWorkspace,+    checkWorkspaceForService,      -- * Multi-file diagnostics     WorkspaceDiagnostic (..),@@ -101,12 +103,23 @@ import GHC.Generics import Keiro.Dsl.Grammar import Keiro.Dsl.LanguageVersion (ParsedSource (..), SourceLanguage (..), SourceLanguageDiagnostic, effectiveLanguageVersion, languageVersionText)-import Keiro.Dsl.Parser (ParseError, ParseFailure (..), parseSource, renderParseFailure)+import Keiro.Dsl.Parser (ParseError, ParseFailure (..), parseSourceDocument, renderParseFailure) import Keiro.Dsl.RuntimePackage (RuntimePackageName (..), mkRuntimePackageName) import Keiro.Dsl.Scaffold (Context (..))-import Keiro.Dsl.ScaffoldRun (Refusal (..), originLine, planServiceScaffoldWithRuntimePackageAndGoldens, planningRefusalDiagnostics)-import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, checkedSource, effectiveLanguageContract)+import Keiro.Dsl.ScaffoldRun (Refusal (..), originLine, planIndexedServiceScaffoldWithRuntimePackageAndGoldens, planningRefusalDiagnostics)+import Keiro.Dsl.SemanticContract (CheckedService, EffectiveLanguageContract, checkedLanguageContract, checkedServiceForContract, checkedSource, effectiveLanguageContract)+import Keiro.Dsl.Source (SourcePoint (..), SourceSpan (..))+import Keiro.Dsl.SourceIndex+  ( ParsedSourceDocument (..),+    SemanticSourceIndex,+    SourceIndexFailure (..),+    compatibilitySemanticSourceIndex,+    emptySemanticSourceIndex,+    repathSemanticSourceIndex,+    unionSemanticSourceIndexes,+  ) import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), Severity (..), nodeIdentity, validateService)+import Numeric.Natural (Natural) import System.Directory (doesFileExist) import System.FilePath (takeBaseName, takeDirectory, takeFileName, (</>)) import Text.Megaparsec hiding (ParseError)@@ -467,6 +480,9 @@ instance HasLocs Integer where   traverseLocs _ = pure +instance HasLocs Natural where+  traverseLocs _ = pure+ instance HasLocs Double where   traverseLocs _ = pure @@ -636,6 +652,9 @@     wmSpec :: !Spec,     -- | The member's declared-versus-legacy source contract.     wmSourceLanguage :: !SourceLanguage,+    -- | Exact member-local semantic source provenance, using the normalized+    -- manifest-relative member path.+    wmSourceIndex :: !SemanticSourceIndex,     -- | Added to this member's lines to place them in the merged spec.     wmLineBase :: !Int,     -- | Source lines in the member file.@@ -668,6 +687,8 @@     -- | Canonical order.     wsMembers :: ![WorkspaceMember],     wsMergedSpec :: !Spec,+    -- | Checked union of the members' exact, unrelocated source indices.+    wsSourceIndex :: !SemanticSourceIndex,     wsLineMap :: !LineMap,     wsOwnership :: !OwnershipIndex   }@@ -697,6 +718,21 @@ -- | Preserve provenance when adapting one parsed source to workspace consumers. oneMemberParsedWorkspace :: FilePath -> ParsedSource -> WorkspaceSpec oneMemberParsedWorkspace path parsedSource =+  oneMemberWithIndex path parsedSource compatibilityIndex+  where+    relative = takeFileName path+    compatibilityIndex =+      either (const emptySemanticSourceIndex) id (compatibilitySemanticSourceIndex relative (parsedSpec parsedSource))++-- | Adapt an exact parsed document to one-member workspace semantics while+-- normalizing its index source path to the member path.+oneMemberParsedDocumentWorkspace :: FilePath -> ParsedSourceDocument -> Either SourceIndexFailure WorkspaceSpec+oneMemberParsedDocumentWorkspace path ParsedSourceDocument {documentParsedSource = parsedSource, documentSourceIndex = sourceIndex} = do+  normalized <- repathSemanticSourceIndex path (takeFileName path) sourceIndex+  pure (oneMemberWithIndex path parsedSource normalized)++oneMemberWithIndex :: FilePath -> ParsedSource -> SemanticSourceIndex -> WorkspaceSpec+oneMemberWithIndex path parsedSource sourceIndex =   WorkspaceSpec     { wsService = T.pack (takeBaseName path),       wsManifestPath = path,@@ -710,11 +746,13 @@             { wmPath = relative,               wmSpec = spec,               wmSourceLanguage = parsedSourceLanguage parsedSource,+              wmSourceIndex = sourceIndex,               wmLineBase = 0,               wmLineCount = maximum (0 : collectLocs spec)             }         ],       wsMergedSpec = spec,+      wsSourceIndex = sourceIndex,       wsLineMap = LineMap [(0, maxBound, relative)],       wsOwnership = ownershipOf [(relative, spec)]     }@@ -728,10 +766,7 @@ -- contract, so downstream consumers need not inspect member provenance. checkedWorkspace :: WorkspaceSpec -> CheckedService checkedWorkspace workspace =-  CheckedService-    { checkedLanguageContract = wsLanguageContract workspace,-      checkedSpec = wsMergedSpec workspace-    }+  checkedServiceForContract (wsLanguageContract workspace) (wsMergedSpec workspace)  -- | Validate a composed workspace. This runs the /existing/ whole-spec -- validator over the merged spec once and maps each diagnostic's line back@@ -739,6 +774,10 @@ -- on what counts as valid. checkWorkspace :: WorkspaceSpec -> [WorkspaceDiagnostic] checkWorkspace workspace =+  checkWorkspaceForService workspace (checkedWorkspace workspace)++checkWorkspaceForService :: WorkspaceSpec -> CheckedService -> [WorkspaceDiagnostic]+checkWorkspaceForService workspace service =   [ WorkspaceDiagnostic       { wdLocations =           locationFor (line diagnostic)@@ -750,7 +789,7 @@         wdSourceLanguageCause = Nothing,         wdMessage = message diagnostic       }-  | diagnostic <- validateService (checkedWorkspace workspace)+  | diagnostic <- validateService service   ]   where     locationFor n = case resolveWorkspaceLine workspace n of@@ -785,7 +824,7 @@ composeWorkspace ::   FilePath ->   WorkspaceManifest ->-  [(FilePath, Text, ParsedSource)] ->+  [(FilePath, Text, ParsedSourceDocument)] ->   Either (NonEmpty WorkspaceDiagnostic) WorkspaceSpec composeWorkspace manifestPath manifest supplied   | (d : ds) <- unsupplied = Left (d :| ds)@@ -793,7 +832,7 @@   | otherwise = Right composed   where     ordered =-      [ (ref, lookup (wmrPath ref) [(path, (text, parsedSource)) | (path, text, parsedSource) <- supplied])+      [ (ref, lookup (wmrPath ref) [(path, (text, document)) | (path, text, document) <- supplied])       | ref <- NE.toList (wmfMembers manifest)       ]     unsupplied =@@ -807,10 +846,46 @@       | (ref, Nothing) <- ordered       ]     entries =-      [ (ref, text, parsedSourceLanguage parsedSource, parsedSpec parsedSource)-      | (ref, Just (text, parsedSource)) <- ordered+      [ (ref, text, parsedSourceLanguage parsedSource, parsedSpec parsedSource, sourceIndex)+      | (ref, Just (text, ParsedSourceDocument {documentParsedSource = parsedSource, documentSourceIndex = sourceIndex})) <- ordered       ] +    qualifiedIndexResults =+      [ ( ref,+          repathSemanticSourceIndex+            (workspaceDisplayPath manifestPath (WorkspaceMemberFile (wmrPath ref)))+            (wmrPath ref)+            sourceIndex+        )+      | (ref, _, _, _, sourceIndex) <- entries+      ]+    memberSourceIndexRefusals =+      [ WorkspaceDiagnostic+          { wdLocations = pure (memberLocation ref (sourceIndexFailureLine indexFailure) ""),+            wdSeverity = Error,+            wdCode = WorkspaceSourceIndexInvalid,+            wdSourceLanguageCause = Nothing,+            wdMessage = "workspace member source index is incoherent: " <> sourceIndexFailureText indexFailure+          }+      | (ref, Left indexFailure) <- qualifiedIndexResults+      ]+    qualifiedIndexes = [index | (_, Right index) <- qualifiedIndexResults]+    workspaceSourceIndexResult = unionSemanticSourceIndexes qualifiedIndexes+    unionSourceIndexRefusals = case workspaceSourceIndexResult of+      Left indexFailure ->+        [ WorkspaceDiagnostic+            { wdLocations = pure (sourceIndexFailureLocation indexFailure),+              wdSeverity = Error,+              wdCode = WorkspaceSourceIndexInvalid,+              wdSourceLanguageCause = Nothing,+              wdMessage = "workspace source-index union is incoherent: " <> sourceIndexFailureText indexFailure+            }+        ]+      Right _ -> []+    sourceIndexRefusals = memberSourceIndexRefusals <> unionSourceIndexRefusals+    sourceIndexFor ref =+      fromMaybe emptySemanticSourceIndex (lookup (wmrPath ref) [(wmrPath candidate, index) | (candidate, Right index) <- qualifiedIndexResults])+     refusals =       languageRefusals         <> contextRefusals@@ -818,12 +893,13 @@         <> layoutRefusals         <> declarationRefusals         <> nodeRefusals+        <> sourceIndexRefusals         <> collisionRefusals      --------------------------------------------------------------------------     -- Effective source language and context     ---------------------------------------------------------------------------    effectiveVersions = nub [effectiveLanguageVersion sourceLanguage | (_, _, sourceLanguage, _) <- entries]+    effectiveVersions = nub [effectiveLanguageVersion sourceLanguage | (_, _, sourceLanguage, _, _) <- entries]     languageRefusals       | length effectiveVersions <= 1 = []       | otherwise =@@ -834,7 +910,7 @@                         ref                         (sourceLanguageLine text sourceLanguage)                         ("member selects effective language version " <> languageVersionText (effectiveLanguageVersion sourceLanguage))-                    | (ref, text, sourceLanguage, _) <- entries+                    | (ref, text, sourceLanguage, _, _) <- entries                     ],                 wdSeverity = Error,                 wdCode = WorkspaceLanguageVersionMismatch,@@ -848,9 +924,9 @@     sourceLanguageLine text LegacyUnversioned = clauseLine "context" text     sourceLanguageLine _ DeclaredLanguage {languageVersionLoc = Loc lineNumber} = Just lineNumber -    declaredContexts = nub [specContext spec | (_, _, _, spec) <- entries]+    declaredContexts = nub [specContext spec | (_, _, _, spec, _) <- entries]     effectiveContext = case entries of-      (_, _, _, spec) : _ -> specContext spec+      (_, _, _, spec, _) : _ -> specContext spec       [] -> ""     contextRefusals       | length declaredContexts <= 1 = []@@ -859,7 +935,7 @@               { wdLocations =                   NE.fromList                     [ memberLocation ref (clauseLine "context" text) ("member declares context '" <> specContext spec <> "'")-                    | (ref, text, _, spec) <- entries+                    | (ref, text, _, spec, _) <- entries                     ],                 wdSeverity = Error,                 wdCode = WorkspaceContextMismatch,@@ -925,7 +1001,7 @@           where             disagreeing =               [ (ref, text, value)-              | (ref, text, _, spec) <- entries,+              | (ref, text, _, spec, _) <- entries,                 Just value <- [memberValue spec],                 value /= authority               ]@@ -950,7 +1026,7 @@                 ]               )           where-            declared = [(ref, text, value) | (ref, text, _, spec) <- entries, Just value <- [memberValue spec]]+            declared = [(ref, text, value) | (ref, text, _, spec, _) <- entries, Just value <- [memberValue spec]]       where         thd (_, _, value) = value @@ -959,7 +1035,7 @@     --------------------------------------------------------------------------     declarationSites =       [ (name, (namespace, ref, loc))-      | (ref, _, _, spec) <- entries,+      | (ref, _, _, spec, _) <- entries,         (namespace, name, loc) <- sharedDeclarations spec       ]     declarationRefusals =@@ -983,7 +1059,7 @@      nodeSites =       [ ((kind, name), (ref, loc))-      | (ref, _, _, spec) <- entries,+      | (ref, _, _, spec, _) <- entries,         node <- specNodes spec,         let (kind, name, loc) = nodeIdentity node       ]@@ -1011,17 +1087,18 @@     --------------------------------------------------------------------------     -- Merged spec and line map     ---------------------------------------------------------------------------    lineCounts = [max 1 (length (T.lines text)) | (_, text, _, _) <- entries]+    lineCounts = [max 1 (length (T.lines text)) | (_, text, _, _, _) <- entries]     lineBases = scanl (+) 0 lineCounts     members =       [ WorkspaceMember           { wmPath = wmrPath ref,             wmSpec = spec,             wmSourceLanguage = sourceLanguage,+            wmSourceIndex = sourceIndexFor ref,             wmLineBase = base,             wmLineCount = memberLines           }-      | ((ref, _, sourceLanguage, spec), base, memberLines) <- zip3 entries lineBases lineCounts+      | ((ref, _, sourceLanguage, spec, _), base, memberLines) <- zip3 entries lineBases lineCounts       ]     relocatedSpecs = [relocateLocs (shiftBy (wmLineBase member)) (wmSpec member) | member <- members]     -- The placeholder location 'Loc 0' must stay 0: shifting it would land it@@ -1061,10 +1138,11 @@       -- Only ask the scaffold planner about a spec that already validates.       -- An invalid merged spec is 'checkWorkspace''s report to make, and the       -- planner is only designed to see specs that passed validation.-      | any blocksCollisionPlanning (validateService (checkedWorkspace composed)) = []-      | otherwise = case planServiceScaffoldWithRuntimePackageAndGoldens [] (wmfRuntimePackage manifest) plannerContext (checkedWorkspace composed) of+      | any blocksCollisionPlanning (validateService collisionService) = []+      | otherwise = case planIndexedServiceScaffoldWithRuntimePackageAndGoldens [] (wmfRuntimePackage manifest) (wsSourceIndex composed) plannerContext collisionService of           Right _ -> []           Left plannerRefusals -> concatMap planningRefusal plannerRefusals+    collisionService = checkedWorkspace composed     planningRefusal refusal = case crossMemberCollision refusal of       [] -> map liftPlanningDiagnostic (planningRefusalDiagnostics [refusal])       workspaceDiagnostics -> workspaceDiagnostics@@ -1133,17 +1211,25 @@           wsLayout = effectiveLayout,           wsMembers = members,           wsMergedSpec = mergedSpec,+          wsSourceIndex = either (const emptySemanticSourceIndex) id workspaceSourceIndexResult,           wsLineMap = lineMap,           wsOwnership = ownershipOf [(wmPath member, wmSpec member) | member <- members]         }      effectiveSourceLanguage = case entries of-      (_, _, sourceLanguage, _) : _ -> sourceLanguage+      (_, _, sourceLanguage, _, _) : _ -> sourceLanguage       [] -> LegacyUnversioned      manifestLocation loc role = WorkspaceLocation WorkspaceManifestFile (max 1 (unLoc loc)) role     memberLocation ref found role =       WorkspaceLocation (WorkspaceMemberFile (wmrPath ref)) (fromMaybe 1 found) role+    sourceIndexFailureLine SourceIndexFailure {failureSpan} =+      fmap (\SourceSpan {start = SourcePoint {line}} -> line) failureSpan+    sourceIndexFailureLocation indexFailure@SourceIndexFailure {failureSpan} = case failureSpan of+      Just SourceSpan {source, start = SourcePoint {line}} -> WorkspaceLocation (WorkspaceMemberFile source) line ""+      Nothing -> WorkspaceLocation WorkspaceManifestFile 1 (sourceIndexFailureText indexFailure)+    sourceIndexFailureText SourceIndexFailure {failureCode, failureMessage} =+      T.pack (show failureCode) <> ": " <> failureMessage  -- | Group @(key, site)@ pairs by key, preserving first-appearance order. groupSites :: (Ord k) => [(k, v)] -> [(k, [v])]@@ -1264,7 +1350,7 @@       result <- csRead source (wmrPath ref)       pure $ case result of         Left reason -> Left (memberFailure ref WorkspaceMemberUnreadable ("workspace member '" <> T.pack (wmrPath ref) <> "' could not be read: " <> reason) Nothing)-        Right text -> case parseSource (workspaceDisplayPath manifestPath (WorkspaceMemberFile (wmrPath ref))) text of+        Right text -> case parseSourceDocument (workspaceDisplayPath manifestPath (WorkspaceMemberFile (wmrPath ref))) text of           Left parseFailure ->             Left               ( memberFailure@@ -1273,7 +1359,7 @@                   ("workspace member '" <> T.pack (wmrPath ref) <> "' failed to parse:\n" <> renderParseFailure parseFailure)                   (case parseFailure of SourceLanguageFailure diagnostic -> Just diagnostic; BodyGrammarFailure {} -> Nothing)               )-          Right parsedSource -> Right (wmrPath ref, text, parsedSource)+          Right document -> Right (wmrPath ref, text, document)     memberFailure ref failureCode note sourceLanguageCause =       WorkspaceDiagnostic         { wdLocations = pure (WorkspaceLocation WorkspaceManifestFile (max 1 (unLoc (wmrLoc ref))) ""),@@ -1314,6 +1400,8 @@  instance HasLocs ContractNode +instance HasLocs DomainOutcomeTypes+ instance HasLocs ContractType  instance HasLocs CorrelateDecl@@ -1406,10 +1494,42 @@  instance HasLocs ProjectionSpec +instance HasLocs ProjectionTargetNode++instance HasLocs RebuildGroupNode++instance HasLocs PromotionObjectKindNode++instance HasLocs PromotionObjectNode++instance HasLocs RevisionTargetNode++instance HasLocs ProjectionRevisionNode++instance HasLocs ExternalReadNode++instance HasLocs CatalogSource++instance HasLocs CheckpointOnMissingNode++instance HasLocs ProjectionReplayPolicy++instance HasLocs ProjectionDelivery++instance HasLocs ProjectionOwnerNode++instance HasLocs TargetResetPolicy+ instance HasLocs PublisherNode  instance HasLocs ReadModelNode +instance HasLocs QueryFreshnessNode++instance HasLocs ReadModelSupply++instance HasLocs ReadModelQueryTypes+ instance HasLocs RegDecl  instance HasLocs RegInitial@@ -1418,6 +1538,10 @@  instance HasLocs ResolveSource +instance HasLocs RouterSelectionDecl++instance HasLocs SelectionDispositionSyntax+ instance HasLocs RmColumn  instance HasLocs RmFeed@@ -1446,6 +1570,8 @@  instance HasLocs Transition +instance HasLocs TransitionOutcome+ instance HasLocs TransitionImplementation  instance HasLocs TransitionMode@@ -1475,6 +1601,10 @@ instance HasLocs WqDispRow  instance HasLocs WqField++instance HasLocs QueuePayloadType++instance HasLocs QueueScalar  instance HasLocs WqGroupKey

src/Keiro/Dsl/WorkspaceDiff.hs view

@@ -10,6 +10,9 @@     WorkspaceMeta (..),     WorkspaceDiffReport,     workspaceDiffReport,+    workspaceDiffReportWithSemanticImpact,+    workspaceDiffReportWithCoordinationImpact,+    workspaceDiffReportWithImpacts,     diffWorkspaces,     renderWorkspaceFinding,   )@@ -22,7 +25,7 @@ import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.Diff (Change (..), ChangeKind (..), advisoryAt, consumerBuildContext, diffServices, sourceLanguageChange)-import Keiro.Dsl.DiffReport (OwnedSite (..), WorkspaceChange (..), WorkspaceDiffReport, WorkspaceMeta (..), renderFinding, workspaceDiffReport)+import Keiro.Dsl.DiffReport (OwnedSite (..), WorkspaceChange (..), WorkspaceDiffReport, WorkspaceMeta (..), renderFinding, workspaceDiffReport, workspaceDiffReportWithCoordinationImpact, workspaceDiffReportWithImpacts, workspaceDiffReportWithSemanticImpact) import Keiro.Dsl.FoldFingerprint (FoldSurfaceError) import Keiro.Dsl.Grammar (Loc (..), Name, Placement (..)) import Keiro.Dsl.LanguageVersion (SourceLanguage (..))

src/Keiro/Dsl/WorkspaceRecord.hs view

@@ -63,12 +63,15 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as Text import Keiro.Dsl.BehaviorCoverage (BehaviorRecordRow (..))+import Keiro.Dsl.CoordinationImpact (RouterSelectionSnapshot (..)) import Keiro.Dsl.ExplainBindings (BindingHole (..)) import Keiro.Dsl.HaskellName (GeneratedHaskellNamingEdition (..), parseGeneratedHaskellNamingEdition, renderGeneratedHaskellNamingEdition) import Keiro.Dsl.LanguageVersion (SourceLanguage (..), declaredLanguageVersionMaybe, effectiveLanguageVersion, sourceFormText) import Keiro.Dsl.MappedConsumer (MappingIdentity (..))+import Keiro.Dsl.ReadModelQueryContract (QueryContractIdentity, queryContractIdentityKey) import Keiro.Dsl.Scaffold (ModuleKind (..), ModuleRole (..)) import Keiro.Dsl.SemanticContract (EffectiveLanguageContract, effectiveLanguageContract)+import Keiro.Dsl.SemanticImpact (SemanticImpactSnapshot) import Keiro.Dsl.SidecarNames qualified as SidecarNames import System.FilePath (isAbsolute, splitDirectories) @@ -206,7 +209,12 @@     wrNominalEqualities :: ![Text],     wrBindingObligations :: ![BindingHole],     wrBehaviorRequirements :: ![BehaviorRecordRow],-    wrAdopted :: ![AdoptedRow]+    wrProjectionCatalogFacts :: ![Text],+    wrQueryContractBaseline :: !Bool,+    wrQueryContracts :: ![QueryContractIdentity],+    wrRouterSelections :: ![RouterSelectionSnapshot],+    wrAdopted :: ![AdoptedRow],+    wrSemanticImpact :: !(Maybe SemanticImpactSnapshot)   }   deriving stock (Eq, Show) @@ -233,6 +241,11 @@       <> ["nominal-equality " <> identity | identity <- wrNominalEqualities record]       <> ["binding " <> encodeRow obligation | obligation <- wrBindingObligations record]       <> ["behavior " <> encodeRow requirement | requirement <- wrBehaviorRequirements record]+      <> ["projection-catalog-fact " <> fact | fact <- wrProjectionCatalogFacts record]+      <> ["query-contract-baseline v1" | wrQueryContractBaseline record]+      <> ["query-contract " <> encodeRow identity | identity <- wrQueryContracts record]+      <> ["router-selection " <> encodeRow selection | selection <- wrRouterSelections record]+      <> ["semantic-impact " <> encodeRow snapshot | Just snapshot <- [wrSemanticImpact record]]       <> ["adopted " <> encodeRow adopted | adopted <- wrAdopted record]   where     rootLabel = if T.null (wrModuleRoot record) then "(none)" else wrModuleRoot record@@ -265,6 +278,11 @@         let nominalEqualities = [identity | row <- rows, Just identity <- [T.stripPrefix "nominal-equality " row]]         obligations <- traverse (decodeRow "binding ") (rowsWith "binding " rows)         behaviorRequirements <- traverse (decodeRow "behavior ") (rowsWith "behavior " rows)+        let catalogFacts = [fact | row <- rows, Just fact <- [T.stripPrefix "projection-catalog-fact " row]]+        queryContractBaseline <- parseQueryContractBaseline rows+        queryContracts <- traverse (decodeRow "query-contract ") (rowsWith "query-contract " rows)+        routerSelections <- traverse (decodeRow "router-selection ") (rowsWith "router-selection " rows)+        semanticImpact <- parseSemanticImpact rows         adopted <- traverse (decodeRow "adopted ") (rowsWith "adopted " rows)         checkedAdopted <- traverse checkedAdoption adopted         if hasDuplicates members@@ -274,6 +292,9 @@           || hasDuplicates nominalEqualities           || hasDuplicates (map bindingKey obligations)           || hasDuplicates (map behaviorRecordKey behaviorRequirements)+          || hasDuplicates catalogFacts+          || hasDuplicates (map queryContractIdentityKey queryContracts)+          || hasDuplicates (map selectionRouter routerSelections)           then Nothing           else             pure@@ -293,7 +314,12 @@                   wrNominalEqualities = nominalEqualities,                   wrBindingObligations = obligations,                   wrBehaviorRequirements = behaviorRequirements,-                  wrAdopted = checkedAdopted+                  wrProjectionCatalogFacts = catalogFacts,+                  wrQueryContractBaseline = queryContractBaseline,+                  wrQueryContracts = queryContracts,+                  wrRouterSelections = routerSelections,+                  wrAdopted = checkedAdopted,+                  wrSemanticImpact = semanticImpact                 }   _ -> Nothing   where@@ -334,6 +360,14 @@     parseNamingEdition rows = case rowsWith "naming-edition " rows of       [] -> Just LegacyNamingV1       [row] -> T.stripPrefix "naming-edition " row >>= parseGeneratedHaskellNamingEdition+      _ -> Nothing+    parseSemanticImpact rows = case rowsWith "semantic-impact " rows of+      [] -> Just Nothing+      [row] -> Just <$> decodeRow "semantic-impact " row+      _ -> Nothing+    parseQueryContractBaseline rows = case rowsWith "query-contract-baseline " rows of+      [] -> Just False+      ["query-contract-baseline v1"] -> Just True       _ -> Nothing     checkedSourceLanguage row = do       path <- safePath (T.pack (wrslPath row))

src/Keiro/Dsl/WorkspaceScaffold.hs view

@@ -56,7 +56,8 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as TIO-import Keiro.Dsl.BehaviorCoverage (BehaviorKey (..), BehaviorRecordRow (..), attributeBehaviorOwner, behaviorRecordRows, deriveBehaviorRequirements)+import Keiro.Dsl.BehaviorCoverage (BehaviorKey (..), BehaviorRecordRow (..), attributeBehaviorOwner, behaviorRecordRows, deriveBehaviorRequirementsForService)+import Keiro.Dsl.BehaviorSourceMap qualified as BehaviorSource import Keiro.Dsl.ConformancePackage   ( ConformancePackagePlan,     ConformancePackageReport,@@ -66,29 +67,43 @@     preflightConformancePackage,     renderConformancePackageReport,   )+import Keiro.Dsl.CoordinationImpact (RouterSelectionDrift, renderRouterSelectionDrift, routerSelectionDrift, routerSelectionSnapshots) import Keiro.Dsl.ExplainBindings (BindingHole (..), bindingHolesForService) import Keiro.Dsl.Goldens (GoldenPayload) import Keiro.Dsl.Grammar-import Keiro.Dsl.Harness (harnessForServiceWithGoldens, harnessProcess, harnessReadModel, harnessRouter, harnessWorkflow)+import Keiro.Dsl.Harness (harnessForServiceWithGoldens, harnessProcess, harnessReadModelForService, harnessRouterForService, harnessWorkflow) import Keiro.Dsl.HaskellName (currentGeneratedHaskellNamingEdition) import Keiro.Dsl.HaskellSourceMove (SourceMove (..), SourceMoveError, planSourceMoves) import Keiro.Dsl.IdDomain (idDomainIdentitiesForService) import Keiro.Dsl.LanguageVersion (SourceLanguage, effectiveLanguageVersion, languageVersionText, sourceFormText) import Keiro.Dsl.Manifest (moduleNameOf, renderManifestForServiceWithFacade)-import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), consumerPlan)+import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), consumerPlanForService) import Keiro.Dsl.NominalType (nominalEqualityIdentitiesForService)+import Keiro.Dsl.ProjectionMappedImpact (ProjectionMappedImpact, projectionMappedImpactForService, renderProjectionMappedImpact)+import Keiro.Dsl.ReadModelQueryContract+  ( QueryContractDrift (..),+    QueryContractIdentity (..),+    QueryContractPosition (..),+    queryContractDrift,+    queryContractIdentitiesForService,+  ) import Keiro.Dsl.RuntimePackage (RuntimePackageName) import Keiro.Dsl.Scaffold+import Keiro.Dsl.ScaffoldRecord (projectionCatalogFactsForService) import Keiro.Dsl.ScaffoldRun-  ( MappingDrift (..),+  ( GeneratedArtifactImpact,+    MappingDrift (..),     PreparedSourceMove,+    QueryContractMigration (..),     Refusal (..),     StaleGeneratedEvidence (..),     StaleModule (..),     WriteDisposition (..),     applyPreparedSourceMoves,     behaviorDrift,-    constraintPlan,+    checkedSemanticImpactSnapshot,+    constraintPlanForService,+    generatedArtifactImpact,     inertNodesOf,     mappingDrift,     missingGeneratedBanners,@@ -97,14 +112,20 @@     planningGatePipeline,     preflightSourceMoves,     preparedSourceMove,+    queryContractMigrations,+    renderGeneratedArtifactImpact,     renderInertNodeSection,     renderMappingIdentity,+    renderSemanticImpactReport,+    semanticImpactForMappingDrift,     staleAgainst,     withSidecarMovesApplied,   )-import Keiro.Dsl.SemanticContract (CheckedService (..))+import Keiro.Dsl.SemanticContract (CheckedService, checkedLanguageContract, checkedSpec)+import Keiro.Dsl.SemanticImpact (SemanticImpactReport, SemanticImpactSnapshot) import Keiro.Dsl.ServiceHarness (DuplicateServiceFactKey, serviceConformanceModuleName, serviceHarnessModule) import Keiro.Dsl.SidecarMigration+import Keiro.Dsl.StructuralConformance (structuralConformanceModule) import Keiro.Dsl.Validate (nodeIdentity) import Keiro.Dsl.Workspace (WorkspaceMember (..), WorkspaceSpec (..), checkedWorkspace, declarationOwner, nodeOwner) import Keiro.Dsl.WorkspaceAdoption (MigrationReport (..), adoptedRows, adoptionReport, markLegacyRecordSuperseded, renderMigrationReport)@@ -174,29 +195,36 @@   WorkspaceSpec ->   Either [Refusal] WorkspacePlan planWorkspaceScaffoldWithRuntimePackageAndGoldens goldens runtimePackage goldenRoot ctx workspace =-  case planningGatePipeline ctx service modulePlan packageGate of-    Left refusals -> Left refusals-    Right _ -> case taggedModules of-      Left duplicates -> Left [DuplicateConformanceFactKeys duplicates]-      Right tagged -> case packagePlan of-        Left failures -> Left (map ConformancePackageRefusal failures)-        Right plannedPackage ->-          Right-            WorkspacePlan-              { wpWorkspace = workspace,-                wpCheckedService = service,-                wpContext = ctx,-                wpRuntimePackage = runtimePackage,-                wpConformancePackage = plannedPackage,-                wpGoldenRoot = goldenRoot,-                wpModules = tagged-              }+  do+    _ <- planningGatePipeline ctx service baseModulePlan packageGate+    _ <- planningGatePipeline ctx service completeModulePlan packageGate+    tagged <- taggedModules+    plannedPackage <- either (Left . map ConformancePackageRefusal) Right packagePlan+    Right+      WorkspacePlan+        { wpWorkspace = workspace,+          wpCheckedService = service,+          wpContext = ctx,+          wpRuntimePackage = runtimePackage,+          wpConformancePackage = plannedPackage,+          wpGoldenRoot = goldenRoot,+          wpModules = tagged+        }   where     service = checkedWorkspace workspace-    taggedModules = workspaceModules goldens runtimePackage ctx workspace-    modulePlan = case taggedModules of-      Left duplicates -> Left [DuplicateConformanceFactKeys duplicates]+    sourceEntries = do+      requirements <- either (Left . pure . BehaviorRefusal) Right (deriveBehaviorRequirementsForService service)+      either (Left . pure . BehaviorSourceRefusal) Right (BehaviorSource.planBehaviorSourceMap requirements (wsSourceIndex workspace))+    taggedModules = do+      entries <- sourceEntries+      either (Left . pure . DuplicateConformanceFactKeys) Right (workspaceModules goldens runtimePackage entries ctx workspace service)+    baseTaggedModules = either (Left . pure . DuplicateConformanceFactKeys) Right (workspaceModules goldens runtimePackage [] ctx workspace service)+    baseModulePlan = case baseTaggedModules of+      Left refusals -> Left refusals       Right tagged -> Right (map fst tagged)+    completeModulePlan = case taggedModules of+      Left refusals -> Left refusals+      Right tagged -> Right (map fst tagged)     packagePlan =       traverse         (\packageName -> planConformancePackage (WorkspaceConformanceService (wsService workspace)) packageName (serviceConformanceModuleName ctx) service)@@ -213,21 +241,27 @@ -- ('scaffoldStructuralOwners') and nodes carry their own identity -- ('nodeIdentity'), both of which the workspace's ownership index resolves to a -- member file.-workspaceModules :: [GoldenPayload] -> Maybe RuntimePackageName -> Context -> WorkspaceSpec -> Either [DuplicateServiceFactKey] [(ScaffoldModule, ModuleProvenance)]-workspaceModules goldens runtimePackage ctx workspace = do+workspaceModules :: [GoldenPayload] -> Maybe RuntimePackageName -> [BehaviorSource.BehaviorSourceEntry] -> Context -> WorkspaceSpec -> CheckedService -> Either [DuplicateServiceFactKey] [(ScaffoldModule, ModuleProvenance)]+workspaceModules goldens runtimePackage sourceEntries ctx workspace service = do+  structuralConformance <- case structuralConformanceModule ctx service of+    Left failures -> error ("checked workspace structural conformance planning failed: " <> show failures)+    Right Nothing -> Right []+    Right (Just moduleValue) -> Right [(stamp moduleValue, ContextLevel)]   facade <- case runtimePackage of     Nothing -> Right []     Just _ -> fmap (\moduleValue -> [(stamp moduleValue, ContextLevel)]) (serviceHarnessModule ctx service)   pure $-    [attributedStamped (declarationProvenance names) m | (m, names) <- scaffoldStructuralOwnersForService ctx service]+    structuralConformance+      <> [attributedStamped ContextLevel moduleValue | moduleValue <- maybe [] pure (behaviorSourceMapModule ctx sourceEntries)]+      <> [attributedStamped (declarationProvenance names) m | (m, names) <- scaffoldStructuralOwnersForService ctx service]       <> [attributedStamped ContextLevel m | m <- scaffoldReplayAudit ctx merged]+      <> [attributedStamped ContextLevel m | m <- scaffoldProjectionCatalogForService ctx service]       <> concat         [ map (attributedStamped (nodeProvenance node)) (emittersFor node)         | node <- specNodes merged         ]       <> facade   where-    service = checkedWorkspace workspace     merged = checkedSpec service     ownership = wsOwnership workspace     stamp = stampGeneratedModule (checkedLanguageContract service)@@ -238,12 +272,19 @@     emittersFor node = case node of       NAggregate aggregate -> scaffoldAggregateForService ctx service aggregate <> harnessForServiceWithGoldens goldens ctx service aggregate       NProcess process -> scaffoldProcess ctx process <> harnessProcess ctx process-      NRouter router -> scaffoldRouter ctx router <> harnessRouter ctx router+      NRouter router -> scaffoldRouterForService ctx service router <> harnessRouterForService ctx service router       NContract contract -> scaffoldContractForService ctx service contract       NIntake intake -> scaffoldIntake ctx intake       NPublisher publisher -> scaffoldPublisher ctx publisher-      NWorkqueue workqueue -> scaffoldWorkqueue ctx workqueue-      NReadModel readModel -> scaffoldReadModel ctx readModel <> harnessReadModel ctx readModel+      NWorkqueue workqueue -> scaffoldWorkqueueForService ctx service workqueue+      NReadModel readModel ->+        let resolved = resolveCatalogReadModel merged readModel+         in scaffoldReadModelForService ctx service resolved <> harnessReadModelForService ctx service resolved+      NProjectionTarget _ -> []+      NRebuildGroup _ -> []+      NProjectionRevision _ -> []+      NExternalRead _ -> []+      NProjectionOwner _ -> []       NWorkflow workflow -> harnessWorkflow ctx workflow       NEmit _ -> []       NPgmqDispatch _ -> []@@ -372,6 +413,13 @@     wsrConsumerPlan :: !ConsumerPlan,     wsrConstraintPlan :: ![Text],     wsrMappingDrift :: ![MappingDrift],+    wsrQueryContractBaselineUnavailable :: !Bool,+    wsrQueryContractDrift :: ![QueryContractDrift],+    wsrQueryContractMigrations :: ![QueryContractMigration],+    wsrSemanticImpact :: !SemanticImpactReport,+    wsrRouterSelectionDrift :: ![RouterSelectionDrift],+    wsrProjectionMappedImpact :: !(Maybe ProjectionMappedImpact),+    wsrGeneratedArtifactImpact :: ![GeneratedArtifactImpact],     wsrSourceLanguageDrift :: ![WorkspaceSourceLanguageDrift],     wsrNewHoles :: ![BindingHole],     wsrAddedBehavior :: ![BehaviorRecordRow],@@ -471,18 +519,33 @@       applyPreparedSourceMoves out preparedNameMoves       previous <- readWorkspaceRecord recordPath       stale <- staleAgainst out (map modulePath modules) (previousFiles previous)+      queryMigrations <- queryContractMigrations out modules       -- Adoption is a one-shot, guarded by the absence of workspace       -- history: once this workspace owns the directory there is nothing       -- left to import, and the migration report stays as written.       migration <- case previous of         Just _ -> pure Nothing         Nothing -> adoptionReport out (wsContext workspace) service modules-      let currentPlan = consumerPlan merged+      let currentPlan = consumerPlanForService (wpCheckedService plan)           drift = maybe [] (mappingDrift (consumerMappings currentPlan) . wrMappings) previous+          currentSemanticImpact = checkedSemanticImpactSnapshot (wpCheckedService plan)+          semanticReport = semanticImpactForMappingDrift (previous >>= wrSemanticImpact) currentSemanticImpact drift+          currentRouterSelections = routerSelectionSnapshots (wpCheckedService plan)+          selectionDrift = maybe [] (\record -> routerSelectionDrift (wrRouterSelections record) currentRouterSelections) previous           languageDrift = workspaceSourceLanguageDrift workspace previous+          currentQueryContracts = either (const []) id (queryContractIdentitiesForService (wpCheckedService plan))+          queryHistoryBaseline =+            not (null currentQueryContracts)+              || maybe False wrQueryContractBaseline previous+          queryBaselineUnavailable =+            not (null currentQueryContracts)+              && maybe False (not . wrQueryContractBaseline) previous+          queryDrift = case previous of+            Just record | wrQueryContractBaseline record -> queryContractDrift currentQueryContracts (wrQueryContracts record)+            _ -> []           currentObligations = either (const []) id (bindingHolesForService (wpCheckedService plan))           newHoles = maybe [] (newBindingObligations currentObligations . wrBindingObligations) previous-          currentBehavior = workspaceBehaviorRows workspace+          currentBehavior = workspaceBehaviorRows (wpCheckedService plan) workspace           (addedBehavior, removedBehavior) = maybe (currentBehavior, []) (behaviorDrift currentBehavior . wrBehaviorRequirements) previous       createDirectoryIfMissing True out       dispositions <- traverse (writeWorkspaceModule out) (wpModules plan)@@ -493,7 +556,7 @@       let adopted = case migration of             Just report -> adoptedRows report             Nothing -> maybe [] wrAdopted previous-      TIO.writeFile recordPath (renderWorkspaceRecord (currentWorkspaceRecord plan adopted))+      TIO.writeFile recordPath (renderWorkspaceRecord (currentWorkspaceRecord plan adopted queryHistoryBaseline currentSemanticImpact))       packageReport <- case packagePreflight of         Right prepared -> traverse executePreparedConformancePackage prepared         Left _ -> pure Nothing@@ -521,13 +584,20 @@               wsrStale = stale,               wsrOwnershipMoves = ownershipMoves previous (wpModules plan),               wsrConsumerPlan = currentPlan,-              wsrConstraintPlan = constraintPlan merged currentPlan,+              wsrConstraintPlan = constraintPlanForService (wpCheckedService plan) currentPlan,               wsrMappingDrift = drift,+              wsrQueryContractBaselineUnavailable = queryBaselineUnavailable,+              wsrQueryContractDrift = queryDrift,+              wsrQueryContractMigrations = queryMigrations,+              wsrSemanticImpact = semanticReport,+              wsrRouterSelectionDrift = selectionDrift,+              wsrProjectionMappedImpact = projectionMappedImpactForService (wpCheckedService plan),+              wsrGeneratedArtifactImpact = generatedArtifactImpact [(scaffoldModule, disposition) | (scaffoldModule, _, disposition) <- dispositions],               wsrSourceLanguageDrift = languageDrift,               wsrNewHoles = newHoles,               wsrAddedBehavior = addedBehavior,               wsrRemovedBehavior = removedBehavior,-              wsrObsoleteOutputHooks = obsoleteGeneratedOutputHooks merged,+              wsrObsoleteOutputHooks = obsoleteGeneratedOutputHooksForService (wpCheckedService plan),               wsrInertNodes = inertNodesOf merged,               wsrConformancePackage = packageReport,               wsrNameMoves = nameMoves,@@ -555,8 +625,8 @@ -- | The record this run writes: the plan's modules with their owners, the -- canonical member list, the merged graph's mappings and obligations, and any -- files adopted from pre-workspace scaffold output.-currentWorkspaceRecord :: WorkspacePlan -> [AdoptedRow] -> WorkspaceRecord-currentWorkspaceRecord plan adopted =+currentWorkspaceRecord :: WorkspacePlan -> [AdoptedRow] -> Bool -> SemanticImpactSnapshot -> WorkspaceRecord+currentWorkspaceRecord plan adopted queryHistoryBaseline currentSemanticImpact =   WorkspaceRecord     { wrService = wsService workspace,       wrManifest = T.pack (takeFileName (wsManifestPath workspace)),@@ -579,22 +649,26 @@             }         | (m, provenance) <- wpModules plan         ],-      wrMappings = consumerMappings (consumerPlan merged),+      wrMappings = consumerMappings (consumerPlanForService checkedService),       wrIdDomains = idDomainIdentitiesForService checkedService,       wrNominalEqualities = nominalEqualityIdentitiesForService checkedService,       wrBindingObligations = either (const []) id (bindingHolesForService checkedService),-      wrBehaviorRequirements = workspaceBehaviorRows workspace,-      wrAdopted = adopted+      wrBehaviorRequirements = workspaceBehaviorRows checkedService workspace,+      wrProjectionCatalogFacts = projectionCatalogFactsForService checkedService,+      wrQueryContractBaseline = queryHistoryBaseline,+      wrQueryContracts = either (const []) id (queryContractIdentitiesForService checkedService),+      wrRouterSelections = routerSelectionSnapshots checkedService,+      wrAdopted = adopted,+      wrSemanticImpact = Just currentSemanticImpact     }   where     workspace = wpWorkspace plan     checkedService = wpCheckedService plan-    merged = checkedSpec checkedService     ctx = wpContext plan -workspaceBehaviorRows :: WorkspaceSpec -> [BehaviorRecordRow]-workspaceBehaviorRows workspace =-  either (const []) (behaviorRecordRows . map attribute) (deriveBehaviorRequirements (checkedSpec (checkedWorkspace workspace)))+workspaceBehaviorRows :: CheckedService -> WorkspaceSpec -> [BehaviorRecordRow]+workspaceBehaviorRows service workspace =+  either (const []) (behaviorRecordRows . map attribute) (deriveBehaviorRequirementsForService service)   where     attribute = attributeBehaviorOwner (fmap fst . nodeOwner (wsOwnership workspace) "aggregate") @@ -694,7 +768,13 @@     <> nameMoveSection     <> constraintSection     <> newHolesSection+    <> queryContractSection+    <> queryContractMigrationSection     <> mappingDriftSection+    <> renderSemanticImpactReport (wsrSemanticImpact report)+    <> renderRouterSelectionDrift (wsrRouterSelectionDrift report)+    <> maybe [] renderProjectionMappedImpact (wsrProjectionMappedImpact report)+    <> renderGeneratedArtifactImpact (wsrSemanticImpact report) (wsrGeneratedArtifactImpact report)     <> sourceLanguageDriftSection     <> behaviorDriftSection     <> obsoleteOutputSection@@ -774,6 +854,40 @@     obligationLines hole =       [ "  " <> holeModule hole,         "    " <> holeSignature hole <> " (" <> obligationKindLabel (holeKind hole) <> ")"+      ]+    queryContractSection =+      [ "query contract history: baseline unavailable in the previous ledger; no legacy `()` API was inferred"+      | wsrQueryContractBaselineUnavailable report+      ]+        <> case wsrQueryContractDrift report of+          [] -> []+          drifts ->+            ["query contract drift: " <> tshow (length drifts) <> " input/result position(s) changed since the previous scaffold:"]+              <> concatMap queryDriftLines drifts+    queryDriftLines drift =+      [ "  " <> readModel <> " " <> queryPositionLabel position,+        "    previous: " <> maybe "(absent)" renderQueryIdentity (qcdPrevious drift),+        "    current:  " <> maybe "(absent)" renderQueryIdentity (qcdCurrent drift)+      ]+      where+        (readModel, position) = qcdKey drift+    renderQueryIdentity identity =+      qciTypeExpression identity+        <> " mapped=["+        <> T.intercalate ", " (qciMappedDependencies identity)+        <> "]"+    queryPositionLabel QueryInputConsumer = "input"+    queryPositionLabel QueryResultConsumer = "result"+    queryContractMigrationSection = case wsrQueryContractMigrations report of+      [] -> []+      migrations ->+        ["query contract migration required: " <> tshow (length migrations) <> " hand-owned hole module(s)"]+          <> concatMap queryMigrationLines migrations+    queryMigrationLines migration =+      [ "  " <> qcmOwner migration,+        "    edit " <> T.pack (qcmHolePath migration),+        "    remove the local QueryInput/QueryResult type aliases",+        "    add " <> qcmRequiredImport migration       ]     mappingDriftSection = case wsrMappingDrift report of       [] -> []

test/Keiro/Dsl/ConformanceBaseline.hs view

@@ -3,20 +3,30 @@ import Control.Monad (filterM, forM, forM_, unless) import Data.Aeson (FromJSON (..), withObject, (.:), (.:?)) import Data.Aeson qualified as Aeson-import Data.List (nub, sort, (\\))+import Data.List (isSuffixOf, nub, sort, (\\)) import Data.Maybe (listToMaybe, mapMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as TIO import Keiro.Dsl.FrontendCompatibility (SourceExpectation (..), observeSource, readRepoText) import Keiro.Dsl.Grammar (Spec (..))-import Keiro.Dsl.LanguageVersion (currentStableLanguageVersion, languageVersionNumber)-import Keiro.Dsl.Parser (parseSource)+import Keiro.Dsl.LanguageVersion+  ( LanguageDefinition (..),+    LanguageMaturity (..),+    LanguageSupport (..),+    currentAuthoringLanguageVersion,+    currentStableLanguageVersion,+    languageVersion,+    languageVersionNumber,+    lookupLanguageDefinition,+  )+import Keiro.Dsl.Parser (parseSource, parseSourceDocument) import Keiro.Dsl.RuntimePackage (RuntimePackageName (..)) import Keiro.Dsl.Scaffold (Context (..), ModuleKind (..), Placement (..), ScaffoldModule (..), defaultContext)-import Keiro.Dsl.ScaffoldRun (planServiceScaffoldWithRuntimePackage, scaffoldServiceModules)-import Keiro.Dsl.SemanticContract (CheckedService (..), checkedSource)+import Keiro.Dsl.ScaffoldRun (planIndexedServiceScaffold, planIndexedServiceScaffoldWithRuntimePackage, scaffoldServiceModules)+import Keiro.Dsl.SemanticContract (CheckedService, checkedSource, checkedSpec) import Keiro.Dsl.Skeleton (skeletonFor)+import Keiro.Dsl.SourceIndex (ParsedSourceDocument (..), SemanticSourceIndex) import Keiro.Dsl.Workspace (WorkspaceSpec (..), fileContentSource, loadWorkspace) import Keiro.Dsl.WorkspaceScaffold (WorkspacePlan (..), planWorkspaceScaffold) import Numeric.Natural (Natural)@@ -49,6 +59,7 @@     suiteSource :: !(Maybe FilePath),     suiteGeneration :: !Text,     suiteRole :: !Text,+    suiteLanguageVersion :: !(Maybe Natural),     suiteReason :: !Text   }   deriving stock (Eq, Show)@@ -61,11 +72,14 @@       <*> fields .:? "source"       <*> fields .: "generation"       <*> fields .: "role"+      <*> fields .:? "languageVersion"       <*> fields .: "reason"  data ConformanceBaseline = ConformanceBaseline   { baselineSchema :: !Text,     baselineStableLanguageVersion :: !Natural,+    baselineAuthoringLanguageVersion :: !Natural,+    baselinePrimaryLanguageVersions :: ![Natural],     baselineFixtureExceptions :: ![FixtureException],     baselineCompiledSuites :: ![CompiledSuite]   }@@ -76,25 +90,31 @@     ConformanceBaseline       <$> fields .: "schema"       <*> fields .: "stableLanguageVersion"+      <*> fields .: "authoringLanguageVersion"+      <*> fields .: "primaryLanguageVersions"       <*> fields .: "fixtureExceptions"       <*> fields .: "compiledSuites"  conformanceBaselineSpec :: SpecWith () conformanceBaselineSpec = describe "conformance baseline" $ do-  it "uses the registered stable language and explicit non-stable fixture rows" $ do+  it "uses the registered stable and authoring languages plus explicit compatibility rows" $ do     baseline <- readBaseline-    baselineSchema baseline `shouldBe` "keiro-dsl/conformance-baseline/1"+    baselineSchema baseline `shouldBe` "keiro-dsl/conformance-baseline/2"     baselineStableLanguageVersion baseline       `shouldBe` languageVersionNumber currentStableLanguageVersion+    baselineAuthoringLanguageVersion baseline+      `shouldBe` languageVersionNumber currentAuthoringLanguageVersion     paths <- fixturePaths     observations <- forM paths $ \path -> (path,) <$> observeSource path-    let stableVersion = languageVersionNumber currentStableLanguageVersion+    baselinePrimaryLanguageVersions baseline `shouldContain` [languageVersionNumber currentStableLanguageVersion]+    baselinePrimaryLanguageVersions baseline `shouldContain` [languageVersionNumber currentAuthoringLanguageVersion]+    let primaryVersions = baselinePrimaryLanguageVersions baseline         nonStablePaths =           sort             [ path             | (path, observation) <- observations,               sourceForm observation /= "declared"-                || sourceEffectiveVersion observation /= Just stableVersion+                || maybe True (`notElem` primaryVersions) (sourceEffectiveVersion observation)             ]         exceptionPaths = sort (map exceptionPath (baselineFixtureExceptions baseline))     (nonStablePaths \\ exceptionPaths)@@ -109,7 +129,7 @@         `shouldBe` "compatibility-proof"       exceptionReason exception `shouldSatisfy` (not . T.null . T.strip) -  it "accounts for every compiled conformance component and stable generated banner" $ do+  it "accounts for every compiled conformance component and primary generated banner" $ do     baseline <- readBaseline     cabal <- readRepoText "keiro-dsl/keiro-dsl.cabal"     let cabalComponents = conformanceComponents cabal@@ -120,46 +140,92 @@       `shouldBe` ([] :: [Text])     forM_ (baselineCompiledSuites baseline) $ \suite -> do       suiteRole suite-        `shouldSatisfy` (`elem` ["stable-primary", "compatibility-proof", "version-independent"])+        `shouldSatisfy` (`elem` ["stable-primary", "published-compatibility", "compatibility-proof", "version-independent"])+      validateSuiteLanguageOwnership baseline suite       suiteReason suite `shouldSatisfy` (not . T.null . T.strip)       directory <- resolveRepoDirectory ("keiro-dsl" </> suiteDirectory suite)       doesDirectoryExist directory `shouldReturn` True-      case suiteRole suite of-        "stable-primary" -> do+      case suiteLanguageVersion suite of+        Just primaryVersion -> do           unless (suiteGeneration suite `elem` ["workspace", "skeletons"]) $ do             source <- requiredSuiteSource suite             observation <- observeSource source             sourceForm observation `shouldBe` "declared"             sourceResult observation `shouldBe` "accept"-            sourceEffectiveVersion observation-              `shouldBe` Just (languageVersionNumber currentStableLanguageVersion)+            sourceEffectiveVersion observation `shouldBe` Just primaryVersion           banners <- generatedBannerLines directory           unless (not (null banners)) $             expectationFailure (T.unpack (suiteComponent suite <> " has no generated banners"))-          let expected =-                "language keiro-dsl "-                  <> T.pack (show (languageVersionNumber currentStableLanguageVersion))-              stableBanners = [(path, banner) | (path, banner) <- banners, expected `T.isInfixOf` banner]+          let expectedVersion = "language keiro-dsl " <> T.pack (show primaryVersion)+              primaryBanners = [(path, banner) | (path, banner) <- banners, expectedVersion `T.isInfixOf` banner]               isVersionIndependentAuxiliary banner = "@generated by keiro-dsl codec comparison" `T.isInfixOf` banner-          unless (not (null stableBanners)) $-            expectationFailure (T.unpack (suiteComponent suite <> " has no stable generated banners"))+          unless (not (null primaryBanners)) $+            expectationFailure (T.unpack (suiteComponent suite <> " has no " <> T.pack (show primaryVersion) <> " generated banners"))           forM_ banners $ \(path, banner) ->-            unless (expected `T.isInfixOf` banner || isVersionIndependentAuxiliary banner) $-              expectationFailure (T.unpack (decorate path banner <> " (expected " <> expected <> ")"))+            unless (expectedVersion `T.isInfixOf` banner || isVersionIndependentAuxiliary banner) $+              expectationFailure (T.unpack (decorate path banner <> " (expected " <> expectedVersion <> ")"))           expectedPaths <- expectedStableGeneratedPaths suite-          let actualPaths = sort (nub (map fst stableBanners))-          unless (actualPaths == expectedPaths) $+          let actualPaths = sort (nub (map fst primaryBanners))+              -- Plan 218 refreshes focused compiled fixtures only. The final+              -- corpus-wide regeneration in plan 222 will remove this narrow+              -- inventory normalization after every mapped suite has adopted+              -- its new context module.+              deferredContextModule path =+                "/StructuralConformance.hs" `isSuffixOf` path+                  || "/BehaviorSourceMap.hs" `isSuffixOf` path+              comparedExpectedPaths = filter (not . deferredContextModule) expectedPaths+              comparedActualPaths = filter (not . deferredContextModule) actualPaths+          unless (comparedActualPaths == comparedExpectedPaths) $             expectationFailure               ( T.unpack                   ( suiteComponent suite                       <> " generated module inventory differs\nexpected: "-                      <> T.pack (show expectedPaths)+                      <> T.pack (show comparedExpectedPaths)                       <> "\n but got: "-                      <> T.pack (show actualPaths)+                      <> T.pack (show comparedActualPaths)                   )               )-        _ -> pure ()+        Nothing -> pure () +validateSuiteLanguageOwnership :: ConformanceBaseline -> CompiledSuite -> IO ()+validateSuiteLanguageOwnership baseline suite = case (suiteRole suite, suiteLanguageVersion suite) of+  ("stable-primary", Just rawVersion) -> do+    rawVersion `shouldBe` baselineStableLanguageVersion baseline+    definition <- requireRegisteredDefinition suite rawVersion+    definitionSupport definition `shouldBe` Stable+    definitionMaturity definition `shouldBe` PublishedLanguage+  ("published-compatibility", Just rawVersion) -> do+    rawVersion `shouldNotBe` baselineStableLanguageVersion baseline+    definition <- requireRegisteredDefinition suite rawVersion+    definitionSupport definition `shouldBe` CompatibilityOnly+    definitionMaturity definition `shouldBe` PublishedLanguage+  ("compatibility-proof", Nothing) -> pure ()+  ("version-independent", Nothing) -> pure ()+  (role, version) ->+    expectationFailure+      ( T.unpack+          ( suiteComponent suite+              <> " has invalid language ownership for role "+              <> role+              <> ": "+              <> T.pack (show version)+          )+      )++requireRegisteredDefinition :: CompiledSuite -> Natural -> IO LanguageDefinition+requireRegisteredDefinition suite rawVersion =+  case languageVersion rawVersion >>= lookupLanguageDefinition of+    Just definition -> pure definition+    Nothing -> do+      expectationFailure+        ( T.unpack+            ( suiteComponent suite+                <> " owns unregistered language "+                <> T.pack (show rawVersion)+            )+        )+      fail "unregistered conformance language owner"+ expectedStableGeneratedPaths :: CompiledSuite -> IO [FilePath] expectedStableGeneratedPaths suite = case suiteGeneration suite of   "source" -> do@@ -168,8 +234,8 @@   "source-with-conformance-facade" -> do     source <- requiredSuiteSource suite     sourceText <- readRepoText source-    service <- parseCheckedSource source sourceText-    modules <- case planServiceScaffoldWithRuntimePackage (Just (RuntimePackageName "conformance-runtime")) (defaultContext (specContext (checkedSpec service))) service of+    (service, sourceIndex) <- parseCheckedDocument source sourceText+    modules <- case planIndexedServiceScaffoldWithRuntimePackage (Just (RuntimePackageName "conformance-runtime")) sourceIndex (defaultContext (specContext (checkedSpec service))) service of       Left refusals -> expectationFailure (show refusals) >> fail "stable configured source scaffold refusal"       Right value -> pure value     pure (generatedPaths modules)@@ -196,13 +262,22 @@ generatedPathsForSource :: FilePath -> IO [FilePath] generatedPathsForSource path = do   source <- readRepoText path-  service <- parseCheckedSource path source-  pure (generatedPaths (scaffoldServiceModules (defaultContext (specContext (checkedSpec service))) service))+  (service, sourceIndex) <- parseCheckedDocument path source+  modules <- case planIndexedServiceScaffold sourceIndex (defaultContext (specContext (checkedSpec service))) service of+    Left refusals -> expectationFailure (show refusals) >> fail "stable source scaffold refusal"+    Right value -> pure value+  pure (generatedPaths modules)  parseCheckedSource :: FilePath -> Text -> IO CheckedService parseCheckedSource path source = case parseSource path source of   Left problem -> expectationFailure (show problem) >> fail "invalid stable source"   Right parsed -> pure (checkedSource parsed)++parseCheckedDocument :: FilePath -> Text -> IO (CheckedService, SemanticSourceIndex)+parseCheckedDocument path source = case parseSourceDocument path source of+  Left problem -> expectationFailure (show problem) >> fail "invalid stable source document"+  Right ParsedSourceDocument {documentParsedSource = parsed, documentSourceIndex = sourceIndex} ->+    pure (checkedSource parsed, sourceIndex)  generatedPaths :: [ScaffoldModule] -> [FilePath] generatedPaths = sort . map modulePath . filter ((== Generated) . kind)

test/Keiro/Dsl/FrontendProfiles.hs view

@@ -19,38 +19,47 @@  frontendProfilesSpec :: SpecWith () frontendProfilesSpec = do-  describe "released language profiles" $ do+  describe "FrontendProfiles: released language profiles" $ do     it "pins each released syntax profile, predecessor, and runtime contract explicitly" $ do       map definitionRow (NE.toList languageRegistry)         `shouldBe` [ (1, Nothing, "keiro-dsl/syntax-profile/1", "keiro-dsl/runtime-semantics/1"),                      (2, Just 1, "keiro-dsl/syntax-profile/2", "keiro-dsl/runtime-semantics/1"),                      (3, Just 2, "keiro-dsl/syntax-profile/2", "keiro-dsl/runtime-semantics/2"),-                     (4, Just 3, "keiro-dsl/syntax-profile/3", "keiro-dsl/runtime-semantics/3")+                     (4, Just 3, "keiro-dsl/syntax-profile/3", "keiro-dsl/runtime-semantics/3"),+                     (5, Just 4, "keiro-dsl/syntax-profile/4", "keiro-dsl/runtime-semantics/4")                    ]       map definitionCapabilities (NE.toList languageRegistry)         `shouldBe` [ [],                      [],                      [GeneratedIdDomainTypeIdV7, NominalEqualityV2],-                     [GeneratedIdDomainTypeIdV7, NominalEqualityV2, ContractIdDomainTypeIdV7, StrictSpecSurfaceValidation]+                     [GeneratedIdDomainTypeIdV7, NominalEqualityV2, ContractIdDomainTypeIdV7, StrictSpecSurfaceValidation],+                     [GeneratedIdDomainTypeIdV7, NominalEqualityV2, ContractIdDomainTypeIdV7, StrictSpecSurfaceValidation, ProjectionCatalogRuntime, TypedDomainCommandOutcomes, SeparatedProjectionQueryPolicy]                    ]       map (runtimeProfileFoldSegments . definitionRuntimeSemanticsProfile) (NE.toList languageRegistry)         `shouldBe` [ [],                      [],                      ["semantic-contract:keiro-dsl/runtime-semantics/2"],-                     ["semantic-contract:keiro-dsl/runtime-semantics/2"]+                     ["semantic-contract:keiro-dsl/runtime-semantics/2"],+                     ["semantic-contract:keiro-dsl/projection-catalog/1", "semantic-contract:keiro-dsl/runtime-semantics/2"]                    ]       map definitionSupport (NE.toList languageRegistry)-        `shouldBe` [CompatibilityOnly, CompatibilityOnly, CompatibilityOnly, Stable]-      currentStableLanguageVersion `shouldBe` version 4+        `shouldBe` [CompatibilityOnly, CompatibilityOnly, CompatibilityOnly, CompatibilityOnly, Stable]+      map definitionMaturity (NE.toList languageRegistry)+        `shouldBe` [PublishedLanguage, PublishedLanguage, PublishedLanguage, PublishedLanguage, PublishedLanguage]+      currentStableLanguageVersion `shouldBe` version 5+      currentAuthoringLanguageVersion `shouldBe` version 5       languageSupportForVersion (version 1) `shouldBe` Just CompatibilityOnly       languageSupportForVersion (version 2) `shouldBe` Just CompatibilityOnly       languageSupportForVersion (version 3) `shouldBe` Just CompatibilityOnly-      languageSupportForVersion (version 4) `shouldBe` Just Stable-      languageSupportForVersion (version 5) `shouldBe` Nothing+      languageSupportForVersion (version 4) `shouldBe` Just CompatibilityOnly+      languageSupportForVersion (version 5) `shouldBe` Just Stable+      languageSupportForVersion (version 999999) `shouldBe` Nothing       [definitionVersion definition | definition <- NE.toList languageRegistry, definitionSupport definition == Stable]         `shouldBe` [currentStableLanguageVersion]-      definitionVersion (NE.last languageRegistry) `shouldBe` currentStableLanguageVersion-      definitionPredecessor (NE.last languageRegistry) `shouldBe` Just (version 3)+      [definitionVersion definition | definition <- NE.toList languageRegistry, definitionSupport definition == Candidate]+        `shouldBe` []+      definitionVersion (NE.last languageRegistry) `shouldBe` currentAuthoringLanguageVersion+      definitionPredecessor (NE.last languageRegistry) `shouldBe` Just (version 4)       forM_ (adjacent (NE.toList languageRegistry)) $ \(predecessor, successor) ->         forM_ allRuntimeCapabilities $ \capability ->           runtimeProfileHasCapability (definitionRuntimeSemanticsProfile predecessor) capability@@ -58,16 +67,24 @@               not wasSupported                 || runtimeProfileHasCapability (definitionRuntimeSemanticsProfile successor) capability       forM_ allFeatures $ \feature -> do-        let minimumVersion = if feature == FieldAliasSyntax then version 4 else version 2+        let minimumVersion = case feature of+              ProjectionCatalogSyntax -> version 5+              ExternalReadContractSyntax -> version 5+              MappedConsumerSurfaceSyntax -> version 5+              DomainCommandOutcomeSyntax -> version 5+              DeclarativeRouterSelectionSyntax -> version 5+              SeparatedProjectionQueryPolicySyntax -> version 5+              FieldAliasSyntax -> version 4+              _ -> version 2         languageFeatureMinimumVersion feature `shouldBe` minimumVersion-        forM_ [1, 2, 3, 4] $ \versionNumber ->+        forM_ [1, 2, 3, 4, 5] $ \versionNumber ->           languageSupportsFeature (version versionNumber) feature             `shouldBe` (version versionNumber >= minimumVersion) -    it "does not infer a hypothetical successor profile or runtime contract" $ do-      lookupLanguageDefinition (version 5) `shouldBe` Nothing-      effectiveLanguageContractForVersion (version 5) `shouldBe` Nothing-      forM_ allFeatures $ \feature -> languageSupportsFeature (version 5) feature `shouldBe` False+    it "does not infer a profile or runtime contract for an unregistered sentinel" $ do+      lookupLanguageDefinition (version 999999) `shouldBe` Nothing+      effectiveLanguageContractForVersion (version 999999) `shouldBe` Nothing+      forM_ allFeatures $ \feature -> languageSupportsFeature (version 999999) feature `shouldBe` False       languageVersionPolicy <- readRepoText "keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs"       semanticPolicy <- readRepoText "keiro-dsl/src/Keiro/Dsl/SemanticContract.hs"       languageVersionPolicy `shouldNotSatisfy` T.isInfixOf "version >="@@ -85,7 +102,7 @@      it "checks every real feature marker against the exact selected profile" $ do       forM_ featureCases $ \FeatureCase {feature, marker, body} ->-        forM_ [1, 2, 3, 4] $ \versionNumber -> do+        forM_ [1, 2, 3, 4, 5] $ \versionNumber -> do           let sourceName = "profile-" <> show versionNumber <> ".keiro"               source = preamble versionNumber <> body           case (languageSupportsFeature (version versionNumber) feature, parseSurfaceSource sourceName source) of@@ -101,14 +118,14 @@      it "keeps feature spellings inert in comments, strings, wire keys, and identifiers" $ do       inertBody <- readRepoText "keiro-dsl/test/fixtures/language-identifier-v1.keiro"-      forM_ [1, 2, 3, 4] $ \versionNumber ->+      forM_ [1, 2, 3, 4, 5] $ \versionNumber ->         parseSurfaceSource ("inert-" <> show versionNumber <> ".keiro") (preamble versionNumber <> inertBody)           `shouldSatisfy` isRight -  describe "frontend diagnostics" $ do+  describe "FrontendProfiles: frontend diagnostics" $ do     it "classifies malformed and unsupported preambles at source selection with exact spans" $ do       assertSourceSelection InvalidLanguageVersion "language keiro-dsl nope\ncontext malformed\n" "language keiro-dsl nope"-      assertSourceSelection UnsupportedLanguageVersion "language keiro-dsl 5\ncontext future\n" "language keiro-dsl 5"+      assertSourceSelection UnsupportedLanguageVersion "language keiro-dsl 999999\ncontext unregistered\n" "language keiro-dsl 999999"      it "reports ordinary body syntax with expected items and a point span" $ do       let source = "language keiro-dsl 1\ncontext body\nlayout\n"@@ -143,7 +160,7 @@     it "keeps the released compatibility renderer byte-identical" $ do       forM_         [ "language keiro-dsl nope\ncontext malformed\n",-          "language keiro-dsl 5\ncontext future\n",+          "language keiro-dsl 999999\ncontext unregistered\n",           preamble 1 <> featureBody TypedAggregateExpressionSyntax,           "language keiro-dsl 1\ncontext\n"         ]@@ -164,7 +181,15 @@     FeatureCase IntegerScalarSyntax "Integer" (featureBody IntegerScalarSyntax),     FeatureCase TypedAggregateExpressionSyntax "cmd." (featureBody TypedAggregateExpressionSyntax),     FeatureCase ExplicitTransitionImplementationSyntax "implementation hole" (featureBody ExplicitTransitionImplementationSyntax),-    FeatureCase FieldAliasSyntax "haskell" (featureBody FieldAliasSyntax)+    FeatureCase FieldAliasSyntax "haskell" (featureBody FieldAliasSyntax),+    FeatureCase ProjectionCatalogSyntax "target" (featureBody ProjectionCatalogSyntax),+    FeatureCase ExternalReadContractSyntax "external-read" (featureBody ExternalReadContractSyntax),+    FeatureCase DomainCommandOutcomeSyntax "domain-outcomes" (featureBody DomainCommandOutcomeSyntax),+    FeatureCase DomainCommandOutcomeSyntax "outcome" domainOutcomeClauseFeatureBody,+    FeatureCase MappedConsumerSurfaceSyntax ":" mappedQueueFeatureBody,+    FeatureCase MappedConsumerSurfaceSyntax "query" mappedQueryFeatureBody,+    FeatureCase DeclarativeRouterSelectionSyntax "declarative" declarativeRouterFeatureBody,+    FeatureCase SeparatedProjectionQueryPolicySyntax "freshness" separatedProjectionQueryPolicyBody   ]  featureBody :: LanguageFeature -> Text@@ -200,9 +225,136 @@         "  states Open",         "  command Rename { type haskell payloadType as \"type\":Text }"       ]+  ProjectionCatalogSyntax ->+    T.unlines+      [ "context profile",+        "target profile_view {",+        "  schema = \"public\"",+        "  table = \"profile_view\"",+        "  reset = preserve",+        "}"+      ]+  ExternalReadContractSyntax ->+    T.unlines+      [ "context profile",+        "external-read profile_reader {",+        "  version = 1",+        "  query = profiles",+        "  result-schema = \"app_contract\"",+        "  result-type = \"profile_row_v1\"",+        "  compatible-revisions = [ profiles_v1 ]",+        "  surface-generation = 1",+        "}"+      ]+  MappedConsumerSurfaceSyntax -> mappedQueueFeatureBody+  DomainCommandOutcomeSyntax ->+    T.unlines+      [ "context profile",+        "aggregate Profile",+        "  domain-outcomes rejection=ProfileRejection no-op=ProfileNoOp",+        "  regs",+        "  states Open"+      ]+  DeclarativeRouterSelectionSyntax -> declarativeRouterFeatureBody+  SeparatedProjectionQueryPolicySyntax -> separatedProjectionQueryPolicyBody  allFeatures :: [LanguageFeature]-allFeatures = [NominalBindingSyntax, IntegerScalarSyntax, TypedAggregateExpressionSyntax, ExplicitTransitionImplementationSyntax, FieldAliasSyntax]+allFeatures = [NominalBindingSyntax, IntegerScalarSyntax, TypedAggregateExpressionSyntax, ExplicitTransitionImplementationSyntax, FieldAliasSyntax, ProjectionCatalogSyntax, ExternalReadContractSyntax, MappedConsumerSurfaceSyntax, DomainCommandOutcomeSyntax, DeclarativeRouterSelectionSyntax, SeparatedProjectionQueryPolicySyntax]++separatedProjectionQueryPolicyBody :: Text+separatedProjectionQueryPolicyBody =+  T.unlines+    [ "context profile",+      "readmodel profiles {",+      "  table = \"profiles\"",+      "  schema = \"public\"",+      "  columns {}",+      "  version = 1",+      "  shape = \"fixture\"",+      "  freshness = immediate",+      "}"+    ]++declarativeRouterFeatureBody :: Text+declarativeRouterFeatureBody =+  T.unlines+    [ "context profile",+      "router ProfileRouter",+      "  name \"profile-router\"",+      "  input ProfileInput : ProfileInput",+      "  key input.profileId",+      "  resolve declarative {",+      "    identity = \"profile-selection\"",+      "    version = 1",+      "    query = read-model profiles with input",+      "    where = row.enabled == true",+      "    recipient = row.profileId",+      "    order = target-stream",+      "    dedupe = target-stream",+      "    max-recipients = 1",+      "    empty => ack",+      "    failure => retry",+      "    redelivery = stable-union",+      "    partial = retain-successes",+      "  }",+      "  target Profile",+      "  projections []",+      "  dispatch-each RefreshProfile { profileId=row.profileId }",+      "    on-appended AckOk ; on-duplicate AckOk ; on-failed Retry",+      "  dispatch-id strategy=uuidv5 from=(name, key, sourceEventId, targetStreamName, occurrence)",+      "  rejected => deadLetter",+      "  poison => halt"+    ]++domainOutcomeClauseFeatureBody :: Text+domainOutcomeClauseFeatureBody =+  T.unlines+    [ "context profile",+      "aggregate Profile",+      "  regs",+      "  states Open",+      "  command Touch {}",+      "  event Touched = fields(Touch)",+      "  Open -- Touch --> outcome accepted ; emit Touched ; goto Open"+    ]++mappedQueueFeatureBody :: Text+mappedQueueFeatureBody =+  T.unlines+    [ "context profile",+      "workqueue jobs {",+      "  queue logical = \"profile-jobs\"",+      "  derive physical = \"profile-jobs\"",+      "    dlq = \"profile-jobs_dlq\"",+      "    table = \"q_profile-jobs\"",+      "  payload JobPayload {",+      "    jobData -> \"payload\" : JobPayload",+      "  }",+      "  retry maxRetries = 3 delay = 1s dlq = on",+      "  disposition {",+      "    storeFailure -> retry 1s",+      "    commandRejected -> ackOk",+      "    decodeFailure -> deadLetter",+      "    onCodecReject -> deadLetter",+      "  }",+      "}"+    ]++mappedQueryFeatureBody :: Text+mappedQueryFeatureBody =+  T.unlines+    [ "context profile",+      "readmodel profiles {",+      "  table = \"profiles\"",+      "  schema = \"public\"",+      "  columns {}",+      "  query input = ProfileLookup",+      "  query result = Optional ProfileSummary",+      "  version = 1",+      "  shape = \"fixture\"",+      "  freshness = immediate",+      "}"+    ]  allRuntimeCapabilities :: [RuntimeCapability] allRuntimeCapabilities = [minBound .. maxBound]

test/Keiro/Dsl/FrontendPublicApiProbe.hs view

@@ -7,11 +7,13 @@ where  import Data.Text (Text)-import Keiro.Dsl.Frontend (FrontendFailure, LoweringFailure, lowerSurfaceSource, parseSurfaceSource)+import Keiro.Dsl.Frontend (FrontendFailure, LoweringFailure, lowerSurfaceDocument, lowerSurfaceSource, parseSurfaceSource) import Keiro.Dsl.Grammar (Name, Node, Placement, Spec, specContext, specLayout, specModuleRoot, specNodes) import Keiro.Dsl.LanguageVersion (ParseFailure, ParsedSource, SourceLanguage, SourceLanguageDiagnostic, SourceLanguageErrorCode, parsedSourceLanguage, parsedSpec, sourceLanguageErrorCode)-import Keiro.Dsl.Parser (ParseError, parseSource, parseSpec, parseSpecText)+import Keiro.Dsl.Parser (ParseError, parseSource, parseSourceDocument, parseSpec, parseSpecText) import Keiro.Dsl.PrettyPrint (renderSource, renderSpec)+import Keiro.Dsl.Source (SourceSpan)+import Keiro.Dsl.SourceIndex (ParsedSourceDocument, SemanticSourceIndex, SourcePositionQuality, SourceSubject, lookupSourceSpan) import Keiro.Dsl.Syntax (SurfaceSource)  parseSurfaceSourceProbe :: FilePath -> Text -> Either FrontendFailure SurfaceSource@@ -20,9 +22,18 @@ lowerSurfaceSourceProbe :: SurfaceSource -> Either LoweringFailure ParsedSource lowerSurfaceSourceProbe = lowerSurfaceSource +lowerSurfaceDocumentProbe :: SurfaceSource -> Either LoweringFailure ParsedSourceDocument+lowerSurfaceDocumentProbe = lowerSurfaceDocument+ parseSourceProbe :: FilePath -> Text -> Either ParseFailure ParsedSource parseSourceProbe = parseSource +parseSourceDocumentProbe :: FilePath -> Text -> Either ParseFailure ParsedSourceDocument+parseSourceDocumentProbe = parseSourceDocument++lookupSourceSpanProbe :: SourceSubject -> SemanticSourceIndex -> Maybe (SourcePositionQuality, SourceSpan)+lookupSourceSpanProbe = lookupSourceSpan+ parseSpecProbe :: FilePath -> Text -> Either ParseError Spec parseSpecProbe = parseSpec @@ -62,16 +73,19 @@ apiProbe =   parseSurfaceSourceProbe `seq`     lowerSurfaceSourceProbe `seq`-      parseSourceProbe `seq`-        parseSpecProbe `seq`-          parseSpecTextProbe `seq`-            renderSourceProbe `seq`-              renderSpecProbe `seq`-                parsedSourceLanguageProbe `seq`-                  parsedSpecProbe `seq`-                    sourceLanguageErrorCodeProbe `seq`-                      specContextProbe `seq`-                        specModuleRootProbe `seq`-                          specLayoutProbe `seq`-                            specNodesProbe `seq`-                              ()+      lowerSurfaceDocumentProbe `seq`+        parseSourceProbe `seq`+          parseSourceDocumentProbe `seq`+            lookupSourceSpanProbe `seq`+              parseSpecProbe `seq`+                parseSpecTextProbe `seq`+                  renderSourceProbe `seq`+                    renderSpecProbe `seq`+                      parsedSourceLanguageProbe `seq`+                        parsedSpecProbe `seq`+                          sourceLanguageErrorCodeProbe `seq`+                            specContextProbe `seq`+                              specModuleRootProbe `seq`+                                specLayoutProbe `seq`+                                  specNodesProbe `seq`+                                    ()

test/Keiro/Dsl/FrontendSurface.hs view

@@ -3,6 +3,7 @@ module Keiro.Dsl.FrontendSurface (frontendSurfaceSpec) where  import Control.Monad (forM_)+import Data.List (find) import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.Frontend@@ -14,8 +15,9 @@   ) import Keiro.Dsl.Grammar import Keiro.Dsl.LanguageVersion-import Keiro.Dsl.Parser (parseSource)+import Keiro.Dsl.Parser (parseSource, parseSourceDocument, parseSpec, parseSpecText) import Keiro.Dsl.Source+import Keiro.Dsl.SourceIndex import Keiro.Dsl.Syntax import Test.Hspec hiding (Spec) import Prelude hiding (span)@@ -31,6 +33,15 @@           end = SourcePoint {offset = 2, line = 2, column = 1}       mkSourceSpan "invalid.keiro" start end `shouldBe` Nothing +    forM_ exactSpanCases $ \ExactSpanCase {caseLabel, caseSource, caseSelector, caseOwnedSyntax} ->+      it caseLabel $ do+        surface <- parseSurfaceRight (caseLabel <> ".keiro") caseSource+        actualSpan <- case selectSpan caseSource caseSelector surface of+          Left problem -> expectationFailure problem >> fail "unreachable"+          Right selected -> pure selected+        spanText caseSource actualSpan `shouldBe` caseOwnedSyntax+        spanPoints actualSpan `shouldBe` expectedSpanPoints caseSource caseOwnedSyntax+     it "locates Unicode-prefixed syntax and excludes trailing comments" $ do       let leading = "# λ🙂\n"           preambleText = "language keiro-dsl 2"@@ -96,7 +107,93 @@           } -> bodySpan `shouldBe` contextSpan         other -> expectationFailure ("unexpected empty surface shape: " <> show other) +    it "owns exact terminal-state and complete generated, replay-only, Hole, and adjacent transition syntax" $ do+      let source =+            T.unlines+              [ "language keiro-dsl 2",+                "context semantic-source-index",+                "aggregate Journey",+                "  regs",+                "    count Natural = 0",+                "  states Empty Active Closed!",+                "  command Start { amount:Natural }",+                "  event Started = fields(Start)",+                "  Empty -- Start -->",+                "    guard cmd.amount > 0",+                "    write count := cmd.amount",+                "    emit Started",+                "    goto Active",+                "  replay-only Empty -- Start -->",+                "    implementation hole",+                "    goto Active",+                "  Active -- Start --> implementation hole; goto Closed",+                "  Closed -- Start --> implementation hole; goto Closed # trailing"+              ]+      surface <- parseSurfaceRight "semantic-source-index.keiro" source+      let SurfaceSource {spec = Located {value = SurfaceSpec {elements}}} = surface+          stateSpans =+            [ (aggregateName, stateName, spanText source stateSpan)+            | Located {span = stateSpan, value = SurfaceAggregateState aggregateName stateName} <- elements+            ]+          transitionSpans =+            [ (aggregateName, ordinal, spanText source transitionSpan)+            | Located {span = transitionSpan, value = SurfaceAggregateTransition aggregateName ordinal} <- elements+            ]+      stateSpans+        `shouldBe` [ ("Journey", "Empty", "Empty"),+                     ("Journey", "Active", "Active"),+                     ("Journey", "Closed", "Closed!")+                   ]+      transitionSpans+        `shouldBe` [ ( "Journey",+                       0,+                       "Empty -- Start -->\n    guard cmd.amount > 0\n    write count := cmd.amount\n    emit Started\n    goto Active"+                     ),+                     ( "Journey",+                       1,+                       "replay-only Empty -- Start -->\n    implementation hole\n    goto Active"+                     ),+                     ("Journey", 2, "Active -- Start --> implementation hole; goto Closed"),+                     ("Journey", 3, "Closed -- Start --> implementation hole; goto Closed")+                   ]+      document <- case parseSourceDocument "semantic-source-index.keiro" source of+        Left failure -> expectationFailure (show failure) >> fail "unreachable"+        Right value -> pure value+      let ParsedSourceDocument {documentParsedSource, documentSourceIndex} = document+      parseSource "semantic-source-index.keiro" source `shouldBe` Right documentParsedSource+      length (semanticSourceEntries documentSourceIndex) `shouldBe` 7+      case lookupSourceSpan (AggregateStateSubject "Journey" "Closed") documentSourceIndex of+        Just (ExactSourcePosition, SourceSpan {source = spanSource, start = SourcePoint {line, column}}) -> do+          spanSource `shouldBe` "semantic-source-index.keiro"+          (line, column) `shouldBe` (6, 23)+        other -> expectationFailure ("expected exact terminal-state location, got " <> show other)+      case lookupSourceSpan (AggregateTransitionSubject "Journey" (TransitionOrdinal 1)) documentSourceIndex of+        Just (ExactSourcePosition, SourceSpan {start = SourcePoint {line, column}}) ->+          (line, column) `shouldBe` (14, 3)+        other -> expectationFailure ("expected exact replay-only transition location, got " <> show other)++    it "refuses incomplete and duplicate semantic source indices" $ do+      let subject = AggregateStateSubject "Journey" "Empty"+          point = SourcePoint {offset = 0, line = 1, column = 1}+          sourceSpan = SourceSpan {source = "index.keiro", start = point, end = point}+      exactSemanticSourceIndex "index.keiro" [subject] []+        `shouldSatisfy` isFailure MissingSourceSubject+      exactSemanticSourceIndex "index.keiro" [subject] [(subject, sourceSpan), (subject, sourceSpan)]+        `shouldSatisfy` isFailure DuplicateSourceSubject+   describe "surface lowering" $ do+    it "keeps every public parser projection equal for one rich source" $ do+      surface <- parseSurfaceRight "parser-parity.keiro" richParitySource+      lowered <- lowerRight surface+      document <- case parseSourceDocument "parser-parity.keiro" richParitySource of+        Left failure -> expectationFailure (show failure) >> fail "unreachable"+        Right parsed -> pure parsed+      let ParsedSourceDocument {documentParsedSource} = document+      documentParsedSource `shouldBe` lowered+      parseSource "parser-parity.keiro" richParitySource `shouldBe` Right lowered+      parseSpec "parser-parity.keiro" richParitySource `shouldBe` Right (parsedSpec lowered)+      parseSpecText richParitySource `shouldBe` Right (parsedSpec lowered)+     it "preserves top-level source order before grouping the semantic graph" $ do       let source = T.unlines ["context ordering", "id FirstId prefix=first", "enum Mode { On=on Off=off }", "id SecondId prefix=second"]       surface <- parseSurfaceRight "ordering.keiro" source@@ -205,6 +302,145 @@ spanText source SourceSpan {start = SourcePoint {offset = startOffset}, end = SourcePoint {offset = endOffset}} =   T.take (endOffset - startOffset) (T.drop startOffset source) +data SpanSelector+  = SelectPreamble+  | SelectContext+  | SelectFirstItem+  | SelectDocumentBody+  | SelectElement Text++data ExactSpanCase = ExactSpanCase+  { caseLabel :: String,+    caseSource :: Text,+    caseSelector :: SpanSelector,+    caseOwnedSyntax :: Text+  }++exactSpanCases :: [ExactSpanCase]+exactSpanCases =+  [ ExactSpanCase+      { caseLabel = "tracks a leading tab with Megaparsec tab stops",+        caseSource = "\tcontext tabs\n",+        caseSelector = SelectContext,+        caseOwnedSyntax = "context tabs"+      },+    ExactSpanCase+      { caseLabel = "counts Unicode characters before owned syntax",+        caseSource = "# λ🙂\ncontext unicode\n",+        caseSelector = SelectContext,+        caseOwnedSyntax = "context unicode"+      },+    ExactSpanCase+      { caseLabel = "tracks LF lines and excludes trailing spaces and comments",+        caseSource = "# leading\n\ncontext lf\nid LfId prefix=lf   # trailing\n",+        caseSelector = SelectFirstItem,+        caseOwnedSyntax = "id LfId prefix=lf"+      },+    ExactSpanCase+      { caseLabel = "tracks CRLF lines and excludes trailing comments",+        caseSource = "# leading\r\ncontext crlf\r\nid CrlfId prefix=crlf  # trailing\r\n",+        caseSelector = SelectFirstItem,+        caseOwnedSyntax = "id CrlfId prefix=crlf"+      },+    ExactSpanCase+      { caseLabel = "tracks mixed LF and CRLF sequences",+        caseSource = "# first\r\n# second\ncontext mixed\r\nid MixedId prefix=mixed\n",+        caseSelector = SelectFirstItem,+        caseOwnedSyntax = "id MixedId prefix=mixed"+      },+    ExactSpanCase+      { caseLabel = "keeps a hash inside a string literal as owned syntax",+        caseSource = richParitySource,+        caseSelector = SelectElement richGuardExpression,+        caseOwnedSyntax = richGuardExpression+      },+    ExactSpanCase+      { caseLabel = "ends an empty document body at its context clause",+        caseSource = "context empty   # trailing\r\n",+        caseSelector = SelectDocumentBody,+        caseOwnedSyntax = "context empty"+      },+    ExactSpanCase+      { caseLabel = "locates a nested aggregate field",+        caseSource = richParitySource,+        caseSelector = SelectElement "amount:Natural",+        caseOwnedSyntax = "amount:Natural"+      },+    ExactSpanCase+      { caseLabel = "locates a nested boolean and arithmetic expression",+        caseSource = richParitySource,+        caseSelector = SelectElement richGuardExpression,+        caseOwnedSyntax = richGuardExpression+      }+  ]++richParitySource :: Text+richParitySource =+  T.concat+    [ "# leading λ🙂\r\n",+      "language keiro-dsl 4\n",+      "context parser-parity\r\n",+      "aggregate SpanMatrix\n",+      "  regs\r\n",+      "    count Natural = 0\n",+      "    limit Natural = 100\r\n",+      "    label Text = \"ready # literal\"\n",+      "  states Empty Active Closed!\r\n",+      "  command Advance { amount:Natural delta:Natural note:Text }\n",+      "  event Advanced = fields(Advance)\r\n",+      "  Empty -- Advance -->\n",+      "    guard " <> richGuardExpression <> "\r\n",+      "    write count := reg.count + cmd.amount\n",+      "    write limit := reg.limit + cmd.delta\r\n",+      "    write label := cmd.note\n",+      "    emit Advanced\r\n",+      "    goto Active   # trailing\n"+    ]++richGuardExpression :: Text+richGuardExpression = "cmd.amount + cmd.delta > reg.count && reg.limit >= cmd.amount && cmd.note == \"ready # literal\""++selectSpan :: Text -> SpanSelector -> SurfaceSource -> Either String SourceSpan+selectSpan source selector SurfaceSource {preamble, spec = Located {span = bodySpan, value = SurfaceSpec {context = locatedContext, items, elements}}} =+  case selector of+    SelectPreamble -> maybe (Left "expected a language preamble span") (Right . locatedSpan) preamble+    SelectContext -> Right (locatedSpan locatedContext)+    SelectFirstItem -> case items of+      Located {span = itemSpan} : _ -> Right itemSpan+      [] -> Left "expected at least one top-level item span"+    SelectDocumentBody -> Right bodySpan+    SelectElement expectedText ->+      case find ((== expectedText) . spanText source . locatedSpan) elements of+        Just Located {span = elementSpan} -> Right elementSpan+        Nothing -> Left ("expected an element span owning " <> show expectedText)++locatedSpan :: Located value -> SourceSpan+locatedSpan Located {span} = span++expectedSpanPoints :: Text -> Text -> ((Int, Int, Int), (Int, Int, Int))+expectedSpanPoints source ownedSyntax =+  case T.breakOn ownedSyntax source of+    (_, suffix) | T.null suffix -> error ("expected owned syntax in exact-span fixture: " <> T.unpack ownedSyntax)+    (prefix, _) -> (pointAfterMegaparsec prefix, pointAfterMegaparsec (prefix <> ownedSyntax))++pointAfterMegaparsec :: Text -> (Int, Int, Int)+pointAfterMegaparsec = T.foldl' advance (0, 1, 1)+  where+    advance (currentOffset, currentLine, currentColumn) character =+      case character of+        '\n' -> (currentOffset + 1, currentLine + 1, 1)+        '\t' ->+          ( currentOffset + 1,+            currentLine,+            currentColumn + 8 - ((currentColumn - 1) `mod` 8)+          )+        _ -> (currentOffset + 1, currentLine, currentColumn + 1)++isFailure :: SourceIndexFailureCode -> Either SourceIndexFailure value -> Bool+isFailure expected = \case+  Left SourceIndexFailure {failureCode} -> failureCode == expected+  Right _ -> False+ isFacadeImport :: Text -> Bool isFacadeImport line =   let stripped = T.strip line@@ -234,6 +470,7 @@   map     ("keiro-dsl/src/Keiro/Dsl/" <>)     [ "Source.hs",+      "SourceIndex.hs",       "Syntax.hs",       "Grammar.hs",       "Validate.hs"

test/Main.hs view

@@ -13,10811 +13,13763 @@ import Data.Either (isLeft, isRight) import Data.Foldable (toList) import Data.KindID qualified as KindID-import Data.List (partition, permutations, sort, (\\))-import Data.List.NonEmpty (NonEmpty (..))-import Data.List.NonEmpty qualified as NE-import Data.Map.Strict qualified as Map-import Data.Set qualified as Set-import Data.Text qualified as T-import Data.Text.IO qualified as TIO-import Data.Text.Lazy qualified as LazyText-import Data.Text.Lazy.Encoding qualified as LazyTextEncoding-import Data.Version (showVersion)-import Keiki.ProjectionDomain (matchesTextPattern)-import Keiro.Codec (Codec (..), EventType (..), decodeRaw)-import Keiro.Codec.IdDomain (IdDomainFailure (..), idDomainSampleText, idDomainTextPattern, parseKindIdV7Text, parseKindIdV7Value, typeIdV7Domain, validateIdDomainText)-import Keiro.Dsl.AggregateType-import Keiro.Dsl.BehaviorCoverage qualified as Behavior-import Keiro.Dsl.CanonicalEncoding (foldFingerprint128)-import Keiro.Dsl.CodecCompare-import Keiro.Dsl.ConformanceBaseline (conformanceBaselineSpec)-import Keiro.Dsl.ConformancePackage-import Keiro.Dsl.Coverage qualified as Coverage-import Keiro.Dsl.Diff (Change (..), ChangeKind (..), CompatibilitySurface (..), CompatibilityVector (..), FamilyDiff (..), Label (..), NodeFamily, RolloutConstraint (..), SurfaceVerdict (..), defaultGate, deriveLabel, familyRegistry, gateWith, gatedBreaking, isAdvisory, isBreaking, verdictFor)-import Keiro.Dsl.Diff qualified as CheckedDiff-import Keiro.Dsl.DiffReport (Remedy (..), diffReport, parseSurfaceName, remediationFor, renderExplainBlock, renderFinding)-import Keiro.Dsl.EventOutput-import Keiro.Dsl.ExplainBindings (BindingHole (..), BindingObligation (..), BindingObligationKind (..), bindingHoles, bindingObligations, bindingObligationsForService, renderBindingObligations)-import Keiro.Dsl.Expression-import Keiro.Dsl.FoldFingerprint (FoldSurfaceError (..))-import Keiro.Dsl.FoldFingerprint qualified as CheckedFold-import Keiro.Dsl.FrontendCompatibility (frontendCompatibilitySpec)-import Keiro.Dsl.FrontendProfiles (frontendProfilesSpec)-import Keiro.Dsl.FrontendSurface (frontendSurfaceSpec)-import Keiro.Dsl.Goldens (GoldenEvidence (..), GoldenPayload (..), emitGoldenPayloads, goldenRelativePath, goldensForDiff)-import Keiro.Dsl.Grammar-import Keiro.Dsl.Harness (harnessFor, harnessForService, harnessForWithGoldens, harnessReadModel, harnessRouter, harnessWorkflow)-import Keiro.Dsl.HaskellSourceMove-import Keiro.Dsl.IdDomain (IdDomainContract (..), contractIdDomainContractFor, idDomainContractFor, idDomainIdentitiesForService)-import Keiro.Dsl.LanguageVersion-import Keiro.Dsl.Manifest (manifestDependencies, manifestDependenciesForService, moduleNameOf, renderManifest, renderManifestForService, renderManifestForServiceWithFacade)-import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), MappingIdentity (..), consumerPlan)-import Keiro.Dsl.NominalType hiding (NominalInvalidHaskellSource, NominalInvalidIdPrefix, NominalInvalidIdentity, NominalMissingIngredient)-import Keiro.Dsl.Parser (parseSource, parseSpec)-import Keiro.Dsl.PrettyPrint (renderSource, renderSpec, renderTransition)-import Keiro.Dsl.ReadModelShape (canonicalShape, deriveShapeHash, registryNameFor, subscriptionNameFor)-import Keiro.Dsl.ReplayImpact (AggregateImpact (..), ReplayImpact (..))-import Keiro.Dsl.ReplayImpact qualified as ReplayImpact-import Keiro.Dsl.Scaffold (Context (..), ModuleKind (..), NominalGenerationOwner (..), NominalUseSite (..), ScaffoldModule (..), StructuralProjection (..), codecComparisonBanner, codecComparisonModule, defaultContext, firewallBreaches, genPrefixFor, generatedBanner, generatedBannerFor, generatedNominalModule, holePrefixFor, isGeneratedBannerLine, moduleRole, obsoleteGeneratedOutputHooks, planNominalGeneration, projectionSpecs, scaffoldAggregate, scaffoldContract, scaffoldContractForService, scaffoldIntake, scaffoldProcess, scaffoldPublisher, scaffoldReadModel, scaffoldRefusals, scaffoldReplayAudit, scaffoldRouter, scaffoldStructural, scaffoldWorkqueue, windowSeconds)-import Keiro.Dsl.ScaffoldRecord (GeneratedHaskellNamingEdition (..), ScaffoldModuleRoleRow (..), ScaffoldRecord (..), parseRecord, recordFileName, renderRecord)-import Keiro.Dsl.ScaffoldRun (MappingDrift (..), Refusal (..), ScaffoldReport (..), SourceLanguageDrift (..), StaleGeneratedEvidence (..), StaleModule (..), WriteDisposition (..), auditGeneratedHaskell, checkServiceDiagnostics, executeScaffold, executeScaffoldWithLanguage, executeServiceScaffold, executeServiceScaffoldWithRuntimePackage, executeServiceScaffoldWithRuntimePackageAndNameMigrations, planScaffold, planServiceScaffold, planServiceScaffoldWithRuntimePackage, planningRefusalDiagnostics, renderRefusals, renderScaffoldReport, scaffoldModules, scaffoldServiceModules)-import Keiro.Dsl.SemanticContract-import Keiro.Dsl.ServiceHarness-import Keiro.Dsl.SidecarMigration-import Keiro.Dsl.SidecarNames-import Keiro.Dsl.Skeleton (skeletonFor, skeletonKinds)-import Keiro.Dsl.TypeGraph-import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), Severity (..), derivedQueueTrio, diagnosticCodeText, parseDiagnosticCode, renderDiagnostic, validateService, validateSpec)-import Keiro.Dsl.Workspace-import Keiro.Dsl.WorkspaceAdoption-import Keiro.Dsl.WorkspaceDiff hiding (diffWorkspaces)-import Keiro.Dsl.WorkspaceDiff qualified as CheckedWorkspaceDiff-import Keiro.Dsl.WorkspaceRecord-import Keiro.Dsl.WorkspaceScaffold-import Paths_keiro_dsl qualified as Package-import System.Directory (canonicalizePath, createDirectory, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getTemporaryDirectory, listDirectory, removeFile, removePathForcibly, renameFile)-import System.Environment (lookupEnv)-import System.Exit (ExitCode (..))-import System.FilePath (takeDirectory, takeExtension, takeFileName, (</>))-import System.IO (hClose, openTempFile)-import System.Process (readProcessWithExitCode)-import Test.Hspec hiding (Spec)-import Test.QuickCheck--resolvedFold :: Either FoldSurfaceError value -> value-resolvedFold = either (error . ("unexpected fold-surface failure in checked fixture: " <>) . show) id--aggregateFoldFingerprintForService :: CheckedService -> Aggregate -> T.Text-aggregateFoldFingerprintForService service aggregate = resolvedFold (CheckedFold.aggregateFoldFingerprintForService service aggregate)--aggregateFoldSurfaceForService :: CheckedService -> Aggregate -> T.Text-aggregateFoldSurfaceForService service aggregate = resolvedFold (CheckedFold.aggregateFoldSurfaceForService service aggregate)--aggregateFoldFingerprint :: Spec -> Aggregate -> T.Text-aggregateFoldFingerprint spec aggregate = aggregateFoldFingerprintForService (stableCheckedService spec) aggregate--aggregateFoldSurface :: Spec -> Aggregate -> T.Text-aggregateFoldSurface spec aggregate = aggregateFoldSurfaceForService (stableCheckedService spec) aggregate--legacyAggregateFoldFingerprint :: Spec -> Aggregate -> T.Text-legacyAggregateFoldFingerprint spec aggregate = aggregateFoldFingerprintForService (legacyCheckedService spec) aggregate--legacyAggregateFoldSurface :: Spec -> Aggregate -> T.Text-legacyAggregateFoldSurface spec aggregate = aggregateFoldSurfaceForService (legacyCheckedService spec) aggregate--diffServices :: CheckedService -> CheckedService -> [Change]-diffServices old new = resolvedFold (CheckedDiff.diffServices old new)--diffSources :: ParsedSource -> ParsedSource -> [Change]-diffSources old new = resolvedFold (CheckedDiff.diffSources old new)--diffSpecs :: Spec -> Spec -> [Change]-diffSpecs old new = diffServices (stableCheckedService old) (stableCheckedService new)--legacyDiffSpecs :: Spec -> Spec -> [Change]-legacyDiffSpecs old new = diffServices (legacyCheckedService old) (legacyCheckedService new)--diffWorkspaces :: WorkspaceSpec -> WorkspaceSpec -> [WorkspaceChange]-diffWorkspaces old new = resolvedFold (CheckedWorkspaceDiff.diffWorkspaces old new)--replayImpactSpecs :: Spec -> Spec -> ReplayImpact-replayImpactSpecs old new =-  resolvedFold (ReplayImpact.replayImpactServices (stableCheckedService old) (stableCheckedService new))--legacyReplayImpactSpecs :: Spec -> Spec -> ReplayImpact-legacyReplayImpactSpecs old new =-  resolvedFold (ReplayImpact.replayImpactServices (legacyCheckedService old) (legacyCheckedService new))--nominalEqualityIdentities :: Spec -> [T.Text]-nominalEqualityIdentities = nominalEqualityIdentitiesForService . stableCheckedService--stableCheckedService :: Spec -> CheckedService-stableCheckedService = checkedService stableSourceLanguage--stableSourceLanguage :: SourceLanguage-stableSourceLanguage =-  DeclaredLanguage-    { declaredLanguageVersion = currentStableLanguageVersion,-      languageVersionLoc = noLoc-    }--main :: IO ()-main = hspec $ do-  conformanceBaselineSpec-  frontendCompatibilitySpec-  frontendSurfaceSpec-  frontendProfilesSpec--  describe "language support" $ do-    it "serializes support from the registered version and decodes older records" $ do-      v1Contract <- maybe (expectationFailure "missing v1 contract" >> fail "unreachable") pure (effectiveLanguageContractForVersion =<< languageVersion 1)-      v4Contract <- maybe (expectationFailure "missing v4 contract" >> fail "unreachable") pure (effectiveLanguageContractForVersion =<< languageVersion 4)-      effectiveLanguageSupport v1Contract `shouldBe` CompatibilityOnly-      effectiveLanguageSupport v4Contract `shouldBe` Stable-      Aeson.toJSON v4Contract-        `shouldBe` object-          [ "languageVersion" .= (4 :: Int),-            "runtimeSemantics" .= ("keiro-dsl/runtime-semantics/3" :: T.Text),-            "languageSupport" .= ("stable" :: T.Text)-          ]-      Aeson.eitherDecode "{\"languageVersion\":1,\"runtimeSemantics\":\"keiro-dsl/runtime-semantics/1\"}"-        `shouldBe` Right v1Contract--    it "reports stable and compatibility-only support through source inspection" $ do-      (stableCode, stableOut, stableErr) <- runKeiroDsl ["inspect", "test/fixtures/contract-v4.keiro", "--format=json"]-      stableCode `shouldBe` ExitSuccess-      stableErr `shouldBe` ""-      stableOut `shouldContain` "\"languageVersion\":4"-      stableOut `shouldContain` "\"languageSupport\":\"stable\""-      (compatibilityCode, compatibilityOut, compatibilityErr) <- runKeiroDsl ["inspect", "test/fixtures/language-v1.keiro", "--format=json"]-      compatibilityCode `shouldBe` ExitSuccess-      compatibilityErr `shouldBe` ""-      compatibilityOut `shouldContain` "\"languageVersion\":1"-      compatibilityOut `shouldContain` "\"languageSupport\":\"compatibility-only\""--    it "surfaces non-stable contracts and enforces a released minimum language" $ do-      let legacyPath = "test/fixtures/language-legacy.keiro"-          stablePath = "test/fixtures/contract-v4.keiro"-      (legacyCode, legacyOut, legacyErr) <- runKeiroDsl ["check", legacyPath]-      legacyCode `shouldBe` ExitSuccess-      legacyOut `shouldBe` "OK\n"-      legacyErr `shouldContain` "language contract: effective keiro-dsl 1 (legacy-unversioned, compatibility-only, runtime semantics keiro-dsl/runtime-semantics/1)"-      legacyErr `shouldContain` "language-4 strict spec-surface validation is not applied"--      (stableCode, stableOut, stableErr) <- runKeiroDsl ["check", stablePath]-      stableCode `shouldBe` ExitSuccess-      stableOut `shouldBe` "OK\n"-      stableErr `shouldBe` ""--      (floorCode, floorOut, floorErr) <- runKeiroDsl ["check", legacyPath, "--min-language", "4"]-      floorCode `shouldBe` ExitFailure 1-      floorOut `shouldBe` ""-      floorErr `shouldContain` "language-legacy.keiro:1: error[LanguageVersionBelowMinimum]"-      floorErr `shouldContain` "effective language version 1 (legacy-unversioned) is below the required minimum 4"--      (metCode, metOut, _) <- runKeiroDsl ["check", legacyPath, "--min-language", "1"]-      metCode `shouldBe` ExitSuccess-      metOut `shouldBe` "OK\n"--      (unsupportedCode, _, unsupportedErr) <- runKeiroDsl ["check", legacyPath, "--min-language", "9"]-      unsupportedCode `shouldBe` ExitFailure 1-      unsupportedErr `shouldContain` "supported versions: 1, 2, 3, 4"--    it "attributes a workspace language floor to its manifest and every member" $ do-      let v1Member = T.unlines ["language keiro-dsl 1", "context language-floor"]-      withInlineWorkspace-        "keiro-dsl-language-floor"-        ( "language-floor",-          [ ("domain/a.keiro", v1Member),-            ("domain/b.keiro", v1Member)-          ]-        )-        $ \root _ _ -> do-          let manifest = root </> "service.keiro-workspace"-          (floorCode, floorOut, floorErr) <- runKeiroDsl ["check", manifest, "--min-language", "4"]-          floorCode `shouldBe` ExitFailure 1-          floorOut `shouldBe` ""-          floorErr `shouldContain` (manifest <> ":1: error[LanguageVersionBelowMinimum]")-          floorErr `shouldContain` "domain/a.keiro:1: note: member selects effective language version 1"-          floorErr `shouldContain` "domain/b.keiro:1: note: member selects effective language version 1"-          floorErr `shouldContain` "workspace, 0 legacy-unversioned member(s)"--          (metCode, metOut, _) <- runKeiroDsl ["check", manifest, "--min-language", "1"]-          metCode `shouldBe` ExitSuccess-          metOut `shouldBe` "OK\n"--  describe "warning enforcement" $ do-    it "round-trips every stable diagnostic code spelling" $ do-      forM_ [minBound .. maxBound] $ \diagnosticCode ->-        parseDiagnosticCode (diagnosticCodeText diagnosticCode) `shouldBe` Just diagnosticCode--    it "fails only the warnings selected by invocation policy" $ do-      let fixture = "test/fixtures/deny-unlogged.keiro"-          warningText = "warning[WqUnloggedDurability]"-          summaryText = "check: 1 warning(s) escalated to failure (denied: WqUnloggedDurability)"--      (plainCode, plainOut, plainErr) <- runKeiroDsl ["check", fixture]-      plainCode `shouldBe` ExitSuccess-      plainOut `shouldBe` "OK\n"-      plainErr `shouldContain` warningText-      plainErr `shouldNotContain` "escalated to failure"--      (allCode, allOut, allErr) <- runKeiroDsl ["check", fixture, "--deny-warnings"]-      allCode `shouldBe` ExitFailure 1-      allOut `shouldBe` ""-      allErr `shouldContain` warningText-      allErr `shouldContain` summaryText--      (selectedCode, selectedOut, selectedErr) <- runKeiroDsl ["check", fixture, "--deny", "WqUnloggedDurability"]-      selectedCode `shouldBe` ExitFailure 1-      selectedOut `shouldBe` ""-      selectedErr `shouldContain` warningText-      selectedErr `shouldContain` summaryText--      (otherCode, otherOut, otherErr) <- runKeiroDsl ["check", fixture, "--deny", "WireSchemaVersionMismatch"]-      otherCode `shouldBe` ExitSuccess-      otherOut `shouldBe` "OK\n"-      otherErr `shouldContain` warningText-      otherErr `shouldNotContain` "escalated to failure"--      (unionCode, unionOut, unionErr) <--        runKeiroDsl-          [ "check",-            fixture,-            "--deny-warnings",-            "--deny",-            "WireSchemaVersionMismatch,WqUnloggedDurability"-          ]-      unionCode `shouldBe` ExitFailure 1-      unionOut `shouldBe` ""-      unionErr `shouldContain` warningText-      unionErr `shouldContain` summaryText--      (unknownCode, _, unknownErr) <- runKeiroDsl ["check", fixture, "--deny", "NotACode"]-      unknownCode `shouldBe` ExitFailure 1-      unknownErr `shouldContain` "unknown diagnostic code `NotACode`"-      unknownErr `shouldContain` "warning[Code]"--    -- A denial that can never match reads like a CI gate and is not one. Every-    -- code `check` cannot emit is refused at the point of use instead.-    it "refuses a denial of a code check can never emit" $ do-      let fixture = "test/fixtures/deny-unlogged.keiro"--      (diffCode, _, diffErr) <- runKeiroDsl ["check", fixture, "--deny", "EvtFieldWireKeyChanged"]-      diffCode `shouldBe` ExitFailure 1-      diffErr `shouldContain` "`EvtFieldWireKeyChanged` is emitted by `keiro-dsl diff`"-      diffErr `shouldContain` "would never match"--      -- Rejection survives being hidden inside a comma-separated list.-      (mixedCode, _, mixedErr) <--        runKeiroDsl ["check", fixture, "--deny", "WqUnloggedDurability,WorkflowShapeChanged"]-      mixedCode `shouldBe` ExitFailure 1-      mixedErr `shouldContain` "`WorkflowShapeChanged` is emitted by `keiro-dsl diff`"--      (codecCode, _, codecErr) <- runKeiroDsl ["check", fixture, "--deny", "CodecCompareDifference"]-      codecCode `shouldBe` ExitFailure 1-      codecErr `shouldContain` "generated codec-comparison path"--      -- A coverage code is emittable, but only by an invocation that asks for-      -- the coverage pass, so the requirement is stated rather than ignored.-      (noPassCode, _, noPassErr) <- runKeiroDsl ["check", fixture, "--deny", "CoverageOpaqueSurface"]-      noPassCode `shouldBe` ExitFailure 1-      noPassErr `shouldContain` "add --coverage-report FILE or drop the code"--      -- CoverageOpaqueGateExceeded is the error --fail-on-opaque itself raises,-      -- never a warning, so denying it is a silent no-op in every invocation —-      -- with or without the coverage pass it is refused with the real spelling.-      withTempDirectory "keiro-dsl-gate-exceeded-deny" $ \out -> do-        (gateCode, _, gateErr) <--          runKeiroDsl-            ["check", fixture, "--coverage-report", out </> "coverage.json", "--deny", "CoverageOpaqueGateExceeded"]-        gateCode `shouldBe` ExitFailure 1-        gateErr `shouldContain` "pass --fail-on-opaque instead of denying it"-      (gateNoPassCode, _, gateNoPassErr) <- runKeiroDsl ["check", fixture, "--deny", "CoverageOpaqueGateExceeded"]-      gateNoPassCode `shouldBe` ExitFailure 1-      gateNoPassErr `shouldContain` "pass --fail-on-opaque instead of denying it"--    it "applies the warning policy to structural-coverage findings" $ do-      withTempDirectory "keiro-dsl-coverage-deny" $ \out -> do-        let fixture = "test/fixtures/structural-conformance.keiro"-            coveragePath = out </> "coverage.json"-            reportPath = out </> "nested" </> "dir" </> "check.json"-            warningText = "warning[CoverageOpaqueSurface]"--        -- Reporting-only by default: the finding prints and the check passes.-        (plainCode, _, plainErr) <--          runKeiroDsl ["check", fixture, "--coverage-report", coveragePath]-        plainCode `shouldBe` ExitSuccess-        plainErr `shouldContain` warningText-        plainErr `shouldNotContain` "escalated to failure"--        -- Before ExecPlan 199 this combination exited 0 with the warning printed.-        (deniedCode, _, deniedErr) <--          runKeiroDsl-            [ "check",-              fixture,-              "--coverage-report",-              coveragePath,-              "--deny-warnings",-              -- The nested path also proves --report-out creates parent dirs.-              "--report-out",-              reportPath-            ]-        deniedCode `shouldBe` ExitFailure 1-        deniedErr `shouldContain` warningText-        deniedErr `shouldContain` "escalated to failure (denied: CoverageOpaqueSurface)"--        report <- decodeJsonValue reportPath-        jsonField "ok" report `shouldBe` Just (Aeson.Bool False)-        (jsonField "summary" report >>= jsonField "deniedWarnings") `shouldBe` Just (Aeson.Number 1)-        case jsonField "diagnostics" report of-          Just (Aeson.Array entries) ->-            [entry | entry <- toList entries, jsonField "code" entry == Just (Aeson.String "CoverageOpaqueSurface")]-              `shouldSatisfy` \matching -> case matching of-                entry : _ ->-                  jsonField "severity" entry == Just (Aeson.String "warning")-                    && jsonField "denied" entry == Just (Aeson.Bool True)-                [] -> False-          other -> expectationFailure ("expected diagnostics array, got " <> show other)--        -- Selecting the code by name gates it just as precisely.-        (selectedCode, _, _) <--          runKeiroDsl-            ["check", fixture, "--coverage-report", coveragePath, "--deny", "CoverageOpaqueSurface"]-        selectedCode `shouldBe` ExitFailure 1--    it "spells warning severity the same way in both JSON reports" $ do-      withTempDirectory "keiro-dsl-severity-vocabulary" $ \out -> do-        let coveragePath = out </> "coverage.json"-        (exitCode, _, _) <--          runKeiroDsl-            ["check", "test/fixtures/structural-conformance.keiro", "--coverage-report", coveragePath]-        exitCode `shouldBe` ExitSuccess-        coverage <- decodeJsonValue coveragePath-        case jsonField "findings" coverage of-          Just (Aeson.Array entries) -> case toList entries of-            entry : _ -> jsonField "severity" entry `shouldBe` Just (Aeson.String "warning")-            [] -> expectationFailure "coverage report had no findings"-          other -> expectationFailure ("expected findings array, got " <> show other)--    it "writes the machine report when a workspace is refused during composition" $ do-      withTempDirectory "keiro-dsl-workspace-refusal-report" $ \out -> do-        let reportPath = out </> "made" </> "up" </> "refusal.json"-        (exitCode, stdoutText, _) <--          runKeiroDsl-            [ "check",-              "test/fixtures/workspace-dup-decl/service.keiro-workspace",-              "--report-out",-              reportPath-            ]-        exitCode `shouldBe` ExitFailure 1-        stdoutText `shouldBe` ""-        report <- decodeJsonValue reportPath-        jsonField "schema" report `shouldBe` Just (Aeson.String "keiro-dsl/check-report/1")-        jsonField "kind" report `shouldBe` Just (Aeson.String "workspace")-        jsonField "ok" report `shouldBe` Just (Aeson.Bool False)-        -- No service graph was composed, so there is no language contract.-        jsonField "language" report `shouldBe` Just Aeson.Null-        case jsonField "diagnostics" report of-          Just (Aeson.Array entries) -> case toList entries of-            entry : _ -> do-              jsonField "code" entry `shouldBe` Just (Aeson.String "WorkspaceDuplicateDeclaration")-              jsonField "severity" entry `shouldBe` Just (Aeson.String "error")-            [] -> expectationFailure "workspace refusal report had no diagnostics"-          other -> expectationFailure ("expected diagnostics array, got " <> show other)--    it "applies the same warning policy to a composed workspace" $ do-      warningSource <- readTestText "test/fixtures/deny-unlogged.keiro"-      withInlineWorkspace-        "keiro-dsl-warning-policy"-        ("warning-policy", [("domain/jobs.keiro", warningSource)])-        $ \root _ _ -> do-          let manifest = root </> "service.keiro-workspace"-          (plainCode, plainOut, plainErr) <- runKeiroDsl ["check", manifest]-          plainCode `shouldBe` ExitSuccess-          plainOut `shouldBe` "OK\n"-          plainErr `shouldContain` "domain/jobs.keiro:4: warning[WqUnloggedDurability]"--          (deniedCode, deniedOut, deniedErr) <- runKeiroDsl ["check", manifest, "--deny", "WqUnloggedDurability"]-          deniedCode `shouldBe` ExitFailure 1-          deniedOut `shouldBe` ""-          deniedErr `shouldContain` "domain/jobs.keiro:4: warning[WqUnloggedDurability]"-          deniedErr `shouldContain` "check: 1 warning(s) escalated to failure (denied: WqUnloggedDurability)"--  describe "check report" $ do-    it "writes the source failure report and matches the public-CLI golden" $ do-      withTempDirectory "keiro-dsl-check-report-floor" $ \out -> do-        let reportPath = out </> "report.json"-        (exitCode, stdoutText, _) <--          runKeiroDsl-            [ "check",-              "test/fixtures/language-legacy.keiro",-              "--min-language",-              "4",-              "--report-out",-              reportPath-            ]-        exitCode `shouldBe` ExitFailure 1-        stdoutText `shouldBe` ""-        report <- decodeJsonValue reportPath-        goldenPath <- resolveTestPath "test/fixtures/check-report/legacy-min-language.golden.json"-        golden <- decodeJsonValue goldenPath-        report `shouldBe` golden-        jsonField "schema" report `shouldBe` Just (Aeson.String "keiro-dsl/check-report/1")-        jsonField "kind" report `shouldBe` Just (Aeson.String "source")-        jsonField "ok" report `shouldBe` Just (Aeson.Bool False)-        (jsonField "language" report >>= jsonField "stable") `shouldBe` Just (Aeson.Bool False)-        (jsonField "summary" report >>= jsonField "errors") `shouldBe` Just (Aeson.Number 1)-        case jsonField "diagnostics" report of-          Just (Aeson.Array entries) -> case toList entries of-            entry : _ -> do-              jsonField "code" entry `shouldBe` Just (Aeson.String "LanguageVersionBelowMinimum")-              jsonField "severity" entry `shouldBe` Just (Aeson.String "error")-              jsonField "line" entry `shouldBe` Just (Aeson.Number 1)-            [] -> expectationFailure "check report had no diagnostics"-          other -> expectationFailure ("expected diagnostics array, got " <> show other)--    it "marks denied warnings without changing their severity" $ do-      withTempDirectory "keiro-dsl-check-report-deny" $ \out -> do-        let deniedPath = out </> "denied.json"-            allowedPath = out </> "allowed.json"-            fixture = "test/fixtures/deny-unlogged.keiro"-        (deniedCode, _, _) <- runKeiroDsl ["check", fixture, "--deny-warnings", "--report-out", deniedPath]-        deniedCode `shouldBe` ExitFailure 1-        deniedReport <- decodeJsonValue deniedPath-        jsonField "ok" deniedReport `shouldBe` Just (Aeson.Bool False)-        (jsonField "summary" deniedReport >>= jsonField "deniedWarnings") `shouldBe` Just (Aeson.Number 1)-        case jsonField "diagnostics" deniedReport of-          Just (Aeson.Array entries) -> case toList entries of-            entry : _ -> do-              jsonField "severity" entry `shouldBe` Just (Aeson.String "warning")-              jsonField "denied" entry `shouldBe` Just (Aeson.Bool True)-            [] -> expectationFailure "denied-warning report had no diagnostics"-          other -> expectationFailure ("expected diagnostics array, got " <> show other)--        (allowedCode, _, _) <- runKeiroDsl ["check", fixture, "--report-out", allowedPath]-        allowedCode `shouldBe` ExitSuccess-        allowedReport <- decodeJsonValue allowedPath-        jsonField "ok" allowedReport `shouldBe` Just (Aeson.Bool True)-        (jsonField "summary" allowedReport >>= jsonField "deniedWarnings") `shouldBe` Just (Aeson.Number 0)-        case jsonField "diagnostics" allowedReport of-          Just (Aeson.Array entries) -> case toList entries of-            entry : _ -> jsonField "denied" entry `shouldBe` Just (Aeson.Bool False)-            [] -> expectationFailure "allowed-warning report had no diagnostics"-          other -> expectationFailure ("expected diagnostics array, got " <> show other)--    it "reports canonical workspace members and writes nothing before parse success" $ do-      withTempDirectory "keiro-dsl-check-report-workspace" $ \out -> do-        let workspacePath = out </> "workspace.json"-            parseFailurePath = out </> "parse-failure.json"-        (workspaceCode, _, _) <- runKeiroDsl ["check", canonicalWorkspacePath, "--report-out", workspacePath]-        workspaceCode `shouldBe` ExitSuccess-        workspaceReport <- decodeJsonValue workspacePath-        jsonField "kind" workspaceReport `shouldBe` Just (Aeson.String "workspace")-        jsonField "ok" workspaceReport `shouldBe` Just (Aeson.Bool True)-        (jsonField "language" workspaceReport >>= jsonField "sourceForm") `shouldBe` Just (Aeson.String "workspace-composed")-        case jsonField "members" workspaceReport of-          Just (Aeson.Array members) -> length members `shouldBe` 3-          other -> expectationFailure ("expected members array, got " <> show other)--        let v1Member = T.unlines ["language keiro-dsl 1", "context report-floor"]-        withInlineWorkspace-          "keiro-dsl-check-report-workspace-floor"-          ( "report-floor",-            [ ("domain/a.keiro", v1Member),-              ("domain/b.keiro", v1Member)-            ]-          )-          $ \root _ _ -> do-            let manifest = root </> "service.keiro-workspace"-                floorReportPath = out </> "workspace-floor.json"-            (floorCode, _, _) <--              runKeiroDsl ["check", manifest, "--min-language", "4", "--report-out", floorReportPath]-            floorCode `shouldBe` ExitFailure 1-            floorReport <- decodeJsonValue floorReportPath-            case jsonField "diagnostics" floorReport of-              Just (Aeson.Array entries) -> case toList entries of-                entry : _ -> do-                  jsonField "file" entry `shouldBe` Just (Aeson.String (T.pack manifest))-                  jsonField "code" entry `shouldBe` Just (Aeson.String "LanguageVersionBelowMinimum")-                  case jsonField "related" entry of-                    Just (Aeson.Array related) -> length related `shouldBe` 2-                    other -> expectationFailure ("expected related-location array, got " <> show other)-                [] -> expectationFailure "workspace-floor report had no diagnostics"-              other -> expectationFailure ("expected diagnostics array, got " <> show other)--        (parseCode, _, _) <--          runKeiroDsl-            [ "check",-              "test/fixtures/language-future.keiro",-              "--report-out",-              parseFailurePath-            ]-        parseCode `shouldBe` ExitFailure 1-        doesFileExist parseFailurePath `shouldReturn` False--  describe "runtime capability and fold identity baseline (plan 181)" $ do-    it "pins the fold-only FNV-1a-128 UTF-8 encoding" $ do-      foldFingerprint128 "" `shouldBe` "6c62272e07bb014262b821756295c58d"-      foldFingerprint128 "雪" `shouldBe` "a68afaae758b5822836dbc787bb233bd"--    it "pins complete fold surfaces and fingerprints across representative aggregates" $ do-      scalar <- checkedServiceOf "test/fixtures/aggregate-scalar-expressions-v2.keiro"-      nominal <- checkedServiceOf "test/fixtures/nominal-scalars.keiro"-      idDomain <- checkedServiceOf "test/fixtures/id-domain-migration-v3.keiro"-      behavior <- checkedServiceOf "test/fixtures/behavior-complete.keiro"-      workspace <- shouldComposeWorkspace "test/fixtures/workspace-nominals/service.keiro-workspace"-      let actual =-            T.intercalate-              "\n\n"-              [ renderFoldBaseline "aggregate-scalar-expressions-v2" scalar,-                renderFoldBaseline "nominal-scalars" nominal,-                renderFoldBaseline "id-domain-migration-v3" idDomain,-                renderFoldBaseline "behavior-complete" behavior,-                renderFoldBaseline "workspace-nominals" (checkedWorkspace workspace)-              ]-      assertMatchesGolden "test/fixtures/fold-identity-baseline.golden" actual--    it "pins all four runtime gates and fingerprint segment projections" $ do-      nominalSpec <- specOf "test/fixtures/id-domain-migration-v3.keiro"-      nominalRegistry <- case resolveNominalTypes nominalSpec of-        Left errors -> expectationFailure (show errors) >> fail "unreachable"-        Right value -> pure value-      nominal <- case lookupNominalType "OrderId" nominalRegistry of-        Nothing -> expectationFailure "missing OrderId nominal" >> fail "unreachable"-        Just value -> pure value-      strictSpec <--        parseInlineSpec-          "<strict-profile>"-          ( T.unlines-              [ "context strict-profile",-                "aggregate DuplicateRegister",-                "  regs",-                "    value Int = 0",-                "    value Int = 0",-                "  states Open"-              ]-          )-      rows <- forM [1 .. 4 :: Int] $ \number -> do-        contract <- case languageVersion (fromIntegral number) >>= effectiveLanguageContractForVersion of-          Nothing -> expectationFailure ("missing released language contract " <> show number) >> fail "unreachable"-          Just value -> pure value-        let hasAggregateIdDomain = maybe False (const True) (idDomainContractFor contract "ord")-            hasContractIdDomain = maybe False (const True) (contractIdDomainContractFor contract "ord")-            nominalContract = equalityContractVersion <$> nominalEqualityContractForService contract nominal-            strictService = CheckedService contract strictSpec-            hasStrictValidation = any ((== AggregateDuplicateRegister) . code) (validateService strictService)-        pure-          ( number,-            effectiveRuntimeSemantics contract,-            runtimeSemanticsFingerprintSegments contract,-            hasAggregateIdDomain,-            hasContractIdDomain,-            nominalContract,-            hasStrictValidation-          )-      rows-        `shouldBe` [ (1, "keiro-dsl/runtime-semantics/1", [], False, False, Just "keiro-dsl/nominal-equality/1", False),-                     (2, "keiro-dsl/runtime-semantics/1", [], False, False, Just "keiro-dsl/nominal-equality/1", False),-                     (3, "keiro-dsl/runtime-semantics/2", ["semantic-contract:keiro-dsl/runtime-semantics/2"], True, False, Just "keiro-dsl/nominal-equality/2", False),-                     (4, "keiro-dsl/runtime-semantics/3", ["semantic-contract:keiro-dsl/runtime-semantics/2"], True, True, Just "keiro-dsl/nominal-equality/2", True)-                   ]--    it "explains a serialized runtime-profile mismatch" $ do-      case (Aeson.eitherDecode "{\"languageVersion\":4,\"runtimeSemantics\":\"keiro-dsl/runtime-semantics/2\"}" :: Either String EffectiveLanguageContract) of-        Left message -> do-          message `shouldContain` "runtimeSemantics does not match language version 4"-          message `shouldContain` "keiro-dsl/runtime-semantics/3"-          message `shouldContain` "keiro-dsl/runtime-semantics/2"-        Right _ -> expectationFailure "expected a runtime-profile mismatch"--    it "reports every formerly silent fold-resolution failure and propagates it" $ do-      baseService <- checkedServiceOf "test/fixtures/id-domain-migration-v3.keiro"-      recursiveMapped <- specOf "test/fixtures/mapped-recursive.keiro"-      brokenNominal <- specOf "test/fixtures/nominal-missing-facts.keiro"-      missingInitial <- specOf "test/fixtures/mapped-missing-initial.keiro"-      let contract = checkedLanguageContract baseService-          baseSpec = checkedSpec baseService-          baseAggregate = onlyAggregate baseSpec-          withAggregate transform =-            baseSpec-              { specNodes =-                  [ NAggregate (transform aggregate)-                  | NAggregate aggregate <- specNodes baseSpec-                  ]-              }-          replaceFirstTransition transform aggregate =-            aggregate-              { aggTransitions = case aggTransitions aggregate of-                  transition : rest -> transform transition : rest-                  [] -> []-              }-          guardSpec = withAggregate (replaceFirstTransition (\transition -> transition {tGuard = Just (EAtom (AName "missingGuardRoot"))}))-          outputSpec = withAggregate (replaceFirstTransition (\transition -> transition {tEmits = ["MissingEvent"]}))-          typeGraphSpec = baseSpec {specMapped = specMapped recursiveMapped}-          nominalSpec = baseSpec {specNominalScalars = specNominalScalars brokenNominal}-          cases =-            [ (CheckedService contract typeGraphSpec, baseAggregate, \case FoldTypeGraphResolutionFailed {} -> True; _ -> False),-              (CheckedService contract nominalSpec, baseAggregate, \case FoldNominalResolutionFailed {} -> True; _ -> False),-              (CheckedService contract missingInitial, onlyAggregate missingInitial, \case FoldRegisterInitialResolutionFailed {} -> True; _ -> False),-              (CheckedService contract guardSpec, onlyAggregate guardSpec, \case FoldGuardResolutionFailed {} -> True; _ -> False),-              (CheckedService contract outputSpec, onlyAggregate outputSpec, \case FoldEventOutputResolutionFailed {} -> True; _ -> False)-            ]-      forM_ cases $ \(service, aggregate, matches) -> do-        CheckedFold.aggregateFoldSurfaceForService service aggregate-          `shouldSatisfy` either matches (const False)-        CheckedFold.aggregateFoldFingerprintForService service aggregate-          `shouldSatisfy` either matches (const False)-      let brokenService = CheckedService contract guardSpec-      CheckedDiff.diffServices brokenService baseService `shouldSatisfy` isLeft-      ReplayImpact.replayImpactServices brokenService baseService `shouldSatisfy` isLeft-      planServiceScaffold (defaultContext (specContext guardSpec)) brokenService-        `shouldSatisfy` \case-          Left refusals -> any (\case FoldSurfaceRefusal {} -> True; _ -> False) refusals-          Right _ -> False--    it "pins representative diff and replay-impact rendering" $ do-      old <- parsedSourceOf "test/fixtures/reservation.keiro"-      new <- parsedSourceOf "test/fixtures/reservation-guard-tightened.keiro"-      let changes = diffSources old new-          impact = resolvedFold (ReplayImpact.replayImpactServices (checkedSource old) (checkedSource new))-          actual =-            T.intercalate-              "\n"-              ( "diff:"-                  : map renderFinding changes-                    <> ["replay:", ReplayImpact.renderReplayImpact impact]-              )-      assertMatchesGolden "test/fixtures/fold-identity-diff-replay.golden" actual--    it "pins unrelated public 64-bit identities outside the fold digest" $ do-      readModelSpec <- specOf "test/fixtures/readmodel.keiro"-      wireSpec <- specOf "test/fixtures/consumer-types.keiro"-      behaviorSpec <- specOf "test/fixtures/behavior-complete.keiro"-      readModel <- case [value | NReadModel value <- specNodes readModelSpec] of-        value : _ -> pure value-        [] -> expectationFailure "missing read-model fixture" >> fail "unreachable"-      graph <- shouldResolveTypeGraph wireSpec-      behaviorKey <- case Behavior.deriveBehaviorRequirements behaviorSpec of-        Right (requirement : _) -> pure (Behavior.unBehaviorKey (Behavior.requirementKey requirement))-        result -> expectationFailure ("missing behavior requirement: " <> show result) >> fail "unreachable"-      deriveShapeHash readModel `shouldBe` "fnv1a:3717f6d9e3c44bd6"-      wireFingerprint graph "ArtifactInfo" `shouldBe` "2bd99b3e57bcde9b"-      behaviorKey `shouldBe` "behavior-v1-0128e858fee6f2b3"--  describe "source language version" $ do-    let legacy = "context hospital-capacity\n"-        declared = "# leading comment\n\nlanguage keiro-dsl 1\ncontext hospital-capacity\n"-        failureCode source = case parseSource "source.keiro" source of-          Left (SourceLanguageFailure diagnostic) -> Just (sourceLanguageErrorCode diagnostic)-          _ -> Nothing-        parseRight name source = case parseSource name source of-          Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-          Right value -> pure value-        declaredVersionOf DeclaredLanguage {declaredLanguageVersion = version} = Just version-        declaredVersionOf LegacyUnversioned = Nothing-        orderedSubstrings needles haystack = go (map T.pack needles) (T.pack haystack)-          where-            go [] _ = True-            go (needle : rest) remaining =-              let (_, suffix) = T.breakOn needle remaining-               in not (T.null suffix) && go rest (T.drop (T.length needle) suffix)--    it "selects declared v1 after comments while preserving semantic equality" $ do-      legacySource <- parseRight "legacy.keiro" legacy-      declaredSource <- parseRight "declared.keiro" declared-      parsedSpec legacySource `shouldBe` parsedSpec declaredSource-      parsedSourceLanguage legacySource `shouldBe` LegacyUnversioned-      declaredVersionOf (parsedSourceLanguage declaredSource) `shouldBe` languageVersion 1-      effectiveLanguageVersion (parsedSourceLanguage legacySource)-        `shouldBe` effectiveLanguageVersion (parsedSourceLanguage declaredSource)--    it "threads paired released versions through one checked semantic boundary" $ do-      let body = T.unlines ["context semantic-pair", "aggregate Counter", "  regs", "  states Open"]-          v1Text = "language keiro-dsl 1\n" <> body-          v2Text = "language keiro-dsl 2\n" <> body-      v1Source <- parseRight "reservation-v1.keiro" v1Text-      v2Source <- parseRight "reservation-v2.keiro" v2Text-      let v1Service = checkedSource v1Source-          v2Service = checkedSource v2Source-          v1Spec = checkedSpec v1Service-          v2Spec = checkedSpec v2Service-          ctx = defaultContext (specContext v1Spec)-          aggregates spec = [aggregate | NAggregate aggregate <- specNodes spec]-      v1Spec `shouldBe` v2Spec-      Just (effectiveContractLanguageVersion (checkedLanguageContract v1Service)) `shouldBe` languageVersion 1-      Just (effectiveContractLanguageVersion (checkedLanguageContract v2Service)) `shouldBe` languageVersion 2-      effectiveRuntimeSemantics (checkedLanguageContract v1Service)-        `shouldBe` effectiveRuntimeSemantics (checkedLanguageContract v2Service)-      validateService v1Service `shouldBe` validateService v2Service-      scaffoldServiceModules ctx v1Service `shouldBe` scaffoldServiceModules ctx v2Service-      case (aggregates v1Spec, aggregates v2Spec) of-        ([v1Aggregate], [v2Aggregate]) -> do-          aggregateFoldSurfaceForService v1Service v1Aggregate-            `shouldBe` aggregateFoldSurfaceForService v2Service v2Aggregate-          aggregateFoldFingerprintForService v1Service v1Aggregate-            `shouldBe` aggregateFoldFingerprintForService v2Service v2Aggregate-        other -> expectationFailure ("expected one aggregate per paired source, got " <> show (fmap length other))-      diffServices v1Service v2Service `shouldBe` []-      resolvedFold (ReplayImpact.replayImpactServices v1Service v2Service) `shouldBe` ReplayNeutral--    it "retains one effective contract for same-version workspaces and refuses mixed versions" $ do-      let manifest = "service semantic-workspace\nspec domain/a.keiro\nspec domain/b.keiro\n"-          v1Body = "language keiro-dsl 1\ncontext semantic-workspace\n"-          v2Body = "language keiro-dsl 2\ncontext semantic-workspace\n"-          sourceWith b =-            memoryContentSource-              ( Map.fromList-                  [ ("service.keiro-workspace", manifest),-                    ("domain/a.keiro", b),-                    ("domain/b.keiro", b)-                  ]-              )-          mixedSource =-            memoryContentSource-              ( Map.fromList-                  [ ("service.keiro-workspace", manifest),-                    ("domain/a.keiro", v1Body),-                    ("domain/b.keiro", v2Body)-                  ]-              )-      sameVersion <- loadWorkspace (sourceWith v2Body) "service.keiro-workspace"-      case sameVersion of-        Right workspace -> do-          Just (effectiveContractLanguageVersion (checkedLanguageContract (checkedWorkspace workspace))) `shouldBe` languageVersion 2-          validateService (checkedWorkspace workspace) `shouldBe` []-        Left failure -> expectationFailure (show failure)-      mixed <- loadWorkspace mixedSource "service.keiro-workspace"-      case mixed of-        Left (WorkspaceRefused diagnostics) ->-          map wdCode (NE.toList diagnostics) `shouldContain` [WorkspaceLanguageVersionMismatch]-        other -> expectationFailure ("expected a mixed-version refusal, got " <> show other)--    it "refuses a source/service contract mismatch before creating the output directory" $ do-      v1Version <- maybe (expectationFailure "version 1 missing" >> fail "unreachable") pure (languageVersion 1)-      parsed <- parseRight "semantic-v2.keiro" "language keiro-dsl 2\ncontext semantic-refusal\n"-      let service = checkedSource parsed-          ctx = defaultContext "semantic-refusal"-      modules <- case planServiceScaffold ctx service of-        Left refusals -> expectationFailure (show refusals) >> fail "unreachable"-        Right planned -> pure planned-      withTempDirectory "keiro-dsl-semantic-refusal" $ \root -> do-        let out = root </> "not-created"-        result <- executeServiceScaffold out False "semantic-v2.keiro" (DeclaredLanguage v1Version noLoc) ctx service modules-        result `shouldBe` Left [SemanticContractMismatch "source provenance and checked service selected different effective language contracts"]-        doesDirectoryExist out `shouldReturn` False--    it "retains explicit declarations in source rendering and leaves legacy unversioned" $ do-      legacySource <- parseRight "legacy.keiro" legacy-      declaredSource <- parseRight "declared.keiro" declared-      renderSource legacySource `shouldBe` "context hospital-capacity\n"-      renderSource declaredSource `shouldBe` "language keiro-dsl 1\ncontext hospital-capacity\n"-      parseSpec "declared.keiro" declared `shouldBe` Right (parsedSpec declaredSource)--    it "classifies invalid, unsupported, duplicate, and misplaced preambles" $ do-      failureCode "language keiro-dsl 0\ncontext hospital-capacity\n" `shouldBe` Just InvalidLanguageVersion-      failureCode "language keiro-dsl nope\ncontext hospital-capacity\n" `shouldBe` Just InvalidLanguageVersion-      failureCode "language keiro-dsl -1\ncontext hospital-capacity\n" `shouldBe` Just InvalidLanguageVersion-      failureCode "language keiro-dsl 5\ncontext hospital-capacity\n" `shouldBe` Just UnsupportedLanguageVersion-      failureCode "language keiro-dsl 1\nlanguage keiro-dsl 1\ncontext hospital-capacity\n" `shouldBe` Just DuplicateLanguagePreamble-      failureCode "context hospital-capacity\nlanguage keiro-dsl 1\n" `shouldBe` Just MisplacedLanguagePreamble--    it "treats language and successor spellings as data in nested grammar positions" $ do-      forM_ ["language-identifier-v1.keiro", "language-identifier-v2.keiro"] $ \fixture -> do-        source <- readTestText ("test/fixtures/" <> fixture)-        parsed <- parseRight fixture source-        validateSpec (parsedSpec parsed) `shouldBe` []-      v1 <- readTestText "test/fixtures/language-identifier-v1.keiro"-      let manifest = "service language-collisions\nspec domain/collisions.keiro\n"-          workspaceSource = memoryContentSource (Map.fromList [("service.keiro-workspace", manifest), ("domain/collisions.keiro", v1)])-      loaded <- loadWorkspace workspaceSource "service.keiro-workspace"-      loaded `shouldSatisfy` isRight--    it "keeps duplicate and misplaced preamble diagnostics on their grammar lines" $ do-      let sourceFailureAt expectedCode expectedLine source =-            case parseSource "located.keiro" source of-              Left (SourceLanguageFailure diagnostic) -> do-                sourceLanguageErrorCode diagnostic `shouldBe` expectedCode-                unLoc (sourceLanguageLoc diagnostic) `shouldBe` expectedLine-              other -> expectationFailure ("expected located source-language failure, got " <> show other)-      sourceFailureAt DuplicateLanguagePreamble 2 "language keiro-dsl 1\nlanguage keiro-dsl 1\ncontext located\n"-      sourceFailureAt MisplacedLanguagePreamble 3 "context located\nid language prefix=lang\nlanguage keiro-dsl 1\n"--    it "rejects a future version before parsing an invalid v1 body" $-      case parseSource "future.keiro" "language keiro-dsl 5\nthis is not a v2 body\n" of-        Left failure@(SourceLanguageFailure diagnostic) -> do-          sourceLanguageErrorCode diagnostic `shouldBe` UnsupportedLanguageVersion-          renderParseFailure failure `shouldSatisfy` T.isInfixOf "supported versions: 1, 2, 3, 4"-          renderParseFailure failure `shouldNotSatisfy` T.isInfixOf "expecting `context`"-        other -> expectationFailure ("expected source-language failure, got " <> show other)--    it "accepts and canonically round-trips nominal declarations only in v2" $ do-      let nominalSource =-            T.unlines-              [ "language keiro-dsl 2",-                "context orders",-                "id OrderId prefix=ord using {",-                "  haskell package=orders-domain module=Orders.Id type=OrderId",-                "  binding = \"Orders.KeiroBindings.orderIdBinding\"",-                "  binding-version = \"1\"",-                "  canonical-type = \"orders.OrderId.v1\"",-                "  fixtures = \"Orders.KeiroBindings.orderIdFixtures\"",-                "}",-                "enum OrderStatus { Draft=draft Submitted=submitted } using {",-                "  haskell package=orders-domain module=Orders.Order type=OrderStatus",-                "  binding = \"Orders.KeiroBindings.orderStatusBinding\"",-                "  binding-version = \"1\"",-                "  canonical-type = \"orders.OrderStatus.v1\"",-                "  fixtures = \"Orders.KeiroBindings.orderStatusFixtures\"",-                "}",-                "mapped nominal AccountNumber : Text {",-                "  haskell package=orders-domain module=Orders.Account type=AccountNumber",-                "  binding = \"Orders.KeiroBindings.accountNumberBinding\"",-                "  binding-version = \"1\"",-                "  canonical-type = \"orders.AccountNumber.v1\"",-                "  fixtures = \"Orders.KeiroBindings.accountNumberFixtures\"",-                "  initial = \"Orders.KeiroBindings.initialAccountNumber\"",-                "}"-              ]-      parsed <- parseRight "nominal.keiro" nominalSource-      length (specIds (parsedSpec parsed)) `shouldBe` 1-      length (specEnums (parsedSpec parsed)) `shouldBe` 1-      length (specNominalScalars (parsedSpec parsed)) `shouldBe` 1-      parseSource "nominal-round-trip.keiro" (renderSource parsed) `shouldBe` Right parsed--    it "reports successor nominal syntax as one language-version diagnostic under v1 and legacy" $ do-      let body = "context orders\nmapped nominal AccountNumber : Text {}\n"-      failureCode ("language keiro-dsl 1\n" <> body) `shouldBe` Just LanguageFeatureRequiresVersion-      failureCode body `shouldBe` Just LanguageFeatureRequiresVersion--    it "parses and canonically round-trips field aliases only in language 4" $ do-      let v4Source =-            T.unlines-              [ "language keiro-dsl 4",-                "context aliases",-                "aggregate Order",-                "  regs",-                "  states Open",-                "  command Change { type haskell payloadType as \"type\":Text haskell as }",-                "contract publicOrder {",-                "  schemaVersion 1",-                "  discriminator kind",-                "  topic changes \"orders.v1\"",-                "  event Changed on changes {",-                "    region haskell serviceRegion as \"region_code\": text",-                "  }",-                "}"-              ]-          v3Source = T.replace "language keiro-dsl 4" "language keiro-dsl 3" v4Source-      parsed <- parseRight "field-aliases.keiro" v4Source-      parseSource "field-aliases-round-trip.keiro" (renderSource parsed) `shouldBe` Right parsed-      case specNodes (parsedSpec parsed) of-        [NAggregate aggregate, NContract contract] -> do-          case cmdFields =<< aggCommands aggregate of-            aliased : haskellField : asField : _ -> do-              (aggregateFieldName aliased, aggregateFieldSelector aliased, aggregateFieldWireKey aliased)-                `shouldBe` ("type", Just "payloadType", Just "type")-              map aggregateFieldName [haskellField, asField] `shouldBe` ["haskell", "as"]-            fields -> expectationFailure ("unexpected aggregate alias fields: " <> show fields)-          case ceFields =<< ctrEvents contract of-            [field] ->-              (cfName field, cfSelector field, cfWireKey field, cfLoc field)-                `shouldBe` ("region", Just "serviceRegion", Just "region_code", Loc 12)-            fields -> expectationFailure ("unexpected contract alias fields: " <> show fields)-        nodes -> expectationFailure ("unexpected alias nodes: " <> show nodes)-      failureCode v3Source `shouldBe` Just LanguageFeatureRequiresVersion--    it "attributes every successor feature gate to its owning grammar production" $ do-      let featureFailureAt expectedLine source =-            case parseSource "feature.keiro" source of-              Left (SourceLanguageFailure diagnostic) -> do-                sourceLanguageErrorCode diagnostic `shouldBe` LanguageFeatureRequiresVersion-                unLoc (sourceLanguageLoc diagnostic) `shouldBe` expectedLine-              other -> expectationFailure ("expected a located feature gate, got " <> show other)-          aggregateWith clause =-            T.unlines-              [ "language keiro-dsl 1",-                "context feature-gates",-                "aggregate Account",-                "  regs",-                "    balance Text = \"0\"",-                "  states Open",-                "  command Adjust { amount:Text }",-                "  event Adjusted = fields(Adjust)",-                "  Open -- Adjust --> " <> clause <> " ; emit Adjusted ; goto Open"-              ]-      featureFailureAt 3 (T.unlines ["language keiro-dsl 1", "context feature-gates", "id AccountId prefix=acct using {"])-      featureFailureAt 3 (T.unlines ["language keiro-dsl 1", "context feature-gates", "mapped nominal AccountNumber : Text {}"])-      featureFailureAt 5 (T.unlines ["language keiro-dsl 1", "context feature-gates", "aggregate Account", "  regs", "    balance Integer = 0", "  states Open"])-      featureFailureAt 9 (aggregateWith "guard reg.balance == cmd.amount")-      featureFailureAt 9 (aggregateWith "implementation hole")--    it "reports a declaration-only rewrite without semantic, generated, fold, or replay impact" $ do-      fixture <- readTestText "test/fixtures/language-v1.keiro"-      let legacyFixture = T.unlines (drop 1 (T.lines fixture))-      legacySource <- parseRight "legacy.keiro" legacyFixture-      declaredSource <- parseRight "declared.keiro" fixture-      let oldSpec = parsedSpec legacySource-          newSpec = parsedSpec declaredSource-          changes = diffSources legacySource declaredSource-          vectors = [ckVector kind | change <- changes, let kind = workspaceChangeKind change]-      map changeCode changes `shouldBe` [SourceLanguageDeclarationChanged]-      legacyDiffSpecs oldSpec newSpec `shouldBe` []-      vectors `shouldSatisfy` all (\compatibility -> all ((== VCompatible) . (`verdictFor` compatibility)) [minBound .. maxBound])-      case changes of-        [change] ->-          remediationFor (ckContext (workspaceChangeKind change)) SourceLanguageDeclarationChanged-            `shouldBe` (RemedyNoSemanticAction :| [])-        _ -> expectationFailure "expected one source-language change"-      let legacyGeneratedSurface spec =-            [ (modulePath scaffoldModule, moduleText scaffoldModule, kind scaffoldModule)-            | scaffoldModule <- scaffoldModules (defaultContext (specContext spec)) spec-            ]-          legacyFoldFingerprint spec aggregate = aggregateFoldFingerprintForService (legacyCheckedService spec) aggregate-      legacyGeneratedSurface oldSpec `shouldBe` legacyGeneratedSurface newSpec-      [legacyFoldFingerprint oldSpec aggregate | NAggregate aggregate <- specNodes oldSpec]-        `shouldBe` [legacyFoldFingerprint newSpec aggregate | NAggregate aggregate <- specNodes newSpec]-      legacyReplayImpactSpecs oldSpec newSpec `shouldBe` ReplayNeutral--    it "exposes stable JSON inspection for a source and canonically ordered workspace members" $ do-      (sourceCode, sourceOut, sourceErr) <- runKeiroDsl ["inspect", "test/fixtures/reservation.keiro", "--format=json"]-      sourceCode `shouldBe` ExitSuccess-      sourceErr `shouldBe` ""-      sourceOut `shouldContain` "\"schema\":\"keiro-dsl/source-inspection/1\""-      sourceOut `shouldContain` "\"kind\":\"source\""-      sourceOut `shouldContain` "\"sourceForm\":\"declared\""-      sourceOut `shouldContain` "\"declaredLanguageVersion\":4"-      sourceOut `shouldContain` "\"effectiveLanguageVersion\":4"-      sourceOut `shouldContain` "\"effectiveSemanticContract\":{"-      sourceOut `shouldContain` "\"runtimeSemantics\":\"keiro-dsl/runtime-semantics/3\""-      sourceOut `shouldContain` "\"languageSupport\":\"stable\""-      (workspaceCode, workspaceOut, workspaceErr) <- runKeiroDsl ["inspect", canonicalWorkspacePath, "--format=json"]-      workspaceCode `shouldBe` ExitSuccess-      workspaceErr `shouldBe` ""-      workspaceOut `shouldContain` "\"kind\":\"workspace\""-      workspaceOut `shouldContain` "\"service\":\"demo-project\""-      workspaceOut `shouldContain` "\"effectiveSemanticContract\":{"-      workspaceOut `shouldContain` "\"languageSupport\":\"stable\""-      workspaceOut `shouldSatisfy` orderedSubstrings ["domain/project-artifact.keiro", "domain/project.keiro", "domain/shared.keiro"]--    it "keeps only the named source-version compatibility fixtures outside stable v4" $ do-      fixtureTree <- treeSnapshot "test/fixtures"-      let outsideStableV4 =-            sort-              [ path-              | (path, contents) <- fixtureTree,-                takeExtension path == ".keiro",-                "language keiro-dsl 4" `notElem` T.lines contents-              ]-      outsideStableV4-        `shouldBe` sort-          [ "aggregate-collection-expressions-v2-rejects.keiro",-            "aggregate-scalar-expressions-v1-rejects.keiro",-            "contract-v1-compat.keiro",-            "id-domain-migration-v3.keiro",-            "language-duplicate.keiro",-            "language-future.keiro",-            "language-identifier-v1.keiro",-            "language-identifier-v2.keiro",-            "language-legacy.keiro",-            "language-malformed.keiro",-            "language-misplaced.keiro",-            "language-v1.keiro",-            "language-zero.keiro",-            "nominal-v1.keiro"-          ]--    it "checks v1, rejects a future contract once, and inspects legacy explicitly" $ do-      (v1Code, v1Out, v1Err) <- runKeiroDsl ["check", "test/fixtures/language-v1.keiro"]-      v1Code `shouldBe` ExitSuccess-      v1Out `shouldBe` "OK\n"-      v1Err `shouldContain` "language contract: effective keiro-dsl 1 (declared, compatibility-only, runtime semantics keiro-dsl/runtime-semantics/1)"-      (futureCode, _, futureErr) <- runKeiroDsl ["check", "test/fixtures/language-future.keiro"]-      futureCode `shouldBe` ExitFailure 1-      T.count "UnsupportedLanguageVersion" (T.pack futureErr) `shouldBe` 1-      futureErr `shouldContain` "supported versions: 1, 2, 3, 4"-      futureErr `shouldNotContain` "expecting `context`"-      (legacyCode, legacyOut, legacyErr) <- runKeiroDsl ["inspect", "test/fixtures/language-legacy.keiro", "--format=json"]-      legacyCode `shouldBe` ExitSuccess-      legacyErr `shouldBe` ""-      legacyOut `shouldContain` "\"sourceForm\":\"legacy-unversioned\""-      legacyOut `shouldContain` "\"declaredLanguageVersion\":null"-      legacyOut `shouldContain` "\"effectiveLanguageVersion\":1"-      legacyOut `shouldContain` "\"languageSupport\":\"compatibility-only\""--    it "checks and scaffolds contextual language identifiers through the CLI" $ do-      forM_ ["language-identifier-v1.keiro", "language-identifier-v2.keiro"] $ \fixture -> do-        let sourcePath = "test/fixtures/" <> fixture-        (checkCode, checkOut, checkErr) <- runKeiroDsl ["check", sourcePath]-        checkCode `shouldBe` ExitSuccess-        checkOut `shouldBe` "OK\n"-        checkErr `shouldContain` "language contract: effective keiro-dsl"-        withTempDirectory ("keiro-dsl-" <> fixture) $ \out -> do-          (scaffoldCode, _, scaffoldErr) <- runKeiroDsl ["scaffold", sourcePath, "--out", out]-          scaffoldCode `shouldBe` ExitSuccess-          scaffoldErr `shouldContain` "language contract: effective keiro-dsl"-          scaffoldErr `shouldContain` "firewall: OK"--    it "notices only the working-tree contract during diff" $ do-      (diffCode, _, diffErr) <- runKeiroDsl ["diff", "test/fixtures/language-v1.keiro", "--since", "HEAD"]-      diffCode `shouldBe` ExitSuccess-      T.count "language contract:" (T.pack diffErr) `shouldBe` 1-      diffErr `shouldContain` "language contract: effective keiro-dsl 1 (declared, compatibility-only, runtime semantics keiro-dsl/runtime-semantics/1)"--    it "preserves a workspace member's source-selection code beneath outer attribution" $ do-      let manifest = "service demo\nspec domain/future.keiro\n"-          futureSource = "language keiro-dsl 5\nthis body must not parse\n"-          source = memoryContentSource (Map.fromList [("service.keiro-workspace", manifest), ("domain/future.keiro", futureSource)])-      loaded <- loadWorkspace source "service.keiro-workspace"-      case loaded of-        Left (WorkspaceRefused (diagnostic :| [])) -> do-          wdCode diagnostic `shouldBe` WorkspaceMemberParseFailed-          sourceLanguageErrorCode <$> wdSourceLanguageCause diagnostic-            `shouldBe` Just UnsupportedLanguageVersion-          renderWorkspaceDiagnostic "service.keiro-workspace" diagnostic-            `shouldSatisfy` T.isInfixOf "UnsupportedLanguageVersion"-        other -> expectationFailure ("expected one attributed source-language refusal, got " <> show other)--    it "attributes a workspace provenance-only diff to the changed member" $ do-      workspace <- shouldComposeWorkspace canonicalWorkspacePath-      case wsMembers workspace of-        firstMember : remaining -> do-          let changedMember = firstMember {wmSourceLanguage = LegacyUnversioned}-              changedWorkspace = workspace {wsMembers = changedMember : remaining}-              changes = diffWorkspaces workspace changedWorkspace-          map (changeCode . wcChange) changes `shouldBe` [SourceLanguageDeclarationChanged]-          map (fmap osFile . wcDeclarationSite) changes `shouldBe` [Just (wmPath firstMember)]-          map wcChange changes `shouldSatisfy` all (not . gatedBreaking (gateWith [minBound .. maxBound]))-        _ -> expectationFailure "canonical workspace had no member"--  describe "ID domain" $ do-    let parseRight name source = case parseSource name source of-          Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-          Right value -> pure value--    it "registers language 3 as the first enforced runtime contract" $ do-      parsed <- case parseSource "id-domain-v3.keiro" "language keiro-dsl 3\ncontext id-domain\n" of-        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-        Right value -> pure value-      let contract = checkedLanguageContract (checkedSource parsed)-      effectiveRuntimeSemantics contract `shouldBe` "keiro-dsl/runtime-semantics/2"-      effectiveContractLanguageVersion contract `shouldBe` maybe (error "missing v3") id (languageVersion 3)-      idDomainContractFor contract "req" `shouldSatisfy` (/= Nothing)--    it "registers language 4 as contract admission semantics without changing aggregate ID admission" $ do-      v3 <- parseRight "id-domain-v3.keiro" "language keiro-dsl 3\ncontext id-domain\n"-      v4 <- parseRight "id-domain-v4.keiro" "language keiro-dsl 4\ncontext id-domain\n"-      let v3Contract = checkedLanguageContract (checkedSource v3)-          v4Contract = checkedLanguageContract (checkedSource v4)-      effectiveRuntimeSemantics v4Contract `shouldBe` "keiro-dsl/runtime-semantics/3"-      effectiveContractLanguageVersion v4Contract `shouldBe` maybe (error "missing v4") id (languageVersion 4)-      idDomainContractFor v4Contract "req" `shouldBe` idDomainContractFor v3Contract "req"-      contractIdDomainContractFor v3Contract "req" `shouldBe` Nothing-      contractIdDomainContractFor v4Contract "req" `shouldBe` Just (typeIdV7Domain "req")--    it "constructs typed KindIDs only after the frozen four-way admission policy" $ do-      let valid = "req_01h455vb4pex5vsknk084sn02q"-          uppercase = "req_01H455VB4PEX5VSKNK084SN02Q"-          nonV7 = "req_00041061050r3gg28a1c60t3gf"-      (KindID.toText @"req" <$> parseKindIdV7Text @"req" valid) `shouldBe` Right valid-      parseKindIdV7Text @"req" "req-1" `shouldSatisfy` \case-        Left IdDomainMalformed {} -> True-        _ -> False-      parseKindIdV7Text @"req" "other_01h455vb4pex5vsknk084sn02q" `shouldSatisfy` \case-        Left (IdDomainWrongPrefix "req" "other") -> True-        _ -> False-      parseKindIdV7Text @"req" uppercase `shouldBe` Left IdDomainNonCanonical-      parseKindIdV7Text @"req" nonV7 `shouldSatisfy` \case-        Left IdDomainNotUuidV7 {} -> True-        _ -> False-      parseEither (parseKindIdV7Value @"req") (Aeson.String uppercase)-        `shouldSatisfy` \case-          Left problem -> "not canonical lowercase" `T.isInfixOf` T.pack problem-          Right _ -> False--    it "validates contract TypeID prefixes only at the language-4 boundary" $ do-      let source versionNumber =-            T.unlines-              [ "language keiro-dsl " <> T.pack (show versionNumber),-                "context invalid-contract-prefix",-                "contract emergency {",-                "  schemaVersion 1",-                "  discriminator messageType",-                "  topic incidentEvents \"emergency.incident.events\"",-                "  event IncidentDeclared on incidentEvents {",-                "    incidentId: typeid \"Bad\"",-                "  }",-                "}"-              ]-      v3 <- parseRight "contract-prefix-v3.keiro" (source (3 :: Int))-      v4 <- parseRight "contract-prefix-v4.keiro" (source (4 :: Int))-      validateService (checkedSource v3) `shouldBe` []-      case validateService (checkedSource v4) of-        [diagnostic] -> do-          code diagnostic `shouldBe` ContractInvalidTypeIdPrefix-          line diagnostic `shouldBe` 8-          message diagnostic `shouldSatisfy` T.isInfixOf "contract 'emergency' event 'IncidentDeclared' field 'incidentId'"-          message diagnostic `shouldSatisfy` T.isInfixOf "invalid TypeID prefix 'Bad'"-        diagnostics -> expectationFailure ("expected one invalid contract prefix diagnostic, got " <> show diagnostics)--    it "keeps version-3 and version-4 aggregate fold and replay semantics equal" $ do-      v3Text <- readTestText "test/fixtures/id-domain-migration-v3.keiro"-      v3 <- parseRight "fold-v3.keiro" v3Text-      v4 <- parseRight "fold-v4.keiro" (T.replace "language keiro-dsl 3" "language keiro-dsl 4" v3Text)-      let v3Service = checkedSource v3-          v4Service = checkedSource v4-          fingerprints service =-            [ aggregateFoldFingerprintForService service aggregate-            | NAggregate aggregate <- specNodes (checkedSpec service)-            ]-      fingerprints v4Service `shouldBe` fingerprints v3Service-      diffServices v3Service v4Service `shouldBe` []-      resolvedFold (ReplayImpact.replayImpactServices v3Service v4Service) `shouldBe` ReplayNeutral--    it "keeps runtime validation and the exact Keiki text image in agreement" $ do-      let contract = typeIdV7Domain "req"-          sampleText = idDomainSampleText contract-          suffix = T.drop (T.length "req_") sampleText-          replaceAt position replacement value =-            T.take position value <> T.singleton replacement <> T.drop (position + 1) value-          accepted =-            [ sampleText,-              replaceAt (T.length "req_" + 10) 'f' sampleText,-              replaceAt (T.length "req_" + 13) 'v' sampleText-            ]-          rejected =-            [ "",-              "req_",-              "other_" <> suffix,-              "req__" <> suffix,-              T.dropEnd 1 sampleText,-              sampleText <> "0",-              T.toUpper sampleText,-              replaceAt (T.length "req_" + 0) '8' sampleText,-              replaceAt (T.length "req_" + 10) 'd' sampleText,-              replaceAt (T.length "req_" + 13) 'c' sampleText-            ]-          patternValue = either (error . show) id (idDomainTextPattern contract)-      idDomainVersion contract `shouldBe` "keiro-dsl/id-domain/typeid-v7/1"-      idDomainSeparator contract `shouldBe` '_'-      idDomainSuffixLength contract `shouldBe` 26-      idDomainMaxLength contract `shouldBe` T.length sampleText-      forM_ accepted $ \value -> do-        validateIdDomainText contract value `shouldBe` Right ()-        matchesTextPattern patternValue value `shouldBe` True-      forM_ rejected $ \value -> do-        validateIdDomainText contract value `shouldSatisfy` isLeft-        matchesTextPattern patternValue value `shouldBe` False--    it "agrees for generated canonical and malformed domain values" $ property $ do-      let crockford = "0123456789abcdefghjkmnpqrstvwxyz"-          segment count = vectorOf count (elements crockford)-      leading <- elements "01234567"-      beforeVersion <- segment 9-      version <- elements "ef"-      beforeVariant <- segment 2-      variantDigit <- elements "89abrstv"-      afterVariant <- segment 12-      let value = T.pack ("req_" <> [leading] <> beforeVersion <> [version] <> beforeVariant <> [variantDigit] <> afterVariant)-          contract = typeIdV7Domain "req"-          patternValue = either (error . show) id (idDomainTextPattern contract)-          invalidValues = [T.toUpper value, "other_" <> T.drop 4 value, T.dropEnd 1 value, value <> "0"]-      pure $-        conjoin-          ( counterexample (T.unpack value) (validateIdDomainText contract value == Right () && matchesTextPattern patternValue value)-              : [counterexample (T.unpack invalid) (isLeft (validateIdDomainText contract invalid) && not (matchesTextPattern patternValue invalid)) | invalid <- invalidValues]-          )--    it "enforces the same contract before consumer binding conversion and explains its version" $ do-      v2Source <- readTestText "test/fixtures/nominal-scalars.keiro"-      let v3Text = T.replace "language keiro-dsl 2" "language keiro-dsl 3" v2Source-      parsed <- case parseSource "nominal-scalars-v3.keiro" v3Text of-        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-        Right value -> pure value-      let service = checkedSource parsed-          spec = checkedSpec service-          modules = scaffoldServiceModules (defaultContext (specContext spec)) service-          generatedText suffix = case [moduleText value | value <- modules, T.pack suffix `T.isSuffixOf` T.pack (modulePath value)] of-            [value] -> value-            values -> error ("expected one generated module ending in " <> suffix <> ", got " <> show (length values))-          codecModule = generatedText "NominalLedger/Codec.hs"-          projectionModule = generatedText "NominalProjections.hs"-          harnessModule = generatedText "NominalLedger/Harness.hs"-      validateService service `shouldBe` []-      codecModule `shouldSatisfy` T.isInfixOf "case validateIdDomainText (typeIdV7Domain \"ord\") input of"-      codecModule `shouldSatisfy` T.isInfixOf "Right () -> case KindID.parseText @\"ord\" input of"-      projectionModule `shouldSatisfy` T.isInfixOf "idDomainTextPattern (typeIdV7Domain \"ord\")"-      projectionModule `shouldSatisfy` T.isInfixOf "validateIdDomainText (typeIdV7Domain \"ord\") value"-      harnessModule `shouldSatisfy` T.isInfixOf "nominal ID binding preserves canonical representations: OrderId"-      harnessModule `shouldSatisfy` T.isInfixOf "nominal ID boundary rejects wrong-prefix and normalized text: OrderId"-      obligations <- either (\errors -> expectationFailure (show errors) >> pure []) pure (bindingObligationsForService service)-      let orderIdBindings = [obligation | obligation <- obligations, obligationMappedName obligation == "OrderId", obligationKind obligation == BindingValue]-      map obligationIdDomainContract orderIdBindings `shouldBe` [Just "keiro-dsl/id-domain/typeid-v7/1"]-      renderBindingObligations (specContext spec) obligations-        `shouldSatisfy` T.isInfixOf "id-domain-contract: \"keiro-dsl/id-domain/typeid-v7/1\""--    it "reports adoption by boundary, invalidates snapshots, and preserves replay compatibility" $ do-      v2Text <- readTestText "test/fixtures/id-domain-migration-v3.keiro"-      let oldText = T.replace "language keiro-dsl 3" "language keiro-dsl 2" v2Text-      oldSource <- case parseSource "id-domain-migration-v2.keiro" oldText of-        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-        Right value -> pure value-      newSource <- case parseSource "id-domain-migration-v3.keiro" v2Text of-        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-        Right value -> pure value-      let oldService = checkedSource oldSource-          newService = checkedSource newSource-          changes = diffSources oldSource newSource-          findings = [kindOfChange change | change <- changes, changeCode change == IdDomainContractChanged]-      length findings `shouldBe` 1-      forM_ findings $ \finding -> do-        verdictFor PrivateHistoryRead (ckVector finding) `shouldBe` VCompatible-        verdictFor OldBinaryReadNewEvents (ckVector finding) `shouldBe` VCompatible-        verdictFor SnapshotHydration (ckVector finding) `shouldBe` VAdvisory-        verdictFor PublicConsumer (ckVector finding) `shouldBe` VBreaking-        verdictFor PersistedIdentity (ckVector finding) `shouldBe` VCompatible-        verdictFor ConsumerBuild (ckVector finding) `shouldBe` VAdvisory-        ckDetail finding `shouldSatisfy` T.isInfixOf "historical event replay retains its legacy decoder"-        remediationFor (ckContext finding) (ckCode finding)-          `shouldBe` RemedyDeploymentOrder RolloutProducerLast :| [RemedyStateCodecBump, RemedyRecompileConsumers, RemedyRunConformance]-      [ckDetail finding | change <- changes, changeCode change == SourceLanguageDeclarationChanged, let finding = kindOfChange change]-        `shouldSatisfy` all (T.isInfixOf "effective runtime semantics changed")-      idDomainIdentitiesForService oldService `shouldBe` []-      idDomainIdentitiesForService newService-        `shouldSatisfy` any (T.isInfixOf "contract=keiro-dsl/id-domain/typeid-v7/1")-      resolvedFold (ReplayImpact.replayImpactServices oldService newService) `shouldSatisfy` \case-        ReplayImpact.ReplayAffected impacts ->-          maybe False includeSnapshotStreams (Map.lookup "OrderBook" impacts)-        ReplayImpact.ReplayNeutral -> False--    it "keeps the raw constructor outside the compiled public module surface" $-      withTempDirectory "keiro-dsl-id-domain-hidden-constructor" $ \out -> do-        sourceText <- readTestText "test/fixtures/id-domain-migration-v3.keiro"-        parsed <- case parseSource "id-domain-migration-v3.keiro" sourceText of-          Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-          Right value -> pure value-        let service = checkedSource parsed-            spec = checkedSpec service-            ctx = defaultContext (specContext spec)-            modules = scaffoldServiceModules ctx service-            attempt = out </> "Attempt.hs"-            ghcOutput = out </> ".ghc"-        result <- executeServiceScaffold out False "id-domain-migration-v3.keiro" (parsedSourceLanguage parsed) ctx service modules-        result `shouldSatisfy` isRight-        recordContents <- TIO.readFile (out </> recordFileName (specContext spec))-        record <- case parseRecord recordContents of-          Nothing -> expectationFailure "generated ID-domain scaffold record did not parse" >> fail "unreachable"-          Just value -> pure value-        recIdDomains record `shouldBe` idDomainIdentitiesForService service-        recNominalEqualities record-          `shouldSatisfy` any (T.isInfixOf "keiro-dsl/id-domain/typeid-v7/1")-        createDirectoryIfMissing True ghcOutput-        TIO.writeFile-          attempt-          ( T.unlines-              [ "module Attempt where",-                "import Generated.IdDomainMigration.Nominals (OrderId (..))",-                "bad :: OrderId",-                "bad = OrderId \"ord_LEGACY-NOT-TYPEID\""-              ]-          )-        (exitCode, standardOutput, standardError) <--          readProcessWithExitCode-            "cabal"-            [ "exec",-              "--",-              "ghc",-              "-XGHC2024",-              "-XOverloadedStrings",-              "-fno-code",-              "-fforce-recomp",-              "-outputdir",-              ghcOutput,-              "-i" <> out,-              attempt-            ]-            ""-        exitCode `shouldSatisfy` (/= ExitSuccess)-        (standardOutput <> standardError) `shouldContain` "OrderId"--    it "emits one enforced nominal owner for a version-3 workspace" $ do-      manifest <- readTestText "test/fixtures/workspace-nominals/service.keiro-workspace"-      shared <- readTestText "test/fixtures/workspace-nominals/domain/shared.keiro"-      project <- readTestText "test/fixtures/workspace-nominals/domain/project.keiro"-      artifact <- readTestText "test/fixtures/workspace-nominals/domain/project-artifact.keiro"-      let v3 = T.replace "language keiro-dsl 2" "language keiro-dsl 3"-          source =-            memoryContentSource-              ( Map.fromList-                  [ ("service.keiro-workspace", manifest),-                    ("domain/shared.keiro", v3 shared),-                    ("domain/project.keiro", v3 project),-                    ("domain/project-artifact.keiro", v3 artifact)-                  ]-              )-      loaded <- loadWorkspace source "service.keiro-workspace"-      workspace <- case loaded of-        Left failure -> expectationFailure (show failure) >> fail "unreachable"-        Right value -> pure value-      plan <- case planWorkspaceScaffold "goldens" (workspaceContext workspace) workspace of-        Left refusals -> expectationFailure (show refusals) >> fail "unreachable"-        Right value -> pure value-      let paths = map (modulePath . fst) (wpModules plan)-      length (filter (== "Generated/WorkspaceNominalProof/Nominals.hs") paths) `shouldBe` 1-      length (filter (== "Generated/WorkspaceNominalProof/Nominals/Internal.hs") paths) `shouldBe` 1-      forM_ [moduleText value | (value, _) <- wpModules plan, "/Domain.hs" `T.isSuffixOf` T.pack (modulePath value)] $ \domainText ->-        domainText `shouldSatisfy` (not . T.isInfixOf "ProjectId (..)")-      withTempDirectory "keiro-dsl-v3-workspace-record" $ \out -> do-        emitted <- executeWorkspaceScaffold out False plan-        emitted `shouldSatisfy` isRight-        recordContents <- TIO.readFile (out </> workspaceRecordFileName (wsService workspace))-        record <- case parseWorkspaceRecord recordContents of-          Nothing -> expectationFailure "version-3 workspace record did not parse" >> fail "unreachable"-          Just value -> pure value-        wrIdDomains record `shouldBe` idDomainIdentitiesForService (wpCheckedService plan)-        wrNominalEqualities record-          `shouldSatisfy` any (T.isInfixOf "keiro-dsl/id-domain/typeid-v7/1")--    it "emits an abstract public ID, an internal legacy seam, and exact equality" $ do-      v2Source <- readTestText "test/fixtures/aggregate-scalar-expressions-v2.keiro"-      let v3Source = T.replace "language keiro-dsl 2" "language keiro-dsl 3" v2Source-      parsed <- case parseSource "aggregate-scalar-expressions-v3.keiro" v3Source of-        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-        Right value -> pure value-      let service = checkedSource parsed-          spec = checkedSpec service-          modules = scaffoldServiceModules (defaultContext (specContext spec)) service-          moduleAt path = case [value | value <- modules, modulePath value == path] of-            [value] -> pure value-            values -> expectationFailure ("expected one module at " <> path <> ", got " <> show (map modulePath values)) >> fail "unreachable"-      validateService service `shouldBe` []-      publicNominals <- moduleAt "Generated/AggregateScalarExpressions/Nominals.hs"-      internalNominals <- moduleAt "Generated/AggregateScalarExpressions/Nominals/Internal.hs"-      domainModule <- moduleAt "Generated/AggregateScalarExpressions/ScalarAccount/Domain.hs"-      codecModule <- moduleAt "Generated/AggregateScalarExpressions/ScalarAccount/Codec.hs"-      transducerModule <- moduleAt "Generated/AggregateScalarExpressions/ScalarAccount/Transducer.hs"-      moduleText publicNominals `shouldSatisfy` T.isInfixOf "parseRequestId"-      moduleText publicNominals `shouldSatisfy` T.isInfixOf "instance ExactFieldProjection RequestIdEqualityProjection"-      moduleText publicNominals `shouldSatisfy` T.isInfixOf "idDomainTextPattern (typeIdV7Domain \"req\")"-      moduleText publicNominals `shouldSatisfy` (not . T.isInfixOf "unsafeRequestIdFromLegacyText")-      moduleText publicNominals `shouldSatisfy` (not . T.isInfixOf "newtype RequestId")-      moduleText internalNominals `shouldSatisfy` T.isInfixOf "newtype RequestId = RequestId Text"-      moduleText internalNominals `shouldSatisfy` T.isInfixOf "unsafeRequestIdFromLegacyText"-      moduleText domainModule `shouldSatisfy` (not . T.isInfixOf "RequestId (..)")-      moduleText codecModule `shouldSatisfy` T.isInfixOf "unsafeRequestIdFromLegacyText <$>"-      moduleText transducerModule `shouldSatisfy` T.isInfixOf "case parseRequestId"-      firewallBreaches modules `shouldBe` []--  describe "scalar expressions" $ do-    it "parses, validates, and round-trips the authoritative stable scalar fixture" $ do-      source <- readTestText "test/fixtures/aggregate-scalar-expressions-v2.keiro"-      parsed <- case parseSource "aggregate-scalar-expressions-v2.keiro" source of-        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-        Right value -> pure value-      validateSpec (parsedSpec parsed) `shouldBe` []-      parseSource "round-trip.keiro" (renderSource parsed) `shouldBe` Right parsed-      case [aggregate | NAggregate aggregate <- specNodes (parsedSpec parsed)] of-        [aggregate] -> case aggTransitions aggregate of-          transition : holeTransition : [] -> do-            tImplementation transition `shouldBe` GeneratedImplementation-            tImplementation holeTransition `shouldBe` HoleImplementation-            let environment = expressionEnvironment (parsedSpec parsed) aggregate transition-            case lookup "reserved" (tWrites transition) >>= either (const Nothing) Just . resolveWriteExpr environment "reserved" of-              Just resolved -> do-                typedScalarType resolved `shouldBe` AggregateNatural-                show (typedScalarNode resolved) `shouldContain` "TotalNaturalArithmetic"-              Nothing -> expectationFailure "reserved write did not resolve"-            let service = checkedSource parsed-                modules = scaffoldServiceModules (defaultContext (specContext (parsedSpec parsed))) service-                transducer = generatedTextEndingIn "Transducer.hs" modules-                holes = holeTextEndingIn "Holes.hs" modules-                surface = aggregateFoldSurfaceForService service aggregate-                manifest = renderManifestForService "aggregate-scalar-expressions-v2.keiro" modules service-                readableTransducer = T.unwords (T.words transducer)-            aggregateFoldFingerprintForService service aggregate `shouldBe` "60f4f059f718b2ee2bca06360ea20221"-            T.lines surface-              `shouldBe` [ "semantic-contract:keiro-dsl/runtime-semantics/2",-                           "state:Open|terminal=false",-                           "state:Reviewed|terminal=false",-                           "state:Closed|terminal=true",-                           "reg:balance:Integer=0",-                           "reg:reserved:Natural=0",-                           "reg:capacity:Natural=5",-                           "reg:machine:Int=0",-                           "reg:label:Text=\"\"",-                           "reg:active:Bool=False",-                           "reg:mode:AccountMode=Normal",-                           "reg:requestId:RequestId=placeholder",-                           "reg:openedAt:Time=(UTCTime (fromGregorian 2026 1 1) (picosecondsToDiffTime 0))",-                           "reg:limits:Limits=initial",-                           "mapped-register:Limits|wire=4463db782a5b9924|canonical=scalar-expressions.Limits.v1|binding=ScalarExpressions.Bindings.limitsBinding|binding-version=1|initial=ScalarExpressions.Bindings.initialLimits",-                           "nominal-equality-use:nominal-equality|name=AccountMode|contract=keiro-dsl/nominal-equality/1|key=Text|domain=finite-text:normal,restricted|owner=generated",-                           "nominal-equality-use:nominal-equality|name=RequestId|contract=keiro-dsl/nominal-equality/2|key=Text|domain=typeid-v7-text:req:keiro-dsl/id-domain/typeid-v7/1|owner=generated",-                           "transition:live|Open|Adjust|implementation=generated|guard=cmd.balance + reg.balance >= -100 && reg.reserved + cmd.requested <= reg.capacity && cmd.observedAt >= reg.openedAt && cmd.limits.minimum >= reg.limits.minimum && cmd.active == false && cmd.mode == reg.mode && cmd.requestId == reg.requestId|writes=balance:=reg.balance + cmd.balance * 2;reserved:=reg.reserved + (cmd.requested - reg.capacity);machine:=-7;label:=\"adjusted\";active:=true;mode:=AccountMode.Restricted;requestId:=RequestId(\"req_01h455vb4pex5vsknk084sn02q\");openedAt:=\"2026-02-03T04:05:06Z\";limits:=cmd.limits|emits=Adjusted|outputs=Adjusted=generated-command-identity:Adjust[balance=balance:Integer,requested=requested:Natural,machine=machine:Int,label=label:Text,active=active:Bool,mode=mode:AccountMode,requestId=requestId:RequestId,observedAt=observedAt:Time,limits=limits:Limits]|goto=Reviewed",-                           "transition:live|Reviewed|Close|implementation=hole|guard=|writes=|emits=ClosedEvent|outputs=ClosedEvent=generated-command-identity:Close[balance=balance:Integer]|goto=Closed"-                         ]-            diffServices service service `shouldBe` []-            resolvedFold (ReplayImpact.replayImpactServices service service) `shouldBe` ReplayNeutral-            manifest `shouldSatisfy` (not . T.isInfixOf "Generated.AggregateScalarExpressions.ScalarAccount.Expressions")-            map modulePath modules `shouldSatisfy` all (not . T.isSuffixOf "Expressions.hs" . T.pack)-            map modulePath modules `shouldSatisfy` any (T.isSuffixOf "Transducer.hs" . T.pack)-            transducer `shouldSatisfy` T.isInfixOf "let commandLimitsMinimum = K.inpProj"-            transducer `shouldSatisfy` T.isInfixOf "registerLimitsMinimum = K.regProj"-            readableTransducer `shouldSatisfy` T.isInfixOf "B.requireGuard $ (((((d.balance .+ B.reg @\"balance\" .>= K.lit (-100 :: Integer) .&& B.reg @\"reserved\" .+ d.requested .<= B.reg @\"capacity\") .&& d.observedAt .>= B.reg @\"openedAt\") .&& commandLimitsMinimum .>= registerLimitsMinimum) .&& d.active .== K.lit False) .&& commandMode .== registerMode) .&& commandRequestId .== registerRequestId"-            transducer `shouldSatisfy` T.isInfixOf "B.slot @\"balance\" =: (B.reg @\"balance\" .+ d.balance .* K.lit (2 :: Integer))"-            transducer `shouldSatisfy` T.isInfixOf "B.slot @\"reserved\" =: (B.reg @\"reserved\" .+ (d.requested .- B.reg @\"capacity\"))"-            transducer `shouldSatisfy` (not . T.isInfixOf "K.PAnd")-            transducer `shouldSatisfy` (not . T.isInfixOf "K.tadd")-            transducer `shouldSatisfy` T.isInfixOf "scalarAccountPredicateVerifications"-            transducer `shouldSatisfy` T.isInfixOf "S.verifyPredicate predicate"-            transducer `shouldSatisfy` T.isInfixOf "B.emit wireAdjusted (AdjustedTermFields"-            transducer `shouldSatisfy` T.isInfixOf "balance = d.balance"-            transducer `shouldSatisfy` (not . T.isInfixOf "transition1OpenAdjustOutput1Adjusted")-            holes `shouldSatisfy` (not . T.isInfixOf "transition1OpenAdjustOutput1Adjusted")-            holes `shouldSatisfy` (not . T.isInfixOf "transition2ReviewedCloseOutput1ClosedEvent")-            holes `shouldSatisfy` T.isInfixOf "transition2ReviewedCloseHoleFoldVersion"-            holes `shouldSatisfy` (not . T.isInfixOf "scalarAccountTransducer")-            firewallBreaches modules `shouldBe` []-          _ -> expectationFailure "expected one generated and one Hole scalar transition"-        _ -> expectationFailure "expected one scalar aggregate"--    it "pins every readable operator, equal-precedence child position, and bare Boolean guard" $ do-      let source =-            T.unlines-              [ "language keiro-dsl 2",-                "context readable-renderer",-                "enum RenderStatus { Ready=ready Waiting=waiting }",-                "aggregate Renderer",-                "  regs",-                "    total Integer = 0",-                "    leftNested Integer = 0",-                "    product Integer = 1",-                "    status RenderStatus = Ready",-                "  states Open Closed!",-                "  command Evaluate { left:Integer right:Integer third:Integer status:RenderStatus }",-                "  event Evaluated = fields(Evaluate)",-                "  Open -- Evaluate -->",-                "    guard ((cmd.left < cmd.right || cmd.left <= cmd.right) || (cmd.left > cmd.right || cmd.left >= cmd.right))",-                "      && (cmd.left == cmd.right && cmd.left != cmd.third)",-                "      && cmd.status == RenderStatus.Waiting",-                "    write total := reg.total + (cmd.left - cmd.right)",-                "    write leftNested := (reg.leftNested + cmd.left) - cmd.right",-                "    write product := cmd.left * (cmd.right * cmd.third)",-                "    write status := RenderStatus.Ready",-                "    emit Evaluated",-                "    goto Closed",-                "aggregate BooleanRenderer",-                "  regs",-                "    enabled Bool = False",-                "  states Open Closed!",-                "  command Enable { enabled:Bool }",-                "  event Enabled = fields(Enable)",-                "  Open -- Enable -->",-                "    guard cmd.enabled",-                "    write enabled := cmd.enabled",-                "    emit Enabled",-                "    goto Closed"-              ]-      spec <- parseInlineSpec "<readable-renderer>" source-      errorCodes spec `shouldBe` []-      let modules = scaffoldModules (defaultContext (specContext spec)) spec-          moduleAt suffix = case [moduleText value | value <- modules, T.pack suffix `T.isSuffixOf` T.pack (modulePath value)] of-            [value] -> pure value-            values -> expectationFailure ("expected one generated module ending in " <> suffix <> ", got " <> show (length values)) >> fail "unreachable"-      renderer <- moduleAt "/Renderer/Transducer.hs"-      booleanRenderer <- moduleAt "/BooleanRenderer/Transducer.hs"-      let normalizedRenderer = T.unwords (T.words renderer)-          normalizedBooleanRenderer = T.unwords (T.words booleanRenderer)-      renderer-        `shouldSatisfy` T.isInfixOf "import Keiki.Core (HsPred, SymTransducer, (.*), (.+), (.-), (.==), (./=), (.<), (.<=), (.>), (.>=), (.&&), (.||))"-      normalizedRenderer-        `shouldSatisfy` T.isInfixOf "(d.left .< d.right .|| d.left .<= d.right) .|| d.left .> d.right .|| d.left .>= d.right"-      normalizedRenderer-        `shouldSatisfy` T.isInfixOf ".&& d.left .== d.right .&& d.left ./= d.third"-      normalizedRenderer-        `shouldSatisfy` T.isInfixOf ".&& commandStatus .== K.lit (\"waiting\" :: Text)"-      renderer-        `shouldSatisfy` T.isInfixOf "B.slot @\"total\" =: (B.reg @\"total\" .+ (d.left .- d.right))"-      renderer-        `shouldSatisfy` T.isInfixOf "B.slot @\"leftNested\" =: (B.reg @\"leftNested\" .+ d.left .- d.right)"-      renderer-        `shouldSatisfy` T.isInfixOf "B.slot @\"product\" =: d.left .* (d.right .* d.third)"-      normalizedBooleanRenderer `shouldSatisfy` T.isInfixOf "B.requireGuard $ d.enabled .== K.lit True"-      firewallBreaches modules `shouldBe` []--    it "renders resolved command selectors in scalar and projected expressions" $ do-      source <- readTestText "test/fixtures/aggregate-scalar-expressions-v2.keiro"-      let aliasedSource =-            T.replace "active:Bool" "active haskell commandActive:Bool"-              . T.replace "mode:AccountMode" "mode haskell commandMode:AccountMode"-              . T.replace "requestId:RequestId" "requestId haskell commandRequestId:RequestId"-              . T.replace "limits:Limits" "limits haskell commandLimits:Limits"-              $ source-      service <- checkedServiceFromText "aggregate-scalar-expression-aliases.keiro" aliasedSource-      let spec = checkedSpec service-          transducer = generatedTextEndingIn "Transducer.hs" (scaffoldServiceModules (defaultContext (specContext spec)) service)-      validateService service `shouldBe` []-      transducer `shouldSatisfy` T.isInfixOf "d.commandActive"-      transducer `shouldSatisfy` T.isInfixOf "d.commandLimits"-      transducer `shouldSatisfy` T.isInfixOf "(#commandMode :: K.Index"-      transducer `shouldSatisfy` T.isInfixOf "(#commandRequestId :: K.Index"-      transducer `shouldSatisfy` T.isInfixOf "(#commandLimits :: K.Index"-      transducer `shouldSatisfy` (not . T.isInfixOf "d.active")-      transducer `shouldSatisfy` (not . T.isInfixOf "inCtorAdjust (#mode :: K.Index")-      transducer `shouldSatisfy` (not . T.isInfixOf "inCtorAdjust (#requestId :: K.Index")-      transducer `shouldSatisfy` (not . T.isInfixOf "inCtorAdjust (#limits :: K.Index")--    it "suffixes normalized projection-alias collisions deterministically" $ do-      let source =-            T.unlines-              [ "language keiro-dsl 2",-                "context projection-alias-collision",-                "mapped structural record AliasCollision {",-                "  haskell package=keiro-dsl module=Renderer.Domain type=AliasCollision",-                "  binding = \"Renderer.Bindings.aliasCollisionBinding\"",-                "  binding-version = \"1\"",-                "  canonical-type = \"renderer.AliasCollision.v1\"",-                "  fixtures = \"Renderer.Bindings.aliasCollisionCases\"",-                "  initial = \"Renderer.Bindings.initialAliasCollision\"",-                "  wire object constructor=AliasCollision unknown-fields=reject {",-                "    dash as \"foo-bar\" : Integer required",-                "    underscore as \"foo_bar\" : Integer required",-                "  }",-                "}",-                "aggregate AliasRenderer",-                "  regs",-                "    values AliasCollision = initial",-                "  states Open Closed!",-                "  command Compare { values:AliasCollision }",-                "  event Compared = fields(Compare)",-                "  Open -- Compare -->",-                "    guard cmd.values.dash == reg.values.dash",-                "      && cmd.values.underscore == reg.values.underscore",-                "    emit Compared",-                "    goto Closed"-              ]-      spec <- parseInlineSpec "<projection-alias-collision>" source-      errorCodes spec `shouldBe` []-      let transducer = generatedTextEndingIn "Transducer.hs" (scaffoldModules (defaultContext (specContext spec)) spec)-      transducer `shouldSatisfy` T.isInfixOf "let commandValuesFooBar = K.inpProj"-      transducer `shouldSatisfy` T.isInfixOf "registerValuesFooBar = K.regProj"-      transducer `shouldSatisfy` T.isInfixOf "commandValuesFooBar2 = K.inpProj"-      transducer `shouldSatisfy` T.isInfixOf "registerValuesFooBar2 = K.regProj"--    it "keeps evolution identity independent of module layout but sensitive to checked behavior" $ do-      source <- readTestText "test/fixtures/aggregate-scalar-expressions-v2.keiro"-      original <- case parseSource "aggregate-scalar-expressions-v2.keiro" source of-        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-        Right value -> pure value-      changed <- case parseSource "aggregate-scalar-expressions-changed.keiro" (T.replace "cmd.active == false" "cmd.active == true" source) of-        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-        Right value -> pure value-      case ( [aggregate | NAggregate aggregate <- specNodes (parsedSpec original)],-             [aggregate | NAggregate aggregate <- specNodes (parsedSpec changed)]-           ) of-        ([originalAggregate], [changedAggregate]) -> do-          let service = checkedSource original-              changedService = checkedSource changed-              prefixed = defaultContext (specContext (parsedSpec original))-              collocated = prefixed {moduleRoot = "Acme", placement = CollocatedLeaf}-              prefixedModules = scaffoldServiceModules prefixed service-              collocatedModules = scaffoldServiceModules collocated service-              originalSurface = aggregateFoldSurfaceForService service originalAggregate-              originalFingerprint = aggregateFoldFingerprintForService service originalAggregate-          map modulePath prefixedModules `shouldNotBe` map modulePath collocatedModules-          sum (map (T.length . moduleText) prefixedModules) `shouldSatisfy` (> 0)-          sum (map (T.length . moduleText) collocatedModules) `shouldSatisfy` (> 0)-          aggregateFoldSurfaceForService service originalAggregate `shouldBe` originalSurface-          aggregateFoldFingerprintForService service originalAggregate `shouldBe` originalFingerprint-          aggregateFoldSurfaceForService changedService changedAggregate `shouldNotBe` originalSurface-          aggregateFoldFingerprintForService changedService changedAggregate `shouldNotBe` originalFingerprint-        found -> expectationFailure ("expected one aggregate before and after behavior mutation, got " <> show (length (fst found), length (snd found)))--    it "rejects cross-command fields(Command) output before scaffolding" $ do-      let source =-            T.unlines-              [ "language keiro-dsl 2",-                "context output-command-mismatch",-                "aggregate Account",-                "  regs",-                "  states Open Closed!",-                "  command OpenAccount { accountId:Text }",-                "  command CloseAccount { accountId:Text }",-                "  event AccountOpened = fields(OpenAccount)",-                "  Open -- CloseAccount --> emit AccountOpened ; goto Closed"-              ]-      spec <- parseInlineSpec "<output-command-mismatch>" source-      errorCodes spec `shouldContain` [EventOutputCommandMismatch]-      case [aggregate | NAggregate aggregate <- specNodes spec] of-        [aggregate] -> case aggTransitions aggregate of-          [transition] ->-            eventOutputMapping spec aggregate transition 1 "AccountOpened"-              `shouldBe` Left (OutputCommandMismatch "OpenAccount" "CloseAccount" "AccountOpened")-          _ -> expectationFailure "expected one transition"-        _ -> expectationFailure "expected one aggregate"--    it "rejects Int arithmetic and mixed numeric operands before scaffolding" $ do-      let source =-            T.unlines-              [ "language keiro-dsl 2",-                "context scalar-errors",-                "aggregate Counter",-                "  regs",-                "    machine Int = 0",-                "    exact Integer = 0",-                "  states Open Closed!",-                "  command Add { machine:Int exact:Integer }",-                "  event Added = fields(Add)",-                "  Open -- Add -->",-                "    guard cmd.machine + 1 >= 0 && cmd.exact == cmd.machine",-                "    emit Added",-                "    goto Closed"-              ]-      spec <- parseInlineSpec "<scalar-errors>" source-      errorCodes spec `shouldContain` [AggregateExpressionOperatorUnsupported, AggregateExpressionOperandTypeMismatch]--    it "rejects nominal type confusion and unqualified enum values at source checking" $ do-      let source =-            T.unlines-              [ "language keiro-dsl 2",-                "context nominal-type-confusion",-                "id OrderId prefix=ord",-                "id UserId prefix=usr",-                "enum OrderStatus { Draft=draft Submitted=submitted }",-                "enum UserStatus { Active=active Disabled=disabled }",-                "aggregate Account",-                "  regs",-                "    orderId OrderId = placeholder",-                "    status OrderStatus = Draft",-                "  states Open Closed!",-                "  command Compare { orderId:OrderId userId:UserId status:OrderStatus userStatus:UserStatus label:Text }",-                "  event Compared = fields(Compare)",-                "  Open -- Compare -->",-                "    guard cmd.orderId == cmd.userId",-                "      && cmd.status == cmd.userStatus",-                "      && cmd.orderId == cmd.label",-                "      && cmd.status == Draft",-                "    emit Compared",-                "    goto Closed"-              ]-      spec <- parseInlineSpec "<nominal-type-confusion>" source-      let diagnostics = validateSpec spec-      length [() | diagnostic <- diagnostics, code diagnostic == AggregateExpressionOperandTypeMismatch]-        `shouldBe` 3-      errorCodes spec `shouldContain` [AggregateExpressionRootUnknown]-      T.unlines (map message diagnostics) `shouldSatisfy` T.isInfixOf "qualify"--    it "rejects machine-Int arithmetic at both platform bounds" $ do-      let source =-            T.unlines-              [ "language keiro-dsl 2",-                "context scalar-int-bounds",-                "aggregate Counter",-                "  regs",-                "    machine Int = 0",-                "  states Open Closed!",-                "  command Set { machine:Int }",-                "  event SetEvent = fields(Set)",-                "  Open -- Set -->",-                "    guard cmd.machine + 1 >= " <> T.pack (show (minBound :: Int)),-                "      && cmd.machine - 1 <= " <> T.pack (show (maxBound :: Int)),-                "    emit SetEvent",-                "    goto Closed"-              ]-      spec <- parseInlineSpec "<scalar-int-bounds>" source-      length [() | diagnostic <- validateSpec spec, code diagnostic == AggregateExpressionOperatorUnsupported]-        `shouldBe` 2--    it "rejects predicate-valued Bool writes that Keiki cannot represent as scalar terms" $ do-      let source =-            T.unlines-              [ "language keiro-dsl 2",-                "context scalar-bool-write",-                "aggregate Flag",-                "  regs",-                "    active Bool = False",-                "  states Open Closed!",-                "  command Set { active:Bool }",-                "  event SetEvent = fields(Set)",-                "  Open -- Set -->",-                "    write active := cmd.active == true",-                "    emit SetEvent",-                "    goto Closed"-              ]-      spec <- parseInlineSpec "<scalar-bool-write>" source-      errorCodes spec `shouldContain` [AggregateExpressionOperatorUnsupported]--    it "requires explicit roots for a same-named register and command field" $ do-      let source =-            T.unlines-              [ "language keiro-dsl 2",-                "context scalar-ambiguity",-                "aggregate Counter",-                "  regs",-                "    amount Integer = 0",-                "  states Open Closed!",-                "  command Set { amount:Integer }",-                "  event SetEvent = fields(Set)",-                "  Open -- Set -->",-                "    guard amount == 0",-                "    emit SetEvent",-                "    goto Closed"-              ]-      spec <- parseInlineSpec "<scalar-ambiguity>" source-      errorCodes spec `shouldContain` [AggregateExpressionRootAmbiguous]--    it "enforces exclusive Hole ownership and preserves its canonical spelling" $ do-      let source =-            T.unlines-              [ "language keiro-dsl 2",-                "context scalar-hole",-                "aggregate Counter",-                "  regs",-                "    amount Integer = 0",-                "  states Open Closed!",-                "  command Set { amount:Integer }",-                "  event SetEvent = fields(Set)",-                "  Open -- Set -->",-                "    implementation hole",-                "    guard cmd.amount >= 0",-                "    emit SetEvent",-                "    goto Closed"-              ]-      parsed <- case parseSource "<scalar-hole>" source of-        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-        Right value -> pure value-      errorCodes (parsedSpec parsed) `shouldContain` [AggregateTransitionOwnershipConflict]-      renderSource parsed `shouldSatisfy` T.isInfixOf "implementation hole"--    it "generates a stable per-transition Hole boundary and fold token" $ do-      let source =-            T.unlines-              [ "language keiro-dsl 2",-                "context scalar-hole",-                "aggregate Counter",-                "  regs",-                "    amount Integer = 0",-                "  states Open Closed!",-                "  command Set { amount:Integer }",-                "  event SetEvent = fields(Set)",-                "  Open -- Set -->",-                "    implementation hole",-                "    emit SetEvent",-                "    goto Closed"-              ]-      spec <- parseInlineSpec "<scalar-hole-valid>" source-      aggregate <- case [value | NAggregate value <- specNodes spec] of-        [value] -> pure value-        _ -> expectationFailure "expected one Hole aggregate" >> fail "unreachable"-      let modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate-          transducer = generatedTextEndingIn "Transducer.hs" modules-          holes = holeTextEndingIn "Holes.hs" modules-      errorCodes spec `shouldBe` []-      map modulePath modules `shouldSatisfy` all (not . T.isSuffixOf "Expressions.hs" . T.pack)-      transducer `shouldSatisfy` T.isInfixOf "Holes.transition1OpenSetHole d"-      transducer `shouldSatisfy` T.isInfixOf "foldToken Holes.transition1OpenSetHoleFoldVersion"-      holes `shouldSatisfy` T.isInfixOf "transition1OpenSetHole _d = B.requireGuard K.PTop"-      holes `shouldSatisfy` T.isInfixOf "transition1OpenSetHoleFoldVersion = FoldVersion"-      holes `shouldSatisfy` (not . T.isInfixOf "counterTransducer")--    it "pins v1 and collection rejection at their stable boundaries" $ do-      v1Source <- readTestText "test/fixtures/aggregate-scalar-expressions-v1-rejects.keiro"-      case parseSource "v1.keiro" v1Source of-        Left (SourceLanguageFailure diagnostic) -> sourceLanguageErrorCode diagnostic `shouldBe` LanguageFeatureRequiresVersion-        other -> expectationFailure ("expected v1 source-language refusal, got " <> show other)-      collectionSource <- readTestText "test/fixtures/aggregate-collection-expressions-v2-rejects.keiro"-      case parseSource "collections.keiro" collectionSource of-        Left failure -> renderParseFailure failure `shouldSatisfy` T.isInfixOf "CollectionExpressionUnsupported"-        Right _ -> expectationFailure "collection syntax unexpectedly parsed"--    it "keeps arithmetic operands intact when complementing a scalar comparison" $ do-      let left = EAdd noLoc (EPath noLoc CommandRoot ["balance"]) (ELiteral noLoc (LiteralIntegral 2))-          right = ESubtract noLoc (EPath noLoc RegisterRoot ["balance"]) (ELiteral noLoc (LiteralIntegral 3))-          predicate = ECmp OpLt left right-      complementExpr predicate `shouldBe` ECmp OpGe left right-      complementExpr (complementExpr predicate) `shouldBe` predicate--    it "keeps the committed scalar-expression conformance tree fresh" $ do-      modules <- scaffoldFixture "test/fixtures/aggregate-scalar-expressions-v2.keiro"-      forM_ [generatedModule | generatedModule <- modules, kind generatedModule == Generated] $ \generatedModule -> do-        committed <- readTestText ("test/conformance-scalar-expressions/" <> modulePath generatedModule)-        normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText generatedModule)--  describe "behavior obligations" $ do-    it "uses one source-wide layout and excludes replay-only initial edges from live harness probes" $ do-      spec <--        parseInlineSpec "<transition-layout>" $-          T.unlines-            [ "language keiro-dsl 4",-              "context transition-layout",-              "aggregate Journey",-              "  regs",-              "  states Empty Active",-              "  command Start { current:Bool }",-              "  command Legacy { current:Bool }",-              "  event Started = fields(Start)",-              "  event LegacyStarted = fields(Legacy)",-              "  Empty -- Start --> guard cmd.current == true ; emit Started ; goto Active",-              "  Active -- Start --> emit Started ; goto Active",-              "  replay-only Empty -- Start --> guard cmd.current == false ; emit Started ; goto Active",-              "  Active -- Legacy --> emit LegacyStarted ; goto Active",-              "  replay-only Empty -- Legacy --> emit LegacyStarted ; goto Active"-            ]-      aggregate <- case [value | NAggregate value <- specNodes spec] of-        [value] -> pure value-        _ -> expectationFailure "expected one transition-layout aggregate" >> fail "unreachable"-      let ctx = defaultContext (specContext spec)-          modules = scaffoldAggregate ctx spec aggregate <> harnessFor ctx spec aggregate-          transducer = generatedTextEndingIn "Transducer.hs" modules-          harness = generatedTextEndingIn "Harness.hs" modules-          contract = generatedTextEndingIn "BehaviorContract.hs" modules-      T.count "B.from JourneyEmpty do" transducer `shouldBe` 1-      transducer `shouldSatisfy` T.isInfixOf "transition3EmptyStart"-      transducer `shouldSatisfy` T.isInfixOf "transition5EmptyLegacy"-      T.count "acceptStart :: Bool" harness `shouldBe` 1-      harness `shouldSatisfy` (not . T.isInfixOf "acceptLegacy")-      contract `shouldSatisfy` T.isInfixOf "K.EdgeRef JourneyEmpty 1"-      contract `shouldSatisfy` T.isInfixOf "K.EdgeRef JourneyEmpty 2"--    it "refuses duplicate live initial harness helpers with both source locations" $ do-      spec <--        parseInlineSpec "<initial-helper-collision>" $-          T.unlines-            [ "language keiro-dsl 4",-              "context helper-collision",-              "aggregate Journey",-              "  regs",-              "  states Empty Active",-              "  command Start { current:Bool }",-              "  event Started = fields(Start)",-              "  Empty -- Start --> guard cmd.current == true ; emit Started ; goto Active",-              "  Empty -- Start --> guard cmd.current == false ; emit Started ; goto Active"-            ]-      let collisions = [diagnostic | diagnostic <- validateSpec spec, code diagnostic == GeneratedOccurrenceCollision]-      map line collisions `shouldBe` [9, 9]-      collisions `shouldSatisfy` all (elem (8, "'Start' also normalizes here") . relatedLocations)--    it "inventories generated harness sample constants before rendering" $ do-      service <--        checkedServiceFromText-          "<sample-helper-collision>"-          ( T.unlines-              [ "language keiro-dsl 4",-                "context helper-collision",-                "id ObservedAt prefix=obs",-                "aggregate Journey",-                "  regs",-                "  states Empty",-                "  command Start {",-                "    request:ObservedAt",-                "    observedAt:Time",-                "  }"-              ]-          )-      let collisions = [diagnostic | diagnostic <- validateService service, code diagnostic == GeneratedOccurrenceCollision]-      map line collisions `shouldBe` [9]-      collisions `shouldSatisfy` all (elem (3, "'ObservedAt' also normalizes here") . relatedLocations)--    it "inventories every live-reachable cell, guarded edge, terminal rejection, and replay edge" $ do-      spec <- specOf "test/fixtures/behavior-complete.keiro"-      requirements <- either (\errors -> expectationFailure (show errors) >> pure []) pure (Behavior.deriveBehaviorRequirements spec)-      length requirements `shouldBe` 19-      length [() | requirement <- requirements, Behavior.requirementKind requirement == Behavior.LiveTransition] `shouldBe` 5-      length [() | requirement <- requirements, Behavior.requirementKind requirement == Behavior.RequiredRejection] `shouldBe` 11-      length [() | requirement <- requirements, Behavior.requirementKind requirement == Behavior.ReplayTransition] `shouldBe` 3-      [Behavior.requirementSource requirement | requirement <- requirements, Behavior.requirementKind requirement == Behavior.RequiredRejection]-        `shouldContain` ["Active", "Closed"]-      length [() | requirement <- requirements, Behavior.requirementGuardCoverage requirement == Behavior.GuardTotal] `shouldBe` 3-      length [() | requirement <- requirements, Behavior.requirementGuardCoverage requirement == Behavior.GuardUnknown] `shouldBe` 2-      let report = Behavior.BehaviorObligationsReport "behavior-complete.keiro" Nothing requirements-          encoded = Behavior.encodeBehaviorObligationsJson report-      encoded `shouldSatisfy` T.isInfixOf "\"schema\":\"keiro-dsl/behavior-obligations/1\""-      encoded `shouldSatisfy` T.isInfixOf "\"source\":\"Closed\""-      encoded `shouldSatisfy` T.isInfixOf "\"kind\":\"replay-transition\""-      encoded `shouldSatisfy` (not . T.isInfixOf "\"filled\"")-      encoded `shouldSatisfy` (not . T.isInfixOf "\"missing\"")--    it "keeps semantic keys stable across line movement and canonical pretty printing" $ do-      source <- readTestText "test/fixtures/behavior-complete.keiro"-      parsed <- case parseSource "behavior-complete.keiro" source of-        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-        Right value -> pure value-      let original = parsedSpec parsed-      moved <- parseInlineSpec "behavior-complete-moved.keiro" ("# line movement must not rename witnesses\n\n" <> source)-      pretty <- parseInlineSpec "behavior-complete-pretty.keiro" (renderSource parsed)-      let keys spec = fmap (map Behavior.requirementKey) (Behavior.deriveBehaviorRequirements spec)-      keys moved `shouldBe` keys original-      keys pretty `shouldBe` keys original--    it "generates direct fields(Command) output and separate create-once pending witnesses" $ do-      service <- checkedServiceOf "test/fixtures/behavior-complete.keiro"-      let spec = checkedSpec service-      aggregate <- case [value | NAggregate value <- specNodes spec] of-        [value] -> pure value-        _ -> expectationFailure "expected one behavior-complete aggregate" >> fail "unreachable"-      let ctx = defaultContext (specContext spec)-          modules = scaffoldAggregate ctx spec aggregate-          harness = generatedTextEndingIn "Harness.hs" (harnessForService ctx service aggregate)-          transducer = generatedTextEndingIn "Transducer.hs" modules-          codec = generatedTextEndingIn "Codec.hs" modules-          contract = generatedTextEndingIn "BehaviorContract.hs" modules-          projection = generatedTextEndingIn "Projection.hs" modules-          behaviorHoles = case [moduleText value | value <- modules, T.isSuffixOf "BehaviorHoles.hs" (T.pack (modulePath value))] of-            [value] -> value-            values -> error ("expected one BehaviorHoles module, got " <> show (length values))-          ordinaryHoles = [value | value <- modules, T.isSuffixOf "/Holes.hs" (T.pack (modulePath value)), not (T.isSuffixOf "BehaviorHoles.hs" (T.pack (modulePath value)))]-      transducer `shouldSatisfy` T.isInfixOf "requestId = d.requestId"-      transducer `shouldSatisfy` T.isInfixOf "observedAt = d.observedAt"-      transducer `shouldSatisfy` T.isInfixOf "amount = d.amount"-      transducer `shouldSatisfy` T.isInfixOf "details = d.details"-      codec `shouldSatisfy` T.isInfixOf "display_label"-      codec `shouldSatisfy` T.isInfixOf "optional_note"-      transducer `shouldSatisfy` (not . T.isInfixOf "Output")-      ordinaryHoles `shouldBe` []-      obsoleteGeneratedOutputHooks spec `shouldContain` [("Journey", "transition1EmptyStartOutput1Started")]-      T.count "B.from JourneyEmpty do" transducer `shouldBe` 1-      transducer `shouldSatisfy` T.isInfixOf "verifyTransition \"transition3EmptyStart\" GeneratedOwned JourneyEmpty 1"-      transducer `shouldSatisfy` T.isInfixOf "verifyTransition \"transition5EmptyLegacyStart\" GeneratedOwned JourneyEmpty 2"-      T.count "acceptStart :: Bool" harness `shouldBe` 1-      harness `shouldSatisfy` (not . T.isInfixOf "acceptLegacyStart")-      contract `shouldSatisfy` T.isInfixOf "keiro/behavior-conformance/1"-      contract `shouldSatisfy` T.isInfixOf "commandKind command == requirementCommandName requirement"-      contract `shouldSatisfy` (not . T.isInfixOf "OPTIONS_GHC")-      contract `shouldSatisfy` T.isInfixOf "module Generated.BehaviorComplete.Journey.BehaviorContract\n  ( BehaviorKey (..)"-      contract `shouldSatisfy` T.isInfixOf "runRejection :: BehaviorRequirement"-      contract `shouldSatisfy` T.isInfixOf "failureSubject :: !Text"-      contract `shouldSatisfy` T.isInfixOf "\"subject\" .= failureSubject behaviorFailure"-      contract `shouldSatisfy` T.isInfixOf "-- JourneyEmpty x Start: live transition (spec line 38)"-      contract `shouldSatisfy` T.isInfixOf "requirementKey = BehaviorKey \"behavior-v1-"-      contract `shouldSatisfy` T.isInfixOf "requirementCommandName = \"Start\""-      contract `shouldSatisfy` T.isInfixOf "requirementExpectedEdge = (Just (K.EdgeRef JourneyEmpty 1))"-      contract `shouldSatisfy` T.isInfixOf "requirementCommandName = \"LegacyStart\""-      contract `shouldSatisfy` T.isInfixOf "requirementExpectedEdge = (Just (K.EdgeRef JourneyEmpty 2))"-      contract `shouldSatisfy` T.isInfixOf "runtime event values differ from the exact witness expectation; actual="-      T.count "Pending (BehaviorKey " behaviorHoles `shouldBe` 19-      behaviorHoles `shouldSatisfy` T.isInfixOf "-- JourneyEmpty x Start: live transition (spec line 38)"-      behaviorHoles `shouldSatisfy` (not . T.isInfixOf "undefined")-      behaviorHoles `shouldSatisfy` (not . T.isInfixOf "error")-      T.count "sampleRequestId :: RequestId" harness `shouldBe` 1-      T.count "sampleObservedAt :: UTCTime" harness `shouldBe` 1-      harness `shouldSatisfy` T.isInfixOf "Left problem -> error (show problem)"-      harness `shouldSatisfy` T.isInfixOf "sampleEventStarted = Started (StartedData sampleRequestId sampleObservedAt"-      harness `shouldSatisfy` T.isInfixOf "case step journeyTransducer (JourneyEmpty, initialJourneyRegs) (Start (StartData"-      harness `shouldSatisfy` T.isInfixOf "-- clock-free: spec samples no wall clock (verified at scaffold time)"-      harness `shouldSatisfy` (not . T.isInfixOf "(\"clock-free: spec samples no wall clock\", True)")-      codec `shouldSatisfy` T.isInfixOf "parseOptionalField (pure Nothing) (\\value -> case value of Null -> pure Nothing; other -> Just <$> parseJSON other) objectValue \"optional_note\""-      T.count "parseOptionalField ::" codec `shouldBe` 1-      projection `shouldSatisfy` T.isInfixOf "-- No projection declarations are present; this module keeps the generated manifest inventory total."--    it "rejects eventless state or register changes while accepting a true no-op" $ do-      invalid <--        parseInlineSpec "<eventless-change>" $-          T.unlines-            [ "language keiro-dsl 2",-              "context eventless-change",-              "aggregate Counter",-              "  regs",-              "    count Natural = 0",-              "  states Open Closed!",-              "  command Tick { count:Natural }",-              "  Open -- Tick --> write count := cmd.count ; goto Closed"-            ]-      errorCodes invalid `shouldContain` [AggregateEventlessStateChange]-      valid <--        parseInlineSpec "<eventless-noop>" $-          T.unlines-            [ "language keiro-dsl 2",-              "context eventless-noop",-              "aggregate Counter",-              "  regs",-              "    count Natural = 0",-              "  states Open",-              "  command Tick { count:Natural }",-              "  event Ticked = fields(Tick)",-              "  Open -- Tick --> goto Open"-            ]-      errorCodes valid `shouldBe` []--    it "refuses duplicate semantic behavior identities before scaffolding" $ do-      duplicate <--        parseInlineSpec "<duplicate-behavior>" $-          T.unlines-            [ "language keiro-dsl 2",-              "context duplicate-behavior",-              "aggregate Counter",-              "  regs",-              "  states Open",-              "  command Tick { amount:Natural }",-              "  event Ticked = fields(Tick)",-              "  Open -- Tick --> emit Ticked ; goto Open",-              "  Open -- Tick --> emit Ticked ; goto Open"-            ]-      let isBehaviorRefusal (BehaviorRefusal _) = True-          isBehaviorRefusal _ = False-      case planScaffold (defaultContext (specContext duplicate)) duplicate of-        Left refusals -> refusals `shouldSatisfy` any isBehaviorRefusal-        Right _ -> expectationFailure "duplicate behavior identity reached a scaffold write set"--    it "round-trips additive single-file and workspace behavior rows with member ownership" $ do-      spec <- specOf "test/fixtures/behavior-complete.keiro"-      requirements <- either (\errors -> expectationFailure (show errors) >> pure []) pure (Behavior.deriveBehaviorRequirements spec)-      version <- maybe (expectationFailure "language version 2 was not constructible" >> fail "unreachable") pure (languageVersion 2)-      let rows = Behavior.behaviorRecordRows requirements-          singleRecord =-            ScaffoldRecord-              { recSpecPath = "behavior-complete.keiro",-                recModuleRoot = "",-                recLayout = "prefixed",-                recSourceLanguage = DeclaredLanguage version noLoc,-                recLanguageContract = effectiveLanguageContract (DeclaredLanguage version noLoc),-                recNamingEdition = IdiomaticNamingV1,-                recModuleRoles = [],-                recFiles = [],-                recMappings = [],-                recIdDomains = [],-                recNominalEqualities = [],-                recBindingObligations = [],-                recBehaviorRequirements = rows-              }-      T.count "behavior " (renderRecord singleRecord) `shouldBe` 19-      parseRecord (renderRecord singleRecord) `shouldBe` Just singleRecord--      workspace <- shouldComposeWorkspace "test/fixtures/behavior-complete-workspace/service.keiro-workspace"-      workspaceRequirements <- either (\errors -> expectationFailure (show errors) >> pure []) pure (Behavior.deriveBehaviorRequirements (wsMergedSpec workspace))-      let ownedRequirements =-            map-              (Behavior.attributeBehaviorOwner (fmap fst . nodeOwner (wsOwnership workspace) "aggregate"))-              workspaceRequirements-          ownedRows = Behavior.behaviorRecordRows ownedRequirements-          workspaceRecord =-            WorkspaceRecord-              { wrService = wsService workspace,-                wrManifest = "service.keiro-workspace",-                wrContext = wsContext workspace,-                wrModuleRoot = "",-                wrLayout = "prefixed",-                wrMembers = map wmPath (wsMembers workspace),-                wrSourceLanguages = [WorkspaceSourceLanguageRow (wmPath member) (wmSourceLanguage member) | member <- wsMembers workspace],-                wrLanguageContract = wsLanguageContract workspace,-                wrNamingEdition = IdiomaticNamingV1,-                wrModules = [],-                wrMappings = [],-                wrIdDomains = [],-                wrNominalEqualities = [],-                wrBindingObligations = [],-                wrBehaviorRequirements = ownedRows,-                wrAdopted = []-              }-      map Behavior.behaviorRecordOwner ownedRows `shouldSatisfy` all (== Just "journey.keiro")-      T.count "behavior " (renderWorkspaceRecord workspaceRecord) `shouldBe` 19-      parseWorkspaceRecord (renderWorkspaceRecord workspaceRecord) `shouldBe` Just workspaceRecord--    it "keeps the initial replay fixture byte-identical across single, workspace, and repeat scaffolds" $ do-      withTempDirectory "keiro-dsl-initial-replay-layout" $ \base -> do-        let singleOut = base </> "single"-            workspaceOut = base </> "workspace"-            singleSource = "test/fixtures/behavior-complete.keiro"-            workspaceSource = "test/fixtures/behavior-complete-workspace/service.keiro-workspace"-            journeyModules = filter (T.isPrefixOf "Generated/BehaviorComplete/Journey/" . T.pack . fst)-            behaviorContractPath = "Generated/BehaviorComplete/Journey/BehaviorContract.hs"-            withoutBehaviorContract = filter ((/= behaviorContractPath) . fst)-            present = maybe False (const True)-            normalizeRequirementLines =-              T.unlines-                . map-                  ( \sourceLine ->-                      if "requirementLine =" `T.isInfixOf` sourceLine-                        then fst (T.breakOn "=" sourceLine) <> "= <source-line>"-                        else case T.breakOn "(spec line " sourceLine of-                          (prefix, suffix)-                            | T.null suffix -> sourceLine-                            | otherwise -> prefix <> "(spec line <source-line>)"-                  )-                . T.lines-        (singleCode, singleStdout, singleStderr) <- runKeiroDsl ["scaffold", singleSource, "--out", singleOut]-        unless (singleCode == ExitSuccess) (expectationFailure (singleStdout <> singleStderr))-        singleTree <- treeSnapshot singleOut-        (singleRepeatCode, singleRepeatStdout, singleRepeatStderr) <- runKeiroDsl ["scaffold", singleSource, "--out", singleOut]-        unless (singleRepeatCode == ExitSuccess) (expectationFailure (singleRepeatStdout <> singleRepeatStderr))-        treeSnapshot singleOut `shouldReturn` singleTree-        (workspaceCode, workspaceStdout, workspaceStderr) <- runKeiroDsl ["scaffold", workspaceSource, "--out", workspaceOut]-        unless (workspaceCode == ExitSuccess) (expectationFailure (workspaceStdout <> workspaceStderr))-        workspaceTree <- treeSnapshot workspaceOut-        let singleJourney = journeyModules singleTree-            workspaceJourney = journeyModules workspaceTree-        withoutBehaviorContract workspaceJourney `shouldBe` withoutBehaviorContract singleJourney-        case (lookup behaviorContractPath workspaceJourney, lookup behaviorContractPath singleJourney) of-          (Just workspaceContract, Just singleContract) ->-            normalizeRequirementLines workspaceContract `shouldBe` normalizeRequirementLines singleContract-          (workspaceContract, singleContract) ->-            expectationFailure-              ( "expected both generated behavior contracts, got "-                  <> show (present workspaceContract, present singleContract)-              )-        (workspaceRepeatCode, workspaceRepeatStdout, workspaceRepeatStderr) <- runKeiroDsl ["scaffold", workspaceSource, "--out", workspaceOut]-        unless (workspaceRepeatCode == ExitSuccess) (expectationFailure (workspaceRepeatStdout <> workspaceRepeatStderr))-        treeSnapshot workspaceOut `shouldReturn` workspaceTree--  describe "nominal consumer types" $ do-    it "resolves every category through one checked registry and explains exact obligations" $ do-      spec <- specOf "test/fixtures/nominal-scalars.keiro"-      errorCodes spec `shouldBe` []-      registry <- case resolveNominalTypes spec of-        Left errors -> expectationFailure (show errors) >> fail "unreachable"-        Right value -> pure value-      Map.keys (nominalTypes registry)-        `shouldBe` ["AccountNumber", "FeatureFlag", "ObservedAt", "OrderId", "OrderStatus", "RiskScore", "SequenceNumber"]-      obligations <- either (\errors -> expectationFailure (show errors) >> pure []) pure (bindingObligations spec)-      length obligations `shouldBe` 21-      map obligationCategory obligations `shouldSatisfy` all (`elem` ["nominal-id", "nominal-enum", "nominal-scalar"])-      length [() | obligation <- obligations, obligationEqualityContract obligation /= Nothing] `shouldBe` 2-      renderBindingObligations (specContext spec) obligations `shouldSatisfy` T.isInfixOf "equality-contract:"-      let signatures = map obligationSignature obligations-      forM_-        [ "orderIdBinding :: NominalBinding NominalConformance.Domain.OrderId (KindID \"ord\")",-          "orderStatusBinding :: NominalBinding NominalConformance.Domain.OrderStatus Generated.NominalScalars.Nominal.Shape.OrderStatus.OrderStatusRepresentation",-          "accountNumberBinding :: NominalBinding NominalConformance.Domain.AccountNumber Text",-          "orderIdFixtures :: NominalFixtureCases NominalConformance.Domain.OrderId",-          "initialAccountNumber :: NominalConformance.Domain.AccountNumber"-        ]-        (`shouldSatisfy` (`elem` signatures))-      map obligationCanonicalType obligations `shouldSatisfy` all (/= Nothing)-      let rendered = renderBindingObligations (specContext spec) obligations-      rendered `shouldSatisfy` T.isInfixOf "nominal-id type OrderId"-      rendered `shouldSatisfy` T.isInfixOf "canonical-type: \"nominal.OrderId.v1\""-      case obligations of-        firstObligation : _ ->-          (Aeson.eitherDecode (Aeson.encode firstObligation) :: Either String BindingObligation)-            `shouldBe` Right firstObligation-        [] -> expectationFailure "expected nominal binding obligations"--    it "allocates distinct stable diagnostics for incomplete or incompatible nominal declarations" $ do-      missing <- errorCodesOf "test/fixtures/nominal-missing-facts.keiro"-      missing `shouldBe` replicate 5 NominalMissingIngredient-      errorCodesOf "test/fixtures/nominal-bad-qualified.keiro" `shouldReturn` [NominalInvalidQualifiedName]-      errorCodesOf "test/fixtures/nominal-invalid-prefix.keiro" `shouldReturn` replicate 2 NominalInvalidIdPrefix-      errorCodesOf "test/fixtures/nominal-unsupported-representation.keiro" `shouldReturn` [NominalUnsupportedRepresentation]-      errorCodesOf "test/fixtures/nominal-missing-initial.keiro" `shouldReturn` [NominalMissingInitialValue]-      errorCodesOf "test/fixtures/nominal-name-collision.keiro"-        `shouldReturn` [NominalNameCollision, GeneratedOccurrenceCollision, NominalNameCollision]--    it "keeps v1 rejection at the source-language boundary" $ do-      source <- readTestText "test/fixtures/nominal-v1.keiro"-      case parseSource "nominal-v1.keiro" source of-        Left (SourceLanguageFailure diagnostic) -> sourceLanguageErrorCode diagnostic `shouldBe` LanguageFeatureRequiresVersion-        other -> expectationFailure ("expected source-language refusal, got " <> show other)--    it "scaffolds consumer types, checked codecs, enum representation, projections, and deterministic manifests" $ do-      spec <- specOf "test/fixtures/nominal-scalars.keiro"-      let ctx = defaultContext (specContext spec)-          modules = scaffoldModules ctx spec-          moduleAt path = case [value | value <- modules, modulePath value == path] of-            [value] -> pure value-            values -> expectationFailure ("expected one module at " <> path <> ", got " <> show (map modulePath values)) >> fail "unreachable"-      domainModule <- moduleAt "Generated/NominalScalars/NominalLedger/Domain.hs"-      codecModule <- moduleAt "Generated/NominalScalars/NominalLedger/Codec.hs"-      enumModule <- moduleAt "Generated/NominalScalars/Nominal/Shape/OrderStatus.hs"-      projectionModule <- moduleAt "Generated/NominalScalars/NominalProjections.hs"-      bindingModule <- moduleAt "NominalConformance/Bindings.hs"-      map modulePath modules `shouldNotContain` ["NominalScalars/NominalLedger/Holes.hs"]-      moduleText domainModule `shouldSatisfy` T.isInfixOf "import NominalConformance.Domain (AccountNumber, FeatureFlag, ObservedAt, OrderId, OrderStatus, RiskScore, SequenceNumber)"-      moduleText domainModule `shouldSatisfy` T.isInfixOf "orderId :: !OrderId"-      moduleText domainModule `shouldSatisfy` (not . T.isInfixOf "NominalConformance.Domain.OrderId")-      moduleText domainModule `shouldSatisfy` (not . T.isInfixOf "newtype OrderId")-      moduleText domainModule `shouldSatisfy` (not . T.isInfixOf "data OrderStatus =")-      moduleText codecModule `shouldSatisfy` T.isInfixOf "KindID.parseText @\"ord\""-      moduleText codecModule `shouldSatisfy` T.isInfixOf "KindID.toText (nominalToRepresentation"-      moduleText codecModule `shouldSatisfy` T.isInfixOf "nominalFromRepresentation"-      forM_ ["coerce", "unsafe", "read ", "error "] $ \forbidden ->-        moduleText codecModule `shouldSatisfy` (not . T.isInfixOf forbidden)-      moduleText enumModule `shouldSatisfy` T.isInfixOf "data OrderStatusRepresentation = Draft | Submitted"-      moduleText enumModule `shouldSatisfy` (not . T.isInfixOf "NominalConformance")-      moduleText projectionModule `shouldSatisfy` T.isInfixOf "type FieldOwner AccountNumberNominalProjection = AccountNumber"-      moduleText projectionModule `shouldSatisfy` T.isInfixOf "projectFieldValue _ = nominalToRepresentation Bindings.accountNumberBinding"-      moduleText projectionModule `shouldSatisfy` T.isInfixOf "instance ExactFieldProjection OrderIdEqualityProjection"-      moduleText projectionModule `shouldSatisfy` T.isInfixOf "textProjectionDomain orderIdEqualityPattern"-      moduleText projectionModule `shouldSatisfy` T.isInfixOf "instance ExactFieldProjection OrderStatusEqualityProjection"-      moduleText projectionModule `shouldSatisfy` T.isInfixOf "finiteProjectionDomain (\"draft\" :| [\"submitted\"])"-      kind bindingModule `shouldBe` HoleStub-      moduleText bindingModule `shouldSatisfy` T.isInfixOf "import NominalConformance.Domain (AccountNumber, FeatureFlag, ObservedAt, OrderId, OrderStatus, RiskScore, SequenceNumber)"-      moduleText bindingModule `shouldSatisfy` T.isInfixOf "orderIdBinding :: NominalBinding OrderId (KindID \"ord\")"-      moduleText bindingModule `shouldSatisfy` T.isInfixOf "orderStatusBinding :: NominalBinding OrderStatus ShapeOrderStatus.OrderStatusRepresentation"-      firewallBreaches modules `shouldBe` []-      scaffoldModules ctx spec `shouldBe` modules-      manifestDependencies spec `shouldContain` ["mmzk-typeid", "nominal-conformance"]--    it "persists nominal provenance in a separate forward-compatible row kind" $ do-      spec <- specOf "test/fixtures/nominal-scalars.keiro"-      workspace <- shouldComposeWorkspace canonicalWorkspacePath-      let plan = consumerPlan spec-          record =-            ScaffoldRecord-              { recSpecPath = "nominal-scalars.keiro",-                recModuleRoot = "",-                recLayout = "prefixed",-                recSourceLanguage = LegacyUnversioned,-                recLanguageContract = effectiveLanguageContract LegacyUnversioned,-                recNamingEdition = IdiomaticNamingV1,-                recModuleRoles = [],-                recFiles = [],-                recMappings = consumerMappings plan,-                recIdDomains = [],-                recNominalEqualities = nominalEqualityIdentities spec,-                recBindingObligations = [],-                recBehaviorRequirements = []-              }-          encoded = renderRecord record-          workspaceRecord =-            (sampleWorkspaceRecord workspace)-              { wrMappings = consumerMappings plan-              }-          workspaceEncoded = renderWorkspaceRecord workspaceRecord-      consumerPackages plan `shouldBe` ["nominal-conformance"]-      length [() | NominalMapping {} <- consumerMappings plan] `shouldBe` 7-      T.count "nominal-mapping " encoded `shouldBe` 7-      T.count "nominal-equality " encoded `shouldBe` 2-      T.count "\nmapping " encoded `shouldBe` 0-      parseRecord encoded `shouldBe` Just record-      T.count "nominal-mapping " workspaceEncoded `shouldBe` 7-      T.count "nominal-equality " workspaceEncoded `shouldSatisfy` (>= 2)-      T.count "\nmapping " workspaceEncoded `shouldBe` 0-      parseWorkspaceRecord workspaceEncoded `shouldBe` Just workspaceRecord--    it "reports bound-ID decoder tightening and makes binding provenance replay-visible" $ do-      current <- specOf "test/fixtures/nominal-scalars.keiro"-      let useGeneratedIdInitial (NAggregate aggregate) =-            NAggregate-              aggregate-                { aggRegs =-                    [ if regName register == "orderId"-                        then register {regInitial = RegInitBare "placeholder"}-                        else register-                    | register <- aggRegs aggregate-                    ]-                }-          useGeneratedIdInitial node = node-          unbound =-            current-              { specIds = [declaration {idBinding = Nothing} | declaration <- specIds current],-                specNodes = map useGeneratedIdInitial (specNodes current)-              }-          adoption = diffSpecs unbound current-          decoderFindings = [kindOfChange change | change <- adoption, changeCode change == NominalIdDecoderTightened]-      map ckSubject decoderFindings `shouldContain` ["NominalLedger event NominalsRecorded .orderId"]-      decoderFindings `shouldSatisfy` all ((== VAdvisory) . verdictFor PrivateHistoryRead . ckVector)-      let bumped =-            current-              { specIds =-                  [ declaration-                      { idBinding = fmap (\binding -> binding {nominalBindingVersion = Just "2"}) (idBinding declaration)-                      }-                  | declaration <- specIds current-                  ]-              }-          bindingChanges = diffSpecs current bumped-      map changeCode bindingChanges `shouldContain` [NominalBindingChanged]-      replayImpactSpecs current bumped `shouldSatisfy` \case-        ReplayImpact.ReplayAffected impacts ->-          maybe False (\impact -> Set.member "NominalsRecorded" (ReplayImpact.eventTypes impact) && includeSnapshotStreams impact) (Map.lookup "NominalLedger" impacts)-        ReplayImpact.ReplayNeutral -> False-      case [aggregate | NAggregate aggregate <- specNodes current] of-        aggregate : _ -> do-          aggregateFoldSurface current aggregate `shouldSatisfy` T.isInfixOf "nominal-equality-use:"-          aggregateFoldSurface current aggregate `shouldNotBe` aggregateFoldSurface bumped aggregate-        [] -> expectationFailure "expected nominal aggregate"--  describe "historical codec comparison" $ do-    it "treats object-key order as RFC 8785 parity" $ do-      let historical = object ["z" .= (1 :: Int), "a" .= (2 :: Int)]-          generated = object ["a" .= (2 :: Int), "z" .= (1 :: Int)]-      classifyObservation (EncodeObservation "ordered-object" historical generated)-        `shouldBe` Right JsonParity-    it "classifies an omitted key versus explicit null as version work at that pointer" $ do-      let historical = object []-          generated = object ["description" .= Aeson.Null]-      classifyObservation (EncodeObservation "absent-description" historical generated)-        `shouldBe` Right (RequiresVersionWork (EncodedValueDifference (JsonPointer "/description") historical generated))-    it "classifies generated rejection of a historical value as version work" $-      classifyObservation-        ( DecodeObservation-            "legacy.json"-            (object ["tag" .= ("legacy" :: T.Text)])-            (DecodedShape (object ["tag" .= ("legacy" :: T.Text)]))-            (DecodeFailed "unknown tag")-        )-        `shouldBe` Right (RequiresVersionWork (GeneratedDecodeRejected "unknown tag"))-    it "treats historical-codec rejection as invalid input rather than parity" $-      classifyObservation-        ( DecodeObservation-            "corrupt.json"-            Aeson.Null-            (DecodeFailed "not historical data")-            (DecodeFailed "not generated data")-        )-        `shouldBe` Left (HistoricalCodecRejected "corrupt.json" "not historical data")-    it "reports uncovered union arms separately by corpus origin" $ do-      let canonical = DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical")-          local = DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local_file")-          report = compareReport comparisonProvenance [] [] [canonical, local] [ObservedBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local_file")]-      crCoverageGaps report-        `shouldBe` [CoverageGap HistoricalGolden (JsonPointer "/location") (UnionArm "canonical")]-      reportSucceeded report `shouldBe` False-    it "derives optional, null, and union-arm observations from a generated branch schema" $ do-      let schema =-            BranchRecord-              [ BranchField "description" True (BranchOptional BranchScalar),-                BranchField "location" False (BranchUnion "tag" "contents" [BranchArm "local" (Just BranchScalar), BranchArm "canonical" Nothing])-              ]-          historical = object ["location" .= object ["tag" .= ("canonical" :: T.Text)]]-      observedBranchesFor HistoricalGolden schema historical-        `shouldBe` [ ObservedBranch HistoricalGolden (JsonPointer "/description") OptionalMissing,-                     ObservedBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical")-                   ]-      let declared = declaredBranchesFor HistoricalGolden schema-      forM_-        [ DeclaredBranch HistoricalGolden (JsonPointer "/description") OptionalMissing,-          DeclaredBranch HistoricalGolden (JsonPointer "/description") OptionalPresent,-          DeclaredBranch HistoricalGolden (JsonPointer "/description") ExplicitNull,-          DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local"),-          DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical")-        ]-        (\branch -> declared `shouldContain` [branch])-    it "round-trips the stable machine report" $ do-      let observation = EncodeObservation "parity" (object ["a" .= (1 :: Int)]) (object ["a" .= (1 :: Int)])-          report = compareReport comparisonProvenance [] [observation] [] []-      Aeson.eitherDecode (Aeson.encode report) `shouldBe` Right report-    it "atomically writes and replaces the machine report" $-      withTempDirectory "keiro-dsl-codec-compare" $ \out -> do-        let path = out </> "report.json"-            firstReport = compareReport comparisonProvenance [] [] [] []-            secondReport = compareReport comparisonProvenance [HistoricalGoldenUnreadable "bad.json" "bad JSON"] [] [] []-        writeCompareReportAtomic path firstReport `shouldReturn` Right ()-        Aeson.eitherDecodeFileStrict path `shouldReturn` Right firstReport-        writeCompareReportAtomic path secondReport `shouldReturn` Right ()-        Aeson.eitherDecodeFileStrict path `shouldReturn` Right secondReport--  describe "historical codec comparison scaffold" $ do-    it "emits an opt-in non-production runner without entering the ordinary module registry" $ do-      spec <- specOf "test/fixtures/structural-conformance.keiro"-      let ctx = defaultContext (specContext spec)-          planned = codecComparisonModule ctx spec "ArtifactInfo"-          ordinary = scaffoldModules ctx spec-      case planned of-        Left err -> expectationFailure (T.unpack err)-        Right comparisonModule -> do-          modulePath comparisonModule-            `shouldBe` "Generated/StructuralConformance/Structural/CodecCompare/ArtifactInfo.hs"-          moduleText comparisonModule `shouldSatisfy` T.isInfixOf codecComparisonBanner-          moduleText comparisonModule `shouldSatisfy` T.isInfixOf "Generated.StructuralConformance.ArtifactCatalog.Codec qualified as GeneratedCodec"-          moduleText comparisonModule `shouldSatisfy` T.isInfixOf "branchSchema = BranchRecord"-          map modulePath ordinary `shouldNotContain` [modulePath comparisonModule]-    it "refuses opaque selections rather than upgrading their claim" $ do-      spec <- specOf "test/fixtures/structural-conformance.keiro"-      codecComparisonModule (defaultContext (specContext spec)) spec "VendorGeometry"-        `shouldSatisfy` either (T.isInfixOf "is opaque") (const False)--  describe "structural/opaque coverage reporting" $ do-    it "reports mapped private-event roots and consumer-json register boundaries without a percentage" $ do-      spec <- specOf "test/fixtures/structural-conformance.keiro"-      report <- shouldResolveCoverage "structural-conformance.keiro" spec-      Coverage.privateEventPayloads (Coverage.coverageSummary report)-        `shouldBe` Coverage.CoverageCounts 2 1 1 0-      Coverage.snapshotRegisters (Coverage.coverageSummary report)-        `shouldBe` Coverage.CoverageCounts 2 1 1 0-      map Coverage.opaqueMappedType (Coverage.coverageOpaqueBoundaries report)-        `shouldBe` ["VendorGeometry"]-      map Coverage.snapshotEncoding (Coverage.coverageSnapshotBoundaries report)-        `shouldBe` ["consumer-json-cache", "consumer-json-cache"]-      map Coverage.snapshotInvalidation (Coverage.coverageSnapshotBoundaries report)-        `shouldBe` ["tracked-by-mapped-wire-fingerprint", "tracked-by-mapped-wire-fingerprint"]-      map Coverage.findingCode (Coverage.coverageFindings report)-        `shouldBe` [CoverageOpaqueSurface]-      map Coverage.findingSeverity (Coverage.coverageFindings report)-        `shouldBe` [Warning]-      case Aeson.toJSON report of-        Aeson.Object values ->-          forM_ ["spec", "roots", "opaqueBoundaries", "snapshotBoundaries", "unsupportedSurfaces"] $-            \key -> KeyMap.member key values `shouldBe` True-        value -> expectationFailure ("coverage report was not an object: " <> show value)-    it "reports explicit Json leaves by their complete persisted path" $ do-      spec <- withMetadataJson <$> specOf "test/fixtures/structural-conformance.keiro"-      report <- shouldResolveCoverage "structural-conformance-json.keiro" spec-      Coverage.jsonBoundaries (Coverage.privateEventPayloads (Coverage.coverageSummary report))-        `shouldBe` 1-      map Coverage.jsonPath (Coverage.coverageJsonBoundaries report)-        `shouldBe` ["ArtifactCatalog event ArtifactRecorded .artifact : ArtifactInfo .metadata : ArtifactMetadata .note"]-    it "keeps a zero-opaque spec advisory-free and makes rejection explicitly opt-in" $ do-      original <- specOf "test/fixtures/structural-conformance.keiro"-      clear <- shouldResolveCoverage "structural-only.keiro" (withoutVendorGeometry original)-      Coverage.opaqueRoots (Coverage.privateEventPayloads (Coverage.coverageSummary clear)) `shouldBe` 0-      Coverage.coverageOpaqueBoundaries clear `shouldBe` []-      Coverage.coverageFindings clear `shouldBe` []-      opaque <- shouldResolveCoverage "structural-conformance.keiro" original-      Coverage.coverageSucceeded opaque `shouldBe` True-      let gated = Coverage.failOnOpaque opaque-      Coverage.coverageSucceeded gated `shouldBe` False-      map Coverage.findingCode (Coverage.coverageFindings gated)-        `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueGateExceeded]-      map Coverage.findingSeverity (Coverage.coverageFindings gated)-        `shouldBe` [Warning, Error]-    it "diffs named opaque boundaries and fails only an explicitly gated increase" $ do-      newSpec <- specOf "test/fixtures/structural-conformance.keiro"-      report <- case Coverage.coverageDiffReport "structural-conformance.keiro" "HEAD" (withoutVendorGeometry newSpec) newSpec of-        Left err -> expectationFailure (show err) >> fail "unreachable"-        Right value -> pure value-      fmap Coverage.opaqueBoundaryDelta (Coverage.coverageDelta report) `shouldBe` Just 1-      fmap (map Coverage.opaqueMappedType . Coverage.addedOpaqueBoundaries) (Coverage.coverageDelta report)-        `shouldBe` Just ["VendorGeometry"]-      map Coverage.findingCode (Coverage.coverageFindings report)-        `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueBoundaryAdded]-      Coverage.coverageSucceeded report `shouldBe` True-      let gated = Coverage.failOnOpaqueIncrease report-      Coverage.coverageSucceeded gated `shouldBe` False-      map Coverage.findingCode (Coverage.coverageFindings gated)-        `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueBoundaryAdded, CoverageOpaqueGateExceeded]-    it "appends the six stable coverage and comparison registry codes" $-      map-        show-        [ CoverageOpaqueSurface,-          CoverageOpaqueBoundaryAdded,-          CoverageOpaqueGateExceeded,-          CodecCompareDifference,-          CodecCompareCoverageGap,-          CodecCompareInvalidInput-        ]-        `shouldBe` [ "CoverageOpaqueSurface",-                     "CoverageOpaqueBoundaryAdded",-                     "CoverageOpaqueGateExceeded",-                     "CodecCompareDifference",-                     "CodecCompareCoverageGap",-                     "CodecCompareInvalidInput"-                   ]--  describe "parse . pretty round-trip" $-    do-      it "re-parses any generated spec to an equal AST (modulo source locations)" $-        checkCoverage $-          forAll genSpec $ \s ->-            let families = map nodeTag (specNodes s)-                roundTrip = parseSpec "<gen>" (renderSpec s) === Right s-             in cover 5 (not (null (specMapped s))) "mapped" $-                  foldr (\family -> cover 1 (family `elem` families) family) roundTrip allNodeTags-      it "round-trips an aggregate with no states" $-        parseSpec "<empty-states>" (renderSpec emptyStatesSpec) `shouldBe` Right emptyStatesSpec-      it "separates transition emit clauses from following nodes" $ do-        spec <- parseInlineSpec "<cross-family-boundaries>" crossFamilyBoundarySpec-        case specNodes spec of-          [NAggregate first, NEmit _, NAggregate second, NPgmqDispatch _] -> do-            concatMap tEmits (aggTransitions first) `shouldBe` ["Changed"]-            aggStates second `shouldBe` []-          nodes -> expectationFailure ("unexpected node sequence: " <> show (map nodeTag nodes))--  describe "mapped types (EP-149)" $ do-    it "round-trips the canonical structural and opaque consumer fixture" $ do-      source <- TIO.readFile "test/fixtures/consumer-types.keiro"-      spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source-      parseStableRenderedSpec "<consumer-types-round-trip>" spec `shouldBe` Right spec-      length (specMapped spec) `shouldBe` 4-    it "preserves every missing-value policy, nested type expression, and unit union arm" $ do-      source <- TIO.readFile "test/fixtures/consumer-types.keiro"-      spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source-      let fields = [field | MappedStructural {msShape = ShapeRecord _ _ recordFields} <- specMapped spec, field <- recordFields]-          arms = [arm | MappedStructural {msShape = ShapeUnion _ unionArms} <- specMapped spec, arm <- unionArms]-      [value | field <- fields, Just value <- [wfOnMissing field]]-        `shouldBe` [OmCtor "Guide", OmNull, OmInt 0, OmBool False, OmEmptyList, OmEmptyMap]-      [wfType field | field <- fields, wfHaskell field == "labels"]-        `shouldBe` [TList (TOptional TText)]-      [waCtor arm | arm <- arms, waPayload arm == Nothing]-        `shouldBe` ["Unknown"]-    it "rejects every mapped validation fixture with its stable diagnostic code" $ do-      let cases =-            [ ("mapped-unresolved.keiro", MappedUnresolvedName),-              ("mapped-ambiguous.keiro", MappedAmbiguousName),-              ("mapped-dup-fieldname.keiro", MappedDuplicateFieldName),-              ("mapped-dup-wirekey.keiro", MappedDuplicateWireKey),-              ("mapped-dup-armname.keiro", MappedDuplicateArmName),-              ("mapped-dup-tag.keiro", MappedDuplicateWireTag),-              ("mapped-recursive.keiro", MappedRecursiveType),-              ("mapped-recursive-mutual.keiro", MappedRecursiveType),-              ("mapped-bad-encoding.keiro", MappedUnsupportedEncoding),-              ("mapped-union-key-collision.keiro", MappedUnsupportedEncoding),-              ("mapped-optional-json.keiro", MappedNonInjectiveNullability),-              ("mapped-optional-optional.keiro", MappedNonInjectiveNullability),-              ("mapped-optional-opaque.keiro", MappedNonInjectiveNullability),-              ("mapped-missing-binding.keiro", MappedMissingIngredient),-              ("mapped-missing-binding-version.keiro", MappedMissingIngredient),-              ("mapped-missing-canonical.keiro", MappedMissingIngredient),-              ("mapped-missing-fixture.keiro", MappedMissingIngredient),-              ("mapped-missing-initial.keiro", MappedMissingInitialValue),-              ("mapped-bad-haskell-name.keiro", MappedInvalidHaskellName),-              ("mapped-empty-identity.keiro", MappedInvalidIdentity),-              ("mapped-import-conflict.keiro", MappedImportConflict),-              ("mapped-illtyped-default.keiro", MappedDefaultIllTyped),-              ("mapped-guard.keiro", AggregateExpressionOperatorUnsupported)-            ]-      forM_ cases $ \(fixture, expected) ->-        errorCodesOf ("test/fixtures/" <> fixture) `shouldReturn` [expected]-    it "keeps Time and Natural in Keiki's curated comparison set" $ do-      errorCodesOf "test/fixtures/mapped-guard-time.keiro" `shouldReturn` []-      errorCodesOf "test/fixtures/mapped-guard-natural.keiro" `shouldReturn` []-    it "rejects required defaults, missing optional policies, Int overflow, and negative Natural defaults" $ do-      let invalidFields =-            [ WireField "requiredDefault" "requiredDefault" TText PRequired (Just (OmText "x")) noLoc,-              WireField "missingPolicy" "missingPolicy" TText POptional Nothing noLoc,-              WireField "overflow" "overflow" TInt POptional (Just (OmInt (toInteger (maxBound :: Int) + 1))) noLoc,-              WireField "negativeNatural" "negativeNatural" TNatural POptional (Just (OmInt (-1))) noLoc-            ]-          declaration = completeStructural "Defaults" (ShapeRecord "Defaults" RejectUnknown invalidFields)-      errorCodes (mappedSpec [declaration])-        `shouldBe` [MappedDefaultIllTyped, MappedMissingIngredient, MappedDefaultIllTyped, MappedDefaultIllTyped]--  describe "aggregate type capabilities" $ do-    it "enumerates the policy for every resolved type and use site" $ do-      let resolvedTypes =-            [ AggregateText,-              AggregateInt,-              AggregateBool,-              AggregateTime,-              AggregateNatural,-              AggregateNominal (ResolvedNominalType "EntityId" (IdRepresentation "ent") GeneratedNominal noLoc),-              AggregateNominal (ResolvedNominalType "Status" (EnumRepresentation (("Active", "active") :| [])) GeneratedNominal noLoc),-              AggregateNominal (ResolvedNominalType "Amount" (ScalarRepresentation NominalInt) (consumerNominalFor "Amount") noLoc),-              AggregateNominal (ResolvedNominalType "Label" (ScalarRepresentation NominalText) (consumerNominalFor "Label") noLoc),-              AggregateVertex "EntityVertex",-              AggregateMapped (MappedKey "ConsumerValue")-            ]-          useSites = [minBound .. maxBound]-          expected useSite resolvedType = case useSite of-            OrderingGuardUse -> case resolvedType of-              AggregateInt -> SolverVisible-              AggregateTime -> SolverVisible-              AggregateNatural -> SolverVisible-              AggregateNominal nominal -> case resolvedNominalRepresentation nominal of-                ScalarRepresentation NominalInt -> SolverVisible-                ScalarRepresentation NominalNatural -> SolverVisible-                ScalarRepresentation NominalTime -> SolverVisible-                _ -> Unsupported-              _ -> Unsupported-            EqualityGuardUse -> case resolvedType of-              AggregateMapped {} -> Unsupported-              AggregateNominal {} -> SolverVisible-              AggregateVertex {} -> OpaqueOnly-              _ -> SolverVisible-            _ -> case resolvedType of-              AggregateNominal nominal -> case resolvedNominalRepresentation nominal of-                ScalarRepresentation {} -> SolverVisible-                _ -> OpaqueOnly-              AggregateVertex {} -> OpaqueOnly-              AggregateMapped {} -> OpaqueOnly-              _ -> SolverVisible-          actual =-            [ (useSite, resolvedType, aggregateCapability useSite resolvedType)-            | useSite <- useSites,-              resolvedType <- resolvedTypes-            ]-          wanted =-            [ (useSite, resolvedType, expected useSite resolvedType)-            | useSite <- useSites,-              resolvedType <- resolvedTypes-            ]-      actual `shouldBe` wanted-    it "lowers direct Time and Natural through every generated aggregate boundary" $ do-      spec <- specOf "test/fixtures/aggregate-scalars.keiro"-      errorCodes spec `shouldBe` []-      let aggregate = onlyAggregate spec-          modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate-          generated =-            [ moduleText generatedModule-            | generatedModule <- modules,-              Keiro.Dsl.Scaffold.kind generatedModule == Generated-            ]-          domain = generatedTextEndingIn "Domain.hs" modules-          codec = generatedTextEndingIn "Codec.hs" modules-      domain `shouldSatisfy` T.isInfixOf "observedAt :: !UTCTime"-      domain `shouldSatisfy` T.isInfixOf "revision :: !Natural"-      domain `shouldSatisfy` T.isInfixOf "UTCTime (fromGregorian 2026 1 2) (picosecondsToDiffTime 11045123456789012)"-      domain `shouldSatisfy` T.isInfixOf "import Data.Time.Calendar (fromGregorian)"-      domain `shouldSatisfy` T.isInfixOf "import Data.Time.Clock (UTCTime (..), picosecondsToDiffTime)"-      domain `shouldSatisfy` T.isInfixOf "import Numeric.Natural (Natural)"-      manifestDependencies spec `shouldContain` ["time"]-      manifestDependencies spec `shouldNotContain` ["keiki-codec-json"]-      codec `shouldSatisfy` T.isInfixOf "scalarLedgerEventTypes :: NonEmpty EventType"-      codec `shouldSatisfy` T.isInfixOf "eventTypes = scalarLedgerEventTypes"-      codec `shouldSatisfy` T.isInfixOf "renderExpectedEventTypes scalarLedgerEventTypes"-      codec `shouldSatisfy` (not . T.isInfixOf "; expected one of: ScalarsRecorded\"")-      generated `shouldSatisfy` all (not . T.isInfixOf "error")-      generated `shouldSatisfy` all (not . T.isInfixOf "getCurrentTime")-      generated `shouldSatisfy` all (not . T.isInfixOf "iso8601ParseM")-    it "keeps the event-list binding disjoint from the private formatter" $ do-      source <- readTestText "test/fixtures/aggregate-scalars.keiro"-      spec <- parseInlineSpec "<render-aggregate>" (T.replace "aggregate ScalarLedger" "aggregate Render" source)-      let aggregate = onlyAggregate spec-          modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate-          codec = generatedTextEndingIn "Codec.hs" modules-          codecLines = T.lines codec-      codecLines `shouldContain` ["renderEventTypes :: NonEmpty EventType"]-      codecLines `shouldContain` ["renderExpectedEventTypes :: NonEmpty EventType -> String"]-      codec `shouldSatisfy` T.isInfixOf "eventTypes = renderEventTypes"-      codec `shouldSatisfy` T.isInfixOf "renderExpectedEventTypes renderEventTypes"-    it "canonicalizes Time and UTCTime across pretty, diff, and fold identity" $ do-      source <- readTestText "test/fixtures/aggregate-scalars.keiro"-      canonical <- parseInlineSpec "<time>" source-      alias <- parseInlineSpec "<utctime>" (T.replace ":Time" ":UTCTime" (T.replace " Time =" " UTCTime =" source))-      renderSpec alias `shouldBe` renderSpec canonical-      legacyDiffSpecs canonical alias `shouldBe` []-      legacyAggregateFoldFingerprint canonical (onlyAggregate canonical)-        `shouldBe` legacyAggregateFoldFingerprint alias (onlyAggregate alias)-      legacyAggregateFoldSurface canonical (onlyAggregate canonical)-        `shouldBe` legacyAggregateFoldSurface alias (onlyAggregate alias)-    it "keeps the committed scalar conformance generated tree fresh" $ do-      modules <- scaffoldFixture "test/fixtures/aggregate-scalars.keiro"-      forM_ [generatedModule | generatedModule <- modules, Keiro.Dsl.Scaffold.kind generatedModule == Generated] $ \generatedModule -> do-        committed <- readTestText ("test/conformance-aggregate-scalars/" <> modulePath generatedModule)-        normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText generatedModule)-    it "never sends a clean scalar aggregate to a type scaffold refusal" $-      property $-        forAll (elements scalarRegisterCases) $ \(typeName, initialValue) ->-          case parseSpec "<clean-scalar>" (cleanScalarAggregateSpec typeName initialValue) of-            Left parseError -> counterexample (T.unpack parseError) False-            Right spec ->-              let diagnostics = [diagnostic | diagnostic <- validateSpec spec, severity diagnostic == Error]-                  modules = scaffoldModules (defaultContext (specContext spec)) spec-               in counterexample-                    (show diagnostics <> "\n" <> show (scaffoldRefusals spec))-                    ( null diagnostics-                        && null (scaffoldRefusals spec)-                        && all (not . T.null . moduleText) modules-                    )--  describe "aggregate scalar diagnostics" $ do-    it "reports unsupported shapes, invalid initials, and mismatched guards at stable lines" $ do-      diagnostics <- diagnosticsOf "test/fixtures/aggregate-scalars-unsupported.keiro"-      [(code diagnostic, line diagnostic) | diagnostic <- diagnostics, severity diagnostic == Error]-        `shouldBe` [ (AggregateRegisterInitialInvalid, 6),-                     (AggregateRegisterInitialInvalid, 7),-                     (AggregateTypeUnsupportedAtUse, 10),-                     (AggregateExpressionOperandTypeMismatch, 14)-                   ]-      map message diagnostics `shouldSatisfy` any (T.isInfixOf "non-negative integral literals")-      map message diagnostics `shouldSatisfy` any (T.isInfixOf "ISO-8601 UTC timestamps")-      map message diagnostics `shouldSatisfy` any (T.isInfixOf "mapped structural declaration")-    it "accepts Natural aggregate arithmetic in the stable language" $ do-      diagnostics <- diagnosticsOf "test/fixtures/aggregate-scalars-arithmetic.keiro"-      [(code diagnostic, line diagnostic) | diagnostic <- diagnostics, severity diagnostic == Error]-        `shouldBe` []-    it "covers unknown, container, fractional, out-of-range, and ordering failures" $ do-      diagnostics <- diagnosticsOf "test/fixtures/aggregate-scalars-invalid-capabilities.keiro"-      [(code diagnostic, line diagnostic) | diagnostic <- diagnostics, severity diagnostic == Error]-        `shouldBe` [ (AggregateRegisterInitialInvalid, 6),-                     (AggregateRegisterInitialInvalid, 7),-                     (AggregateTypeUnknown, 10),-                     (AggregateTypeUnsupportedAtUse, 10),-                     (AggregateTypeUnsupportedAtUse, 10),-                     (AggregateTypeUnsupportedAtUse, 10),-                     (AggregateExpressionOperatorUnsupported, 13)-                   ]-    it "keeps one-member workspace diagnostics identical to the single file" $ do-      direct <- diagnosticsOf "test/fixtures/aggregate-scalars-unsupported.keiro"-      composed <- shouldComposeWorkspace "test/fixtures/aggregate-scalars-workspace/service.keiro-workspace"-      let directErrors =-            [(code diagnostic, line diagnostic, message diagnostic) | diagnostic <- direct, severity diagnostic == Error]-          workspaceErrors =-            [ (wdCode diagnostic, wlLine (NE.head (wdLocations diagnostic)), wdMessage diagnostic)-            | diagnostic <- checkWorkspace composed,-              wdSeverity diagnostic == Error-            ]-      workspaceErrors `shouldBe` directErrors--  describe "mapped type graph (EP-149)" $ do-    it "resolves checked declarations, transitive reachability, and every aggregate root path" $ do-      source <- TIO.readFile "test/fixtures/consumer-types.keiro"-      spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source-      graph <- shouldResolveTypeGraph spec-      Map.size (tgDeclarations graph) `shouldBe` 4-      Map.lookup (MappedKey "ArtifactInfo") (tgReachability graph)-        `shouldBe` Just (Set.fromList [MappedKey "ArtifactKind", MappedKey "ArtifactLocation"])-      map renderUsePath (usePaths graph "ArtifactLocation")-        `shouldBe` [ "Catalog command ObserveArtifact .artifact : ArtifactInfo .location : ArtifactLocation",-                     "Catalog event ArtifactObserved .artifact : ArtifactInfo .location : ArtifactLocation",-                     "Catalog register currentArtifact : ArtifactInfo .location : ArtifactLocation"-                   ]-    it "resolves every builtin through the complete expression algebra" $ do-      source <- TIO.readFile "test/fixtures/consumer-types.keiro"-      spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source-      graph <- shouldResolveTypeGraph spec-      case Map.lookup (MappedKey "ArtifactInfo") (tgDeclarations graph) of-        Just (ResolvedStructural _ (RRecord _ _ fields)) ->-          Set.fromList (concatMap (foldTypeExpr expressionTags . rwfType) fields)-            `shouldBe` Set.fromList ["text", "int", "bool", "natural", "time", "json", "optional", "list", "map", "ref:ArtifactKind", "ref:ArtifactLocation"]-        declaration -> expectationFailure ("unexpected ArtifactInfo declaration: " <> show declaration)-    it "rejects direct, mutual, wrapped, and union-arm recursion" $ do-      let direct = mappedSpec [completeStructural "A" (recordShape [TRef "A"])]-          mutual = mappedSpec [completeStructural "A" (recordShape [TRef "B"]), completeStructural "B" (recordShape [TRef "A"])]-          wrapped = mappedSpec [completeStructural "A" (recordShape [TList (TOptional (TRef "A"))])]-          throughArm = mappedSpec [completeStructural "A" (ShapeUnion (TaggedObject "tag" "contents" RejectUnknown) [WireArm "Again" "again" (Just (TRef "A")) noLoc])]-      map (hasTypeGraphError isRecursive . resolveTypeGraph) [direct, mutual, wrapped, throughArm]-        `shouldBe` replicate 4 True-    it "keeps existing ids and enums outside the mapped-reference namespace" $ do-      let spec =-            (mappedSpec [completeStructural "A" (recordShape [TRef "ExistingId"])])-              { specIds = [IdDecl "ExistingId" "id" Nothing noLoc]-              }-      resolveTypeGraph spec `shouldSatisfy` hasTypeGraphError isUnresolved-    it "fingerprints wire identity while ignoring Haskell selector names" $ do-      source <- TIO.readFile "test/fixtures/consumer-types.keiro"-      base <- parseInlineSpec "test/fixtures/consumer-types.keiro" source-      baseGraph <- shouldResolveTypeGraph base-      haskellRenameGraph <- shouldResolveTypeGraph (mapArtifactField (\field -> field {wfHaskell = "renamedKey"}) base)-      wireRenameGraph <- shouldResolveTypeGraph (mapArtifactField (\field -> field {wfKey = "renamed_key"}) base)-      wireFingerprint haskellRenameGraph "ArtifactInfo" `shouldBe` wireFingerprint baseGraph "ArtifactInfo"-      wireFingerprint wireRenameGraph "ArtifactInfo" `shouldNotBe` wireFingerprint baseGraph "ArtifactInfo"--  describe "string literal integrity" $ do-    it "parses an escaped emit-map value as exactly one row" $ do-      let src =-            T.unlines-              [ "context svc",-                "",-                "emit e {",-                "  contract c",-                "  topic events",-                "  source \"svc\"",-                "  key thingId",-                "  map status {",-                "    \"a\\\" => Wat \\\"b\" => ThingAccepted",-                "    _ => skip",-                "  }",-                "  messageId derive hole",-                "  idempotencyKey derive hole",-                "}"-              ]-      case parseSpec "<escaped-map>" src of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> case [row | NEmit e <- specNodes spec, row <- emMap e] of-          [row] -> do-            emrValue row `shouldBe` "a\" => Wat \"b"-            emrEvent row `shouldBe` "ThingAccepted"-          rows -> expectationFailure ("expected one emit-map row, got " <> show (length rows))-    it "rejects a raw newline inside a quoted string" $ do-      let src = "context svc\n\ncontract c {\n  schemaVersion 1\n  discriminator kind\n  topic events \"first\nsecond\"\n}\n"-      parseSpec "<raw-newline>" src `shouldSatisfy` leftContains "unescaped newline"-    it "rejects an unknown escape sequence" $ do-      let src = "context svc\n\ncontract c {\n  schemaVersion 1\n  discriminator kind\n  topic events \"bad\\q\"\n}\n"-      parseSpec "<unknown-escape>" src `shouldSatisfy` leftContains "unknown escape"-    it "round-trips adversarial text through topics, emit maps, and quoted bindings" $-      property $-        forAll genAdversarialText $ \t ->-          let spec = escapedSpec t-              rendered = renderSpec spec-           in counterexample (T.unpack rendered) (parseSpec "<escaped-round-trip>" rendered === Right spec)--  describe "partial status maps" $ do-    it "suppresses totality only when the partial marker is present" $ do-      partial <- parseInlineSpec "<partial-status-map>" (statusMapSpec " partial")-      totalSpec <- parseInlineSpec "<total-status-map>" (statusMapSpec "")-      map code (validateSpec partial) `shouldNotContain` [StatusMapNotTotal]-      map code (validateSpec totalSpec) `shouldContain` [StatusMapNotTotal]-      parseSpec "<partial-round-trip>" (renderSpec partial) `shouldBe` Right partial--  describe "positioned parser diagnostics" $ do-    it "rejects a duplicate goto at the second clause" $ do-      err <- parseErrorOf "<duplicate-goto>" duplicateGotoSpec-      err `shouldSatisfy` T.isInfixOf "duplicate goto"-      err `shouldSatisfy` T.isInfixOf "<duplicate-goto>:10:"-    it "rejects duplicate wire and projection blocks at their second occurrences" $ do-      wireErr <- parseErrorOf "<duplicate-wire>" duplicateWireSpec-      wireErr `shouldSatisfy` T.isInfixOf "duplicate wire block"-      wireErr `shouldSatisfy` T.isInfixOf "<duplicate-wire>:8:"-      projectionErr <- parseErrorOf "<duplicate-projection>" duplicateProjectionSpec-      projectionErr `shouldSatisfy` T.isInfixOf "duplicate projection block"-      projectionErr `shouldSatisfy` T.isInfixOf "<duplicate-projection>:9:"-    it "anchors a missing goto on the transition line" $ do-      err <- parseErrorOf "<missing-goto>" missingGotoSpec-      err `shouldSatisfy` T.isInfixOf "missing a goto clause"-      err `shouldSatisfy` T.isInfixOf "<missing-goto>:8:"-    it "stops before a misplaced dispatch-id and expects schedule at its start" $ do-      let src = misplacedDispatchIdSpec-          expectedPosition =-            "<misplaced-dispatch-id>:"-              <> T.pack (show (lineNumberContaining "dispatch-id" src))-              <> ":5:"-      err <- parseErrorOf "<misplaced-dispatch-id>" src-      err `shouldSatisfy` T.isInfixOf "schedule"-      err `shouldSatisfy` T.isInfixOf expectedPosition-    it "keeps a malformed register declaration's equals error" $ do-      err <- parseErrorOf "<malformed-register>" malformedRegisterSpec-      err `shouldSatisfy` T.isInfixOf "expecting '='"--  describe "bounded decimal literals" $ do-    forM_ decimalOverflowSpecs $ \(site, src) ->-      it ("rejects overflow at " <> site) $ do-        err <- parseErrorOf ("<overflow-" <> site <> ">") src-        err `shouldSatisfy` T.isInfixOf ("decimal literal " <> decimalOverflow <> " is out of range")-    it "accepts maxBound without changing its value" $ do-      spec <- parseInlineSpec "<max-bound>" (wireDecimalSpec (T.pack (show (maxBound :: Int))))-      [wireSchemaVersion wire | NAggregate aggregate <- specNodes spec, Just wire <- [aggWire aggregate]]-        `shouldBe` [maxBound]--  describe "identifier hygiene" $ do-    it "normalizes lowercase logical type names and reports generated Haskell keywords at their owning declarations" $ do-      spec <- parseInlineSpec "<identifier-hygiene>" identifierHygieneSpec-      [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic `elem` [IdentUnsafeNormalization, GeneratedOccurrenceReserved]]-        `shouldBe` [(GeneratedOccurrenceReserved, 7)]-    it "rejects generated vertex constructors that collide with event constructors" $ do-      spec <- parseInlineSpec "<vertex-collision>" vertexCollisionSpec-      [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == VertexCtorCollision]-        `shouldBe` [(VertexCtorCollision, 3)]-    it "rejects underscore-leading names whose normalization would erase a word boundary" $ do-      spec <- parseInlineSpec "<underscore-node>" underscoreNodeSpec-      [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == IdentUnsafeNormalization]-        `shouldBe` [(IdentUnsafeNormalization, 3)]-    it "rejects normalized module collisions with both source locations" $ do-      spec <- parseInlineSpec "<normalized-collision>" normalizedCollisionSpec-      case [diagnostic | diagnostic <- validateSpec spec, code diagnostic == GeneratedOccurrenceCollision] of-        [diagnostic] -> do-          line diagnostic `shouldBe` 8-          relatedLocations diagnostic `shouldBe` [(3, "'fooBar' also normalizes here")]-          renderDiagnostic "<normalized-collision>" diagnostic `shouldSatisfy` T.isInfixOf "fooBar"-        diagnostics -> expectationFailure ("expected one normalized collision, got " <> show diagnostics)-    it "validates explicit selectors and detects selector collisions in aggregate and contract records" $ do-      service <--        checkedServiceFromText-          "<field-selector-validation>"-          ( T.unlines-              [ "language keiro-dsl 4",-                "context aliases",-                "aggregate Order",-                "  regs",-                "  states Open",-                "  command Change {",-                "    first haskell shared:Text",-                "    second haskell shared:Text",-                "    reserved haskell type:Text",-                "    invalid haskell Bad:Text",-                "  }",-                "contract publicOrder {",-                "  schemaVersion 1",-                "  discriminator kind",-                "  topic changes \"orders.v1\"",-                "  event Changed on changes {",-                "    first haskell duplicate: text",-                "    second haskell duplicate: text",-                "  }",-                "}"-              ]-          )-      let diagnostics = validateService service-          selectorCollisions = [diagnostic | diagnostic <- diagnostics, code diagnostic == GeneratedOccurrenceCollision]-      [(code diagnostic, line diagnostic) | diagnostic <- diagnostics, code diagnostic `elem` [GeneratedOccurrenceReserved, IdentUnsafeNormalization]]-        `shouldBe` [(GeneratedOccurrenceReserved, 9), (IdentUnsafeNormalization, 10)]-      map line selectorCollisions `shouldBe` [8, 18]-      map relatedLocations selectorCollisions-        `shouldBe` [ [(7, "'first' also normalizes here")],-                     [(17, "'first' also normalizes here")]-                   ]-    it "rejects empty, duplicate, and envelope-colliding resolved wire keys with field-local evidence" $ do-      service <--        checkedServiceFromText-          "<field-wire-validation>"-          ( T.unlines-              [ "language keiro-dsl 4",-                "context aliases",-                "aggregate Order",-                "  regs",-                "  states Open",-                "  command Change {",-                "    first as \"same\":Text",-                "    second as \"same\":Text",-                "    empty as \"\":Text",-                "  }",-                "  event Changed { value as \"kind\":Text }",-                "contract publicOrder {",-                "  schemaVersion 1",-                "  discriminator kind",-                "  topic changes \"orders.v1\"",-                "  event Published on changes { value as \"kind\": text }",-                "}"-              ]-          )-      let diagnostics = validateService service-          wireDiagnostics = [diagnostic | diagnostic <- diagnostics, code diagnostic `elem` [FieldWireKeyCollision, FieldWireKeyInvalid]]-      map (\diagnostic -> (code diagnostic, line diagnostic)) wireDiagnostics-        `shouldBe` [ (FieldWireKeyCollision, 8),-                     (FieldWireKeyInvalid, 9),-                     (FieldWireKeyCollision, 11),-                     (FieldWireKeyCollision, 16)-                   ]-      case wireDiagnostics of-        firstDiagnostic : _ -> relatedLocations firstDiagnostic `shouldBe` [(7, "wire key 'same' is first declared here")]-        [] -> expectationFailure "expected resolved wire-key diagnostics"-    -- `family` is a contextual keyword GHC accepts as a term under the-    -- advertised GHC2024 contract, and it is the field mori's project signals-    -- are keyed by. This fixture pins that scenario end to end; before ExecPlan-    -- 199 no test referenced it, so the guarantee was untested.-    it "keeps a reserved-word-adjacent contract field intact from check to codec" $-      withTempDirectory "keiro-dsl-reserved-family" $ \out -> do-        let fixture = "test/fixtures/contract-reserved-family.keiro"-        (checkCode, checkOut, checkErr) <- runKeiroDsl ["check", fixture, "--min-language", "4", "--deny-warnings"]-        unless (checkCode == ExitSuccess) (expectationFailure (checkOut <> checkErr))-        checkOut `shouldBe` "OK\n"-        checkErr `shouldNotContain` "warning["--        (scaffoldCode, scaffoldOut, scaffoldErr) <- runKeiroDsl ["scaffold", fixture, "--out", out]-        unless (scaffoldCode == ExitSuccess) (expectationFailure (scaffoldOut <> scaffoldErr))-        tree <- treeSnapshot out-        case [text | (path, text) <- tree, "Contract.hs" `T.isSuffixOf` T.pack path] of-          codec : _ -> do-            -- The DSL name is the record selector …-            codec `shouldSatisfy` T.isInfixOf "family ::"-            -- … and, unaliased, the wire key is the same bytes.-            codec `shouldSatisfy` T.isInfixOf "\"family\""-            codec `shouldNotSatisfy` T.isInfixOf "family_"-          [] -> expectationFailure ("no generated contract module in " <> show (map fst tree))--    -- An alias exists to preserve a brownfield key the current convention would-    -- reject, so its *style* is deliberately not checked (ADR 0021). What is-    -- checked is that the key can be a key: a trailing space or a control-    -- character ships a permanently mis-keyed public field. See ExecPlan 199.-    it "refuses structurally unusable wire-key aliases without opinionating on style" $ do-      let aliasSpec alias =-            T.unlines-              [ "language keiro-dsl 4",-                "context aliases",-                "aggregate Order",-                "  regs",-                "  states Open",-                "  command Change {",-                "    region as \"" <> alias <> "\":Text",-                "  }"-              ]-          keyDiagnostics source = do-            service <- checkedServiceFromText "<alias-content>" source-            pure [diagnostic | diagnostic <- validateService service, code diagnostic == FieldWireKeyInvalid]--      -- Refused: the wire key is the exact bytes on the wire. Written as the-      -- DSL spells them, so `\\n` here is the source's escape, not Haskell's.-      forM_ ["family ", " family", "family\\n", "fam\\tily", "fam\\rily"] $ \bad -> do-        refused <- keyDiagnostics (aliasSpec bad)-        map code refused `shouldBe` [FieldWireKeyInvalid]-        map line refused `shouldBe` [7]--      -- Accepted: these violate `fields=camelCase` and that is exactly the point-      -- of an alias — the brownfield key is preserved, not corrected.-      forM_ ["region_code", "Region-Code", "REGION.CODE", "r\233gion"] $ \brownfield -> do-        accepted <- keyDiagnostics (aliasSpec brownfield)-        accepted `shouldBe` []--    -- The collision planner must register the selector generation actually-    -- emits. Registering a camelized rendering of the raw name made it claim-    -- `foo_bar` "normalizes to" `fooBar`, which generation never does.-    it "plans field collisions against the emitted selector, not a camelized rendering" $ do-      let recordSpec fields =-            T.unlines-              [ "language keiro-dsl 4",-                "context aliases",-                "aggregate Order",-                "  regs",-                "  states Open",-                "  command Change { " <> fields <> " }"-              ]-          collisionsIn source = do-            service <- checkedServiceFromText "<selector-collision>" source-            pure [diagnostic | diagnostic <- validateService service, code diagnostic == GeneratedOccurrenceCollision]--      -- Distinct emitted selectors: `foo_bar` generates `foo_bar`. It is still-      -- refused, but by the generated-name audit that owns lowerCamelCase — not-      -- by a collision claim naming an unrelated sibling.-      falseCollision <- collisionsIn (recordSpec "foo_bar fooBar")-      falseCollision `shouldBe` []--      -- Two declarations that really do emit one selector still collide.-      realCollision <- collisionsIn (recordSpec "fooBar other haskell fooBar")-      map code realCollision `shouldSatisfy` \codes -> GeneratedOccurrenceCollision `elem` codes--    it "checks copied command selectors in both generated record scopes" $ do-      service <--        checkedServiceFromText-          "<copied-selector-collision>"-          ( T.unlines-              [ "language keiro-dsl 4",-                "context aliases",-                "aggregate Order",-                "  regs",-                "  states Open",-                "  command Change { first haskell shared:Text second haskell shared:Text }",-                "  event Changed = fields(Change)"-              ]-          )-      [line diagnostic | diagnostic <- validateService service, code diagnostic == GeneratedOccurrenceCollision]-        `shouldBe` [6, 6]-    it "anchors repeated reserved contract fields at their own lines and maps them through workspaces" $ do-      service <--        checkedServiceFromText-          "domain/member.keiro"-          ( T.unlines-              [ "language keiro-dsl 4",-                "context aliases",-                "contract publicOrder {",-                "  schemaVersion 1",-                "  discriminator kind",-                "  topic changes \"orders.v1\"",-                "  event First on changes { where: text }",-                "  event Second on changes { where: text }",-                "}"-              ]-          )-      [line diagnostic | diagnostic <- validateService service, code diagnostic == GeneratedOccurrenceReserved]-        `shouldBe` [7, 8]-      let workspaceDiagnostics =-            [ diagnostic-            | diagnostic <- checkWorkspace (oneMemberWorkspace "domain/member.keiro" (checkedSpec service)),-              wdCode diagnostic == GeneratedOccurrenceReserved-            ]-          workspaceLocations =-            [ (wlFile location, wlLine location)-            | diagnostic <- workspaceDiagnostics,-              location <- NE.toList (wdLocations diagnostic)-            ]-      workspaceLocations-        `shouldBe` [ (WorkspaceMemberFile "member.keiro", 7),-                     (WorkspaceMemberFile "member.keiro", 8)-                   ]-    it "rejects non-ASCII identifier characters in the parser" $-      parseSpec "<unicode-identifier>" unicodeIdentifierSpec `shouldSatisfy` leftContains "unexpected"--  describe "Haskell.name-audit" $ do-    it "inventories every declaration in a fresh compound-name scaffold" $ do-      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"-      let service = legacyCheckedService spec-          ctx = defaultContext (specContext spec)-          modules = scaffoldServiceModules ctx service-      concatMap auditGeneratedHaskell modules `shouldBe` []-    it "rejects underscore module and declaration mutations but ignores literals and comments" $ do-      let mutated =-            ScaffoldModule-              { modulePath = "Generated/IncidentPaging/Service_oncall/Mutation.hs",-                moduleText =-                  T.unlines-                    [ "module Generated.IncidentPaging.Service_oncall.Mutation where",-                      "-- comment_value :: Text",-                      "literalValue = \"string_value\"",-                      "render_eventTypes :: Int",-                      "render_eventTypes = 1"-                    ],-                kind = Generated,-                origin = "test name-audit mutation"-              }-          violations = auditGeneratedHaskell mutated-      violations `shouldSatisfy` any (T.isInfixOf "Service_oncall")-      violations `shouldSatisfy` any (T.isInfixOf "render_eventTypes")-      violations `shouldSatisfy` all (not . T.isInfixOf "comment_value")-      violations `shouldSatisfy` all (not . T.isInfixOf "string_value")-    it "rejects repeated generated signatures before writing" $ do-      let mutated =-            ScaffoldModule-              { modulePath = "Generated/Repeated.hs",-                moduleText =-                  T.unlines-                    [ "module Generated.Repeated where",-                      "sameValue :: Bool",-                      "sameValue = True",-                      "sameValue :: Bool",-                      "sameValue = False"-                    ],-                kind = Generated,-                origin = "test repeated declaration"-              }-      auditGeneratedHaskell mutated `shouldSatisfy` any (T.isInfixOf "repeated top-level type signature 'sameValue'")--  describe "Haskell.name-migration" $ do-    it "pairs a legacy module path with its stable idiomatic artifact" $ do-      let currentModule =-            ScaffoldModule-              { modulePath = "Generated/IncidentPaging/ServiceOncall/ReadModel.hs",-                moduleText = "module Generated.IncidentPaging.ServiceOncall.ReadModel where\n",-                kind = Generated,-                origin = "readmodel service_oncall ReadModel"-              }-      planSourceMoves [(Nothing, Generated, "Generated/IncidentPaging/Service_oncall/ReadModel.hs")] [currentModule]-        `shouldBe` Right-          [ SourceMove-              { moveRole = moduleRole currentModule,-                moveKind = Generated,-                moveOldModule = "Generated.IncidentPaging.Service_oncall.ReadModel",-                moveNewModule = "Generated.IncidentPaging.ServiceOncall.ReadModel",-                moveOldPath = "Generated/IncidentPaging/Service_oncall/ReadModel.hs",-                moveNewPath = "Generated/IncidentPaging/ServiceOncall/ReadModel.hs",-                moveBackupPath = ".keiro-dsl-name-migrations/legacy-v1-to-idiomatic-v1/Generated/IncidentPaging/Service_oncall/ReadModel.hs",-                moveContentDigest = Nothing,-                moveTransformedDigest = Nothing-              }-          ]-    it "rewrites code-token module references while preserving comments and literals" $ do-      let old = "Generated.IncidentPaging.Service_oncall.ReadModel"-          new = "Generated.IncidentPaging.ServiceOncall.ReadModel"-          source =-            T.unlines-              [ "module IncidentPaging.Service_oncall.ReadModelHoles where",-                "import Generated.IncidentPaging.Service_oncall.ReadModel",-                "value = Generated.IncidentPaging.Service_oncall.ReadModel.constructor",-                "-- Generated.IncidentPaging.Service_oncall.ReadModel in a comment",-                "literal = \"Generated.IncidentPaging.Service_oncall.ReadModel\"",-                "character = 'x'",-                "{- outer {- Generated.IncidentPaging.Service_oncall.ReadModel -} comment -}"-              ]-      case rewriteHaskellModuleReferences (Map.singleton old new) source of-        Left err -> expectationFailure (show err)-        Right rewritten -> do-          rewritten `shouldSatisfy` T.isInfixOf "import Generated.IncidentPaging.ServiceOncall.ReadModel"-          rewritten `shouldSatisfy` T.isInfixOf "value = Generated.IncidentPaging.ServiceOncall.ReadModel.constructor"-          rewritten `shouldSatisfy` T.isInfixOf "-- Generated.IncidentPaging.Service_oncall.ReadModel in a comment"-          rewritten `shouldSatisfy` T.isInfixOf "literal = \"Generated.IncidentPaging.Service_oncall.ReadModel\""-          rewritten `shouldSatisfy` T.isInfixOf "{- outer {- Generated.IncidentPaging.Service_oncall.ReadModel -} comment -}"-    it "refuses without mutation, then applies recoverable generated and hole moves" $-      withTempDirectory "keiro-dsl-name-migration" $ \out -> do-        spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"-        let service = legacyCheckedService spec-            ctx = defaultContext (specContext spec)-        modules <- case planServiceScaffold ctx service of-          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"-          Right planned -> pure planned-        let selected =-              [ scaffoldModule-              | scaffoldModule <- modules,-                any (`T.isSuffixOf` T.pack (modulePath scaffoldModule)) ["ServiceOncall/ReadModel.hs", "ServiceOncall/ReadModelHoles.hs"]-              ]-            legacyPath = T.unpack . T.replace "ServiceOncall" "Service_oncall" . T.pack-            reverseModules =-              Map.fromList-                [ (moduleNameFromPath (modulePath scaffoldModule), moduleNameFromPath (legacyPath (modulePath scaffoldModule)))-                | scaffoldModule <- selected-                ]-        forM_ selected $ \scaffoldModule -> do-          legacyText <- case rewriteHaskellModuleReferences reverseModules (moduleText scaffoldModule) of-            Left err -> expectationFailure (show err) >> fail "unreachable"-            Right source -> pure source-          let oldPath = out </> legacyPath (modulePath scaffoldModule)-              withEvidence-                | kind scaffoldModule == HoleStub =-                    legacyText-                      <> "\n-- Generated.IncidentPaging.Service_oncall.ReadModel remains in this comment\n"-                      <> "migrationLiteral = \"Generated.IncidentPaging.Service_oncall.ReadModel\"\n"-                | otherwise = legacyText-          createDirectoryIfMissing True (takeDirectory oldPath)-          TIO.writeFile oldPath withEvidence-        let legacyRecord =-              ScaffoldRecord-                { recSpecPath = "incident-paging.keiro",-                  recModuleRoot = "",-                  recLayout = "prefixed",-                  recSourceLanguage = LegacyUnversioned,-                  recLanguageContract = effectiveLanguageContract LegacyUnversioned,-                  recNamingEdition = LegacyNamingV1,-                  recModuleRoles = [],-                  recFiles = [(kind scaffoldModule, legacyPath (modulePath scaffoldModule)) | scaffoldModule <- selected],-                  recMappings = [],-                  recIdDomains = [],-                  recNominalEqualities = [],-                  recBindingObligations = [],-                  recBehaviorRequirements = []-                }-            recordPath = out </> recordFileName (specContext spec)-        TIO.writeFile recordPath (renderRecord legacyRecord)-        beforeMigration <- treeSnapshot out-        refused <- executeServiceScaffoldWithRuntimePackageAndNameMigrations Nothing False out False "incident-paging.keiro" LegacyUnversioned ctx service modules-        refused `shouldSatisfy` \case-          Left [NameMigrationRequired moves] ->-            length moves == 2-              && all ((/= Nothing) . moveContentDigest) moves-              && all ((/= Nothing) . moveTransformedDigest) moves-          _ -> False-        treeSnapshot out `shouldReturn` beforeMigration-        applied <- executeServiceScaffoldWithRuntimePackageAndNameMigrations Nothing True out False "incident-paging.keiro" LegacyUnversioned ctx service modules-        report <- case applied of-          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"-          Right value -> pure value-        length (reportNameMoves report) `shouldBe` 2-        let newHole = out </> "IncidentPaging/ServiceOncall/ReadModelHoles.hs"-            oldHole = out </> "IncidentPaging/Service_oncall/ReadModelHoles.hs"-            backupHole = out </> ".keiro-dsl-name-migrations/legacy-v1-to-idiomatic-v1/IncidentPaging/Service_oncall/ReadModelHoles.hs"-        doesFileExist oldHole `shouldReturn` False-        doesFileExist newHole `shouldReturn` True-        doesFileExist backupHole `shouldReturn` True-        migratedHole <- TIO.readFile newHole-        migratedHole `shouldSatisfy` T.isInfixOf "module IncidentPaging.ServiceOncall.ReadModelHoles"-        migratedHole `shouldSatisfy` T.isInfixOf "-- Generated.IncidentPaging.Service_oncall.ReadModel remains in this comment"-        migratedHole `shouldSatisfy` T.isInfixOf "migrationLiteral = \"Generated.IncidentPaging.Service_oncall.ReadModel\""-        backupBefore <- TIO.readFile backupHole-        rerun <- executeServiceScaffoldWithRuntimePackageAndNameMigrations Nothing True out False "incident-paging.keiro" LegacyUnversioned ctx service modules-        case rerun of-          Left refusals -> expectationFailure (show refusals)-          Right rerunReport -> reportNameMoves rerunReport `shouldBe` []-        TIO.readFile backupHole `shouldReturn` backupBefore-        -- Recreate the exact crash state after every backup and prepared file-        -- exists but before any destination is installed. A corrupted prepared-        -- file refuses; restoring its digest lets the next run resume.-        preparedSnapshots <- forM selected $ \scaffoldModule -> do-          let newPath = out </> modulePath scaffoldModule-              preparedPath = newPath <> ".keiro-dsl-name-migration-prepared"-          bytes <- TIO.readFile newPath-          renameFile newPath preparedPath-          pure (preparedPath, bytes)-        TIO.writeFile recordPath (renderRecord legacyRecord)-        case preparedSnapshots of-          (firstPrepared, firstBytes) : _ -> TIO.writeFile firstPrepared (firstBytes <> "\ncorrupt")-          [] -> expectationFailure "expected prepared migration sources"-        conflicted <- executeServiceScaffoldWithRuntimePackageAndNameMigrations Nothing True out False "incident-paging.keiro" LegacyUnversioned ctx service modules-        conflicted `shouldSatisfy` \case Left [NameMigrationRefusal messages] -> any (T.isInfixOf "prepared source digest") messages; _ -> False-        forM_ preparedSnapshots (uncurry TIO.writeFile)-        resumed <- executeServiceScaffoldWithRuntimePackageAndNameMigrations Nothing True out False "incident-paging.keiro" LegacyUnversioned ctx service modules-        case resumed of-          Left refusals -> expectationFailure (show refusals)-          Right resumedReport -> length (reportNameMoves resumedReport) `shouldBe` 2-        doesFileExist newHole `shouldReturn` True-        TIO.readFile backupHole `shouldReturn` backupBefore-    it "applies the same move protocol to a two-member workspace without changing ownership" $-      withTempDirectory "keiro-dsl-workspace-name-migration" $ \out -> do-        workspace <- shouldComposeWorkspace canonicalWorkspacePath-        plan <- shouldPlanWorkspaceSpec workspace-        initial <- executeWorkspaceScaffold out False plan-        case initial of-          Left refusals -> expectationFailure (show refusals)-          Right _ -> pure ()-        let recordPath = out </> workspaceRecordFileName (wsService workspace)-        currentRecord <--          TIO.readFile recordPath >>= \contents ->-            maybe (expectationFailure "fresh workspace record did not parse" >> fail "unreachable") pure (parseWorkspaceRecord contents)-        let selectedRows = [row | row <- wrModules currentRecord, "ProjectActivity" `T.isInfixOf` T.pack (wrmPath row)]-            legacyPath = T.unpack . T.replace "ProjectActivity" "Project_activity" . T.pack-            reverseModules =-              Map.fromList-                [ (moduleNameFromPath (wrmPath row), moduleNameFromPath (legacyPath (wrmPath row)))-                | row <- selectedRows-                ]-        selectedRows `shouldSatisfy` (not . null)-        forM_ selectedRows $ \row -> do-          currentSource <- TIO.readFile (out </> wrmPath row)-          legacySource <- case rewriteHaskellModuleReferences reverseModules currentSource of-            Left err -> expectationFailure (show err) >> fail "unreachable"-            Right source -> pure source-          writeFileWithParents (out </> legacyPath (wrmPath row)) legacySource-          removeFile (out </> wrmPath row)-        let legacyRecord =-              currentRecord-                { wrNamingEdition = LegacyNamingV1,-                  wrModules =-                    [ if row `elem` selectedRows then row {wrmPath = legacyPath (wrmPath row)} else row-                    | row <- wrModules currentRecord-                    ]-                }-            ownersBefore = Map.fromList [(wrmRole row, wrmOwner row) | row <- selectedRows]-        TIO.writeFile recordPath (renderWorkspaceRecord legacyRecord)-        beforeMigration <- treeSnapshot out-        refused <- executeWorkspaceScaffoldWithNameMigrations out False False plan-        refused `shouldSatisfy` \case Left [NameMigrationRequired moves] -> length moves == length selectedRows; _ -> False-        treeSnapshot out `shouldReturn` beforeMigration-        applied <- executeWorkspaceScaffoldWithNameMigrations out False True plan-        report <- case applied of-          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"-          Right value -> pure value-        length (wsrNameMoves report) `shouldBe` length selectedRows-        migratedRecord <--          TIO.readFile recordPath >>= \contents ->-            maybe (expectationFailure "migrated workspace record did not parse" >> fail "unreachable") pure (parseWorkspaceRecord contents)-        wrNamingEdition migratedRecord `shouldBe` IdiomaticNamingV1-        let migratedRows = [row | row <- wrModules migratedRecord, wrmRole row `Map.member` ownersBefore]-        Map.fromList [(wrmRole row, wrmOwner row) | row <- migratedRows] `shouldBe` ownersBefore-        map wrmPath migratedRows `shouldSatisfy` all (not . T.isInfixOf "Project_activity" . T.pack)-        forM_ selectedRows $ \row -> do-          doesFileExist (out </> legacyPath (wrmPath row)) `shouldReturn` False-          doesFileExist (out </> wrmPath row) `shouldReturn` True-          doesFileExist (out </> ".keiro-dsl-name-migrations/legacy-v1-to-idiomatic-v1" </> legacyPath (wrmPath row)) `shouldReturn` True--  describe "sidecar migration (EP-198)" $ do-    it "refuses old context names, applies lossless moves, preserves stale history, and is idempotent" $-      withTempDirectory "keiro-dsl-sidecar-migration" $ \base -> do-        parsed <- parsedSourceOf "test/fixtures/reservation.keiro"-        let service = checkedSource parsed-            spec = checkedSpec service-            ctx = defaultContext (specContext spec)-            sourceLanguage = parsedSourceLanguage parsed-            plain = base </> "plain"-            migrated = base </> "migrated"-            runAt out apply specPath selected =-              executeServiceScaffoldWithRuntimePackageAndNameMigrations-                Nothing-                apply-                out-                False-                specPath-                sourceLanguage-                ctx-                service-                selected-        modules <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planServiceScaffold ctx service)-        _ <- runAt plain False "reservation.keiro" modules >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure-        _ <- runAt migrated False "reservation.keiro" modules >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure-        let reduced = drop 1 modules-            currentLedger = contextLedgerFileName (specContext spec)-            currentFragment = contextCabalFragmentFileName (specContext spec)-            oldLedger = legacyContextRecordFileName (specContext spec)-            oldFragment = legacyContextManifestFileName (specContext spec)-        renameFile (migrated </> currentLedger) (migrated </> oldLedger)-        renameFile (migrated </> currentFragment) (migrated </> oldFragment)-        treeBefore <- treeSnapshot migrated-        refused <- runAt migrated False "reservation-reduced.keiro" reduced-        refused `shouldSatisfy` \case-          Left [SidecarMigrationRequired moves] ->-            length moves == 2-              && all ((== RenameSidecar) . sidecarMoveDisposition) moves-          _ -> False-        renderRefusals (either id (const []) refused)-          `shouldSatisfy` any (T.isInfixOf "--apply-name-migrations")-        treeSnapshot migrated `shouldReturn` treeBefore--        baseline <- runAt plain False "reservation-reduced.keiro" reduced >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure-        applied <- runAt migrated True "reservation-reduced.keiro" reduced >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure-        map sidecarMoveDisposition (reportSidecarMoves applied) `shouldBe` [RenameSidecar, RenameSidecar]-        reportStale applied `shouldBe` reportStale baseline-        reportPreviousSpecPath applied `shouldBe` Just "reservation.keiro"-        doesFileExist (migrated </> oldLedger) `shouldReturn` False-        doesFileExist (migrated </> oldFragment) `shouldReturn` False-        doesFileExist (migrated </> currentLedger) `shouldReturn` True-        doesFileExist (migrated </> currentFragment) `shouldReturn` True--        rerun <- runAt migrated True "reservation-reduced.keiro" reduced >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure-        reportSidecarMoves rerun `shouldBe` []--        let duplicateBytes = "legacy duplicate cabal fragment\n"-            backup = migrated </> ".keiro-dsl-name-migrations/sidecar-v1" </> oldFragment-        TIO.writeFile (migrated </> oldFragment) duplicateBytes-        duplicateRefusal <- runAt migrated False "reservation-reduced.keiro" reduced-        duplicateRefusal `shouldSatisfy` \case-          Left [SidecarMigrationRequired [move]] -> sidecarMoveDisposition move == RetireLegacySidecar-          _ -> False-        retired <- runAt migrated True "reservation-reduced.keiro" reduced >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure-        map sidecarMoveDisposition (reportSidecarMoves retired) `shouldBe` [RetireLegacySidecar]-        doesFileExist (migrated </> oldFragment) `shouldReturn` False-        TIO.readFile backup `shouldReturn` duplicateBytes--  describe "Haskell.name-diff" $ do-    it "classifies a workqueue payload type rename only on consumer-build" $ do-      base <- specOf "test/fixtures/reservation-work.keiro"-      let renamed = mapWorkqueue (\queue -> queue {wqPayloadName = "ReservationJob"}) base-          findings = generatedHaskellNameFindings (diffSpecs base renamed)-      case findings of-        [finding] -> assertGeneratedHaskellNameFinding finding-        values -> expectationFailure ("expected one payload-name finding, got " <> show (length values))-      let workspaceFindings =-            generatedHaskellNameFindings-              (map wcChange (diffWorkspaces (oneMemberWorkspace "queue.keiro" base) (oneMemberWorkspace "queue.keiro" renamed)))-      workspaceFindings `shouldSatisfy` \case [finding] -> isAdvisory finding; _ -> False-      replayImpactSpecs base renamed `shouldBe` ReplayNeutral-    it "pairs a mapped selector rename by unchanged wire key and keeps fold identity stable" $ do-      source <- readTestText "test/fixtures/consumer-types.keiro"-      base <- parseInlineSpec "<mapped-selector-old>" source-      renamed <--        parseInlineSpec-          "<mapped-selector-new>"-          (T.replace "key         as \"key\"" "artifactKey as \"key\"" source)-      let findings = generatedHaskellNameFindings (diffSpecs base renamed)-      case findings of-        [finding] -> do-          assertGeneratedHaskellNameFinding finding-          ckSubject (kindOfChange finding) `shouldSatisfy` T.isInfixOf "artifactKey"-        values -> expectationFailure ("expected one selector-name finding, got " <> show (length values))-      replayImpactSpecs base renamed `shouldBe` ReplayNeutral-      legacyAggregateFoldFingerprint base (onlyAggregate base)-        `shouldBe` legacyAggregateFoldFingerprint renamed (onlyAggregate renamed)-    it "pairs a workqueue module rename by unchanged explicit runtime facts" $ do-      base <- specOf "test/fixtures/reservation-work.keiro"-      let queueOnly = base {specNodes = [node | node@NWorkqueue {} <- specNodes base]}-          renamed = mapWorkqueue (\queue -> queue {wqName = "reservation_jobs"}) queueOnly-          findings = generatedHaskellNameFindings (diffSpecs queueOnly renamed)-      case findings of-        [finding] -> do-          assertGeneratedHaskellNameFinding finding-          ckFacet (kindOfChange finding) `shouldBe` "workqueue-module"-        values -> expectationFailure ("expected one module-name finding, got " <> show (length values))-      map (ckCode . kindOfChange) (diffSpecs queueOnly renamed) `shouldNotContain` [QueueIdentityChanged]-      replayImpactSpecs queueOnly renamed `shouldBe` ReplayNeutral-    it "emits no finding when edited logical spellings normalize identically" $ do-      base <- specOf "test/fixtures/reservation-work.keiro"-      let queueOnly = base {specNodes = [node | node@NWorkqueue {} <- specNodes base]}-          recased = mapWorkqueue (\queue -> queue {wqName = "reservationWork"}) queueOnly-      generatedHaskellNameFindings (diffSpecs queueOnly recased) `shouldBe` []--  describe "canonical reservation.keiro" $-    it "parses into the expected aggregate shape" $ do-      input <- readTestText "test/fixtures/reservation.keiro"-      case parseSpec "test/fixtures/reservation.keiro" input of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> do-          specContext spec `shouldBe` "hospital-capacity"-          length (specIds spec) `shouldBe` 3-          length (specEnums spec) `shouldBe` 3-          length (specRules spec) `shouldBe` 1-          case specNodes spec of-            [NAggregate a] -> do-              aggName a `shouldBe` "Reservation"-              length (aggStates a) `shouldBe` 6-              length (aggCommands a) `shouldBe` 2-              length (aggEvents a) `shouldBe` 2-              length (aggTransitions a) `shouldBe` 2-              map stTerminal (aggStates a) `shouldBe` [False, False, False, True, True, True]-            other -> expectationFailure ("expected one aggregate node, got " <> show (length other))--  describe "validator" $ do-    it "accepts the canonical reservation.keiro" $ do-      codes <- errorCodesOf "test/fixtures/reservation.keiro"-      codes `shouldBe` []-    it "keeps unrelated aggregate-only specs free of inert-surface warnings" $ do-      codes <- diagnosticCodesOf "test/fixtures/reservation.keiro"-      codes-        `shouldNotContain` [ IntakeBindFlagUnenforced,-                             RmInlineSubscriptionIgnored-                           ]-    it "reports empty aggregates at their declaration under legacy and stable contracts" $ do-      spec <- specOf "test/fixtures/reservation.keiro"-      case [aggregate | NAggregate aggregate <- specNodes spec] of-        aggregate : _ -> do-          let emptyAggregate = aggregate {aggCommands = [], aggEvents = [], aggTransitions = []}-              emptySpec = spec {specNodes = [NAggregate emptyAggregate]}-              expectedLine = unLoc (aggLoc aggregate)-              planningCodes = [GeneratedPathCollision, GeneratedImportCycle, BehaviorDerivationInvalid, ConformanceFactKeyCollision, GeneratedPlanningInvariantViolation]-              expectedMessage =-                "aggregate 'Reservation' declares no commands, no events, and no transitions; scaffold cannot lower an empty aggregate -- declare at least one command, one event, and one transition"-          forM_ [legacyCheckedService emptySpec, stableCheckedService emptySpec] $ \service -> do-            let diagnostics = checkServiceDiagnostics Nothing (defaultContext (specContext emptySpec)) service-            [ (severity diagnostic, line diagnostic, message diagnostic)-              | diagnostic <- diagnostics,-                code diagnostic == AggregateEmpty-              ]-              `shouldBe` [(Error, expectedLine, expectedMessage)]-            filter (`elem` planningCodes) (map code diagnostics) `shouldBe` []-          scaffoldRefusals emptySpec `shouldSatisfy` any (T.isPrefixOf "AggregateEmpty:")-        [] -> expectationFailure "reservation fixture has no aggregate"-    it "reports empty contracts at their declaration under legacy and stable contracts" $ do-      spec <- specOf "test/fixtures/contract-v4.keiro"-      case [contract | NContract contract <- specNodes spec] of-        contract : _ -> do-          let emptyContract = contract {ctrEvents = []}-              emptySpec = spec {specNodes = [NContract emptyContract]}-              expectedLine = unLoc (ctrLoc contract)-              planningCodes = [GeneratedPathCollision, GeneratedImportCycle, BehaviorDerivationInvalid, ConformanceFactKeyCollision, GeneratedPlanningInvariantViolation]-              expectedMessage =-                "contract 'emergency' declares no events; scaffold cannot lower an empty contract -- declare at least one event"-          forM_ [legacyCheckedService emptySpec, stableCheckedService emptySpec] $ \service -> do-            let diagnostics = checkServiceDiagnostics Nothing (defaultContext (specContext emptySpec)) service-            [ (severity diagnostic, line diagnostic, message diagnostic)-              | diagnostic <- diagnostics,-                code diagnostic == ContractEmpty-              ]-              `shouldBe` [(Error, expectedLine, expectedMessage)]-            filter (`elem` planningCodes) (map code diagnostics) `shouldBe` []-          scaffoldRefusals emptySpec `shouldSatisfy` any (T.isPrefixOf "ContractEmpty:")-        [] -> expectationFailure "contract fixture has no contract"-    it "keeps a check-time error counterpart for every sampled lowering refusal class" $ do-      emitSource <- readTestText "test/fixtures/emit.keiro"-      incompleteBackoff <- parseInlineSpec "<incomplete-backoff-parity>" (T.replace "backoff constant 2s" "backoff exponential 2s" emitSource)-      baseAggregate <- parseInlineSpec "<lowering-parity>" loweringAggregateSpec-      bareTextInitial <- parseInlineSpec "<bare-text-initial-parity>" (T.replace "\"hello world\"" "hello" loweringAggregateSpec)-      unsupportedField <- parseInlineSpec "<unsupported-field-parity>" (T.replace "count:Int" "count:Json" loweringAggregateSpec)-      mappedInitial <- specOf "test/fixtures/mapped-missing-initial.keiro"-      let candidates =-            [ ("incomplete publisher backoff", incompleteBackoff),-              ("invalid register initial", bareTextInitial),-              ("unrepresentable aggregate field", unsupportedField),-              ("missing mapped register initial", mappedInitial)-            ]-      scaffoldRefusals baseAggregate `shouldBe` []-      forM_ candidates $ \(caseLabel, candidate) ->-        unless-          (not (null (scaffoldRefusals candidate)) && any ((== Error) . severity) (validateSpec candidate))-          (expectationFailure (caseLabel <> " did not fail at both check and scaffold planning"))-    it "rejects policy words that generated Haskell cannot lower" $ do-      emitSpec <- specOf "test/fixtures/emit.keiro"-      intakeSpec <- specOf "test/fixtures/intake.keiro"-      let unknownOrdering = mapPublisher (\publisher -> publisher {pubOrdering = "banana"}) emitSpec-          unknownBackoff =-            mapPublisher-              (\publisher -> publisher {pubBackoff = (pubBackoff publisher) {boKind = "banana"}})-              emitSpec-          incompleteBackoff =-            mapPublisher-              (\publisher -> publisher {pubBackoff = BackoffSpec "exponential" "2s" Nothing Nothing})-              emitSpec-          unknownDedupe = mapIntake (\intake -> intake {inkDedupePolicy = "Banana"}) intakeSpec-      errorCodes unknownOrdering `shouldContain` [PublisherOrderingUnknown]-      errorCodes unknownBackoff `shouldContain` [PublisherBackoffInvalid]-      errorCodes incompleteBackoff `shouldContain` [PublisherBackoffInvalid]-      errorCodes unknownDedupe `shouldContain` [IntakeDedupePolicyUnknown]-    it "gates numeric floors on the unreleased language-4 contract" $ do-      emitSpec <- specOf "test/fixtures/emit.keiro"-      intakeSpec <- specOf "test/fixtures/intake.keiro"-      readModelSpec <- specOf "test/fixtures/workflow.keiro"-      let zeroContract = mapContract (\contract -> contract {ctrSchemaVersion = 0}) emitSpec-          zeroAttempts = mapPublisher (\publisher -> publisher {pubMaxAttempts = 0}) emitSpec-          zeroDecode = mapIntake (\intake -> intake {inkDecode = (inkDecode intake) {decBodySchemaVersion = 0}}) intakeSpec-          zeroReadModel = modifyReadModel "transferDecision" (\readModel -> readModel {rmVersion = 0}) readModelSpec-          floors =-            [ (zeroContract, ContractSchemaVersionBelowMinimum),-              (zeroAttempts, PublisherMaxAttemptsBelowMinimum),-              (zeroDecode, IntakeDecodeSchemaVersionBelowMinimum),-              (zeroReadModel, ReadModelVersionBelowMinimum)-            ]-      forM_ floors $ \(candidate, expected) -> do-        serviceErrorCodes 3 candidate `shouldNotContain` [expected]-        serviceErrorCodes 4 candidate `shouldContain` [expected]-    it "rejects duplicate declarations whose generated behavior cannot work" $ do-      reservation <- specOf "test/fixtures/reservation.keiro"-      integration <- specOf "test/fixtures/emit.keiro"-      let duplicateCommandField =-            modifyAggregate-              "Reservation"-              (\aggregate -> aggregate {aggCommands = updateFirst (\command -> command {cmdFields = duplicateFirst (cmdFields command)}) (aggCommands aggregate)})-              reservation-          duplicateState = modifyAggregate "Reservation" (\aggregate -> aggregate {aggStates = duplicateFirst (aggStates aggregate)}) reservation-          duplicateTransition =-            modifyAggregate-              "Reservation"-              (\aggregate -> aggregate {aggTransitions = aggTransitions aggregate <> take 1 (reverse (aggTransitions aggregate))})-              reservation-          duplicateContractField =-            mapContract-              (\contract -> contract {ctrEvents = updateFirst (\event -> event {ceFields = duplicateFirst (ceFields event)}) (ctrEvents contract)})-              integration-          duplicateContractEvent = mapContract (\contract -> contract {ctrEvents = duplicateFirst (ctrEvents contract)}) integration-          duplicateTopicAlias = mapContract (\contract -> contract {ctrTopics = duplicateFirst (ctrTopics contract)}) integration-          cases =-            [ (duplicateCommandField, AggregateDuplicateFieldName),-              (duplicateState, AggregateDuplicateState),-              (duplicateTransition, TransitionDuplicateUnguarded),-              (duplicateContractField, ContractDuplicateFieldName),-              (duplicateContractEvent, ContractDuplicateEvent),-              (duplicateTopicAlias, ContractDuplicateTopicAlias)-            ]-      forM_ cases $ \(candidate, expected) -> errorCodes candidate `shouldContain` [expected]-    it "gates ambiguous and silently shadowed duplicate surfaces on language 4" $ do-      reservation <- specOf "test/fixtures/reservation.keiro"-      integration <- specOf "test/fixtures/emit.keiro"-      let duplicateRegister = modifyAggregate "Reservation" (\aggregate -> aggregate {aggRegs = duplicateFirst (aggRegs aggregate)}) reservation-          duplicateNominal = reservation {specIds = duplicateFirst (specIds reservation)}-          duplicateMap = mapEmit (\emitNode -> emitNode {emMap = duplicateFirst (emMap emitNode)}) integration-          shadowDiscriminator =-            mapContract-              ( \contract ->-                  contract-                    { ctrEvents =-                        updateFirst-                          (\event -> event {ceFields = updateFirst (\field -> field {cfName = ctrDiscriminator contract}) (ceFields event)})-                          (ctrEvents contract)-                    }-              )-              integration-          guardedSibling =-            modifyAggregate-              "Reservation"-              ( \aggregate ->-                  aggregate-                    { aggTransitions =-                        aggTransitions aggregate-                          <> [transition {tGuard = Just (EAtom (ABool True))} | transition <- take 1 (reverse (aggTransitions aggregate))]-                    }-              )-              reservation-          cases =-            [ (duplicateRegister, AggregateDuplicateRegister),-              (duplicateNominal, NominalDuplicateDeclaration),-              (duplicateMap, EmitMapDuplicateCase),-              (shadowDiscriminator, ContractFieldShadowsDiscriminator),-              (guardedSibling, TransitionUnguardedSibling)-            ]-      forM_ cases $ \(candidate, expected) -> do-        serviceErrorCodes 3 candidate `shouldNotContain` [expected]-        serviceErrorCodes 4 candidate `shouldContain` [expected]-    it "gates stable identities and external names on language 4" $ do-      workflowSpec <- specOf "test/fixtures/workflow.keiro"-      processSpec <- specOf "test/fixtures/surge-service.keiro"-      routerSpec <- specOf "test/fixtures/transfer-routing.keiro"-      integration <- specOf "test/fixtures/emit.keiro"-      let invalidIdentity = mapWorkflow (\workflow -> workflow {wfStable = ""}) workflowSpec-          duplicateIdentity =-            processSpec-              { specNodes =-                  specNodes processSpec-                    <> [NRouter (router {rtName = "surge-demo"}) | NRouter router <- specNodes routerSpec]-              }-          invalidTopic = mapContract (\contract -> contract {ctrTopics = [(alias, "bad topic") | (alias, _) <- ctrTopics contract]}) integration-          emptyTopic = mapContract (\contract -> contract {ctrTopics = [(alias, "") | (alias, _) <- ctrTopics contract]}) integration-          invalidReadModel = modifyReadModel "transferDecision" (\readModel -> readModel {rmTable = "Bad-Table"}) workflowSpec-          duplicateColumn = modifyReadModel "transferDecision" (\readModel -> readModel {rmColumns = duplicateFirst (rmColumns readModel)}) workflowSpec-          gatedCases =-            [ (invalidIdentity, RuntimeIdentityInvalid),-              (duplicateIdentity, RuntimeIdentityDuplicate),-              (invalidTopic, ContractTopicNameInvalid),-              (invalidReadModel, ReadModelIdentifierInvalid),-              (duplicateColumn, ReadModelDuplicateColumn)-            ]-      forM_ gatedCases $ \(candidate, expected) -> do-        serviceErrorCodes 3 candidate `shouldNotContain` [expected]-        serviceErrorCodes 4 candidate `shouldContain` [expected]-      serviceErrorCodes 3 emptyTopic `shouldContain` [ContractTopicNameInvalid]-      serviceErrorCodes 4 emptyTopic `shouldContain` [ContractTopicNameInvalid]-    it "gates declared integration and wire couplings on language 4" $ do-      intakeSpec <- specOf "test/fixtures/intake.keiro"-      reservation <- specOf "test/fixtures/reservation.keiro"-      let unresolvedBind =-            mapIntake-              (\intake -> intake {inkBinds = updateFirst (\binding -> binding {brField = "ghost"}) (inkBinds intake)})-              intakeSpec-          acceptedEventBind =-            mapIntake-              (\intake -> intake {inkBinds = updateFirst (\binding -> binding {brField = "region"}) (inkBinds intake)})-              intakeSpec-          unresolvedDedupe = mapIntake (\intake -> intake {inkDedupeKey = "ghost"}) intakeSpec-          unknownEnvelope = mapIntake (\intake -> intake {inkDecode = (inkDecode intake) {decEnvelope = "banana policy"}}) intakeSpec-          mismatchedSchema = mapIntake (\intake -> intake {inkDecode = (inkDecode intake) {decBodySchemaVersion = 2}}) intakeSpec-          unresolvedAlias =-            mapContract-              (\contract -> contract {ctrEvents = updateFirst (\event -> event {ceTopic = "ghost"}) (ctrEvents contract)})-              intakeSpec-          unsupportedWire =-            modifyAggregate-              "Reservation"-              (\aggregate -> aggregate {aggWire = fmap (\wire -> wire {wireKind = "banana"}) (aggWire aggregate)})-              reservation-          cases =-            [ (unresolvedBind, IntakeBindUnresolved),-              (unresolvedDedupe, IntakeDedupeKeyUnresolved),-              (unknownEnvelope, IntakeEnvelopePolicyUnknown),-              (mismatchedSchema, IntakeDecodeSchemaVersionMismatch),-              (unresolvedAlias, ContractTopicAliasUnresolved),-              (unsupportedWire, WireClauseUnsupported)-            ]-      forM_ cases $ \(candidate, expected) -> do-        serviceErrorCodes 3 candidate `shouldNotContain` [expected]-        serviceErrorCodes 4 candidate `shouldContain` [expected]-      serviceErrorCodes 4 acceptedEventBind `shouldNotContain` [IntakeBindUnresolved]-    it "gates closed workqueue vocabularies and bounded windows on language 4" $ do-      queueSpec <- specOf "test/fixtures/reservation-work.keiro"-      intakeSpec <- specOf "test/fixtures/intake.keiro"-      emitSpec <- specOf "test/fixtures/emit.keiro"-      processSpec <- specOf "test/fixtures/hospital-surge.keiro"-      let huge = "18446744073709551618s"-          unknownPayload =-            mapWorkqueue-              (\queue -> queue {wqPayload = [if wqfName field == "hospitalId" then field {wqfType = "numeric"} else field | field <- wqPayload queue]})-              queueSpec-          queueDelay = mapWorkqueue (\queue -> queue {wqDelay = huge}) queueSpec-          queueRetry = mapWorkqueue (\queue -> queue {wqDisposition = updateFirst (\row -> row {wqdAction = IRetry huge}) (wqDisposition queue)}) queueSpec-          intakeRetry = mapIntake (\intake -> intake {inkDisposition = updateFirst (\row -> row {drAction = IRetry huge}) (inkDisposition intake)}) intakeSpec-          publisherBackoff = mapPublisher (\publisher -> publisher {pubBackoff = (pubBackoff publisher) {boWindow = huge}}) emitSpec-          publisherMaximum =-            mapPublisher-              (\publisher -> publisher {pubBackoff = (pubBackoff publisher) {boKind = "exponential", boMax = Just huge, boMultiplier = Just "2"}})-              emitSpec-          processFireAt =-            modifyProcess-              "HospitalSurge"-              (\process -> process {procTimer = (procTimer process) {tmFireAt = (tmFireAt (procTimer process)) {faWindow = huge}}})-              processSpec-          cases =-            [ (unknownPayload, WqPayloadTypeUnknown),-              (queueDelay, WindowOutOfRange),-              (queueRetry, WindowOutOfRange),-              (intakeRetry, WindowOutOfRange),-              (publisherBackoff, WindowOutOfRange),-              (publisherMaximum, WindowOutOfRange),-              (processFireAt, WindowOutOfRange)-            ]-      forM_ cases $ \(candidate, expected) -> do-        serviceErrorCodes 3 candidate `shouldBe` []-        serviceErrorCodes 4 candidate `shouldContain` [expected]-    -- ExecPlan 199: spellings the grammar accepted that no runtime implements.-    -- Each pair asserts both halves of the contract — the divergent spelling-    -- warns at 3 and errors at 4, and the spelling that matches the runtime-    -- stays completely silent, so these are refusals and not blanket noise.-    it "refuses spec surfaces that contradict the runtime, and stays silent on the ones that describe it" $ do-      intakeSpec <- specOf "test/fixtures/intake.keiro"-      processSpec <- specOf "test/fixtures/hospital-surge.keiro"-      routerSpec <- specOf "test/fixtures/transfer-routing.keiro"-      let lenientBody =-            mapIntake (\intake -> intake {inkDecode = (inkDecode intake) {decBodyStrict = False}}) intakeSpec-          unknownHeader =-            mapIntake-              (\intake -> intake {inkBinds = updateFirst (\binding -> binding {brSource = SrcHeader "x-custom"}) (inkBinds intake)})-              intakeSpec-          retryOnAppended =-            modifyProcess-              "HospitalSurge"-              ( \process ->-                  process-                    { procHandle =-                        (procHandle process)-                          { hDispatch =-                              updateFirst-                                (\d -> d {dispDisposition = (dispDisposition d) {onAppended = DRetry}})-                                (hDispatch (procHandle process))-                          }-                    }-              )-              processSpec-          firedNotMine =-            modifyProcess-              "HospitalSurge"-              ( \process ->-                  let timer = procTimer process-                      fire = tmFire timer-                   in process-                        { procTimer =-                            timer {tmFire = fire {fireDisposition = (fireDisposition fire) {notMine = OFired}}}-                        }-              )-              processSpec-          routerRetryOnAppended =-            mapRouter-              (\router -> router {rtDispatch = (rtDispatch router) {rdDisposition = (rdDisposition (rtDispatch router)) {onAppended = DRetry}}})-              routerSpec-          cases =-            [ (lenientBody, DecodeBodyPostureUnsupported),-              (unknownHeader, IntakeBindHeaderUnknown),-              (retryOnAppended, DispatchOnAppendedUnsupported),-              (firedNotMine, TimerNotMineUnsupported),-              (routerRetryOnAppended, DispatchOnAppendedUnsupported)-            ]-      forM_ cases $ \(candidate, expected) -> do-        serviceErrorCodes 3 candidate `shouldNotContain` [expected]-        serviceWarningCodes 3 candidate `shouldContain` [expected]-        serviceErrorCodes 4 candidate `shouldContain` [expected]--      -- The unmutated fixtures spell every one of these the way the runtime-      -- behaves, so language 4 has nothing to say about them.-      let closedCodes =-            [ DecodeBodyPostureUnsupported,-              IntakeBindHeaderUnknown,-              DispatchOnAppendedUnsupported,-              TimerNotMineUnsupported-            ]-      forM_ [intakeSpec, processSpec, routerSpec] $ \accepted -> do-        serviceErrorCodes 4 accepted `shouldNotContain` closedCodes-        serviceWarningCodes 4 accepted `shouldNotContain` closedCodes--    -- ExecPlan 197 parked these three as "explicitly descriptive-only"; ExecPlan-    -- 199 re-adjudicated each against the path it purports to describe and found-    -- a checkable referent in every one.-    it "checks the references the formerly descriptive-only surfaces name" $ do-      processSpec <- specOf "test/fixtures/hospital-surge.keiro"-      dispatchSpec <- specOf "test/fixtures/reservation-work.keiro"-      let unknownStatus =-            modifyProcess-              "HospitalSurge"-              (\process -> process {procTimer = (procTimer process) {tmDecodeUnknown = "Abandoned"}})-              processSpec-          blankDeadLetter =-            modifyProcess-              "HospitalSurge"-              (\process -> process {procTimer = (procTimer process) {tmDeadLetter = "   "}})-              processSpec-          phantomDedupeKey =-            mapPgmqDispatch (\d -> d {pdDedupKey = "ghostKey"}) dispatchSpec-          uppercaseFanout =-            mapPgmqDispatch (\d -> d {pdFanoutBody = "ResolveTransferCandidates"}) dispatchSpec-          cases =-            [ (unknownStatus, TimerDecodeStatusUnknown),-              (blankDeadLetter, TimerDeadLetterTextInvalid),-              (phantomDedupeKey, DispatchReadModelFieldUnknown),-              (uppercaseFanout, PgmqFanoutFunctionInvalid)-            ]-      forM_ cases $ \(candidate, expected) -> do-        serviceErrorCodes 3 candidate `shouldNotContain` [expected]-        serviceWarningCodes 3 candidate `shouldContain` [expected]-        serviceErrorCodes 4 candidate `shouldContain` [expected]--      -- Every timer status the runtime actually stores is accepted.-      forM_ ["Scheduled", "Firing", "Fired", "Cancelled", "Dead"] $ \status ->-        serviceErrorCodes-          4-          (modifyProcess "HospitalSurge" (\p -> p {procTimer = (procTimer p) {tmDecodeUnknown = status}}) processSpec)-          `shouldNotContain` [TimerDecodeStatusUnknown]--      serviceErrorCodes 4 processSpec `shouldNotContain` [TimerDecodeStatusUnknown, TimerDeadLetterTextInvalid]-      serviceErrorCodes 4 dispatchSpec `shouldNotContain` [PgmqFanoutFunctionInvalid]--    it "holds a process dispatch-id line to the same strictness as a router's" $ do-      -- Both lines document a derivation the spec cannot change, but the two-      -- runtimes key on different tuples: Keiro.ProcessManager on-      -- (name, correlationId, sourceEventId, emitIndex) and Keiro.Router on-      -- (name, key, sourceEventId, targetStreamName, occurrence). Before-      -- ExecPlan 199 the process line accepted any strategy and any tuple.-      processSource <- readTestText "test/fixtures/hospital-surge.keiro"-      let processLine = "dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)"-          rejected =-            [ "dispatch-id strategy=md5 from=(name, correlationId, sourceEventId, emitIndex)",-              "dispatch-id strategy=uuidv5 from=(banana)",-              "dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId)",-              -- The router's tuple is not the process's tuple.-              "dispatch-id strategy=uuidv5 from=(name, key, sourceEventId, targetStreamName, occurrence)"-            ]-      processSource `shouldSatisfy` T.isInfixOf processLine-      parseSpec "accepted" processSource `shouldSatisfy` isRight-      forM_ rejected $ \badLine ->-        parseSpec "mutated" (T.replace processLine badLine processSource)-          `shouldSatisfy` isLeft--    it "gates the remaining locally resolvable identity and field surfaces on language 4" $ do-      reservation <- specOf "test/fixtures/reservation.keiro"-      emitSpec <- specOf "test/fixtures/emit.keiro"-      processSpec <- specOf "test/fixtures/hospital-surge.keiro"-      dispatchSpec <- specOf "test/fixtures/reservation-work.keiro"-      readModelSpec <- specOf "test/fixtures/readmodel.keiro"-      let projectionKey = modifyAggregate "Reservation" (\aggregate -> aggregate {aggProjection = fmap (\projection -> projection {projKey = "ghost"}) (aggProjection aggregate)}) reservation-          outboxField = mapPublisher (\publisher -> publisher {pubOutboxField = "ghost"}) emitSpec-          timerIds =-            modifyProcess-              "HospitalSurge"-              ( \process ->-                  let timer = procTimer process-                      fire = tmFire timer-                   in process-                        { procTimer =-                            timer-                              { tmId = (tmId timer) {ideField = "ghostTimerKey"},-                                tmFire = fire {fireFiredEventId = (fireFiredEventId fire) {ideField = "ghostEventKey"}}-                              }-                        }-              )-              processSpec-          sourceKey = mapDispatch (\dispatch -> dispatch {pdSourceKey = "ghost"}) dispatchSpec-          subscriptionIdentity = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmSubscription = Just "bad subscription"}) readModelSpec-          scopeIdentity = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmScope = Just (RmCategory "bad-category")}) readModelSpec-          cases =-            [ (projectionKey, AggProjectionKeyUnresolved),-              (outboxField, PublisherOutboxFieldUnresolved),-              (timerIds, TimerIdFieldNotCorrelation),-              (sourceKey, DispatchReadModelFieldUnknown),-              (subscriptionIdentity, RuntimeIdentityInvalid),-              (scopeIdentity, RuntimeIdentityInvalid)-            ]-      forM_ cases $ \(candidate, expected) -> do-        serviceErrorCodes 3 candidate `shouldBe` []-        serviceErrorCodes 4 candidate `shouldContain` [expected]-      length (filter (== TimerIdFieldNotCorrelation) (serviceErrorCodes 4 timerIds)) `shouldBe` 2-      parseStableRenderedSpec "<timer-id-fields>" timerIds `shouldBe` Right timerIds-    it "uses a router-specific code for a confirmed duplicate inversion" $ do-      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"-      let changed =-            modifyRouter-              "PagingRouter"-              ( \router ->-                  let dispatch = rtDispatch router-                      disposition = rdDisposition dispatch-                   in router {rtDispatch = dispatch {rdDisposition = disposition {onDuplicate = DAckOk}}}-              )-              spec-          warningCodes = [code diagnostic | diagnostic <- validateSpec changed, severity diagnostic == Warning]-      warningCodes `shouldContain` [RouterBenignInversion]-      warningCodes `shouldNotContain` [ProcessBenignInversion]-    it "pins every emitted legacy single-spec diagnostic that lacked a direct negative test" $ do-      reservation <- specOf "test/fixtures/reservation.keiro"-      intakeSpec <- specOf "test/fixtures/intake.keiro"-      emitSpec <- specOf "test/fixtures/emit.keiro"-      processSpec <- specOf "test/fixtures/surge-service.keiro"-      queueSpec <- specOf "test/fixtures/reservation-work.keiro"-      workflowSpec <- specOf "test/fixtures/workflow.keiro"-      let updateFirstTransition update aggregate = aggregate {aggTransitions = updateFirst update (aggTransitions aggregate)}-          undeclaredEvent = modifyAggregate "Reservation" (updateFirstTransition (\transition -> transition {tEmits = ["GhostEvent"]})) reservation-          undeclaredState = modifyAggregate "Reservation" (updateFirstTransition (\transition -> transition {tGoto = "GhostState"})) reservation-          terminalOutgoing = modifyAggregate "Reservation" (updateFirstTransition (\transition -> transition {tSource = "Expired"})) reservation-          deprecatedEmitted = modifyAggregate "Reservation" (\aggregate -> aggregate {aggEvents = updateFirst (\event -> event {evDeprecated = True}) (aggEvents aggregate)}) reservation-          wireVersionMismatch = modifyAggregate "Reservation" (\aggregate -> aggregate {aggWire = fmap (\wire -> wire {wireSchemaVersion = 2}) (aggWire aggregate)}) reservation-          decodeRetry =-            mapIntake-              ( \intake ->-                  intake-                    { inkDisposition =-                        [ if drOutcome row == "decodeFailed" then row {drAction = IRetry "5s"} else row-                        | row <- inkDisposition intake-                        ]-                    }-              )-              intakeSpec-          unresolvedPublisher = mapPublisher (\publisher -> publisher {pubEmit = "ghost"}) emitSpec-          unresolvedIntake = mapIntake (\intake -> intake {inkContract = "ghost"}) intakeSpec-          unboundedQueue = mapWorkqueue (\queue -> queue {wqMaxRetries = 0}) queueSpec-          unresolvedEnqueue = mapDispatch (\dispatch -> dispatch {pdEnqueueTo = "ghost"}) queueSpec-          unresolvedWorkflow =-            mapOperation-              ( \operation -> case opShape operation of-                  RunOp _ input outcome -> operation {opShape = RunOp "GhostWorkflow" input outcome}-                  _ -> operation-              )-              workflowSpec-          cases =-            [ (undeclaredEvent, UndeclaredEvent),-              (undeclaredState, UndeclaredState),-              (terminalOutgoing, TerminalHasOutgoing),-              (deprecatedEmitted, DeprecatedEventStillEmitted),-              (wireVersionMismatch, WireSchemaVersionMismatch),-              (processSpec, ProcessBenignInversion),-              (decodeRetry, DispositionDecodeUnboundedRetry),-              (unresolvedPublisher, PublisherUnresolvedEmit),-              (unresolvedIntake, IntakeUnresolvedContract),-              (unboundedQueue, WqDlqWithoutCeiling),-              (unresolvedEnqueue, DispatchEnqueueUnresolved),-              (unresolvedWorkflow, RunWorkflowUnresolved)-            ]-      forM_ cases $ \(candidate, expected) -> diagnosticCodes candidate `shouldContain` [expected]-    it "rejects a missing status-map as StatusMapNotTotal" $ do-      codes <- diagnosticCodesOf "test/fixtures/reservation-no-statusmap.keiro"-      codes `shouldContain` [StatusMapNotTotal]-    it "rejects an undeclared command as UndeclaredCommand" $ do-      codes <- diagnosticCodesOf "test/fixtures/reservation-bad-command.keiro"-      codes `shouldContain` [UndeclaredCommand]-    it "rejects a wall-clock guard atom as ClockSampled" $ do-      codes <- diagnosticCodesOf "test/fixtures/reservation-clock.keiro"-      codes `shouldContain` [ClockSampled]-    it "accepts a v2 event with a contiguous upcaster hole" $ do-      codes <- errorCodesOf "test/fixtures/reservation-v2.keiro"-      codes `shouldBe` []-    it "rejects a v2 event with no upcaster as EvtVersionMissingUpcaster" $ do-      codes <- diagnosticCodesOf "test/fixtures/reservation-v2-noupcast.keiro"-      codes `shouldContain` [EvtVersionMissingUpcaster]-    it "accepts shared upcaster sources for different event kinds" $ do-      codes <- errorCodesOf "test/fixtures/reservation-dup-upcast-source.keiro"-      codes `shouldBe` []-    it "rejects a gap in the aggregate-global upcaster chain" $ do-      codes <- errorCodesOf "test/fixtures/reservation-chain-gap.keiro"-      codes `shouldContain` [UpcasterChainGap]-    it "warns while a retiring event keeps its live emitting transition" $ do-      diagnostics <- diagnosticsOf "test/fixtures/reservation-retiring.keiro"-      [code d | d <- diagnostics, severity d == Error] `shouldBe` []-      [code d | d <- diagnostics, severity d == Warning]-        `shouldContain` [EventRetirementInProgress]-    it "rejects a retiring event after its live emitting transition disappears" $ do-      source <- readTestText "test/fixtures/reservation-retiring.keiro"-      spec <- parseInlineSpec "<retiring-without-emitter>" (T.replace "emit TransferReservationConfirmed ; " "" source)-      [code d | d <- validateSpec spec, severity d == Error]-        `shouldContain` [EventRetirementInProgress]-    it "warns when a deprecated event has no replay-only emitting transition" $ do-      diagnostics <- diagnosticsOf "test/fixtures/reservation-deprecated.keiro"-      [code d | d <- diagnostics, severity d == Error] `shouldBe` []-      [code d | d <- diagnostics, severity d == Warning]-        `shouldContain` [DeprecatedEventReplayHazard]-    it "recognises deprecated plus replay-only as the replay-safe cutover" $ do-      diagnostics <- diagnosticsOf "test/fixtures/reservation-deprecated-replay-only.keiro"-      [code d | d <- diagnostics, severity d == Error] `shouldBe` []-      [code d | d <- diagnostics, severity d == Warning]-        `shouldContain` [EventRetirementInProgress]-      [code d | d <- diagnostics] `shouldNotContain` [DeprecatedEventReplayHazard]-    it "requires exact, unique status-map event keys" $ do-      dangling <- errorCodesOf "test/fixtures/statusmap-dangling.keiro"-      mapM_ (\expected -> dangling `shouldContain` [expected]) [StatusMapDanglingKey, StatusMapNotTotal]-      duplicate <- errorCodesOf "test/fixtures/statusmap-dup-key.keiro"-      duplicate `shouldContain` [StatusMapDuplicateKey]-    it "rejects duplicate spec and aggregate names" $ do-      codes <- errorCodesOf "test/fixtures/duplicate-names.keiro"-      mapM_-        (\expected -> codes `shouldContain` [expected])-        [ DuplicateNodeName,-          DuplicateEnumCtor,-          DuplicateEnumWire,-          DuplicateIdPrefix,-          DuplicateCommandName,-          DuplicateEventName-        ]-    it "rejects aggregate-local references that do not resolve" $ do-      codes <- errorCodesOf "test/fixtures/aggregate-bad-refs.keiro"-      mapM_ (\expected -> codes `shouldContain` [expected]) [RegisterInitialOutOfScope, UndeclaredCommand, WriteTargetNotRegister]-    it "anchors UnreachableState on the state row" $ do-      let src =-            T.unlines-              [ "context repro",-                "",-                "aggregate Thing",-                "  regs",-                "  states",-                "    Initial",-                "    Unreachable"-              ]-      case parseSpec "<unreachable-row>" src of-        Left err -> expectationFailure (T.unpack err)-        Right spec ->-          [line d | d <- validateSpec spec, code d == UnreachableState]-            `shouldBe` [7]-    it "accepts a replay-only twin with a live sibling (plan 143)" $ do-      codes <- errorCodesOf "test/fixtures/reservation-guard-tightened-twin.keiro"-      codes `shouldBe` []-    it "rejects a replay-only transition that emits nothing" $ do-      case parseSpec "<replay-only-no-emit>" (replayOnlySpecWith ["    write reservationState := Held", "    goto  Held"]) of-        Left err -> expectationFailure (T.unpack err)-        Right spec ->-          [code d | d <- validateSpec spec, severity d == Error]-            `shouldContain` [ReplayOnlyEmitsNothing]-    it "warns when a replay-only transition has no live sibling" $ do-      case parseSpec "<replay-only-orphan>" (replayOnlySpecWith ["    emit  TransferReservationCreated", "    goto  Held"]) of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> do-          [code d | d <- validateSpec spec, severity d == Warning]-            `shouldContain` [ReplayOnlyCommandStillLive]-          [code d | d <- validateSpec spec, severity d == Error]-            `shouldNotContain` [ReplayOnlyCommandStillLive]--  describe "complementExpr (plan 143)" $ do-    it "applies De Morgan over and/or and flips comparison operators" $ do-      let a = EAtom (AName "a")-          b = EAtom (AName "b")-      complementExpr (EAnd a b)-        `shouldBe` EOr (ECmp OpEq a (EAtom (ABool False))) (ECmp OpEq b (EAtom (ABool False)))-      complementExpr (ECmp OpLt a b) `shouldBe` ECmp OpGe a b-      complementExpr (ECmp OpEq a b) `shouldBe` ECmp OpNeq a b-      complementExpr (ECmp OpLe a b) `shouldBe` ECmp OpGt a b-      complementExpr (ECmp OpGt a b) `shouldBe` ECmp OpLe a b-      complementExpr (ECmp OpGe a b) `shouldBe` ECmp OpLt a b-      complementExpr (ECmp OpNeq a b) `shouldBe` ECmp OpEq a b-    it "flips boolean literals and grounds bare names as == false" $ do-      complementExpr (EAtom (ABool True)) `shouldBe` EAtom (ABool False)-      complementExpr (EAtom (AName "open"))-        `shouldBe` ECmp OpEq (EAtom (AName "open")) (EAtom (ABool False))-    it "stays inside the grammar: the complement of any guard re-parses" $-      property $-        forAll genExpr $ \e ->-          let twin =-                replayOnlySpecWith-                  [ "    guard " <> renderExprText (complementExpr e),-                    "    emit  TransferReservationCreated",-                    "    goto  Held"-                  ]-           in case parseSpec "<complement>" twin of-                Left err -> counterexample (T.unpack err) False-                Right spec ->-                  [tGuard t | NAggregate a <- specNodes spec, t <- aggTransitions a]-                    === [Just (complementExpr e)]--  describe "evolution parsing" $ do-    it "parses event version and upcaster from reservation-v2.keiro" $ do-      input <- readTestText "test/fixtures/reservation-v2.keiro"-      case parseSpec "test/fixtures/reservation-v2.keiro" input of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> case [e | NAggregate a <- specNodes spec, e <- aggEvents a, evName e == "TransferReservationCreated"] of-          (e : _) -> do-            evVersion e `shouldBe` 2-            evUpcastFrom e `shouldBe` Just (1, Hole)-          [] -> expectationFailure "TransferReservationCreated not found"-    it "round-trips the retiring marker" $ do-      spec <- specOf "test/fixtures/reservation-retiring.keiro"-      parseStableRenderedSpec "<retiring-round-trip>" spec `shouldBe` Right spec-      [evRetiring event | NAggregate aggregate <- specNodes spec, event <- aggEvents aggregate, evName event == "TransferReservationConfirmed"]-        `shouldBe` [True]-    it "rejects an event marked both retiring and deprecated" $ do-      source <- readTestText "test/fixtures/reservation-retiring.keiro"-      let conflicting = T.replace "retiring event TransferReservationConfirmed" "retiring deprecated event TransferReservationConfirmed" source-      parseSpec "<conflicting-retirement-markers>" conflicting `shouldSatisfy` isLeft--  describe "aggregate snapshots (EP-109)" $ do-    it "parses, validates, and round-trips a snapshot policy with codec fixture" $ do-      spec <- specOf "test/fixtures/reservation-snapshot.keiro"-      errorCodesOf "test/fixtures/reservation-snapshot.keiro" `shouldReturn` []-      parseStableRenderedSpec "<snapshot-round-trip>" spec `shouldBe` Right spec-      case [aggregate | NAggregate aggregate <- specNodes spec] of-        [aggregate] -> aggSnapshot aggregate `shouldBe` Just (SnapshotSpec (SnapEvery 100) 1 "7a181ceb7d798d883d28c85201c5c1692bd314a7b489da9128bff91e0f38cd28" noLoc)-        aggregates -> expectationFailure ("expected one snapshot aggregate, got " <> show (length aggregates))-    it "rejects disabled intervals and invalid codec fixtures" $ do-      source <- readTestText "test/fixtures/reservation-snapshot.keiro"-      interval <- parseInlineSpec "<snapshot-zero>" (T.replace "snapshot every 100" "snapshot every 0" source)-      map code (validateSpec interval) `shouldContain` [SnapshotIntervalInvalid]-      version <- parseInlineSpec "<snapshot-version-zero>" (T.replace "state-codec version=1" "state-codec version=0" source)-      map code (validateSpec version) `shouldContain` [SnapshotCodecFixtureInvalid]-      emptyHash <- parseInlineSpec "<snapshot-empty-hash>" (T.replace "shape-hash=\"7a181ceb7d798d883d28c85201c5c1692bd314a7b489da9128bff91e0f38cd28\"" "shape-hash=\"\"" source)-      map code (validateSpec emptyHash) `shouldContain` [SnapshotCodecFixtureInvalid]-    it "conditionally lowers JSON instances and the live defaultStateCodec" $ do-      snapshotService <- checkedServiceOf "test/fixtures/reservation-snapshot.keiro"-      ordinaryService <- checkedServiceOf "test/fixtures/reservation.keiro"-      let snapshot = checkedSpec snapshotService-          ordinary = checkedSpec ordinaryService-      case ([aggregate | NAggregate aggregate <- specNodes snapshot], [aggregate | NAggregate aggregate <- specNodes ordinary]) of-        ([_], [_]) -> do-          let snapshotModules = scaffoldServiceModules (defaultContext (specContext snapshot)) snapshotService-              ordinaryModules = scaffoldServiceModules (defaultContext (specContext ordinary)) ordinaryService-              snapshotDomain = generatedTextEndingIn "Domain.hs" snapshotModules-              snapshotStream = generatedTextEndingIn "EventStream.hs" snapshotModules-              ordinaryDomain = generatedTextEndingIn "Domain.hs" ordinaryModules-              ordinaryStream = generatedTextEndingIn "EventStream.hs" ordinaryModules-          snapshotDomain `shouldSatisfy` T.isInfixOf "deriving anyclass (ToJSON, FromJSON)"-          snapshotStream `shouldSatisfy` T.isInfixOf "snapshotPolicy = Every 100"-          snapshotStream `shouldSatisfy` T.isInfixOf "stateCodec = Just (withFoldFingerprint"-          snapshotStream `shouldSatisfy` T.isInfixOf "Spec-visible fold changes invalidate old"-          snapshotStream `shouldSatisfy` T.isInfixOf "reservationSnapshotFixture = (1, \"7a181ceb7d798d883d28c85201c5c1692bd314a7b489da9128bff91e0f38cd28\")"-          ordinaryDomain `shouldNotSatisfy` T.isInfixOf "DeriveAnyClass"-          ordinaryStream `shouldSatisfy` T.isInfixOf "snapshotPolicy = Never"-          ordinaryStream `shouldSatisfy` T.isInfixOf "stateCodec = Nothing"-          ordinaryStream `shouldSatisfy` T.isInfixOf "reservationCategory = Stream.categoryUnsafe \"reservation\""-          firewallBreaches snapshotModules `shouldBe` []-        _ -> expectationFailure "expected one aggregate in each snapshot test spec"--  describe "aggregate fold fingerprints (plan 138)" $ do-    it "is deterministic across repeated parses and formatting-only changes" $ do-      source <- readTestText "test/fixtures/reservation.keiro"-      first <- parseInlineSpec "<first>" source-      second <- shouldParseStableRenderedSpec "<second>" first-      aggregateFoldFingerprint first (onlyAggregate first)-        `shouldBe` aggregateFoldFingerprint second (onlyAggregate second)-    it "changes for transition writes, guards, and referenced rule bodies" $ do-      base <- specOf "test/fixtures/reservation.keiro"-      writeChanged <- specOf "test/fixtures/reservation-foldchange.keiro"-      guardChanged <- specOf "test/fixtures/reservation-guard-tightened.keiro"-      source <- readTestText "test/fixtures/reservation.keiro"-      ruleChanged <- parseInlineSpec "<rule-change>" (T.replace "RedTag => true" "RedTag => false" source)-      let baseFingerprint = aggregateFoldFingerprint base (onlyAggregate base)-      aggregateFoldFingerprint writeChanged (onlyAggregate writeChanged) `shouldNotBe` baseFingerprint-      aggregateFoldFingerprint guardChanged (onlyAggregate guardChanged) `shouldNotBe` baseFingerprint-      aggregateFoldFingerprint ruleChanged (onlyAggregate ruleChanged) `shouldNotBe` baseFingerprint-    it "ignores wire and projection changes" $ do-      base <- specOf "test/fixtures/reservation.keiro"-      wireChanged <- specOf "test/fixtures/reservation-wire.keiro"-      source <- readTestText "test/fixtures/reservation.keiro"-      projectionChanged <- parseInlineSpec "<projection-change>" (T.replace "projection transfer_decisions" "projection renamed_projection" source)-      let surface = aggregateFoldSurface base (onlyAggregate base)-      aggregateFoldSurface wireChanged (onlyAggregate wireChanged) `shouldBe` surface-      aggregateFoldSurface projectionChanged (onlyAggregate projectionChanged) `shouldBe` surface-    it "invalidates mapped-register snapshots when binding or wire identity changes" $ do-      base <- specOf "test/fixtures/consumer-types.keiro"-      bindingChanged <- specOf "test/fixtures/consumer-types-binding-change.keiro"-      wireChanged <- specOf "test/fixtures/consumer-types-wirekey.keiro"-      let baseFingerprint = aggregateFoldFingerprint base (onlyAggregate base)-      aggregateFoldFingerprint bindingChanged (onlyAggregate bindingChanged) `shouldNotBe` baseFingerprint-      aggregateFoldFingerprint wireChanged (onlyAggregate wireChanged) `shouldNotBe` baseFingerprint--  describe "process/timer (EP-3)" $ do-    it "parses the hospital-surge process + nested timer" $ do-      input <- readTestText "test/fixtures/hospital-surge.keiro"-      case parseSpec "test/fixtures/hospital-surge.keiro" input of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> case [p | NProcess p <- specNodes spec] of-          (p : _) -> do-            procId p `shouldBe` "HospitalSurge"-            procName p `shouldBe` "hospital-surge"-            procRejected p `shouldBe` PolHalt-            procPoison p `shouldBe` PolHalt-            sagaCategory (procSaga p) `shouldBe` "hospitalSurge"-            tmName (procTimer p) `shouldBe` "surgeFollowUp"-            onReject (fireDisposition (tmFire (procTimer p))) `shouldBe` OFired-            onAmbiguous (fireDisposition (tmFire (procTimer p))) `shouldBe` ORetry-            tmMaxAttempts (procTimer p) `shouldBe` 5-          [] -> expectationFailure "no process node parsed"-    it "round-trips the hospital-surge spec through parse . pretty" $ do-      input <- readTestText "test/fixtures/hospital-surge.keiro"-      case parseSpec "in" input of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> parseStableRenderedSpec "in" spec `shouldBe` Right spec-    it "accepts the hospital-surge spec (no errors; benign-inversion warnings only)" $ do-      codes <- errorCodesOf "test/fixtures/hospital-surge.keiro"-      codes `shouldBe` []-    it "rejects illegal saga categories and no longer parses the raw stream-prefix clause" $ do-      spec <- specOf "test/fixtures/hospital-surge.keiro"-      mapM_-        (\categoryName -> processErrorCodes (\process -> process {procSaga = (procSaga process) {sagaCategory = categoryName}}) spec `shouldContain` [SagaCategoryIllegal])-        ["", "$all", "hospital-surge", "hospital surge", "wf:surge"]-      source <- readTestText "test/fixtures/hospital-surge.keiro"-      parseSpec "<legacy-saga>" (T.replace "saga Surge category \"hospitalSurge\"" "saga Surge stream=\"hospital-surge-\" <> correlationId" source)-        `shouldSatisfy` isLeft-    it "rejects a wall-clock fireAt as ProcessFireAtNotInjected" $ do-      codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro"-      codes `shouldContain` [ProcessFireAtNotInjected]-    it "reports one ProcessFireAtNotInjected for a wholly unknown fireAt field" $ do-      codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro"-      length (filter (== ProcessFireAtNotInjected) codes) `shouldBe` 1-    it "rejects a user-supplied dispatch id as ProcessDispatchIdSupplied" $ do-      codes <- errorCodesOf "test/fixtures/hospital-surge-dispatchid.keiro"-      codes `shouldContain` [ProcessDispatchIdSupplied]-    it "rejects an unresolved saga reference as ProcessUnresolvedRef" $ do-      codes <- errorCodesOf "test/fixtures/hospital-surge-badref.keiro"-      codes `shouldContain` [ProcessUnresolvedRef]-    it "rejects unresolved process commands, projections, schedules, and advance ids" $ do-      codes <- errorCodesOf "test/fixtures/process-ghost-refs.keiro"-      length (filter (== ProcessUnresolvedRef) codes) `shouldBe` 5-      codes `shouldContain` [ProcessDispatchIdSupplied]-    it "gates process correlate, dispatch-key, and binding scopes on language 4" $ do-      spec <- specOf "test/fixtures/hospital-surge.keiro"-      let badCorrelate =-            modifyProcess-              "HospitalSurge"-              (\process -> process {procCorrelate = (procCorrelate process) {corrField = "ghost"}})-              spec-          badDispatchKey =-            modifyProcess-              "HospitalSurge"-              ( \process ->-                  let handle = procHandle process-                   in process {procHandle = handle {hDispatch = updateFirst (\dispatch -> dispatch {dispKey = "input.ghost"}) (hDispatch handle)}}-              )-              spec-          badBinding =-            modifyProcess-              "HospitalSurge"-              ( \process ->-                  let handle = procHandle process-                      advance = hAdvance handle-                   in process {procHandle = handle {hAdvance = advance {advFields = updateFirst (\binding -> binding {fbValue = Just "ghost.value"}) (advFields advance)}}}-              )-              spec-          cases =-            [ (badCorrelate, ProcessKeyFieldUnknown),-              (badDispatchKey, ProcessDispatchKeyUnresolved),-              (badBinding, ProcessBindingUnscoped)-            ]-      forM_ cases $ \(candidate, expected) -> do-        serviceErrorCodes 3 candidate `shouldNotContain` [expected]-        serviceErrorCodes 4 candidate `shouldContain` [expected]-      serviceErrorCodes 4 spec-        `shouldNotContain` [ProcessKeyFieldUnknown, ProcessDispatchKeyUnresolved, ProcessBindingUnscoped]--  describe "router (EP-108)" $ do-    it "parses the incident-paging router shape" $ do-      input <- readTestText "test/fixtures/incident-paging/incident-paging.keiro"-      case parseSpec "test/fixtures/incident-paging/incident-paging.keiro" input of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> case [router | NRouter router <- specNodes spec] of-          [router] -> do-            rtId router `shouldBe` "PagingRouter"-            rtName router `shouldBe` "jitsurei-paging"-            corrField (rtKey router) `shouldBe` "incidentId"-            rvSource (rtResolve router) `shouldBe` ResolveReadModel "service_oncall"-            rvRow (rtResolve router) `shouldBe` ["responderId"]-            rdCommand (rtDispatch router) `shouldBe` "SendPage"-            rtRejected router `shouldBe` PolDeadLetter-            rtPoison router `shouldBe` PolHalt-          routers -> expectationFailure ("expected one router, got " <> show (length routers))-    it "round-trips the incident-paging spec through parse . pretty" $ do-      input <- readTestText "test/fixtures/incident-paging/incident-paging.keiro"-      case parseSpec "in" input of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> parseStableRenderedSpec "in" spec `shouldBe` Right spec-    it "accepts the incident-paging router with warnings only" $ do-      codes <- errorCodesOf "test/fixtures/incident-paging/incident-paging.keiro"-      codes `shouldBe` []-      diagnostics <- diagnosticCodesOf "test/fixtures/incident-paging/incident-paging.keiro"-      diagnostics `shouldContain` [PolicyDeadLetterUnused, AmbiguousFollowsRejectedPolicy]-    it "rejects unresolved targets, keys, commands, and binding scopes" $ do-      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"-      routerErrorCodes (\router -> router {rtTarget = "Pge"}) spec `shouldContain` [RouterUnresolvedRef]-      routerErrorCodes (\router -> router {rtKey = (rtKey router) {corrField = "incidntId"}}) spec `shouldContain` [RouterKeyFieldUnknown]-      routerErrorCodes (\router -> router {rtDispatch = (rtDispatch router) {rdCommand = "SendPag"}}) spec `shouldContain` [RouterCommandUnknown]-      routerErrorCodes-        ( \router ->-            let dispatch = rtDispatch router-             in router {rtDispatch = dispatch {rdFields = [FieldBinding "responderId" (Just "resolved.responder")]}}-        )-        spec-        `shouldContain` [RouterBindingUnscoped]-    it "rejects unresolved read models and contradictory rejection policies" $ do-      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"-      let withoutReadModel = removeReadModel "service_oncall" spec-      errorCodes withoutReadModel `shouldContain` [RouterUnresolvedRef]-      routerErrorCodes-        ( \router ->-            let dispatch = rtDispatch router-                disposition = rdDisposition dispatch-             in router-                  { rtRejected = PolHalt,-                    rtDispatch = dispatch {rdDisposition = disposition {onFailed = DDeadLetter "page rejected"}}-                  }-        )-        spec-        `shouldContain` [PolicyContradiction]-    it "gates resolve-row column verification on language 4" $ do-      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"-      let unresolved =-            modifyRouter-              "PagingRouter"-              (\router -> router {rtResolve = (rtResolve router) {rvRow = ["ghostColumn"]}})-              spec-      serviceErrorCodes 3 unresolved `shouldNotContain` [RouterReadModelUnverified]-      serviceErrorCodes 4 unresolved `shouldContain` [RouterReadModelUnverified]-      serviceErrorCodes 4 spec `shouldNotContain` [RouterReadModelUnverified]-    it "rejects on-ambiguous Fired for process timers" $ do-      spec <- specOf "test/fixtures/hospital-surge.keiro"-      let changed =-            spec-              { specNodes =-                  [ case node of-                      NProcess process ->-                        let timer = procTimer process-                            fire = tmFire timer-                            disposition = fireDisposition fire-                         in NProcess process {procTimer = timer {tmFire = fire {fireDisposition = disposition {onAmbiguous = OFired}}}}-                      _ -> node-                  | node <- specNodes spec-                  ]-              }-      errorCodes changed `shouldContain` [AmbiguousMarkedBenign]-    it "requires explicit policy and ambiguity clauses in the grammar" $ do-      source <- readTestText "test/fixtures/hospital-surge.keiro"-      parseSpec "<missing-poison>" (T.replace "  poison => halt\n" "" source) `shouldSatisfy` isLeft-      parseSpec "<missing-ambiguous>" (T.replace " ; on-ambiguous Retry" "" source) `shouldSatisfy` isLeft-    it "scaffolds firewall-clean router wiring, policies, and typed-hole guidance" $ do-      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"-      case [router | NRouter router <- specNodes spec] of-        [router] -> do-          let ctx = defaultContext (specContext spec)-              modules = scaffoldRouter ctx router-              generated = [m | m <- modules, kind m == Generated]-              holes = [m | m <- modules, kind m == HoleStub]-          firewallBreaches generated `shouldBe` []-          case (generated, holes) of-            ([generatedModule], [holeModule]) -> do-              moduleText generatedModule `shouldSatisfy` T.isInfixOf "pagingRouterWorkerOptions"-              moduleText generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedDeadLetter"-              moduleText holeModule `shouldSatisfy` T.isInfixOf "UNION of resolved target identities"-              moduleText holeModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate"-            _ -> expectationFailure "expected one generated router module and one router hole module"-        routers -> expectationFailure ("expected one router, got " <> show (length routers))-    it "requires a caller callback for non-halting poison policies" $ do-      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"-      case [router | NRouter router <- specNodes spec] of-        [router] -> do-          let ctx = defaultContext (specContext spec)-              generatedFor choice = [moduleText m | m <- scaffoldRouter ctx router {rtPoison = choice}, kind m == Generated]-          mapM_-            ( \(choice, constructor) -> case generatedFor choice of-                [generatedModule] -> do-                  generatedModule `shouldSatisfy` T.isInfixOf "(Envelope msg -> Eff es ()) -> WorkerOptions es msg"-                  generatedModule `shouldSatisfy` T.isInfixOf (constructor <> " poisonCallback")-                _ -> expectationFailure "expected one generated router module"-            )-            [(PolDeadLetter, "PoisonDeadLetter"), (PolSkip, "PoisonSkip")]-          case [moduleText m | m <- scaffoldRouter ctx router {rtRejected = PolSkip}, kind m == Generated] of-            [generatedModule] -> generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedSkip"-            _ -> expectationFailure "expected one generated router module"-        routers -> expectationFailure ("expected one router, got " <> show (length routers))-    it "emits router harness facts that pin policy and target-keyed identity" $ do-      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"-      case [router | NRouter router <- specNodes spec] of-        [router] -> case harnessRouter (defaultContext (specContext spec)) router of-          [facts] -> do-            moduleText facts `shouldSatisfy` T.isInfixOf "(\"rejectedPolicy\", \"deadLetter\")"-            moduleText facts `shouldSatisfy` T.isInfixOf "targetStreamName, occurrence"-          modules -> expectationFailure ("expected one router harness, got " <> show (length modules))-        routers -> expectationFailure ("expected one router, got " <> show (length routers))-    it "rejects invalid timer ceilings and target field bindings" $ do-      codes <- errorCodesOf "test/fixtures/process-bad-timer.keiro"-      mapM_-        (\expected -> codes `shouldContain` [expected])-        [ProcessTimerCeilingInvalid, ProcessFieldBindingUnresolved]-    it "accepts resolved process projection references" $ do-      codes <- errorCodesOf "test/fixtures/surge-service.keiro"-      codes `shouldBe` []-    it "scaffolds the process: Generated wiring is firewall-clean + a HoleStub" $ do-      mods <- legacyScaffoldProcessFixture "test/fixtures/hospital-surge.keiro"-      let gens = [m | m <- mods, kind m == Generated]-          holes = [m | m <- mods, kind m == HoleStub]-      length holes `shouldBe` 1-      firewallBreaches gens `shouldBe` []-      case gens of-        [generatedModule] -> do-          -- the worker uses the spec's ceiling, never the dangerous default-          moduleText generatedModule `shouldSatisfy` T.isInfixOf "max-attempts = 5"-          moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeProcessWorkerOptions"-          moduleText generatedModule `shouldSatisfy` T.isInfixOf "import Generated.HospitalCapacity.Surge.EventStream (SurgeEventStreamDef)"-          moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeCategory :: Stream.StreamCategory SurgeEventStreamDef"-          moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeCategory = Stream.categoryUnsafe \"hospitalSurge\""-          moduleText generatedModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate"-          moduleText generatedModule `shouldSatisfy` T.isInfixOf "StreamName -> EventId -> CommandError -> Eff es Bool"-          moduleText generatedModule `shouldSatisfy` T.isInfixOf "Left (CommandAmbiguous _)"-          case holes of-            [holeModule] -> moduleText holeModule `shouldSatisfy` T.isInfixOf "entityStream hospitalSurgeCategory"-            _ -> expectationFailure "expected one process hole module"-        _ -> expectationFailure "expected one generated process module"-    it "process scaffold is deterministic" $ do-      a <- legacyScaffoldProcessFixture "test/fixtures/hospital-surge.keiro"-      b <- legacyScaffoldProcessFixture "test/fixtures/hospital-surge.keiro"-      map moduleText a `shouldBe` map moduleText b-    it "separates aggregate event-stream and command-target categories and emits stable typed sums" $ do-      spec <- specOf "test/fixtures/hospital-surge.keiro"-      let ctx = defaultContext (specContext spec)-          modules = concat [scaffoldAggregate ctx spec aggregate | NAggregate aggregate <- specNodes spec]-          surgeStream = generatedTextEndingIn "Surge/EventStream.hs" modules-          surgeDomain = generatedTextEndingIn "Surge/Domain.hs" modules-      surgeStream `shouldSatisfy` T.isInfixOf "surgeCategory :: Stream.StreamCategory SurgeEventStreamDef"-      surgeStream `shouldSatisfy` T.isInfixOf "surgeCommandCategory :: Stream.StreamCategory SurgeCommand"-      surgeDomain `shouldNotSatisfy` T.isInfixOf "{-# LANGUAGE EmptyDataDecls #-}"-      surgeDomain `shouldSatisfy` T.isInfixOf "data SurgeEvent = SurgeThresholdNoted"-      surgeDomain `shouldSatisfy` (not . T.isInfixOf "data SurgeEvent = ()")--  describe "contract (EP-4)" $ do-    it "parses the emergency contract (topics + events-on-topic + typed fields)" $ do-      input <- readTestText "test/fixtures/contract.keiro"-      case parseSpec "test/fixtures/contract.keiro" input of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> case [c | NContract c <- specNodes spec] of-          (c : _) -> do-            ctrName c `shouldBe` "emergency"-            ctrDiscriminator c `shouldBe` "messageType"-            map fst (ctrTopics c) `shouldBe` ["incidentEvents", "hospitalEvents"]-            map ceName (ctrEvents c) `shouldBe` ["IncidentTransferNeedDeclared", "TransferReservationAccepted"]-          [] -> expectationFailure "no contract node parsed"--    it "branches contract scaffolding, manifests, and durable identities only for language 4" $ do-      sourceText <- readTestText "test/fixtures/contract-v4.keiro"-      parsed <- case parseSource "contract-v4.keiro" sourceText of-        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-        Right value -> pure value-      let service = checkedSource parsed-          spec = checkedSpec service-          ctx = defaultContext (specContext spec)-      contract <- case [value | NContract value <- specNodes spec] of-        [value] -> pure value-        values -> expectationFailure ("expected one contract, got " <> show (length values)) >> fail "unreachable"-      legacyModule <- case scaffoldContract ctx contract of-        [value] -> pure value-        values -> expectationFailure ("expected one legacy module, got " <> show (length values)) >> fail "unreachable"-      typedModule <- case scaffoldContractForService ctx service contract of-        [value] -> pure value-        values -> expectationFailure ("expected one typed module, got " <> show (length values)) >> fail "unreachable"-      let dependencies = manifestDependenciesForService service-          identities = idDomainIdentitiesForService service-          manifestText = renderManifestForService "contract-v4.keiro" [typedModule] service-      assertGeneratedHaskellContract "contract-v4.keiro" manifestText-      committed <- readTestText "test/conformance-contract/Generated/HospitalCapacity/Emergency/Contract.hs"-      normalizeGenerated (moduleText typedModule) `shouldBe` normalizeGenerated committed-      moduleText legacyModule `shouldSatisfy` T.isInfixOf "incidentId :: !Text"-      moduleText legacyModule `shouldSatisfy` (not . T.isInfixOf "KindID")-      moduleText typedModule `shouldSatisfy` T.isInfixOf "incidentId :: !(KindID \"inc\")"-      moduleText typedModule `shouldSatisfy` T.isInfixOf "KindID.toText payload.incidentId"-      moduleText typedModule `shouldSatisfy` T.isInfixOf "explicitParseField (parseKindIdV7Value @\"inc\") o \"incidentId\""-      moduleText typedModule `shouldSatisfy` T.isInfixOf "  , incidentEventsTopic"-      moduleText typedModule `shouldSatisfy` T.isInfixOf "  , hospitalEventsTopic"-      moduleText typedModule `shouldSatisfy` (not . T.isInfixOf "Wno-unused-top-binds")-      dependencies `shouldBe` ["aeson", "base", "keiro-core", "mmzk-typeid", "text"]-      manifestDependencies spec `shouldBe` ["aeson", "base", "text"]-      forM_ dependencies $ \dependency -> manifestText `shouldSatisfy` T.isInfixOf ("    , " <> dependency)-      identities-        `shouldBe` [ "id-domain|name=contract:emergency.IncidentTransferNeedDeclared.incidentId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=inc|separator=_|json=canonical-json-text",-                     "id-domain|name=contract:emergency.TransferReservationAccepted.incidentId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=inc|separator=_|json=canonical-json-text",-                     "id-domain|name=contract:emergency.TransferReservationAccepted.reservationId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=rsv|separator=_|json=canonical-json-text",-                     "id-domain|name=contract:emergency.TransferReservationAccepted.hospitalId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=hsp|separator=_|json=canonical-json-text"-                   ]--    it "persists contract ID domains in single-file and workspace records with owner attribution" $ do-      sourceText <- readTestText "test/fixtures/contract-v4.keiro"-      parsed <- case parseSource "contract-v4.keiro" sourceText of-        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-        Right value -> pure value-      let service = checkedSource parsed-          spec = checkedSpec service-          ctx = defaultContext (specContext spec)-          modules = scaffoldServiceModules ctx service-          identities = idDomainIdentitiesForService service-      duplicateIdentity <- case identities of-        value : _ -> pure value-        [] -> expectationFailure "typed contract service did not expose ID-domain identities" >> fail "unreachable"-      withTempDirectory "keiro-dsl-v4-contract-record" $ \out -> do-        result <- executeServiceScaffold out False "contract-v4.keiro" (parsedSourceLanguage parsed) ctx service modules-        result `shouldSatisfy` isRight-        contents <- TIO.readFile (out </> recordFileName (specContext spec))-        record <- maybe (expectationFailure "typed contract scaffold record did not parse" >> fail "unreachable") pure (parseRecord contents)-        recIdDomains record `shouldBe` identities-        parseRecord (contents <> "id-domain " <> duplicateIdentity <> "\n") `shouldBe` Nothing--      let manifest = "service hospital-capacity\nspec domain/contract.keiro\n"-          source = memoryContentSource (Map.fromList [("service.keiro-workspace", manifest), ("domain/contract.keiro", sourceText)])-      loaded <- loadWorkspace source "service.keiro-workspace"-      workspace <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure loaded-      workspacePlan <- either (\refusals -> expectationFailure (show refusals) >> fail "unreachable") pure (planWorkspaceScaffold "goldens" ctx workspace)-      case [provenance | (scaffoldModule, provenance) <- wpModules workspacePlan, modulePath scaffoldModule == "Generated/HospitalCapacity/Emergency/Contract.hs"] of-        [MemberOwned owner] -> owner `shouldBe` "domain/contract.keiro"-        values -> expectationFailure ("expected one member-owned contract module, got " <> show values)-      withTempDirectory "keiro-dsl-v4-contract-workspace-record" $ \out -> do-        result <- executeWorkspaceScaffold out False workspacePlan-        result `shouldSatisfy` isRight-        contents <- TIO.readFile (out </> workspaceRecordFileName (wsService workspace))-        record <- maybe (expectationFailure "typed contract workspace record did not parse" >> fail "unreachable") pure (parseWorkspaceRecord contents)-        wrIdDomains record `shouldBe` identities-        [(wrmPath row, wrmOwner row) | row <- wrModules record, wrmPath row == "Generated/HospitalCapacity/Emergency/Contract.hs"]-          `shouldBe` [("Generated/HospitalCapacity/Emergency/Contract.hs", Just "domain/contract.keiro")]-        parseWorkspaceRecord (contents <> "id-domain " <> duplicateIdentity <> "\n") `shouldBe` Nothing-    it "round-trips the contract spec through parse . pretty" $ do-      input <- readTestText "test/fixtures/contract.keiro"-      case parseSource "in" input of-        Left failure -> expectationFailure (T.unpack (renderParseFailure failure))-        Right source -> parseSource "in" (renderSource source) `shouldBe` Right source-    it "round-trips the intake (inbox) spec through parse . pretty" $ do-      input <- readTestText "test/fixtures/intake.keiro"-      case parseSpec "in" input of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec-    it "accepts the intake spec (complete disposition, no inversions)" $ do-      codes <- errorCodesOf "test/fixtures/intake.keiro"-      codes `shouldBe` []-    it "warns when intake bind flags describe unenforced generated behavior" $ do-      codes <- diagnosticCodesOf "test/fixtures/intake.keiro"-      codes `shouldContain` [IntakeBindFlagUnenforced]-    it "lowers explicit dedupe-only persistence and defaults omission to full-envelope" $ do-      spec <- specOf "test/fixtures/intake.keiro"-      ordinary <- specOf "test/fixtures/intake-decode.keiro"-      case ([intake | NIntake intake <- specNodes spec], [intake | NIntake intake <- specNodes ordinary]) of-        ([intake], [defaultIntake]) -> do-          inkPersist intake `shouldBe` InkPersistDedupeOnly-          inkPersist defaultIntake `shouldBe` InkPersistFull-          renderSpec spec `shouldSatisfy` T.isInfixOf "persist = dedupe-only"-          renderSpec ordinary `shouldNotSatisfy` T.isInfixOf "persist ="-          let inbox = generatedTextEndingIn "Inbox.hs" (scaffoldIntake (defaultContext (specContext spec)) intake)-          inbox `shouldSatisfy` T.isInfixOf "inboxPersistence = PersistDedupeOnly"-          inbox `shouldSatisfy` T.isInfixOf "data IncidentInboxOutcome"-          inbox `shouldSatisfy` T.isInfixOf "data IncidentInboxDisposition"-          inbox `shouldSatisfy` T.isInfixOf "InboxRetryAfter !RetryDelay !(Maybe InboxFailure)"-          inbox `shouldSatisfy` T.isInfixOf "InboxDeadLetter !(Maybe Text) !(Maybe InboxFailure)"-          inbox `shouldSatisfy` T.isInfixOf "InboxHandlerFailed reason attempts ->"-          inbox `shouldNotSatisfy` T.isInfixOf "Nothing -> InboxRetry"-        (intakes, defaultIntakes) ->-          expectationFailure ("expected one intake in each fixture, got " <> show (length intakes, length defaultIntakes))-    it "rejects duplicate => retry (inversion 1)" $ do-      codes <- errorCodesOf "test/fixtures/intake-dup-retry.keiro"-      codes `shouldContain` [DispositionDuplicateRetry]-    it "rejects previouslyFailed => retry (inversion 2)" $ do-      codes <- errorCodesOf "test/fixtures/intake-pf-retry.keiro"-      codes `shouldContain` [DispositionPreviouslyFailedRetry]-    it "rejects an incomplete disposition table" $ do-      codes <- errorCodesOf "test/fixtures/intake-incomplete.keiro"-      codes `shouldContain` [DispositionIncomplete]-    it "rejects a shadowing duplicate intake disposition row" $ do-      codes <- errorCodesOf "test/fixtures/intake-dup-row.keiro"-      codes `shouldContain` [DispositionDuplicateOutcome]-    it "rejects intake events declared on another topic" $ do-      codes <- errorCodesOf "test/fixtures/intake-topic-mismatch.keiro"-      codes `shouldContain` [TopicAffinityMismatch]-    it "round-trips the emit/publisher spec through parse . pretty" $ do-      input <- readTestText "test/fixtures/emit.keiro"-      case parseSpec "in" input of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec-    it "accepts the emit/publisher spec (skip present, coupling resolves)" $ do-      codes <- errorCodesOf "test/fixtures/emit.keiro"-      codes `shouldBe` []-    -- `derive … hole` is mandatory emit grammar, so a diagnostic saying it-    -- generates nothing would fire on every emit node in every spec and could-    -- never be resolved. It is the scaffold report's inert-node line (asserted-    -- immediately below) that carries the fact, once per run. See ExecPlan 199.-    it "leaves an emit-bearing spec clean enough for --deny-warnings" $ do-      (exitCode, out, err) <- runKeiroDsl ["check", "test/fixtures/emit.keiro", "--deny-warnings"]-      unless (exitCode == ExitSuccess) (expectationFailure (out <> err))-      err `shouldNotContain` "escalated to failure"-    it "reports emit nodes that contribute no generated modules" $-      withTempDirectory "keiro-dsl-inert-report" $ \out -> do-        spec <- specOf "test/fixtures/emit.keiro"-        report <- executePlannedScaffold out "test/fixtures/emit.keiro" (defaultContext (specContext spec)) spec-        reportInertNodes report `shouldBe` [("emit", "reservationResponse")]-        renderScaffoldReport report-          `shouldSatisfy` any-            ( T.isInfixOf-                "no-modules: emit reservationResponse (validated and diff-classified; no generated modules)"-            )-    it "rejects a missing _ => skip catch-all as EmitSkipMissing" $ do-      codes <- errorCodesOf "test/fixtures/emit-noskip.keiro"-      codes `shouldContain` [EmitSkipMissing]-    it "rejects mapping to an undeclared contract event as EmitUnresolvedContract" $ do-      codes <- errorCodesOf "test/fixtures/emit-badevent.keiro"-      codes `shouldContain` [EmitUnresolvedContract]-    it "rejects emit events declared on another topic" $ do-      codes <- errorCodesOf "test/fixtures/emit-topic-mismatch.keiro"-      codes `shouldContain` [TopicAffinityMismatch]--  describe "pgmq workqueue/dispatch (EP-5)" $ do-    it "round-trips the reservation-work spec through parse . pretty" $ do-      input <- readTestText "test/fixtures/reservation-work.keiro"-      case parseSpec "in" input of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec-    it "accepts the reservation-work spec (physical matches, no inversions)" $ do-      codes <- errorCodesOf "test/fixtures/reservation-work.keiro"-      codes `shouldBe` []-    it "rejects a divergent captured physical name as WqPhysicalDivergence" $ do-      codes <- errorCodesOf "test/fixtures/reservation-work-divergent.keiro"-      codes `shouldContain` [WqPhysicalDivergence]-    it "rejects storeFailure => deadLetter as WqStoreFailureNotRetry" $ do-      codes <- errorCodesOf "test/fixtures/reservation-work-sf-deadletter.keiro"-      codes `shouldContain` [WqStoreFailureNotRetry]-    it "rejects decodeFailure => retry as WqDecodeFailureNotDeadLetter" $ do-      codes <- errorCodesOf "test/fixtures/reservation-work-df-retry.keiro"-      codes `shouldContain` [WqDecodeFailureNotDeadLetter]-    it "requires complete, unique workqueue disposition rows" $ do-      incomplete <- errorCodesOf "test/fixtures/workqueue-incomplete.keiro"-      incomplete `shouldContain` [WqDispositionIncomplete]-      duplicateSpec <- specOf "test/fixtures/workqueue-dup-row.keiro"-      let duplicateDiagnostics = [d | d <- validateSpec duplicateSpec, code d == DispositionDuplicateOutcome]-      map line duplicateDiagnostics `shouldBe` [18]-    it "checks the captured queueRef dlq and table fixtures" $ do-      dlqCodes <- errorCodesOf "test/fixtures/workqueue-dlq-divergent.keiro"-      dlqCodes `shouldContain` [WqDlqDivergence]-      tableCodes <- errorCodesOf "test/fixtures/workqueue-table-divergent.keiro"-      tableCodes `shouldContain` [WqTableDivergence]-    it "matches queueRef for upper-case, punctuation, and hashed logical names" $ do-      upper <- errorCodesOf "test/fixtures/workqueue-uppercase-logical.keiro"-      upper `shouldBe` []-      hashed <- errorCodesOf "test/fixtures/workqueue-hashed-logical.keiro"-      hashed `shouldBe` []-      derivedQueueTrio "hospital_capacity.reservation_work.per_hospital_fifo_lane_assignments"-        `shouldBe` ( "hospital_capacity_reservat_757040df00976c33",-                     "hospital_capacity_reservat_757040df00976c33_dlq",-                     "pgmq.q_hospital_capacity_reservat_757040df00976c33"-                   )-    it "resolves dispatch dedup queues and payload wire fields" $ do-      ghost <- errorCodesOf "test/fixtures/dispatch-dedup-ghost-queue.keiro"-      ghost `shouldContain` [DispatchDedupQueueUnresolved]-      field <- errorCodesOf "test/fixtures/dispatch-dedup-bad-field.keiro"-      field `shouldContain` [DispatchDedupFieldUnresolved]-    it "requires a resolvable group key exactly when ordering is FIFO" $ do-      noKey <- errorCodesOf "test/fixtures/reservation-work-fifo-nokey.keiro"-      noKey `shouldContain` [WqGroupKeyMissing]-      unordered <- errorCodesOf "test/fixtures/reservation-work-key-unordered.keiro"-      unordered `shouldContain` [WqGroupKeyWithoutFifo]-      source <- readTestText "test/fixtures/reservation-work.keiro"-      unresolved <- parseInlineSpec "<unresolved-group-key>" (T.replace "group key from reservationId" "group key from missingId" source)-      map code (validateSpec unresolved) `shouldContain` [WqGroupKeyUnresolved]-    it "warns on unlogged storage and rejects empty partition settings" $ do-      warningCodes <- diagnosticCodesOf "test/fixtures/reservation-work-unlogged.keiro"-      warningCodes `shouldContain` [WqUnloggedDurability]-      partitionCodes <- errorCodesOf "test/fixtures/reservation-work-partitioned-empty.keiro"-      partitionCodes `shouldContain` [WqPartitionSpecEmpty]-    -- Every payload field is required — generated decoders use `o .:` for all of-    -- them — so the marker no longer selects anything. A source that omits it and-    -- a source that writes it describe the same queue and produce identical-    -- output. See ExecPlan 199.-    it "treats a payload field as required whether or not the marker is written" $ do-      unmarkedSource <- readTestText "test/fixtures/reservation-work-optfield.keiro"-      let bare = "    note -> \"note\" text"-          markedSource = T.replace bare (bare <> " required") unmarkedSource-      unmarkedSource `shouldSatisfy` T.isInfixOf bare-      parseSpec "unmarked" unmarkedSource `shouldBe` parseSpec "marked" markedSource-      errorCodesOf "test/fixtures/reservation-work-optfield.keiro" >>= (`shouldBe` [])-    it "lowers ordering, provisioning, and raw group-key projection" $ do-      spec <- specOf "test/fixtures/reservation-work.keiro"-      case [workqueue | NWorkqueue workqueue <- specNodes spec] of-        workqueue : _ -> do-          let modules = scaffoldWorkqueue (defaultContext (specContext spec)) workqueue-              queue = generatedTextEndingIn "Queue.hs" modules-              policy = generatedTextEndingIn "QueuePolicy.hs" modules-          queue `shouldSatisfy` T.isInfixOf "groupKeyFor payload = payload.reservationId"-          policy `shouldSatisfy` T.isInfixOf "jobOrdering = FifoThroughput"-          policy `shouldSatisfy` T.isInfixOf "withFifoIndexProvision (standardProvision)"-          policy `shouldSatisfy` T.isInfixOf "data ReservationWorkOutcome"-          policy `shouldSatisfy` T.isInfixOf "jobOutcomeFor :: ReservationWorkOutcome -> JobOutcome"-          policy `shouldNotSatisfy` T.isInfixOf "jobOutcomeFor :: Text -> JobOutcome"-          policy `shouldNotSatisfy` T.isInfixOf "  _ -> Retry"-          firewallBreaches modules `shouldBe` []-        [] -> expectationFailure "reservation-work fixture has no workqueue"--  describe "readmodel (EP-107)" $ do-    it "parses and round-trips first-class read models" $ do-      spec <- specOf "test/fixtures/readmodel.keiro"-      case [readModel | NReadModel readModel <- specNodes spec] of-        [subscriptionModel, inlineModel] -> do-          rmName subscriptionModel `shouldBe` "transfer_decisions"-          rmColumns subscriptionModel-            `shouldBe` [ RmColumn "reservation_id" "text" True,-                         RmColumn "hospital_id" "text" True,-                         RmColumn "status" "text" True,-                         RmColumn "decided_at" "timestamptz" False-                       ]-          rmScope subscriptionModel `shouldBe` Just (RmCategory "reservation")-          rmFeed subscriptionModel `shouldBe` RmSubscription-          rmSubscription subscriptionModel `shouldBe` Just "hospital-capacity-transfer-decisions-sub"-          rmName inlineModel `shouldBe` "subscriptions"-          rmScope inlineModel `shouldBe` Nothing-          rmFeed inlineModel `shouldBe` RmInline-        nodes -> expectationFailure ("expected two readmodel nodes, got " <> show (length nodes))-      parseStableRenderedSpec "in" spec `shouldBe` Right spec-    it "accepts an aggregate projection without a consistency clause" $ do-      spec <- parseInlineSpec "<projection-without-consistency>" projectionWithoutConsistencySpec-      case [projection | NAggregate aggregate <- specNodes spec, Just projection <- [aggProjection aggregate]] of-        [projection] -> projConsistency projection `shouldBe` Nothing-        projections -> expectationFailure ("expected one projection, got " <> show (length projections))-    it "pins the canonical UTF-8 shape digest and runtime identities" $ do-      spec <- specOf "test/fixtures/readmodel.keiro"-      case [readModel | NReadModel readModel <- specNodes spec] of-        (subscriptionModel : inlineModel : _) -> do-          canonicalShape subscriptionModel-            `shouldBe` "transfer_decisions|reservation_id:text:req|hospital_id:text:req|status:text:req|decided_at:timestamptz:null"-          deriveShapeHash subscriptionModel `shouldBe` "fnv1a:3717f6d9e3c44bd6"-          deriveShapeHash inlineModel `shouldBe` "fnv1a:f54d9bb2f40a6738"-          registryNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions"-          subscriptionNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions-sub"-          subscriptionNameFor "billing" inlineModel `shouldBe` "billing-subscriptions-sub"-        nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes))-    it "accepts the positive readmodel fixture with all references resolved" $ do-      spec <- specOf "test/fixtures/readmodel.keiro"-      validateSpec spec `shouldBe` []-    it "rejects shape drift and unknown SQL column types" $ do-      codes <- errorCodesOf "test/fixtures/readmodel-shape-drift.keiro"-      codes `shouldContain` [RmShapeHashDrift, RmUnknownColumnType]-    it "rejects Strong on inline and standalone projections" $ do-      inlineCodes <- errorCodesOf "test/fixtures/readmodel-strong-inline.keiro"-      inlineCodes `shouldContain` [RmStrongInlineOnly]-      standalone <- specOf "test/fixtures/readmodel-strong-standalone.keiro"-      let diagnostics = validateSpec standalone-      map code diagnostics `shouldContain` [RmStrongInlineOnly, RmProjectionWithoutNode]-      [severity diagnostic | diagnostic <- diagnostics, code diagnostic == RmProjectionWithoutNode]-        `shouldBe` [Warning]-    it "rejects scope without Strong and an unreferenced inline feed" $ do-      scopeCodes <- errorCodesOf "test/fixtures/readmodel-scope-eventual.keiro"-      scopeCodes `shouldContain` [RmScopeWithoutStrong]-      inlineCodes <- errorCodesOf "test/fixtures/readmodel-inline-unreferenced.keiro"-      inlineCodes `shouldContain` [RmInlineFeedUnreferenced]-    it "warns when an inline feed carries an ignored subscription override" $ do-      source <- readTestText "test/fixtures/readmodel.keiro"-      spec <--        parseInlineSpec-          "<inline-subscription>"-          (T.replace "  feed = inline\n" "  feed = inline\n  subscription = \"ignored-subscription\"\n" source)-      diagnosticCodes spec `shouldContain` [RmInlineSubscriptionIgnored]-    it "rejects projection consistency conflicts" $ do-      codes <- errorCodesOf "test/fixtures/readmodel-consistency-conflict.keiro"-      codes `shouldContain` [RmConsistencyConflict]-    it "resolves query read models and validates query consistency" $ do-      codes <- errorCodesOf "test/fixtures/readmodel-query-unresolved.keiro"-      codes `shouldContain` [QueryUnresolvedReadModel, QueryConsistencyInvalid]-    it "resolves dispatch read models and declared dedup columns" $ do-      codes <- errorCodesOf "test/fixtures/readmodel-dispatch-unresolved.keiro"-      codes `shouldContain` [DispatchReadModelUnresolved, DispatchReadModelFieldUnknown]-    it "scaffolds runtime records, rebuild helpers, async wiring, and typed holes" $ do-      spec <- specOf "test/fixtures/readmodel.keiro"-      let ctx = defaultContext (specContext spec)-          readModels = [readModel | NReadModel readModel <- specNodes spec]-          modules = concatMap (scaffoldReadModel ctx) readModels-          transfer = generatedTextEndingIn "TransferDecisions/ReadModel.hs" modules-          inline = generatedTextEndingIn "Subscriptions/ReadModel.hs" modules-          transferHoles = [moduleText m | m <- modules, "TransferDecisions/ReadModelHoles.hs" `T.isSuffixOf` T.pack (modulePath m)]-      length modules `shouldBe` 6-      length [m | m <- modules, kind m == Generated] `shouldBe` 4-      length [m | m <- modules, kind m == HoleStub] `shouldBe` 2-      firewallBreaches modules `shouldBe` []-      transfer `shouldSatisfy` T.isInfixOf "registerTransferDecisions"-      transfer `shouldSatisfy` T.isInfixOf "Rebuild.startRebuild transferDecisionsReadModel [\"hospital-capacity-transfer-decisions-async\"]"-      transfer `shouldSatisfy` T.isInfixOf "strongScope = CategoryHead \"reservation\""-      transfer `shouldSatisfy` T.isInfixOf "transferDecisionsAsyncProjection"-      inline `shouldSatisfy` T.isInfixOf "Rebuild.startRebuild subscriptionsReadModel []"-      inline `shouldNotSatisfy` T.isInfixOf "AsyncProjection"-      transferHoles `shouldSatisfy` any (T.isInfixOf "RecordedEvent -> Tx.Transaction ()")-    it "threads qualified table and column guidance into aggregate projection holes" $ do-      spec <- specOf "test/fixtures/readmodel.keiro"-      case [aggregate | NAggregate aggregate <- specNodes spec] of-        [aggregate] -> do-          let modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate-              holes = [moduleText m | m <- modules, kind m == HoleStub]-              projection = generatedTextEndingIn "Projection.hs" modules-          holes `shouldSatisfy` any (T.isInfixOf "subscriptionsQualifiedTable")-          holes `shouldSatisfy` any (T.isInfixOf "Table: \"billing\".\"subscriptions\"")-          projection `shouldSatisfy` T.isInfixOf "ReadModelTable.subscriptionsQualifiedTable"-        aggregates -> expectationFailure ("expected one aggregate, got " <> show (length aggregates))-    it "emits runtime-free derivation facts for each read model" $ do-      spec <- specOf "test/fixtures/readmodel.keiro"-      case [readModel | NReadModel readModel <- specNodes spec] of-        (subscriptionModel : _) -> do-          let modules = harnessReadModel (defaultContext (specContext spec)) subscriptionModel-              harnessText = generatedTextEndingIn "ReadModelHarness.hs" modules-          length modules `shouldBe` 1-          firewallBreaches modules `shouldBe` []-          harnessText `shouldSatisfy` T.isInfixOf "{-# LANGUAGE OverloadedRecordDot #-}"-          harnessText `shouldSatisfy` T.isInfixOf "import Generated.HospitalCapacity.TransferDecisions.ReadModel (transferDecisionsReadModel, transferDecisionsAsyncProjection)"-          harnessText `shouldSatisfy` T.isInfixOf "(\"shapeHash\", \"fnv1a:3717f6d9e3c44bd6\", T.unpack transferDecisionsReadModel.shapeHash)"-          harnessText `shouldSatisfy` T.isInfixOf "(\"strongScope\", \"CategoryHead reservation\", renderStrongScope transferDecisionsReadModel.strongScope)"-          harnessText `shouldSatisfy` T.isInfixOf "T.unpack transferDecisionsAsyncProjection.name"-          harnessText `shouldSatisfy` T.isInfixOf "runReadModelFacts"-        nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes))--  describe "workflow/operation (EP-6)" $ do-    it "round-trips the workflow spec through parse . pretty" $ do-      input <- readTestText "test/fixtures/workflow.keiro"-      case parseSpec "in" input of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> parseStableRenderedSpec "in" spec `shouldBe` Right spec-    it "accepts the workflow spec (await<->signal matches, run resolves)" $ do-      codes <- errorCodesOf "test/fixtures/workflow.keiro"-      codes `shouldBe` []-    it "rejects a signal label with no matching await as AwaitSignalMismatch" $ do-      codes <- errorCodesOf "test/fixtures/workflow-signal-mismatch.keiro"-      codes `shouldContain` [AwaitSignalMismatch]-    it "rejects duplicate workflow labels" $ do-      codes <- errorCodesOf "test/fixtures/workflow-dup-label.keiro"-      codes `shouldContain` [WorkflowDuplicateLabel]-    it "rejects unresolved workflow id and sleep fields" $ do-      codes <- errorCodesOf "test/fixtures/workflow-unresolved-fields.keiro"-      codes `shouldContain` [WorkflowIdFieldUnresolved, WorkflowSleepDelayUnresolved]-    it "validates rule domains, totality, case constructors, and bodies" $ do-      unresolved <- errorCodesOf "test/fixtures/rule-bad-domain.keiro"-      unresolved `shouldBe` [RuleDomainUnresolved]-      codes <- errorCodesOf "test/fixtures/rule-not-total.keiro"-      mapM_-        (\expected -> codes `shouldContain` [expected])-        [RuleNotTotal, RuleCaseUnknownCtor, ClockSampled, GuardAtomOutOfScope]-    it "rejects unresolved command operation references" $ do-      codes <- errorCodesOf "test/fixtures/operation-ghost-aggregate.keiro"-      codes `shouldContain` [OperationUnresolvedRef]-    it "rejects a signal value type that differs from its await" $ do-      codes <- errorCodesOf "test/fixtures/operation-signal-value.keiro"-      codes `shouldContain` [AwaitSignalValueMismatch]-    it "round-trips guarded patches and terminal continueAsNew" $ do-      input <- readTestText "test/fixtures/workflow-evolution.keiro"-      case parseSpec "workflow-evolution" input of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> do-          parseSpec "workflow-evolution" (renderSpec spec) `shouldBe` Right spec-          errorCodes spec `shouldBe` []-    it "rejects duplicate patch ids anywhere in the workflow body" $ do-      codes <- errorCodesOf "test/fixtures/workflow-patch-dup.keiro"-      codes `shouldBe` [WorkflowPatchDuplicate]-    it "rejects non-terminal and nested continueAsNew" $ do-      codes <- errorCodesOf "test/fixtures/workflow-can-mid.keiro"-      codes `shouldBe` [WorkflowContinueAsNewNotTerminal, WorkflowContinueAsNewNotTerminal]-    it "rejects a colon in a patch id with a workflow diagnostic" $ do-      codes <- errorCodesOf "test/fixtures/workflow-patch-colon.keiro"-      codes `shouldBe` [WorkflowPatchIdInvalid]-    it "lowers patch facts and live runtime declarations" $ do-      spec <- specOf "test/fixtures/workflow-evolution.keiro"-      case [workflow | NWorkflow workflow <- specNodes spec] of-        [workflow] -> do-          let modules = harnessWorkflow (defaultContext (specContext spec)) workflow-              facts = generatedTextEndingIn "WorkflowFacts.hs" modules-              runtime = generatedTextEndingIn "WorkflowRuntime.hs" modules-          facts `shouldSatisfy` T.isInfixOf "patch:fraud-check-v2(step:fraud-check)"-          facts `shouldSatisfy` T.isInfixOf "continueAsNew:RolloverSeed"-          facts `shouldSatisfy` T.isInfixOf "data WorkflowFacts = WorkflowFacts"-          facts `shouldSatisfy` T.isInfixOf "workflowFactBody = [\"step:create-transfer-hold\", \"patch:fraud-check-v2(step:fraud-check)\""-          facts `shouldSatisfy` T.isInfixOf "workflowFactAwaitLabels = [\"reservation-confirmation\"]"-          facts `shouldSatisfy` T.isInfixOf "workflowFactPatchIds = [\"fraud-check-v2\"]"-          runtime `shouldSatisfy` T.isInfixOf "declaredPatches = Set.fromList [PatchId \"fraud-check-v2\"]"-          runtime `shouldSatisfy` T.isInfixOf "opts{activePatches = declaredPatches}"-        workflows -> expectationFailure ("expected one workflow, got " <> show (length workflows))--  describe "replay impact" $ do-    it "treats new events and transitions as replay-neutral" $ do-      old <- specOf "test/fixtures/reservation.keiro"-      let aggregate = onlyAggregate old-      case (aggEvents aggregate, aggTransitions aggregate) of-        (event : _, transition : _) -> do-          let newEvent =-                event-                  { evName = "ReservationReviewed",-                    evLoc = noLoc-                  }-              newTransition =-                transition-                  { tEmits = ["ReservationReviewed"],-                    tLoc = noLoc-                  }-              new =-                modifyAggregate-                  "Reservation"-                  ( \candidate ->-                      candidate-                        { aggEvents = aggEvents candidate <> [newEvent],-                          aggTransitions = aggTransitions candidate <> [newTransition]-                        }-                  )-                  old-          replayImpactSpecs old new `shouldBe` ReplayNeutral-        _ -> expectationFailure "reservation fixture must contain an event and transition"--    it "narrows a guard edit to that transition's event types" $ do-      impact <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened.keiro"-      impact-        `shouldBe` ReplayAffected-          ( Map.singleton-              "Reservation"-              AggregateImpact-                { eventTypes = Set.singleton "TransferReservationCreated",-                  includeSnapshotStreams = True-                }-          )--    it "proves a syntactic guard loosening replay-neutral" $ do-      old <- specOf "test/fixtures/reservation.keiro"-      let loosened =-            modifyAggregate-              "Reservation"-              ( \aggregate ->-                  aggregate-                    { aggTransitions =-                        [ transition {tGuard = Nothing}-                        | transition <- aggTransitions aggregate-                        ]-                    }-              )-              old-      replayImpactSpecs old loosened `shouldBe` ReplayNeutral--    it "pairs guard-disambiguated siblings independently of both declaration orders" $ do-      base <- specOf "test/fixtures/reservation.keiro"-      let aggregate = onlyAggregate base-      case (aggTransitions aggregate, aggEvents aggregate) of-        (prototype : _, firstEvent : secondEvent : _) -> do-          let sibling guardExpression eventName =-                prototype-                  { tGuard = guardExpression,-                    tEmits = [eventName],-                    tLoc = noLoc-                  }-              commandOverride = EPath noLoc CommandRoot ["lifeCriticalOverride"]-              exact = sibling (Just (EAtom (ABool True))) (evName firstEvent)-              loosenedOld = sibling (Just commandOverride) (evName firstEvent)-              loosenedNew = sibling Nothing (evName firstEvent)-              changedOld = sibling (Just (ECmp OpEq commandOverride (ELiteral noLoc (LiteralBool False)))) (evName secondEvent)-              changedNew = sibling (Just (ECmp OpEq commandOverride (ELiteral noLoc (LiteralBool True)))) (evName firstEvent)-              oldSiblings = [exact, loosenedOld, changedOld]-              newSiblings = [exact, loosenedNew, changedNew]-              withTransitions transitions =-                modifyAggregate-                  (aggName aggregate)-                  (\candidate -> candidate {aggTransitions = transitions})-                  base-              impacts =-                [ replayImpactSpecs (withTransitions oldOrder) (withTransitions newOrder)-                | oldOrder <- permutations oldSiblings,-                  newOrder <- permutations newSiblings-                ]-          case impacts of-            firstImpact : remainingImpacts -> do-              remainingImpacts `shouldSatisfy` all (== firstImpact)-              firstImpact `shouldSatisfy` (/= ReplayNeutral)-            [] -> expectationFailure "permutations unexpectedly produced no replay comparisons"-        _ -> expectationFailure "reservation fixture must contain one transition and two events"--    it "marks every existing event when the aggregate wire convention changes" $ do-      impact <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-wire.keiro"-      case impact of-        ReplayAffected aggregates ->-          ReplayImpact.eventTypes <$> Map.lookup "Reservation" aggregates-            `shouldBe` Just (Set.fromList ["TransferReservationCreated", "TransferReservationConfirmed"])-        ReplayNeutral -> expectationFailure "expected a wire-clause replay impact"--    it "includes snapshot streams when a write expression changes" $ do-      impact <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-foldchange.keiro"-      case impact of-        ReplayAffected aggregates ->-          includeSnapshotStreams <$> Map.lookup "Reservation" aggregates-            `shouldBe` Just True-        ReplayNeutral -> expectationFailure "expected a fold replay impact"--    it "detects codec evolution and ignores formatting-only rewrites" $ do-      changed <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v2.keiro"-      changed `shouldSatisfy` (/= ReplayNeutral)-      old <- specOf "test/fixtures/reservation.keiro"-      formatted <- shouldParseStableRenderedSpec "<formatted>" old-      replayImpactSpecs old formatted `shouldBe` ReplayNeutral--    it "names mapped nested event and snapshot roots while ignoring Haskell-only changes" $ do-      nested <- replayImpactFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-nested-propagation.keiro"-      case nested of-        ReplayAffected aggregates ->-          Map.lookup "Catalog" aggregates-            `shouldBe` Just AggregateImpact {eventTypes = Set.singleton "ArtifactObserved", includeSnapshotStreams = True}-        ReplayNeutral -> expectationFailure "expected nested mapped wire change to affect replay"-      sourceOnly <- replayImpactFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-haskell-rename.keiro"-      sourceOnly `shouldBe` ReplayNeutral--    it "generates one context target for every aggregate, including the process saga" $ do-      spec <- specOf "test/fixtures/surge-service.keiro"-      case scaffoldReplayAudit (defaultContext (specContext spec)) spec of-        [assembly] -> do-          modulePath assembly `shouldBe` "Generated/SurgeDemo/ReplayAudit.hs"-          moduleText assembly `shouldSatisfy` T.isInfixOf "Hospital.hospitalEventStream"-          moduleText assembly `shouldSatisfy` T.isInfixOf "Surge.surgeEventStream"-          T.count "      AuditTarget" (moduleText assembly) `shouldBe` 2-        assemblies -> expectationFailure ("expected one replay-audit assembly, got " <> show (length assemblies))--  describe "diff (evolution classification)" $ do-    it "covers every node family exactly once and explains exclusions" $ do-      sort (map fst familyRegistry) `shouldBe` ([minBound .. maxBound] :: [NodeFamily])-      [reason | (_, OutOfDiffScope reason) <- familyRegistry, T.null reason] `shouldBe` []-    it "derives every exercised headline from its vector under the default gate" $ do-      changes <--        concat-          <$> mapM-            (uncurry diffFixtures)-            [ ("test/fixtures/reservation.keiro", "test/fixtures/reservation-fieldadd.keiro"),-              ("test/fixtures/reservation.keiro", "test/fixtures/reservation-v2.keiro"),-              ("test/fixtures/reservation.keiro", "test/fixtures/reservation-enumadd.keiro"),-              ("test/fixtures/contract.keiro", "test/fixtures/contract-fieldadd.keiro"),-              ("test/fixtures/reservation-work.keiro", "test/fixtures/reservation-work-rename.keiro")-            ]-      forM_ changes $ \change ->-        do-          deriveLabel defaultGate (ckVector (kindOfChange change))-            `shouldBe` labelOfChange change-          gatedBreaking defaultGate change `shouldBe` isBreaking change-    it "never removes a breaking result when the gate grows" $-      property $-        forAll genCompatibilityVector $ \compatibility ->-          forAll genSurfaceSet $ \gate ->-            forAll genSurfaceSet $ \extra ->-              deriveLabel gate compatibility-                == LabelBreaking-                  ==> deriveLabel (gate <> extra) compatibility-                == LabelBreaking-    it "renders the consumer-neutral matrix with separate private, snapshot, and public surfaces" $ do-      changes <- diffFixtures "test/fixtures/compatibility-vector-old.keiro" "test/fixtures/compatibility-vector-new.keiro"-      let rendered = T.intercalate "\n" (map renderFinding changes)-          explained = T.intercalate "\n" (map renderExplainBlock changes)-          reportJson = T.pack (show (Aeson.toJSON (diffReport defaultGate changes)))-      assertMatchesGolden "test/fixtures/compatibility-vector.diff.golden" rendered-      rendered `shouldSatisfy` T.isInfixOf "Reservation.event.TransferReservationCreated.patientAcuity"-      rendered `shouldSatisfy` T.isInfixOf "old-binary-read-new-events=breaking"-      rendered `shouldSatisfy` T.isInfixOf "snapshot-hydration=advisory"-      rendered `shouldSatisfy` T.isInfixOf "public-consumer=breaking"-      explained `shouldSatisfy` T.isInfixOf "invalidate and rebuild snapshots"-      reportJson `shouldSatisfy` T.isInfixOf "keiro-dsl/diff-report/1"-      reportJson `shouldSatisfy` T.isInfixOf "Reservation.event.TransferReservationCreated.patientAcuity"-      let eventEnumFindings =-            [ change-            | change@(Advisory kind) <- changes,-              ckCode kind == EnumCtorAdded,-              verdictFor OldBinaryReadNewEvents (ckVector kind) == VBreaking-            ]-      eventEnumFindings `shouldSatisfy` all (not . gatedBreaking defaultGate)-      eventEnumFindings `shouldSatisfy` all (gatedBreaking (gateWith [OldBinaryReadNewEvents]))-      forM_ changes $ \change ->-        remediationFor (ckContext (kindOfChange change)) (ckCode (kindOfChange change))-          `shouldSatisfy` (not . null)-    it "rejects unknown --gate values with the valid surface list" $ do-      parseSurfaceName "mystery-surface"-        `shouldSatisfy` either (T.isInfixOf "old-binary-read-new-events" . T.pack) (const False)-    it "covers the mapped evolution matrix with stable codes and non-empty remedies" $ do-      let cases =-            [ ("consumer-types-fieldadd-default.keiro", MappedFieldAddedWithDefault),-              ("consumer-types-fieldadd-nodefault.keiro", MappedFieldAddedNoDefault),-              ("consumer-types-fieldremove.keiro", MappedFieldRemoved),-              ("consumer-types-wirekey.keiro", MappedWireKeyChanged),-              ("consumer-types-haskell-rename.keiro", MappedHaskellSourceChanged),-              ("consumer-types-binding-change.keiro", MappedBindingChanged),-              ("consumer-types-fixtures-change.keiro", MappedFixturesChanged),-              ("consumer-types-initial-change.keiro", MappedInitialChanged),-              ("consumer-types-armadd.keiro", MappedArmAdded),-              ("consumer-types-tagchange.keiro", MappedArmTagChanged),-              ("consumer-types-enumadd.keiro", MappedEnumValueAdded),-              ("consumer-types-enumremove.keiro", MappedEnumValueRemoved),-              ("consumer-types-enumspelling.keiro", MappedEnumSpellingChanged),-              ("consumer-types-encoding.keiro", MappedUnionEncodingChanged),-              ("consumer-types-opaque-version.keiro", MappedOpaqueCodecChanged),-              ("consumer-types-mode-cross.keiro", MappedModeCrossed),-              ("consumer-types-nested-propagation.keiro", MappedArmTagChanged)-            ]-      forM_ cases $ \(fixture, expectedCode) -> do-        changes <- diffFixtures "test/fixtures/consumer-types.keiro" ("test/fixtures/" <> fixture)-        map (ckCode . kindOfChange) changes `shouldContain` [expectedCode]-        forM_ changes $ \change ->-          remediationFor (ckContext (kindOfChange change)) (ckCode (kindOfChange change))-            `shouldSatisfy` (not . null)-    it "separates mapped event migration, snapshot invalidation, and directional rollout" $ do-      breakingAdd <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-fieldadd-nodefault.keiro"-      let noDefault = [change | change <- breakingAdd, ckCode (kindOfChange change) == MappedFieldAddedNoDefault]-      [ckFacet kind | Breaking kind <- noDefault] `shouldContain` ["mapped-event"]-      [ckFacet kind | Advisory kind <- noDefault] `shouldContain` ["mapped-register"]-      defaulted <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-fieldadd-default.keiro"-      [change | change <- defaulted, isBreaking change] `shouldBe` []-      let eventDefaults = [kind | Advisory kind <- defaulted, ckCode kind == MappedFieldAddedWithDefault, ckFacet kind == "mapped-event"]-      eventDefaults `shouldSatisfy` any ((== VBreaking) . verdictFor OldBinaryReadNewEvents . ckVector)-      armAdded <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-armadd.keiro"-      [change | change <- armAdded, isBreaking change] `shouldBe` []-      [kind | Advisory kind <- armAdded, ckCode kind == MappedArmAdded, ckFacet kind == "mapped-event"]-        `shouldSatisfy` any ((== VBreaking) . verdictFor OldBinaryReadNewEvents . ckVector)-    it "propagates a nested mapped leaf to complete command, event, and register paths" $ do-      changes <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-nested-propagation.keiro"-      let subjects =-            [ ckSubject kind-            | change <- changes,-              let kind = kindOfChange change,-              ckCode kind == MappedArmTagChanged-            ]-      subjects-        `shouldContain` [ "Catalog command ObserveArtifact .artifact : ArtifactInfo .location : ArtifactLocation .arm RepoPath[\"repository_path\"]",-                          "Catalog event ArtifactObserved .artifact : ArtifactInfo .location : ArtifactLocation .arm RepoPath[\"repository_path\"]",-                          "Catalog register currentArtifact : ArtifactInfo .location : ArtifactLocation .arm RepoPath[\"repository_path\"]"-                        ]-    it "classifies every remaining mapped field and declaration evolution row" $ do-      base <- specOf "test/fixtures/consumer-types.keiro"-      let mutationCodes =-            [ (mapArtifactNamedField "key" (\field -> field {wfType = TInt}) base, MappedFieldTypeChanged),-              (mapArtifactNamedField "key" (\field -> field {wfPresence = POptional, wfOnMissing = Just (OmText "")}) base, MappedPresenceChanged),-              (mapArtifactNamedField "key" (\field -> field {wfType = TOptional TText}) base, MappedNullabilityChanged),-              (mapArtifactNamedField "description" (\field -> field {wfOnMissing = Nothing}) base, MappedDefaultRemoved),-              (mapArtifactNamedField "count" (\field -> field {wfOnMissing = Just (OmInt 1)}) base, MappedDefaultChanged),-              (mapMappedStructural "ArtifactInfo" renameMappedRecordConstructor base, MappedRecordConstructorChanged),-              (mapMappedStructural "ArtifactInfo" changeMappedCanonical base, MappedCanonicalTypeChanged)-            ]-      forM_ mutationCodes $ \(candidate, expectedCode) ->-        map (ckCode . kindOfChange) (diffSpecs base candidate) `shouldContain` [expectedCode]-      let declarationA = completeStructural "A" (recordShape [TText])-          declarationB = completeStructural "B" (recordShape [TInt])-          onlyA = mappedSpec [declarationA]-          withB = mappedSpec [declarationA, declarationB]-      map (ckCode . kindOfChange) (diffSpecs onlyA withB) `shouldContain` [MappedDeclAdded]-      map (ckCode . kindOfChange) (diffSpecs withB onlyA) `shouldContain` [MappedDeclRemoved]-      diffSpecs base (mapArtifactNamedField "key" (\field -> field {wfHaskell = "renamedKey"}) base)-        `shouldSatisfy` \case-          [Advisory change] -> ckCode change == GeneratedHaskellNameChanged-          _ -> False-    it "visits every mapped wire mutation and reports every complete root path" $ do-      base <- specOf "test/fixtures/consumer-types.keiro"-      let mutations = mappedWireMutations base-      mutations `shouldSatisfy` (not . null)-      visited <- fmap Set.unions . forM mutations $ \mutation -> do-        let changes =-              [ change-              | change <- diffSpecs base (mmCandidate mutation),-                ckCode (kindOfChange change) == mmCode mutation-              ]-            actualSubjects = Set.fromList (map (ckSubject . kindOfChange) changes)-        changes `shouldSatisfy` any (not . isAdditiveChange)-        actualSubjects `shouldBe` mmExpectedSubjects mutation-        pure actualSubjects-      visited `shouldBe` Set.unions (map mmExpectedSubjects mutations)-    it "reports the exact ingredient code when every required mapped fact is deleted" $ do-      base <- specOf "test/fixtures/consumer-types.keiro"-      forM_ (mappedIngredientMutations base) $ \(candidate, expectedCode) ->-        errorCodes candidate `shouldContain` [expectedCode]-    it "classifies a field added without a version bump as BREAKING" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldadd.keiro"-      any isBreaking cs `shouldBe` True-      [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldAddedWithoutBump]-    it "classifies the same field wrapped as v2 + upcaster as ADDITIVE" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v2.keiro"-      any isBreaking cs `shouldBe` False-      [ck | Additive ck <- cs] `shouldSatisfy` any ((== "TransferReservationCreated") . ckSubject)-    it "reports no breaking change when the spec is unchanged" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation.keiro"-      any isBreaking cs `shouldBe` False-    it "classifies a direct event field type change as EvtFieldTypeChanged" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldtype.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldTypeChanged]-    it "resolves fields(Command) before comparing event field types" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-cmdfieldtype.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldTypeChanged]-    it "uses EvtFieldRemovedSameVersion for an unchanged-version removal" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldremove.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldRemovedSameVersion]-    it "classifies selector aliases as build-only and wire aliases as replay-affecting" $ do-      let sourceFor field =-            T.unlines-              [ "language keiro-dsl 4",-                "context field-alias-diff",-                "aggregate AliasDiff",-                "  regs",-                "  states Open",-                "  command Observe { " <> field <> " }",-                "  event Observed = fields(Observe)",-                "  wire kind=ctorName fields=camelCase schemaVersion=1"-              ]-      base <- checkedServiceFromText "field-alias-diff-base.keiro" (sourceFor "region:Text")-      selectorAlias <- checkedServiceFromText "field-alias-diff-selector.keiro" (sourceFor "region haskell serviceRegion:Text")-      wireAlias <- checkedServiceFromText "field-alias-diff-wire.keiro" (sourceFor "region as \"region_code\":Text")-      let selectorChanges = diffServices base selectorAlias-          wireChanges = diffServices base wireAlias-          selectorFindings = [finding | Advisory finding <- selectorChanges, ckCode finding == GeneratedHaskellNameChanged]-          wireFindings = [finding | Breaking finding <- wireChanges, ckCode finding == EvtFieldWireKeyChanged]-      selectorChanges `shouldSatisfy` all (not . isBreaking)-      map ckFacet selectorFindings `shouldContain` ["command-field-selector", "event-field-selector"]-      map (verdictFor ConsumerBuild . ckVector) selectorFindings `shouldSatisfy` all (== VAdvisory)-      resolvedFold (ReplayImpact.replayImpactServices base selectorAlias) `shouldBe` ReplayNeutral-      case wireFindings of-        [finding] -> do-          ckSubject finding `shouldBe` "Observed.region"-          verdictFor PrivateHistoryRead (ckVector finding) `shouldBe` VBreaking-          verdictFor OldBinaryReadNewEvents (ckVector finding) `shouldBe` VBreaking-          ckDetail finding `shouldSatisfy` T.isInfixOf "'region' -> 'region_code'"-        findings -> expectationFailure ("expected one event wire-key finding, got " <> show findings)-      resolvedFold (ReplayImpact.replayImpactServices base wireAlias)-        `shouldSatisfy` \case-          ReplayAffected impacts ->-            maybe False ((== Set.singleton "Observed") . ReplayImpact.eventTypes) (Map.lookup "AliasDiff" impacts)-          ReplayNeutral -> False-    it "retains event selector advisories across a legal version bump" $ do-      let sourceFor eventDeclaration =-            T.unlines-              [ "language keiro-dsl 4",-                "context field-alias-version-diff",-                "aggregate AliasVersionDiff",-                "  regs",-                "  states Open",-                "  command Observe {}",-                eventDeclaration-              ]-      base <- checkedServiceFromText "field-alias-version-base.keiro" (sourceFor "  event Observed { region:Text }")-      bumped <--        checkedServiceFromText-          "field-alias-version-bumped.keiro"-          (sourceFor "  event Observed v2 { region haskell serviceRegion:Text }\n    upcast from v1 = HOLE")-      let changes = diffServices base bumped-          selectorFindings = [finding | Advisory finding <- changes, ckCode finding == GeneratedHaskellNameChanged]-      [ckCode finding | Additive finding <- changes] `shouldContain` [VersionBumped]-      map ckFacet selectorFindings `shouldBe` ["event-field-selector"]-      map (verdictFor ConsumerBuild . ckVector) selectorFindings `shouldBe` [VAdvisory]-    it "classifies contract selector aliases separately from public wire changes" $ do-      let sourceFor field =-            T.unlines-              [ "language keiro-dsl 4",-                "context contract-field-alias-diff",-                "contract emergency {",-                "  schemaVersion 1",-                "  discriminator messageType",-                "  topic events \"emergency.events\"",-                "  event IncidentDeclared on events {",-                "    " <> field,-                "  }",-                "}"-              ]-      base <- checkedServiceFromText "contract-field-alias-base.keiro" (sourceFor "region: text")-      selectorAlias <- checkedServiceFromText "contract-field-alias-selector.keiro" (sourceFor "region haskell serviceRegion: text")-      wireAlias <- checkedServiceFromText "contract-field-alias-wire.keiro" (sourceFor "region as \"region_code\": text")-      let selectorChanges = diffServices base selectorAlias-          wireChanges = diffServices base wireAlias-      selectorChanges `shouldSatisfy` \case-        [Advisory finding] ->-          ckCode finding == GeneratedHaskellNameChanged-            && ckFacet finding == "contract-field-selector"-            && verdictFor ConsumerBuild (ckVector finding) == VAdvisory-        _ -> False-      case [finding | Breaking finding <- wireChanges, ckCode finding == ContractFieldChanged] of-        [finding] -> do-          verdictFor PublicConsumer (ckVector finding) `shouldBe` VBreaking-          cvRollout (ckVector finding) `shouldBe` Set.singleton RolloutProducerLast-          ckDetail finding `shouldSatisfy` T.isInfixOf "consumer-first rollout"-        findings -> expectationFailure ("expected one contract wire-key finding, got " <> show findings)-    it "keeps an alias-free field rename on the existing add/remove path" $ do-      let sourceFor field =-            T.unlines-              [ "language keiro-dsl 4",-                "context field-rename-diff",-                "aggregate RenameDiff",-                "  regs",-                "  states Open",-                "  event Renamed { " <> field <> ":Text }",-                "  wire kind=ctorName fields=camelCase schemaVersion=1"-              ]-      old <- checkedServiceFromText "field-rename-old.keiro" (sourceFor "region")-      new <- checkedServiceFromText "field-rename-new.keiro" (sourceFor "zone")-      let changes = diffServices old new-      [ckCode finding | Breaking finding <- changes]-        `shouldContain` [EvtFieldAddedWithoutBump, EvtFieldRemovedSameVersion]-      [finding | Advisory finding <- changes, ckCode finding == GeneratedHaskellNameChanged]-        `shouldBe` []-    it "uses EvtVersionDecreased for a version decrease" $ do-      cs <- diffFixtures "test/fixtures/reservation-v2.keiro" "test/fixtures/reservation.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [EvtVersionDecreased]-    it "rejects a v1 to v3 jump whose only upcaster starts at v2" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v3-dangling.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [EvtVersionMissingUpcaster]-    it "classifies a vanished historical upcaster rung as UpcasterChainGap" $ do-      cs <- diffFixtures "test/fixtures/reservation-v2.keiro" "test/fixtures/reservation-chain-gap.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [UpcasterChainGap]-    it "classifies an enum constructor removal as EnumCtorRemoved" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumdrop.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [EnumCtorRemoved]-    it "classifies an enum wire-spelling change as EnumWireSpellingChanged" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumwire.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [EnumWireSpellingChanged]-    it "classifies an enum constructor addition per use site as advisory" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumadd.keiro"-      any isBreaking cs `shouldBe` False-      let enumFindings = [k | Advisory k <- cs, ckCode k == EnumCtorAdded]-      [ckSubject k | k <- enumFindings] `shouldContain` ["BlackTag"]-      [verdictFor SnapshotHydration (ckVector k) | k <- enumFindings]-        `shouldContain` [VAdvisory]-    it "classifies an effective wire convention change as WireSpecChanged" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-wire.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [WireSpecChanged]-    it "advises when the aggregate fold surface changes" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-foldchange.keiro"-      any isBreaking cs `shouldBe` False-      [ckCode k | Advisory k <- cs] `shouldContain` [AggFoldSurfaceChanged]-    it "advises on hazardous deprecation and reports un-deprecation" $ do-      deprecated <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-deprecated.keiro"-      any isBreaking deprecated `shouldBe` False-      [ckCode k | Advisory k <- deprecated] `shouldContain` [DeprecatedEventReplayHazard]-      restored <- diffFixtures "test/fixtures/reservation-deprecated.keiro" "test/fixtures/reservation.keiro"-      any isAdvisory restored `shouldBe` True-      [ckCode k | Advisory k <- restored] `shouldContain` [EventUndeprecated]-    it "recognises replay-only deprecation as a replay-safe retirement cutover" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-deprecated-replay-only.keiro"-      any isBreaking cs `shouldBe` False-      [ckCode k | Advisory k <- cs] `shouldContain` [EventRetirementInProgress]-      [ckCode k | Advisory k <- cs] `shouldNotContain` [DeprecatedEventReplayHazard]-    it "advises when event retirement starts" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-retiring.keiro"-      any isBreaking cs `shouldBe` False-      [ckCode k | Advisory k <- cs] `shouldContain` [EventRetirementInProgress]-    it "does not recommend decode-only deprecation for an event removal" $ do-      old <- specOf "test/fixtures/reservation.keiro"-      let new =-            old-              { specNodes =-                  [ case node of-                      NAggregate aggregate ->-                        NAggregate-                          aggregate-                            { aggEvents =-                                [ event-                                | event <- aggEvents aggregate,-                                  evName event /= "TransferReservationConfirmed"-                                ],-                              aggTransitions =-                                [ transition {tEmits = filter (/= "TransferReservationConfirmed") (tEmits transition)}-                                | transition <- aggTransitions aggregate-                                ]-                            }-                      _ -> node-                  | node <- specNodes old-                  ]-              }-          removals = [change | change@(Breaking kind) <- diffSpecs old new, ckCode kind == EvtRemovedNotDeprecated]-      removals `shouldSatisfy` (not . null)-      [ckDetail kind | Breaking kind <- removals]-        `shouldSatisfy` all (not . T.isInfixOf "so old payloads still decode")-    it "prints a paste-ready replay-only twin when a guard tightens (plan 143)" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened.keiro"-      any isBreaking cs `shouldBe` False-      let advisories = [k | Advisory k <- cs, ckCode k == AggGuardTightened]-      map ckSubject advisories `shouldBe` ["Unrequested -- RequestTransferReservation"]-      detail <- case advisories of-        [k] -> pure (ckDetail k)-        other -> expectationFailure ("expected one advisory, got " <> show other) >> pure ""-      detail `shouldSatisfy` T.isInfixOf "replay-only Unrequested -- RequestTransferReservation"-      -- The printed twin is paste-ready: appended to the new spec it-      -- parses, validates without errors, and silences the advisory.-      tightened <- readTestText "test/fixtures/reservation-guard-tightened.keiro"-      let twinText = snd (T.breakOnEnd "\n\n" detail)-          pasted = tightened <> "\n" <> twinText <> "\n"-      case parseSpec "<pasted-twin>" pasted of-        Left err -> expectationFailure (T.unpack err)-        Right pastedSpec -> do-          [code d | d <- validateSpec pastedSpec, severity d == Error] `shouldBe` []-          base <- specOf "test/fixtures/reservation.keiro"-          [k | Advisory k <- diffSpecs base pastedSpec, ckCode k == AggGuardTightened]-            `shouldBe` []-    it "omits the twin advisory when the twin is already present (plan 143)" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened-twin.keiro"-      [k | Advisory k <- cs, ckCode k == AggGuardTightened] `shouldBe` []-    it "classifies a removed contract event as ContractEventRemoved" $ do-      cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventdrop.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [ContractEventRemoved]-    it "classifies contract field type changes and unversioned additions as ContractFieldChanged" $ do-      changed <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldtype.keiro"-      [ckCode k | Breaking k <- changed] `shouldContain` [ContractFieldChanged]-      added <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldadd.keiro"-      [ckCode k | Breaking k <- added] `shouldContain` [ContractFieldChanged]-    it "goldens language-3 to language-4 contract TypeID admission and rollout" $ do-      let source versionNumber prefix =-            T.unlines-              [ "language keiro-dsl " <> T.pack (show versionNumber),-                "context hospital-capacity",-                "contract emergency {",-                "  schemaVersion 1",-                "  discriminator messageType",-                "  topic incidentEvents \"emergency.incident.events\"",-                "  event IncidentTransferNeedDeclared on incidentEvents {",-                "    incidentId: typeid \"" <> prefix <> "\"",-                "  }",-                "}"-              ]-          checked name input = case parseSource name input of-            Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-            Right parsed -> pure (checkedSource parsed)-      v1 <- checked "contract-typeid-v1.keiro" (source (1 :: Int) "inc")-      v3 <- checked "contract-typeid-v3.keiro" (source (3 :: Int) "inc")-      v4 <- checked "contract-typeid-v4.keiro" (source (4 :: Int) "inc")-      v4Edited <- checked "contract-typeid-v4-edited.keiro" (source (4 :: Int) "rsv")-      let changes = diffServices v3 v4-          textGolden = T.intercalate "\n" (map renderFinding changes)-          jsonGolden = LazyText.toStrict (LazyTextEncoding.decodeUtf8 (Aeson.encode (diffReport defaultGate changes)))-          findings = [kind | Breaking kind <- changes, ckCode kind == ContractTypeIdDomainChanged]-      assertMatchesGolden "test/fixtures/contract-typeid-domain.diff.golden" textGolden-      assertMatchesGolden "test/fixtures/contract-typeid-domain.diff.json.golden" jsonGolden-      case findings of-        [finding] -> do-          verdictFor PublicConsumer (ckVector finding) `shouldBe` VBreaking-          verdictFor ConsumerBuild (ckVector finding) `shouldBe` VBreaking-          [verdictFor surface (ckVector finding) | surface <- [PrivateHistoryRead, OldBinaryReadNewEvents, SnapshotHydration, PersistedIdentity]]-            `shouldBe` replicate 4 VNotApplicable-          cvRollout (ckVector finding) `shouldBe` Set.fromList [RolloutDrainRequired, RolloutProducerFirst]-          deriveLabel (Set.singleton PublicConsumer) (ckVector finding) `shouldBe` LabelBreaking-          deriveLabel (Set.singleton ConsumerBuild) (ckVector finding) `shouldBe` LabelBreaking-          remediationFor (ckContext finding) (ckCode finding)-            `shouldBe` RemedyEmitContractTypeIdDomain :| [RemedyDrainLegacyInvalidContractMessages, RemedyRescaffoldContractConsumers, RemedyRunContractConformance]-        values -> expectationFailure ("expected one contract TypeID-domain finding, got " <> show (length values))-      [kind | change <- diffServices v1 v3, let { kind = kindOfChange change }, ckCode kind == ContractTypeIdDomainChanged] `shouldBe` []-      [kind | change <- diffServices v4 v4, let { kind = kindOfChange change }, ckCode kind == ContractTypeIdDomainChanged] `shouldBe` []-      let edited = diffServices v3 v4Edited-      map (ckCode . kindOfChange) edited `shouldContain` [ContractFieldChanged]-      [kind | change <- edited, let { kind = kindOfChange change }, ckCode kind == ContractTypeIdDomainChanged] `shouldBe` []-    it "reports a field addition with a contract version bump as an advisory" $ do-      cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-bump-fieldadd.keiro"-      any isBreaking cs `shouldBe` False-      [ckCode k | Advisory k <- cs] `shouldContain` [ContractSchemaVersionBumped]-    it "classifies a contract schema version decrease separately" $ do-      cs <- diffFixtures "test/fixtures/contract-bump-fieldadd.keiro" "test/fixtures/contract.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [ContractSchemaVersionDecreased]-    it "classifies contract topic and discriminator changes separately" $ do-      topic <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-topic.keiro"-      [ckCode k | Breaking k <- topic] `shouldContain` [ContractTopicChanged]-      discriminator <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-discriminator.keiro"-      [ckCode k | Breaking k <- discriminator] `shouldContain` [ContractDiscriminatorChanged]-    it "classifies a new contract event as additive" $ do-      cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventadd.keiro"-      any isBreaking cs `shouldBe` False-      [ckSubject k | Additive k <- cs] `shouldContain` ["IncidentTransferNeedCancelled"]-    it "classifies workqueue wire names, types, and required additions as WqPayloadFieldChanged" $ do-      wire <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-wirename.keiro"-      [ckCode k | Breaking k <- wire] `shouldContain` [WqPayloadFieldChanged]-      fieldTypeChange <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-fieldtype.keiro"-      [ckCode k | Breaking k <- fieldTypeChange] `shouldContain` [WqPayloadFieldChanged]-      required <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-reqfield.keiro"-      [ckCode k | Breaking k <- required] `shouldContain` [WqPayloadFieldChanged]-    -- Adding a payload field is breaking however it is spelled. Generated-    -- decoders read every field with `o .:`, so a job already queued under the-    -- old shape fails to decode against the new one — the "additive, optional-    -- field" classification this test previously asserted described a decoder-    -- that was never generated. See ExecPlan 199.-    it "classifies any new workqueue payload field as breaking for queued jobs" $ do-      cs <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-optfield.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [WqPayloadFieldChanged]-      [ckSubject k | Breaking k <- cs] `shouldContain` ["note"]-      [ckDetail k | Breaking k <- cs, ckSubject k == "note"]-        `shouldSatisfy` any (T.isInfixOf "queued jobs do not contain it")-    it "classifies workqueue ordering changes as breaking delivery-contract changes" $ do-      cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-ordering-change.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [WqOrderingChanged]-      [ckDetail k | Breaking k <- cs, ckCode k == WqOrderingChanged]-        `shouldSatisfy` any (T.isInfixOf "delivery-order contract")-    it "classifies workqueue provision changes as operational migrations" $ do-      cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-provision-change.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [WqProvisionChanged]-      [ckDetail k | Breaking k <- cs, ckCode k == WqProvisionChanged]-        `shouldSatisfy` any (T.isInfixOf "migrate the existing queue operationally")-    it "classifies workqueue group-key changes as breaking repartitioning" $ do-      cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-group-key-change.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [WqGroupKeyChanged]-      [ckDetail k | Breaking k <- cs, ckCode k == WqGroupKeyChanged]-        `shouldSatisfy` any (T.isInfixOf "re-partitioned")-    it "classifies a process input type change as ProcessInputChanged" $ do-      cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-inputtype.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [ProcessInputChanged]-    it "classifies workflow input and output changes as WorkflowShapeChanged" $ do-      input <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-inputfield.keiro"-      [ckCode k | Breaking k <- input] `shouldContain` [WorkflowShapeChanged]-      output <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-output.keiro"-      [ckCode k | Breaking k <- output] `shouldContain` [WorkflowShapeChanged]-    it "classifies workflow relabeling and appends as WorkflowBodyChanged" $ do-      relabeled <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-body.keiro"-      [ckCode k | Breaking k <- relabeled] `shouldContain` [WorkflowBodyChanged]-      appended <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-stepadd.keiro"-      [ckCode k | Breaking k <- appended] `shouldContain` [WorkflowBodyChanged]-      [ckDetail k | Breaking k <- appended, ckCode k == WorkflowBodyChanged]-        `shouldSatisfy` any (T.isInfixOf "new patch guard")-    it "classifies a body addition wholly guarded by a new patch as additive" $ do-      cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-evolution-diff.keiro"-      any isBreaking cs `shouldBe` False-      [ckSubject k | Additive k <- cs, ckFacet k == "workflow-patch"] `shouldContain` ["fraud-check-v2"]-      [ckSubject k | Additive k <- cs, ckFacet k == "workflow-continue-as-new"] `shouldContain` ["RolloverSeed"]-    it "classifies removing an existing patch as breaking" $ do-      cs <- diffFixtures "test/fixtures/workflow-evolution-diff.keiro" "test/fixtures/workflow-continue.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [WorkflowPatchRemoved]-      [ckDetail k | Breaking k <- cs, ckCode k == WorkflowPatchRemoved]-        `shouldSatisfy` any (T.isInfixOf "cannot prove")-    it "classifies terminal continueAsNew append as additive and seed drift as breaking" $ do-      appended <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-continue.keiro"-      any isBreaking appended `shouldBe` False-      [ckFacet k | Additive k <- appended] `shouldContain` ["workflow-continue-as-new"]-      changed <- diffFixtures "test/fixtures/workflow-continue.keiro" "test/fixtures/workflow-continue-seed-v2.keiro"-      [ckCode k | Breaking k <- changed] `shouldContain` [WorkflowContinueSeedChanged]-      [ckDetail k | Breaking k <- changed, ckCode k == WorkflowContinueSeedChanged]-        `shouldSatisfy` any (T.isInfixOf "restoreSeed")-    it "classifies a workflow stable-name change as WorkflowStableNameChanged" $ do-      cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-rename.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [WorkflowStableNameChanged]-    it "classifies workflow id-derivation changes as DerivedIdentityChanged" $ do-      cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-idfield.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [DerivedIdentityChanged]-    it "classifies an id prefix change as IdPrefixChanged" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-idprefix.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [IdPrefixChanged]-    it "classifies intake dedupe key and policy changes as DedupeIdentityChanged" $ do-      policy <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-dedupepolicy.keiro"-      [ckCode k | Breaking k <- policy] `shouldContain` [DedupeIdentityChanged]-      key <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-dedupekey.keiro"-      [ckCode k | Breaking k <- key] `shouldContain` [DedupeIdentityChanged]-    it "reports intake decode-posture changes as warnings" $ do-      cs <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-decode.keiro"-      any isBreaking cs `shouldBe` False-      [ckCode k | Advisory k <- cs] `shouldContain` [DecodePostureChanged]-      [ckCode k | Advisory k <- cs] `shouldContain` [IntakePersistenceChanged]-    it "classifies process and timer derivation changes as DerivedIdentityChanged" $ do-      processName <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-procname.keiro"-      [ckCode k | Breaking k <- processName] `shouldContain` [DerivedIdentityChanged]-      timerId <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-timerid.keiro"-      [ckCode k | Breaking k <- timerId] `shouldContain` [DerivedIdentityChanged]-      base <- specOf "test/fixtures/hospital-surge.keiro"-      let categoryChange = diffSpecs base (modifyProcess "HospitalSurge" (\process -> process {procSaga = (procSaga process) {sagaCategory = "hospitalSurgeV2"}}) base)-      [ckCode k | Breaking k <- categoryChange] `shouldContain` [DerivedIdentityChanged]-    it "classifies router stable names, keys, and targets as identity-bearing" $ do-      base <- specOf "test/fixtures/incident-paging/incident-paging.keiro"-      let stableName = diffSpecs base (modifyRouter "PagingRouter" (\router -> router {rtName = "paging-v2"}) base)-          keyDerivation = diffSpecs base (modifyRouter "PagingRouter" (\router -> router {rtKey = (rtKey router) {corrVia = "otherIdText"}}) base)-          target = diffSpecs base (modifyRouter "PagingRouter" (\router -> router {rtTarget = "OtherPage"}) base)-      [ckCode k | Breaking k <- stableName] `shouldContain` [RouterStableNameChanged]-      [ckCode k | Breaking k <- keyDerivation] `shouldContain` [DerivedIdentityChanged]-      [ckCode k | Breaking k <- target] `shouldContain` [DerivedIdentityChanged]-    it "advises on router dispatch-surface changes without making them breaking" $ do-      cs <- diffFixtures "test/fixtures/incident-paging/incident-paging.keiro" "test/fixtures/incident-paging/incident-paging-dispatch.keiro"-      any isBreaking cs `shouldBe` False-      [ckCode k | Advisory k <- cs] `shouldBe` [RouterDecideSurfaceChanged]-    it "advises on process dispatch-surface changes without making them breaking" $ do-      cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-handle.keiro"-      any isBreaking cs `shouldBe` False-      [ckCode k | Advisory k <- cs] `shouldBe` [ProcessDecideSurfaceChanged]-    it "advises on unversioned timer payload changes without making them breaking" $ do-      cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-payload.keiro"-      any isBreaking cs `shouldBe` False-      [ckCode k | Advisory k <- cs] `shouldBe` [ProcessTimerPayloadChanged]-    it "ignores formatting-only process and timer surface rewrites" $ do-      original <- specOf "test/fixtures/hospital-surge.keiro"-      formatted <- shouldParseStableRenderedSpec "<formatted-process>" original-      diffSpecs original formatted `shouldBe` []-    it "reports a timer window change as a warning" $ do-      cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-window.keiro"-      any isBreaking cs `shouldBe` False-      [ckCode k | Advisory k <- cs] `shouldContain` [TimerWindowChanged]-    it "reports emit-map changes as warnings and derive changes as breaking" $ do-      mapping <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-mapchange.keiro"-      any isBreaking mapping `shouldBe` False-      [ckCode k | Advisory k <- mapping] `shouldContain` [EmitMappingChanged]-      derive <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-derive.keiro"-      [ckCode k | Breaking k <- derive] `shouldContain` [DerivedIdentityChanged]-    it "classifies publisher outbox identity and ordering independently" $ do-      outbox <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-outboxfield.keiro"-      [ckCode k | Breaking k <- outbox] `shouldContain` [DerivedIdentityChanged]-      ordering <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-ordering.keiro"-      any isBreaking ordering `shouldBe` False-      [ckCode k | Advisory k <- ordering] `shouldContain` [PublisherPolicyChanged]-    it "classifies workqueue names as QueueIdentityChanged" $ do-      cs <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-rename.keiro"-      [ckCode k | Breaking k <- cs] `shouldContain` [QueueIdentityChanged]-    it "classifies pgmq dispatch dedupe and retargeting independently" $ do-      dedupe <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-dedupkey.keiro"-      [ckCode k | Breaking k <- dedupe] `shouldContain` [DedupeIdentityChanged]-      retarget <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-retarget.keiro"-      any isBreaking retarget `shouldBe` False-      [ckCode k | Advisory k <- retarget] `shouldContain` [DispatchRetargeted]-    it "reports aggregate projection changes as warnings" $ do-      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-projection.keiro"-      any isBreaking cs `shouldBe` False-      [ckCode k | Advisory k <- cs] `shouldContain` [ProjectionChanged]-    it "classifies read-model version and unversioned shape changes" $ do-      base <- specOf "test/fixtures/readmodel-runtime.keiro"-      let versionTwo = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmVersion = 2}) base-          changedShape = modifyReadModel "transfer_decisions" changeReadModelShape base-          bumpedShape = modifyReadModel "transfer_decisions" (\readModel -> (changeReadModelShape readModel) {rmVersion = 2}) base-          decreased = diffSpecs versionTwo base-          unversioned = diffSpecs base changedShape-          bumped = diffSpecs base bumpedShape-      [ckCode k | Breaking k <- decreased] `shouldContain` [ReadModelVersionDecreased]-      [ckCode k | Breaking k <- unversioned] `shouldContain` [ReadModelShapeChangedWithoutBump]-      any isBreaking bumped `shouldBe` False-      [ckFacet k | Additive k <- bumped] `shouldContain` ["read-model-version"]-    it "classifies read-model registry, table, subscription, and removal identities" $ do-      base <- specOf "test/fixtures/readmodel-runtime.keiro"-      let tableChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmTable = "transfer_decisions_v2"}) base-          subscriptionChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmSubscription = Just "transfer-decisions-v2"}) base-          renamed = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmName = "reservation_decisions"}) base-          removed = removeReadModel "transfer_decisions" base-      mapM_-        (\changes -> [ckCode k | Breaking k <- changes] `shouldContain` [DerivedIdentityChanged])-        [diffSpecs base tableChanged, diffSpecs base subscriptionChanged, diffSpecs base renamed, diffSpecs base removed]-    it "classifies read-model feed flips and consistency/scope weakening as breaking" $ do-      base <- specOf "test/fixtures/readmodel-runtime.keiro"-      let feedChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmFeed = RmInline}) base-          consistencyWeakened = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmConsistency = Eventual}) base-          entireLog = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmScope = Just RmEntireLog}) base-      [ckCode k | Breaking k <- diffSpecs base feedChanged] `shouldContain` [ReadModelFeedChanged]-      [ckCode k | Breaking k <- diffSpecs base consistencyWeakened] `shouldContain` [ReadModelConsistencyWeakened]-      [ckCode k | Breaking k <- diffSpecs entireLog base] `shouldContain` [ReadModelConsistencyWeakened]-    it "classifies Eventual to Strong read-model consistency as additive" $ do-      strong <- specOf "test/fixtures/readmodel-runtime.keiro"-      let eventual = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmConsistency = Eventual}) strong-          changes = diffSpecs eventual strong-      any isBreaking changes `shouldBe` False-      [ckFacet k | Additive k <- changes] `shouldContain` ["read-model-consistency"]--  describe "module placement (M1)" $ do-    it "GeneratedPrefix is today's namespace (Generated.<Ctx>.<Node>, holes at <Ctx>.<Node>)" $ do-      let ctx = defaultContext "hospital-capacity"-      genPrefixFor ctx "Reservation" `shouldBe` "Generated.HospitalCapacity.Reservation"-      holePrefixFor ctx "Reservation" `shouldBe` "HospitalCapacity.Reservation"-    it "module-root prefixes both layers" $ do-      let ctx = (defaultContext "hospital-capacity") {moduleRoot = "Acme"}-      genPrefixFor ctx "Reservation" `shouldBe` "Acme.Generated.HospitalCapacity.Reservation"-      holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation"-    it "CollocatedLeaf places the generated layer under the domain leaf" $ do-      let ctx = (defaultContext "hospital-capacity") {moduleRoot = "Acme", placement = CollocatedLeaf}-      genPrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation.Generated"-      holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation"-    it "parses and preserves the module/layout clauses through parse . pretty" $ do-      let src = "context hospital-capacity\nmodule Acme.Services\nlayout collocated\n\naggregate Reservation\n  regs\n  states Open\n"-      case parseSpec "<m1>" src of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> do-          specModuleRoot spec `shouldBe` Just "Acme.Services"-          specLayout spec `shouldBe` Just CollocatedLeaf-          parseSpec "<m1>" (renderSpec spec) `shouldBe` Right spec-    it "a spec without the clauses leaves placement at the default" $ do-      input <- readTestText "test/fixtures/reservation.keiro"-      case parseSpec "test/fixtures/reservation.keiro" input of-        Left err -> expectationFailure (T.unpack err)-        Right spec -> do-          specModuleRoot spec `shouldBe` Nothing-          specLayout spec `shouldBe` Nothing--  describe "structural scaffold" $ do-    it "emits one private shape module per structural declaration and one context facade" $ do-      spec <- specOf "test/fixtures/consumer-types.keiro"-      let modules = scaffoldModules (defaultContext (specContext spec)) spec-          paths = map modulePath modules-      paths-        `shouldContain` [ "Generated/ConsumerDemo/Structural/Shape/ArtifactInfo.hs",-                          "Generated/ConsumerDemo/Structural/Shape/ArtifactKind.hs",-                          "Generated/ConsumerDemo/Structural/Shape/ArtifactLocation.hs",-                          "Generated/ConsumerDemo/StructuralProjections.hs"-                        ]-      paths `shouldNotContain` ["Generated/ConsumerDemo/Structural/Shape/VendorGeometry.hs"]-      firewallBreaches modules `shouldBe` []-    it "emits one create-once binding skeleton per owning module and derives Generic for private shapes" $ do-      spec <- specOf "test/fixtures/consumer-types.keiro"-      let modules = scaffoldModules (defaultContext (specContext spec)) spec-          skeletons = [moduleValue | moduleValue <- modules, kind moduleValue == HoleStub, modulePath moduleValue == "Example/Artifact/KeiroBindings.hs"]-          shape = generatedTextEndingIn "Structural/Shape/ArtifactInfo.hs" modules-      case skeletons of-        [skeleton] -> do-          moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactInfoBinding :: StructuralBinding"-          moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactKindBinding :: StructuralBinding"-          moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactLocationBinding :: StructuralBinding"-          moduleText skeleton `shouldSatisfy` T.isInfixOf "HOLE: fill ArtifactInfo bindingToShape.key"-        _ -> expectationFailure ("expected exactly one shared binding skeleton, got " <> show (map modulePath skeletons))-      shape `shouldSatisfy` T.isInfixOf "deriving stock (Eq, Generic, Show)"-      shape `shouldSatisfy` T.isInfixOf "import GHC.Generics (Generic)"-    it "never overwrites an existing binding skeleton" $-      withTempDirectory "keiro-dsl-binding-create-once" $ \out -> do-        spec <- specOf "test/fixtures/consumer-types.keiro"-        let ctx = defaultContext (specContext spec)-            bindingPath = out </> "Example/Artifact/KeiroBindings.hs"-        _ <- executePlannedScaffold out "consumer-types.keiro" ctx spec-        TIO.writeFile bindingPath "hand-owned binding\n"-        second <- executePlannedScaffold out "consumer-types.keiro" ctx spec-        TIO.readFile bindingPath `shouldReturn` "hand-owned binding\n"-        reportDispositions second-          `shouldSatisfy` any (\(moduleValue, disposition) -> modulePath moduleValue == "Example/Artifact/KeiroBindings.hs" && disposition == Skipped)-    it "fresh binding skeletons compile at the application boundary" $-      withTempDirectory "keiro-dsl-binding-compiles" $ \out -> do-        spec <- specOf "test/fixtures/structural-conformance.keiro"-        let ctx = defaultContext (specContext spec)-            bindingSource = out </> "Conformance/Structural/Bindings.hs"-            ghcOutput = out </> ".ghc"-        _ <- executePlannedScaffold out "structural-conformance.keiro" ctx spec-        createDirectoryIfMissing True ghcOutput-        (exitCode, standardOutput, standardError) <--          readProcessWithExitCode-            "cabal"-            [ "exec",-              "--",-              "ghc",-              "-XGHC2024",-              "-XOverloadedStrings",-              "-fno-code",-              "-fforce-recomp",-              "-outputdir",-              ghcOutput,-              "-i" <> out,-              "-itest/conformance-structural",-              "-i../keiro-core/src",-              bindingSource-            ]-            ""-        unless (exitCode == ExitSuccess) $-          expectationFailure (standardOutput <> standardError)-    it "keeps consumer types in Domain while the generated Codec owns keys, tags, and defaults" $ do-      spec <- specOf "test/fixtures/consumer-types.keiro"-      let modules = scaffoldModules (defaultContext (specContext spec)) spec-          domain = generatedTextEndingIn "Catalog/Domain.hs" modules-          codec = generatedTextEndingIn "Catalog/Codec.hs" modules-      domain `shouldSatisfy` T.isInfixOf "import Example.Artifact.Domain (ArtifactInfo)"-      domain `shouldSatisfy` T.isInfixOf "import Vendor.Geometry (Geometry)"-      domain `shouldSatisfy` T.isInfixOf "artifact :: !ArtifactInfo"-      domain `shouldSatisfy` T.isInfixOf "RCons (Proxy @\"currentArtifact\") ArtifactKeiroBindings.emptyArtifactInfo"-      domain `shouldSatisfy` (not . T.isInfixOf "Example.Artifact.Domain.ArtifactInfo")-      codec `shouldSatisfy` T.isInfixOf "\"location\" .= encodeArtifactLocationShape"-      codec `shouldSatisfy` T.isInfixOf "\"local_file\""-      codec `shouldSatisfy` T.isInfixOf "parseOptionalField (pure ShapeArtifactKind.Guide)"-      codec `shouldSatisfy` T.isInfixOf "rejectUnknownFields \"ArtifactInfo\""-      codec `shouldSatisfy` T.isInfixOf "toJSON payload.geometry"-      codec `shouldSatisfy` (not . T.isInfixOf "vendor.geometry.json")-    it "generates shape-only nested types and schema-derived Keiki witnesses" $ do-      spec <- specOf "test/fixtures/consumer-types.keiro"-      let modules = scaffoldModules (defaultContext (specContext spec)) spec-          shape = generatedTextEndingIn "Structural/Shape/ArtifactInfo.hs" modules-          facade = generatedTextEndingIn "StructuralProjections.hs" modules-      shape `shouldSatisfy` T.isInfixOf "data ArtifactInfoShape = ArtifactInfo"-      shape `shouldSatisfy` T.isInfixOf "ArtifactKind.ArtifactKindShape"-      mapM_-        (shape `shouldSatisfy`)-        [ T.isInfixOf "description :: !(Maybe Text)",-          T.isInfixOf "tags :: ![Text]",-          T.isInfixOf "labels :: ![Maybe Text]",-          T.isInfixOf "attributes :: !(Map Text Text)"-        ]-      mapM_-        (shape `shouldNotSatisfy`)-        [ T.isInfixOf "description :: !(Maybe (Text))",-          T.isInfixOf "tags :: !([Text])",-          T.isInfixOf "labels :: !([(Maybe (Text))])",-          T.isInfixOf "attributes :: !(Map Text (Text))"-        ]-      shape `shouldSatisfy` (not . T.isInfixOf "KeiroBindings")-      facade `shouldSatisfy` T.isInfixOf "type FieldName"-      facade `shouldSatisfy` T.isInfixOf "= \"/key\""-      facade `shouldSatisfy` T.isInfixOf "fieldShapeId _ = \"example.artifact.ArtifactInfo.v1\""-      facade `shouldSatisfy` T.isInfixOf "type FieldOwner ArtifactInfoKeyProjection = ArtifactInfo"-      facade `shouldSatisfy` T.isInfixOf "bindingToShape KeiroBindings.artifactInfoBinding owner"-      facade `shouldSatisfy` (not . T.isInfixOf "Example.Artifact.Domain.ArtifactInfo")-      facade `shouldSatisfy` T.isInfixOf "artifactInfoKeyWitness"-      facade `shouldNotSatisfy` T.isInfixOf "structuralProjectionC"-    it "suffixes only structural witness names that collide after normalization" $ do-      source <- readTestText "test/fixtures/consumer-types.keiro"-      collisionSpec <--        parseInlineSpec-          "<projection-name-collision>"-          ( T.replace-              "    key         as \"key\"         : Text                 required"-              ( T.unlines-                  [ "    key         as \"key\"         : Text                 required",-                    "    fooDash     as \"foo-bar\"     : Text                 required",-                    "    fooUnder    as \"foo_bar\"     : Text                 required"-                  ]-              )-              source-          )-      graph <- shouldResolveTypeGraph collisionSpec-      let specs = projectionSpecs graph-          keyWitnesses = [spWitness spec | spec <- specs, spPointer spec == "/key"]-          collidedWitnesses = [spWitness spec | spec <- specs, spPointer spec `elem` ["/foo-bar", "/foo_bar"]]-      keyWitnesses `shouldBe` ["artifactInfoKeyWitness"]-      length collidedWitnesses `shouldBe` 2-      Set.size (Set.fromList collidedWitnesses) `shouldBe` 2-      collidedWitnesses `shouldSatisfy` all (T.isPrefixOf "artifactInfoFooBar")-      collidedWitnesses `shouldSatisfy` all (T.isSuffixOf "Witness")-      collidedWitnesses `shouldSatisfy` all ((== 8) . T.length . T.dropEnd (T.length ("Witness" :: T.Text)) . T.drop (T.length ("artifactInfoFooBar" :: T.Text)))-    it "uses only precedence-required parentheses in nested record field types" $ do-      let spec =-            mappedSpec-              [ completeStructural-                  "Nested"-                  ( recordShape-                      [ TMap (TOptional TText),-                        TOptional (TList TText),-                        TOptional (TMap TText)-                      ]-                  )-              ]-          shape = generatedTextEndingIn "Structural/Shape/Nested.hs" (scaffoldStructural (defaultContext (specContext spec)) spec)-      mapM_-        (shape `shouldSatisfy`)-        [ T.isInfixOf "field1 :: !(Map Text (Maybe Text))",-          T.isInfixOf "field2 :: !(Maybe [Text])",-          T.isInfixOf "field3 :: !(Maybe (Map Text Text))"-        ]-    it "uses the same precedence rules for strict union payloads" $ do-      let spec =-            mappedSpec-              [ completeStructural-                  "Payload"-                  ( ShapeUnion-                      (TaggedObject "tag" "contents" RejectUnknown)-                      [ WireArm "OptionalPayload" "optional" (Just (TOptional TText)) noLoc,-                        WireArm "ListPayload" "list" (Just (TList (TOptional TText))) noLoc,-                        WireArm "MapPayload" "map" (Just (TMap (TOptional TText))) noLoc-                      ]-                  )-              ]-          shape = generatedTextEndingIn "Structural/Shape/Payload.hs" (scaffoldStructural (defaultContext (specContext spec)) spec)-      mapM_-        (shape `shouldSatisfy`)-        [ T.isInfixOf "OptionalPayload !(Maybe Text)",-          T.isInfixOf "ListPayload ![Maybe Text]",-          T.isInfixOf "MapPayload !(Map Text (Maybe Text))"-        ]--  describe "structural manifest" $ do-    it "lists consumer packages and every domain, binding, fixture, and initial module" $ do-      spec <- specOf "test/fixtures/consumer-types.keiro"-      let modules = scaffoldModules (defaultContext (specContext spec)) spec-          manifest = renderManifest "consumer-types.keiro" modules spec-      assertGeneratedHaskellContract "consumer-types.keiro" manifest-      mapM_ (\packageName -> manifestDependencies spec `shouldContain` [packageName]) ["artifact-domain", "vendor-geometry"]-      manifest `shouldSatisfy` T.isInfixOf "consumer-packages:\n    artifact-domain\n    vendor-geometry"-      mapM_-        (\moduleName -> manifest `shouldSatisfy` T.isInfixOf moduleName)-        [ "Example.Artifact.Domain",-          "Example.Artifact.KeiroBindings",-          "Vendor.Geometry",-          "Vendor.Geometry.KeiroBindings"-        ]--  describe "structural scaffold record" $ do-    it "round-trips canonical mapping rows and reports binding drift on the next run" $-      withTempDirectory "keiro-dsl-mapping-record" $ \out -> do-        spec <- specOf "test/fixtures/consumer-types.keiro"-        let ctx = defaultContext (specContext spec)-        first <- executePlannedScaffold out "consumer-types.keiro" ctx spec-        length (consumerMappings (reportConsumerPlan first)) `shouldBe` 4-        recordText <- TIO.readFile (out </> recordFileName (specContext spec))-        let mappingRows = filter (T.isPrefixOf "mapping ") (T.lines recordText)-            bindingRows = filter (T.isPrefixOf "binding ") (T.lines recordText)-        length mappingRows `shouldBe` 4-        bindingRows `shouldSatisfy` (not . null)-        fmap recMappings (parseRecord recordText) `shouldSatisfy` maybe False ((== 4) . length)-        fmap recBindingObligations (parseRecord recordText) `shouldSatisfy` maybe False ((== length bindingRows) . length)-        let bumped = spec {specMapped = map bumpArtifactBindingVersion (specMapped spec)}-        second <- executePlannedScaffold out "consumer-types.keiro" ctx bumped-        reportMappingDrift second-          `shouldSatisfy` any (\drift -> driftSpecName drift == "ArtifactInfo" && driftPrevious drift /= driftCurrent drift)-        renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "mapping drift:")-        case mappingRows of-          row : _ -> parseRecord (recordText <> row <> "\n") `shouldBe` Nothing-          [] -> expectationFailure "expected mapping rows"-        case bindingRows of-          row : _ -> parseRecord (recordText <> row <> "\n") `shouldBe` Nothing-          [] -> expectationFailure "expected binding rows"-    it "reports exactly the newly added binding field without rewriting the shared skeleton" $-      withTempDirectory "keiro-dsl-binding-drift" $ \out -> do-        spec <- specOf "test/fixtures/consumer-types.keiro"-        let ctx = defaultContext (specContext spec)-        _ <- executePlannedScaffold out "consumer-types.keiro" ctx spec-        let extended = spec {specMapped = map addArtifactSummaryField (specMapped spec)}-        second <- executePlannedScaffold out "consumer-types.keiro" ctx extended-        reportNewHoles second-          `shouldBe` [ BindingHole-                         { holeMappedName = "ArtifactInfo",-                           holeModule = "Example.Artifact.KeiroBindings",-                           holeSymbol = "artifactInfoBinding",-                           holeKind = BindingValue,-                           holePath = Just "summary",-                           holeSignature = "artifactInfoBinding.summary :: Text"-                         }-                     ]-        renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "artifactInfoBinding.summary :: Text")-    it "rejects malformed known mapping JSON while ignoring unrelated future rows" $ do-      spec <- specOf "test/fixtures/consumer-types.keiro"-      withTempDirectory "keiro-dsl-mapping-malformed" $ \out -> do-        report <- executePlannedScaffold out "consumer-types.keiro" (defaultContext (specContext spec)) spec-        recordText <- TIO.readFile (reportRecordPath report)-        parseRecord (recordText <> "mapping {not-json}\n") `shouldBe` Nothing-        parseRecord (recordText <> "future-row retained\n") `shouldBe` parseRecord recordText--  describe "structural import plan" $ do-    it "reports the successful dependency plan in the scaffold report" $-      withTempDirectory "keiro-dsl-dependency-plan" $ \out -> do-        spec <- specOf "test/fixtures/consumer-types.keiro"-        report <- executePlannedScaffold out "consumer-types.keiro" (defaultContext (specContext spec)) spec-        renderScaffoldReport report-          `shouldSatisfy` any (T.isInfixOf "dependency plan: consumer packages [artifact-domain, vendor-geometry]")-    it "refuses a binding module inside the generated namespace with the exact cycle" $ do-      spec <- specOf "test/fixtures/consumer-types.keiro"-      let cyclic = spec {specMapped = map moveArtifactBindingIntoGenerated (specMapped spec)}-      case planScaffold (defaultContext (specContext cyclic)) cyclic of-        Left refusals -> do-          refusals `shouldSatisfy` any isImportCycle-          renderRefusals refusals `shouldSatisfy` any (T.isInfixOf "Generated.ConsumerDemo.Bindings")-        Right _ -> expectationFailure "expected an import-cycle refusal"-    it "refuses missing mapped register initials but permits command/event-only use" $ do-      missing <- specOf "test/fixtures/mapped-missing-initial.keiro"-      planScaffold (defaultContext (specContext missing)) missing `shouldSatisfy` isFoldSurfaceRefusal-      spec <- specOf "test/fixtures/consumer-types.keiro"-      let commandOnly = removeMappedRegisterRequirements spec-      planScaffold (defaultContext (specContext commandOnly)) commandOnly `shouldSatisfy` isRight--  describe "binding explanations" $ do-    it "lists binding, fixture, and use-site-scoped initial obligations deterministically" $ do-      spec <- specOf "test/fixtures/consumer-types.keiro"-      obligations <- either (\errors -> expectationFailure (show errors) >> pure []) pure (bindingObligations spec)-      length obligations `shouldBe` 7-      obligations-        `shouldSatisfy` any-          ( \obligation ->-              obligationKind obligation == BindingValue-                && obligationSymbol obligation == "artifactInfoBinding"-                && obligationBindingVersion obligation == Just "1"-          )-      obligations-        `shouldSatisfy` any-          ( \obligation ->-              obligationKind obligation == InitialValue-                && obligationSymbol obligation == "emptyArtifactInfo"-                && any (T.isInfixOf "Catalog register currentArtifact") (obligationUseSites obligation)-          )-      let rendered = renderBindingObligations (specContext spec) obligations-      rendered `shouldSatisfy` T.isInfixOf "binding obligations for context consumer-demo"-      rendered `shouldSatisfy` T.isInfixOf "artifactInfoBinding :: StructuralBinding Example.Artifact.Domain.ArtifactInfo ArtifactInfoShape"-      rendered `shouldSatisfy` T.isInfixOf "provenance: binding-version \"1\""-    it "states explicitly when a spec has no structural obligations" $ do-      spec <- specOf "test/fixtures/reservation.keiro"-      obligations <- either (\errors -> expectationFailure (show errors) >> pure []) pure (bindingObligations spec)-      renderBindingObligations (specContext spec) obligations-        `shouldBe` "no binding obligations for context hospital-capacity"--  describe "exact generic structural bindings" $ do-    forM_-      [ ("renamed-field", "selector mismatch"),-        ("reordered-field", "selector mismatch"),-        ("arity-mismatch", "no exact nominal correspondence"),-        ("incompatible-type", "no exact nominal correspondence")-      ]-      $ \(fixture, diagnostic) ->-        it ("rejects " <> fixture <> " and directs the author to the scaffolded module") $-          expectGenericCompileFailure fixture diagnostic--  describe "structural harness" $ do-    it "emits every structural, wire-policy, projection, and replay assertion family" $ do-      spec <- specOf "test/fixtures/consumer-types.keiro"-      let aggregate = onlyAggregate spec-          ctx = defaultContext (specContext spec)-          harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx spec aggregate)-      mapM_-        (\needle -> harness `shouldSatisfy` T.isInfixOf needle)-        [ "binding domain round-trip: example.artifact.ArtifactInfo.v1/",-          "binding shape round-trip: example.artifact.ArtifactInfo.v1/",-          "mapped codec round-trip: ArtifactObserved/artifact/",-          "fixture coverage: example.artifact.ArtifactLocation.v1",-          "wire policy missing default: example.artifact.ArtifactInfo.v1/description",-          "wire policy explicit null: example.artifact.ArtifactInfo.v1/description",-          "wire policy unknown fields: example.artifact.ArtifactInfo.v1",-          "wire union arm: example.artifact.ArtifactLocation.v1/local_file",-          "canonical identity: example.artifact.ArtifactInfo.v1",-          "projection witness agreement: example.artifact.ArtifactInfo.v1/key",-          "forward/replay equality: ObserveArtifact from CatalogEmpty -- ",-          "register currentArtifact"-        ]-    it "keeps opaque assertions at the declared codec boundary" $ do-      spec <- specOf "test/fixtures/consumer-types.keiro"-      let aggregate = onlyAggregate spec-          ctx = defaultContext (specContext spec)-          modules = scaffoldAggregate ctx spec aggregate <> harnessFor ctx spec aggregate-          harness = generatedTextEndingIn "Harness.hs" modules-          codec = generatedTextEndingIn "Codec.hs" modules-      harness `shouldSatisfy` T.isInfixOf "opaque codec round-trip: vendor.geometry.json@3/"-      harness `shouldNotSatisfy` T.isInfixOf "wire policy unknown fields: vendor.geometry.json"-      harness `shouldNotSatisfy` T.isInfixOf "fixture coverage: vendor.geometry"-      codec `shouldNotSatisfy` T.isInfixOf "encodeVendorGeometryShape"--  describe "generated Haskell language contract" $ do-    it "limits every representative generated module to the closed local extension set" $ do-      let allowed =-            Set.fromList-              [ "BlockArguments",-                "DeriveAnyClass",-                "DuplicateRecordFields",-                "OverloadedLabels",-                "OverloadedRecordDot",-                "QualifiedDo",-                "TemplateHaskell",-                "TypeFamilies"-              ]-          fixtures =-            [ "test/fixtures/aggregate-scalar-expressions-v2.keiro",-              "test/fixtures/nominal-scalars.keiro",-              "test/fixtures/structural-conformance.keiro",-              "test/fixtures/reservation.keiro",-              "test/fixtures/contract-v4.keiro",-              "test/fixtures/intake.keiro",-              "test/fixtures/reservation-work.keiro",-              "test/fixtures/readmodel-runtime.keiro"-            ]-      forM_ fixtures $ \fixture -> do-        modules <- scaffoldFixture fixture-        forM_ [generatedModule | generatedModule <- modules, kind generatedModule == Generated] $ \generatedModule -> do-          let actual = Set.fromList (generatedLocalExtensions generatedModule)-          unless (actual `Set.isSubsetOf` allowed) $-            expectationFailure (fixture <> ":" <> modulePath generatedModule <> ": disallowed local extensions " <> show (Set.toList (actual `Set.difference` allowed)))--    it "retains specialized syntax extensions and removes GHC2024-covered pragmas" $ do-      scalar <- scaffoldFixture "test/fixtures/aggregate-scalar-expressions-v2.keiro"-      structural <- scaffoldFixture "test/fixtures/structural-conformance.keiro"-      reservation <- scaffoldFixture "test/fixtures/reservation.keiro"-      contract <- scaffoldFixture "test/fixtures/contract-v4.keiro"-      intake <- scaffoldFixture "test/fixtures/intake.keiro"-      queue <- scaffoldFixture "test/fixtures/reservation-work.keiro"-      readModel <- scaffoldFixture "test/fixtures/readmodel-runtime.keiro"-      generatedExtensionsEndingIn "ScalarAccount/Domain.hs" scalar-        `shouldBe` ["DeriveAnyClass", "DuplicateRecordFields", "TemplateHaskell"]-      generatedExtensionsEndingIn "ScalarAccount/Transducer.hs" scalar-        `shouldBe` ["BlockArguments", "OverloadedLabels", "OverloadedRecordDot", "QualifiedDo"]-      generatedExtensionsEndingIn "Nominals.hs" scalar `shouldContain` ["DeriveAnyClass", "TypeFamilies"]-      generatedExtensionsEndingIn "Nominals/Internal.hs" scalar `shouldBe` []-      generatedExtensionsEndingIn "StructuralProjections.hs" structural `shouldBe` ["TypeFamilies"]-      let structuralShapeExtensions =-            [ generatedLocalExtensions generatedModule-            | generatedModule <- structural,-              "/Structural/Shape/" `T.isInfixOf` T.pack (modulePath generatedModule)-            ]-      structuralShapeExtensions `shouldSatisfy` all null-      generatedExtensionsEndingIn "Projection.hs" reservation `shouldBe` []-      generatedExtensionsEndingIn "ReplayAudit.hs" reservation `shouldBe` []-      generatedExtensionsEndingIn "Contract.hs" contract `shouldBe` ["DuplicateRecordFields", "OverloadedRecordDot"]-      generatedExtensionsEndingIn "Inbox.hs" intake `shouldBe` []-      generatedExtensionsEndingIn "Queue.hs" queue `shouldBe` ["OverloadedRecordDot"]-      generatedExtensionsEndingIn "ReadModel.hs" readModel `shouldBe` ["OverloadedRecordDot"]--    it "conditions record, label, derivation, and duplicate-selector extensions on emitted syntax" $ do-      mappedGuardSource <- readTestText "test/fixtures/mapped-guard.keiro"-      mappedGuardParsed <- case parseSource "mapped-guard-no-expression.keiro" (T.replace "guard current == current ; " "" mappedGuardSource) of-        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-        Right parsed -> pure parsed-      let mappedGuardService = checkedSource mappedGuardParsed-          mappedGuard = scaffoldServiceModules (defaultContext (specContext (checkedSpec mappedGuardService))) mappedGuardService-      registerFree <- scaffoldFixture "test/fixtures/order.keiro"-      readModels <- scaffoldFixture "test/fixtures/readmodel.keiro"-      snapshot <- scaffoldFixture "test/fixtures/reservation-snapshot.keiro"-      ordinary <- scaffoldFixture "test/fixtures/reservation.keiro"-      generatedExtensionsEndingIn "Holder/Domain.hs" mappedGuard `shouldBe` ["TemplateHaskell"]-      generatedExtensionsEndingIn "Holder/Codec.hs" mappedGuard `shouldBe` []-      generatedExtensionsEndingIn "Holder/Transducer.hs" mappedGuard-        `shouldBe` ["BlockArguments", "QualifiedDo"]-      generatedExtensionsEndingIn "Holder/Harness.hs" mappedGuard `shouldBe` ["OverloadedLabels"]-      generatedExtensionsEndingIn "Order/Harness.hs" registerFree `shouldBe` []-      generatedExtensionsEndingIn "TransferDecisions/ReadModel.hs" readModels `shouldBe` ["OverloadedRecordDot"]-      generatedExtensionsEndingIn "Subscriptions/ReadModel.hs" readModels `shouldBe` []-      generatedExtensionsEndingIn "Reservation/Domain.hs" snapshot `shouldContain` ["DeriveAnyClass"]-      generatedExtensionsEndingIn "Reservation/Domain.hs" ordinary `shouldNotContain` ["DeriveAnyClass"]--      disjoint <--        parseInlineSpec "<disjoint-contract>" $-          T.unlines-            [ "language keiro-dsl 4",-              "context language-contract",-              "contract disjoint {",-              "  schemaVersion 1",-              "  discriminator kind",-              "  topic events \"events\"",-              "  event First on events { first: text }",-              "  event Second on events { second: text }",-              "}"-            ]-      emptyPayload <--        parseInlineSpec "<empty-contract>" $-          T.unlines-            [ "language keiro-dsl 4",-              "context language-contract",-              "contract empty {",-              "  schemaVersion 1",-              "  discriminator kind",-              "  topic events \"events\"",-              "  event Empty on events { }",-              "}"-            ]-      let contractExtensions spec =-            generatedExtensionsEndingIn-              "Contract.hs"-              [ generatedModule-              | contractNode <- [contractNode | NContract contractNode <- specNodes spec],-                generatedModule <- scaffoldContract (defaultContext (specContext spec)) contractNode-              ]-      contractExtensions disjoint `shouldBe` ["OverloadedRecordDot"]-      contractExtensions emptyPayload `shouldBe` []--  describe "manifest (M2)" $ do-    it "lists exactly the modules the scaffolder produced" $ do-      mods <- scaffoldFixture "test/fixtures/reservation.keiro"-      service <- checkedServiceOf "test/fixtures/reservation.keiro"-      let manifest = renderManifestForService "reservation.keiro" mods service-          expectedNames = sort (map (moduleNameOf . modulePath) mods)-      assertGeneratedHaskellContract "reservation.keiro" manifest-      -- every produced module name appears in the manifest…-      mapM_ (\m -> (m `T.isInfixOf` manifest) `shouldBe` True) expectedNames-      -- …and the module list is exactly the scaffolder's output set.-      expectedNames-        `shouldBe` sort-          [ "Generated.HospitalCapacity.Reservation.Codec",-            "Generated.HospitalCapacity.Reservation.BehaviorContract",-            "Generated.HospitalCapacity.Reservation.Domain",-            "Generated.HospitalCapacity.Reservation.EventStream",-            "Generated.HospitalCapacity.Reservation.Harness",-            "Generated.HospitalCapacity.Reservation.Projection",-            "Generated.HospitalCapacity.Reservation.Transducer",-            "Generated.HospitalCapacity.Nominals",-            "Generated.HospitalCapacity.Nominals.Internal",-            "Generated.HospitalCapacity.ReplayAudit",-            "HospitalCapacity.Reservation.BehaviorHoles",-            "HospitalCapacity.Reservation.Holes"-          ]-    it "derives the dependency set from the node kinds present (aggregate)" $ do-      service <- checkedServiceOf "test/fixtures/reservation.keiro"-      manifestDependenciesForService service `shouldBe` ["aeson", "base", "keiki", "keiro", "text"]-    it "derives the process dependency set, including worker-policy runtime imports" $ do-      service <- checkedServiceOf "test/fixtures/hospital-surge.keiro"-      let dependencies = manifestDependenciesForService service-      mapM_ (\dependency -> dependencies `shouldContain` [dependency]) ["time", "uuid", "shibuya-core", "keiki", "keiro"]-    it "uses the registered shibuya-core package name for router scaffolds" $ do-      service <- checkedServiceOf "test/fixtures/incident-paging/incident-paging.keiro"-      let dependencies = manifestDependenciesForService service-      mapM_ (\dependency -> dependencies `shouldContain` [dependency]) ["effectful-core", "keiro", "shibuya-core"]-      dependencies `shouldNotContain` ["shibuya"]--  describe "service conformance facade (plan 188 M2)" $ do-    it "normalizes aggregate and read-model checks behind one base-only API" $ do-      service <- checkedServiceOf "test/fixtures/transfer-routing.keiro"-      let ctx = defaultContext (specContext (checkedSpec service))-      case serviceHarnessModule ctx service of-        Left duplicates -> expectationFailure ("unexpected duplicate fact keys: " <> show duplicates)-        Right facade -> do-          committed <- readTestText ("test/conformance-newsurface/" <> modulePath facade)-          normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText facade)-          moduleNameOf (modulePath facade) `shouldBe` "Generated.TransferRouting.Conformance"-          moduleText facade `shouldSatisfy` T.isInfixOf ".harnessAssertions"-          moduleText facade `shouldSatisfy` T.isInfixOf ".readModelFactResults"-          moduleText facade `shouldSatisfy` T.isInfixOf "aggregate/Hospital/"-          moduleText facade `shouldSatisfy` T.isInfixOf "readmodel/hospital_load/"-          moduleText facade `shouldSatisfy` T.isInfixOf "qualified as Hospital"-          moduleText facade `shouldSatisfy` T.isInfixOf "qualified as HospitalLoad"-          moduleText facade `shouldNotSatisfy` T.isInfixOf "qualified as Harness"-          moduleText facade `shouldNotSatisfy` T.isInfixOf "TransferRouting.Hospital.Holes"-    it "projects process, router, and workflow facts with qualified stable keys" $ do-      processService <- checkedServiceOf "test/fixtures/hospital-surge.keiro"-      routerService <- checkedServiceOf "test/fixtures/incident-paging/incident-paging.keiro"-      workflowService <- checkedServiceOf "test/fixtures/workflow-evolution.keiro"-      let select predicate = filter predicate . specNodes . checkedSpec-          factNodes =-            select (\case NProcess {} -> True; _ -> False) processService-              <> select (\case NRouter {} -> True; _ -> False) routerService-              <> select (\case NWorkflow {} -> True; _ -> False) workflowService-          baseSpec = checkedSpec processService-          service = processService {checkedSpec = baseSpec {specNodes = factNodes}}-          ctx = defaultContext (specContext baseSpec)-      forM_-        [ "process/HospitalSurge/maxAttempts",-          "router/PagingRouter/dispatchCommand",-          "workflow/HospitalTransferReservation/body"-        ]-        (\key -> serviceConformanceFactKeys service `shouldSatisfy` elem key)-      case serviceHarnessModule ctx service of-        Left duplicates -> expectationFailure ("unexpected duplicate fact keys: " <> show duplicates)-        Right facade -> do-          moduleText facade `shouldSatisfy` T.isInfixOf ".processHarnessValues"-          moduleText facade `shouldSatisfy` T.isInfixOf ".routerHarnessValues"-          moduleText facade `shouldSatisfy` T.isInfixOf ".workflowFactValues"-    it "uses the shared context-level placement policy" $ do-      service <- checkedServiceOf "test/fixtures/contract-v4.keiro"-      let ctx = Context {contextName = "modules", moduleRoot = "Mori", placement = CollocatedLeaf}-      serviceConformanceModuleName ctx `shouldBe` "Mori.Modules.Generated.Conformance"-      case serviceHarnessModule ctx service of-        Left duplicates -> expectationFailure ("unexpected duplicate fact keys: " <> show duplicates)-        Right facade -> do-          moduleText facade `shouldSatisfy` T.isInfixOf "runServiceConformanceChecks = pure []"-          moduleText facade `shouldSatisfy` T.isInfixOf "serviceConformanceFacts = []"-    it "adds one facade only to configured single-file plans and exposes only it" $ do-      service <- checkedServiceOf "test/fixtures/reservation.keiro"-      let ctx = defaultContext (specContext (checkedSpec service))-          runtimePackage = RuntimePackageName "reservation-runtime"-      unconfigured <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planServiceScaffold ctx service)-      configured <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planServiceScaffoldWithRuntimePackage (Just runtimePackage) ctx service)-      let facadeName = serviceConformanceModuleName ctx-          facades = [moduleValue | moduleValue <- configured, moduleNameOf (modulePath moduleValue) == facadeName]-          manifest = renderManifestForServiceWithFacade (Just facadeName) "reservation.keiro" configured service-      length configured `shouldBe` length unconfigured + 1-      length facades `shouldBe` 1-      manifest `shouldSatisfy` T.isInfixOf ("exposed-modules:\n    " <> facadeName)-      T.count facadeName manifest `shouldBe` 1-    it "emits one context-level facade for a multi-member workspace regardless of member order" $ do-      canonical <- shouldComposeWorkspace canonicalWorkspacePath-      reordered <- shouldComposeWorkspace "test/fixtures/workspace/service-reordered.keiro-workspace"-      let runtimePackage = Just (RuntimePackageName "demo-runtime")-          plan workspace =-            planWorkspaceScaffoldWithRuntimePackageAndGoldens [] runtimePackage "goldens" (workspaceContext workspace) workspace-          facades workspacePlan =-            [ (moduleText moduleValue, provenance)-            | (moduleValue, provenance) <- wpModules workspacePlan,-              ".Conformance" `T.isSuffixOf` moduleNameOf (modulePath moduleValue)-            ]-      canonicalPlan <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (plan canonical)-      reorderedPlan <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (plan reordered)-      facades canonicalPlan `shouldBe` facades reorderedPlan-      map snd (facades canonicalPlan) `shouldBe` [ContextLevel]-    it "refuses duplicate normalized fact keys before planning writes" $ do-      service <- checkedServiceOf "test/fixtures/hospital-surge.keiro"-      let spec = checkedSpec service-          processes = [node | node@NProcess {} <- specNodes spec]-          duplicated = service {checkedSpec = spec {specNodes = processes <> processes}}-      serviceHarnessModule (defaultContext (specContext spec)) duplicated `shouldSatisfy` isLeft--  describe "runnable service conformance package (plan 188 M3)" $ do-    it "uses readable ordinary names and collision-safe punctuation encoding" $ do-      cabaliseConformanceService "mori" `shouldBe` "mori"-      cabaliseConformanceService "mori_core" `shouldNotBe` cabaliseConformanceService "mori-core"-      cabaliseConformanceService "Mori" `shouldNotBe` cabaliseConformanceService "mori"-      conformancePackageDirectory (WorkspaceConformanceService "mori") `shouldBe` "keiro-dsl-conformance.workspace.mori"-      conformancePackageDirectory (StandaloneConformanceService "mori") `shouldBe` "keiro-dsl-conformance.mori"-    it "plans one base-only package and round-trips its complete generated record" $ do-      service <- checkedServiceOf "test/fixtures/hospital-surge.keiro"-      let runtimePackage = RuntimePackageName "hospital-runtime"-          facade = "Generated.HospitalSurge.Conformance"-      plan <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planConformancePackage (StandaloneConformanceService "hospital-surge") runtimePackage facade service)-      cppPackageName plan `shouldBe` "keiro-hospital-surge-conformance"-      length [file | file <- cppFiles plan, takeExtension (conformanceFilePath file) == ".cabal"] `shouldBe` 1-      cabalFile <- case [file | file <- cppFiles plan, takeExtension (conformanceFilePath file) == ".cabal"] of-        [file] -> pure file-        files -> expectationFailure ("expected one Cabal file, got " <> show (map conformanceFilePath files)) >> fail "unreachable"-      let cabalText = conformanceFileText cabalFile-      cabalText `shouldSatisfy` T.isInfixOf "base >=4.18 && <5"-      T.lines cabalText `shouldSatisfy` (\lines' -> case lines' of first : _ -> first == "cabal-version: 3.0"; [] -> False)-      cabalText `shouldSatisfy` T.isInfixOf "hospital-runtime"-      cabalText `shouldSatisfy` T.isInfixOf "ghc-options: -Wall"-      cabalText `shouldNotSatisfy` T.isInfixOf "    , keiro-dsl\n"-      recordFile <- case [file | file <- cppFiles plan, conformanceFilePath file == conformanceRecordFileName] of-        [file] -> pure file-        files -> expectationFailure ("expected one package record, got " <> show (map conformanceFilePath files)) >> fail "unreachable"-      let recordText = conformanceFileText recordFile-      parseConformancePackageRecord recordText-        `shouldBe` Just-          ConformancePackageRecord-            { cprSchema = 1,-              cprServiceKey = cppServiceKey plan,-              cprRuntimePackage = runtimePackage,-              cprFacadeModule = facade,-              cprFiles = [(conformanceFileKind file, conformanceFilePath file) | file <- cppFiles plan]-            }-    it "tolerates future rows and JSON keys while round-tripping awkward safe paths" $ do-      let recordText =-            T.unlines-              [ "keiro-dsl conformance ledger v1",-                "service-key standalone hospital-surge",-                "runtime-package hospital-runtime",-                "facade-module Generated.HospitalSurge.Conformance",-                "file {\"kind\":\"generated\",\"path\":\"generated/file with space.hs\",\"future-key\":true}",-                "future-row {\"value\":1}"-              ]-          expected =-            ConformancePackageRecord-              { cprSchema = 1,-                cprServiceKey = StandaloneConformanceService "hospital-surge",-                cprRuntimePackage = RuntimePackageName "hospital-runtime",-                cprFacadeModule = "Generated.HospitalSurge.Conformance",-                cprFiles = [(Generated, "generated/file with space.hs")]-              }-      parseConformancePackageRecord recordText `shouldBe` Just expected-      parseConformancePackageRecord (renderConformancePackageRecord expected) `shouldBe` Just expected-      parseConformancePackageRecord (T.replace "generated/file with space.hs" "../escape.hs" recordText)-        `shouldBe` Nothing-      parseConformancePackageRecord (T.replace "future-row {\"value\":1}" "file {\"kind\":\"generated\",\"path\":\"GENERATED/FILE WITH SPACE.HS\"}" recordText)-        `shouldBe` Nothing-    it "compares unique facts by key and distinguishes mismatch, missing, and unexpected" $ do-      compareConformanceFacts [("a", "1"), ("b", "2"), ("d", "4")] [("c", "3"), ("a", "1"), ("b", "9")]-        `shouldBe` Right-          [ ConformanceFactMatch "a" "1",-            ConformanceFactMismatch "b" "2" "9",-            ConformanceFactUnexpected "c" "3",-            ConformanceFactMissing "d" "4"-          ]-      compareConformanceFacts [("a", "1"), ("a", "2")] []-        `shouldBe` Left [DuplicateFactKey ExpectedFact "a"]-    it "creates once, reports generated files unchanged, and preserves accepted expectations" $ do-      withTempDirectory "keiro-dsl-conformance-package" $ \out -> do-        parsed <- parsedSourceOf "test/fixtures/hospital-surge.keiro"-        let service = checkedSource parsed-            spec = checkedSpec service-            ctx = defaultContext (specContext spec)-            runtimePackage = RuntimePackageName "hospital-runtime"-        modules <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planServiceScaffoldWithRuntimePackage (Just runtimePackage) ctx service)-        first <- executeServiceScaffoldWithRuntimePackage (Just runtimePackage) out False "hospital-surge.keiro" (parsedSourceLanguage parsed) ctx service modules-        firstReport <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure first-        firstPackage <- maybe (expectationFailure "expected conformance package report" >> fail "unreachable") pure (reportConformancePackage firstReport)-        let packageRoot = out </> conformancePackageDirectory (StandaloneConformanceService (contextName ctx))-            expectationsPath = packageRoot </> "src/KeiroConformance/Expectations.hs"-            accepted = "module KeiroConformance.Expectations where\n-- accepted by the application\n"-        map snd (conformanceReportDispositions firstPackage) `shouldContain` [ConformanceCreated]-        TIO.writeFile expectationsPath accepted-        second <- executeServiceScaffoldWithRuntimePackage (Just runtimePackage) out True "hospital-surge.keiro" (parsedSourceLanguage parsed) ctx service modules-        secondReport <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure second-        secondPackage <- maybe (expectationFailure "expected conformance package report" >> fail "unreachable") pure (reportConformancePackage secondReport)-        TIO.readFile expectationsPath `shouldReturn` accepted-        [ disposition-          | (file, disposition) <- conformanceReportDispositions secondPackage,-            conformanceFileKind file == Generated-          ]-          `shouldSatisfy` all (== ConformanceUnchanged)-        [ disposition-          | (file, disposition) <- conformanceReportDispositions secondPackage,-            conformanceFileKind file == HoleStub-          ]-          `shouldBe` [ConformanceSkipped]-    -- Migration used to be planned only when the run also planned a conformance-    -- package, so a spec that stopped generating one left its legacy record-    -- behind — and unreadable, since the current reader has no legacy parser.-    -- See ExecPlan 199.-    it "migrates an orphaned legacy conformance record even with no package planned" $-      withTempDirectory "keiro-dsl-orphan-conformance-ledger" $ \out -> do-        parsed <- parsedSourceOf "test/fixtures/hospital-surge.keiro"-        let service = checkedSource parsed-            spec = checkedSpec service-            ctx = defaultContext (specContext spec)-            orphanDirectory = out </> "keiro-dsl-conformance.standalone.retired-service"-            orphanPath = orphanDirectory </> legacyConformanceRecordFileName-            -- No --runtime-package, so this run plans no conformance package at-            -- all: the record below belongs to a package that no longer exists.-            run apply = do-              modules <--                either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure $-                  planServiceScaffoldWithRuntimePackage Nothing ctx service-              executeServiceScaffoldWithRuntimePackageAndNameMigrations-                Nothing-                apply-                out-                False-                "hospital-surge.keiro"-                (parsedSourceLanguage parsed)-                ctx-                service-                modules-        -- Build the orphan from a record the current writer produced, so the-        -- test exercises the discovery change and not a hand-typed format.-        withTempDirectory "keiro-dsl-orphan-source" $ \source -> do-          let sourceRuntime = RuntimePackageName "retired-runtime"-              sourcePackageRoot = source </> conformancePackageDirectory (StandaloneConformanceService (contextName ctx))-          sourceModules <--            either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure $-              planServiceScaffoldWithRuntimePackage (Just sourceRuntime) ctx service-          _ <--            executeServiceScaffoldWithRuntimePackageAndNameMigrations-              (Just sourceRuntime)-              False-              source-              False-              "hospital-surge.keiro"-              (parsedSourceLanguage parsed)-              ctx-              service-              sourceModules-              >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure-          ledger <- TIO.readFile (sourcePackageRoot </> conformanceLedgerFileName)-          record <--            maybe (expectationFailure "conformance ledger did not parse" >> fail "unreachable") pure $-              parseConformancePackageRecord ledger-          createDirectoryIfMissing True orphanDirectory-          TIO.writeFile-            orphanPath-            ( T.unlines $-                [line | line <- T.lines ledger, isGeneratedBannerLine line]-                  <> [ "schema 1",-                       "service-key standalone " <> contextName ctx,-                       "runtime-package " <> unRuntimePackageName (cprRuntimePackage record),-                       "facade-module " <> cprFacadeModule record-                     ]-                  <> [ "file "-                         <> (case fileKind of Generated -> "generated"; HoleStub -> "create-once")-                         <> " "-                         <> T.pack path-                     | (fileKind, path) <- cprFiles record-                     ]-            )-        refused <- run False-        refused `shouldSatisfy` \case-          Left [SidecarMigrationRequired [move]] ->-            sidecarMoveDisposition move == ConvertLegacyConformanceLedger-          _ -> False--        applied <- run True >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure-        map sidecarMoveDisposition (reportSidecarMoves applied) `shouldBe` [ConvertLegacyConformanceLedger]-        doesFileExist orphanPath `shouldReturn` False-        doesFileExist (orphanDirectory </> conformanceLedgerFileName) `shouldReturn` True--    it "converts a legacy conformance record losslessly and keeps service-key mismatch refusal" $-      withTempDirectory "keiro-dsl-conformance-ledger-migration" $ \out -> do-        parsed <- parsedSourceOf "test/fixtures/hospital-surge.keiro"-        let service = checkedSource parsed-            spec = checkedSpec service-            ctx = defaultContext (specContext spec)-            runtimePackage = RuntimePackageName "hospital-runtime"-            packageRoot = out </> conformancePackageDirectory (StandaloneConformanceService (contextName ctx))-            currentPath = packageRoot </> conformanceLedgerFileName-            legacyPath = packageRoot </> legacyConformanceRecordFileName-            backupPath = out </> ".keiro-dsl-name-migrations/sidecar-v1" </> conformancePackageDirectory (StandaloneConformanceService (contextName ctx)) </> legacyConformanceRecordFileName-        modules <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planServiceScaffoldWithRuntimePackage (Just runtimePackage) ctx service)-        let run apply =-              executeServiceScaffoldWithRuntimePackageAndNameMigrations-                (Just runtimePackage)-                apply-                out-                False-                "hospital-surge.keiro"-                (parsedSourceLanguage parsed)-                ctx-                service-                modules-            renderLegacyKey (WorkspaceConformanceService value) = "workspace " <> value-            renderLegacyKey (StandaloneConformanceService value) = "standalone " <> value-            renderLegacyKind Generated = "generated"-            renderLegacyKind HoleStub = "create-once"-        _ <- run False >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure-        currentContents <- TIO.readFile currentPath-        record <- maybe (expectationFailure "fresh conformance ledger did not parse" >> fail "unreachable") pure (parseConformancePackageRecord currentContents)-        let legacyRecord =-              record-                { cprFiles =-                    [ (fileKind, if path == conformanceLedgerFileName then legacyConformanceRecordFileName else path)-                    | (fileKind, path) <- cprFiles record-                    ]-                }-            legacyContents =-              T.unlines $-                [line | line <- T.lines currentContents, isGeneratedBannerLine line]-                  <> [ "schema 1",-                       "service-key " <> renderLegacyKey (cprServiceKey legacyRecord),-                       "runtime-package " <> unRuntimePackageName (cprRuntimePackage legacyRecord),-                       "facade-module " <> cprFacadeModule legacyRecord-                     ]-                  <> ["file " <> renderLegacyKind fileKind <> " " <> T.pack path | (fileKind, path) <- cprFiles legacyRecord]-        renameFile currentPath legacyPath-        TIO.writeFile legacyPath legacyContents-        migrationTreeBefore <- treeSnapshot out-        refused <- run False-        refused `shouldSatisfy` \case-          Left [SidecarMigrationRequired [move]] -> sidecarMoveDisposition move == ConvertLegacyConformanceLedger-          _ -> False-        treeSnapshot out `shouldReturn` migrationTreeBefore-        applied <- run True >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure-        map sidecarMoveDisposition (reportSidecarMoves applied) `shouldBe` [ConvertLegacyConformanceLedger]-        doesFileExist legacyPath `shouldReturn` False-        TIO.readFile backupPath `shouldReturn` legacyContents-        migrated <- TIO.readFile currentPath-        cprServiceKey <$> parseConformancePackageRecord migrated-          `shouldBe` Just (StandaloneConformanceService (contextName ctx))--        TIO.writeFile-          currentPath-          ( T.replace-              ("service-key standalone " <> contextName ctx)-              "service-key standalone another-service"-              migrated-          )-        mismatchBefore <- treeSnapshot out-        mismatch <- run False-        mismatch `shouldSatisfy` \case-          Left [ConformancePackageRefusal ConformancePackageRecordMismatch {}] -> True-          _ -> False-        treeSnapshot out `shouldReturn` mismatchBefore-    it "refuses a bannerless package file before changing any runtime byte" $ do-      withTempDirectory "keiro-dsl-conformance-atomic" $ \out -> do-        parsed <- parsedSourceOf "test/fixtures/hospital-surge.keiro"-        let service = checkedSource parsed-            spec = checkedSpec service-            ctx = defaultContext (specContext spec)-            runtimePackage = RuntimePackageName "hospital-runtime"-        modules <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planServiceScaffoldWithRuntimePackage (Just runtimePackage) ctx service)-        executeServiceScaffoldWithRuntimePackage (Just runtimePackage) out False "hospital-surge.keiro" (parsedSourceLanguage parsed) ctx service modules-          >>= either (\failure -> expectationFailure (show failure)) (const (pure ()))-        facade <- case [moduleValue | moduleValue <- modules, ".Conformance" `T.isSuffixOf` moduleNameOf (modulePath moduleValue)] of-          [moduleValue] -> pure moduleValue-          values -> expectationFailure ("expected one facade, got " <> show (map modulePath values)) >> fail "unreachable"-        let facadePath = out </> modulePath facade-            serviceKey = contextName ctx-            cabalPath = out </> conformancePackageDirectory (StandaloneConformanceService serviceKey) </> T.unpack ("keiro-" <> cabaliseConformanceService serviceKey <> "-conformance.cabal")-        TIO.appendFile facadePath "-- would be overwritten if runtime execution began\n"-        TIO.writeFile cabalPath "hand-owned cabal file\n"-        packageTree <- treeSnapshot out-        refused <- executeServiceScaffoldWithRuntimePackage (Just runtimePackage) out False "hospital-surge.keiro" (parsedSourceLanguage parsed) ctx service modules-        refused `shouldSatisfy` isLeft-        treeSnapshot out `shouldReturn` packageTree-    it "keeps a two-aggregate workspace at exactly one Cabal package" $ do-      withTempDirectory "keiro-dsl-conformance-workspace" $ \out -> do-        workspace <- shouldComposeWorkspace canonicalWorkspacePath-        let runtimePackage = Just (RuntimePackageName "workspace-runtime")-        plan <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planWorkspaceScaffoldWithRuntimePackageAndGoldens [] runtimePackage "goldens" (workspaceContext workspace) workspace)-        length [() | NAggregate {} <- specNodes (checkedSpec (checkedWorkspace workspace))] `shouldBe` 2-        executeWorkspaceScaffold out False plan >>= either (\failure -> expectationFailure (show failure)) (const (pure ()))-        packageDirectories <- filter (T.isPrefixOf "keiro-dsl-conformance.workspace." . T.pack) <$> listDirectory out-        packageDirectories `shouldBe` ["keiro-dsl-conformance.workspace.demo-project"]-        case packageDirectories of-          [packageDirectory] -> do-            cabalFiles <- filter ((== ".cabal") . takeExtension) <$> listDirectory (out </> packageDirectory)-            length cabalFiles `shouldBe` 1-          _ -> expectationFailure "expected one package directory"-    it "scaffolds the multi-member proof idempotently through the public CLI" $ do-      withTempDirectory "keiro-dsl-conformance-proof-cli" $ \base -> do-        let fixture = "test/conformance-service-package"-            copied = base </> "fixture"-            out = copied </> "runtime/src"-            sourcePaths =-              [ "service.keiro-workspace",-                "domain/alpha.keiro",-                "domain/beta.keiro",-                "domain/evidence.keiro",-                "domain/shared.keiro"-              ]-        fixtureManifest <- resolveTestPath (fixture </> "service.keiro-workspace") >>= canonicalizePath-        let fixtureRoot = takeDirectory fixtureManifest-        forM_ sourcePaths $ \relative -> TIO.readFile (fixtureRoot </> relative) >>= writeFileWithParents (copied </> relative)-        (firstCode, firstOut, firstErr) <- runKeiroDsl ["scaffold", copied </> "service.keiro-workspace", "--out", out]-        unless (firstCode == ExitSuccess) (expectationFailure (firstOut <> firstErr))-        firstTree <- treeSnapshot out-        length [path | (path, _) <- firstTree, takeExtension path == ".cabal"] `shouldBe` 1-        length [path | (path, _) <- firstTree, "Generated/Conformance.hs" `T.isSuffixOf` T.pack path] `shouldBe` 1-        let recordPath = out </> conformancePackageDirectory (WorkspaceConformanceService "workspace-proof") </> conformanceRecordFileName-        record <- parseConformancePackageRecord <$> TIO.readFile recordPath-        cprServiceKey <$> record `shouldBe` Just (WorkspaceConformanceService "workspace-proof")-        (secondCode, secondOut, secondErr) <- runKeiroDsl ["scaffold", copied </> "service.keiro-workspace", "--out", out]-        unless (secondCode == ExitSuccess) (expectationFailure (secondOut <> secondErr))-        secondErr `shouldSatisfy` isInfixOfString "keiro-workspace-proof-conformance.cabal (unchanged)"-        secondErr `shouldSatisfy` isInfixOfString "Expectations.hs (skipped: already present)"-        secondErr `shouldSatisfy` isInfixOfString "Generated.Conformance"-        treeSnapshot out `shouldReturn` firstTree-    it "keeps Expectations fixed and turns the generated target red for a changed workflow fact" $ do-      withTempDirectory "keiro-dsl-conformance-proof-mutation" $ \base -> do-        fixtureManifest <- resolveTestPath "test/conformance-service-package/service.keiro-workspace" >>= canonicalizePath-        let fixtureRoot = takeDirectory fixtureManifest-        let copied = base </> "fixture"-            out = copied </> "runtime/src"-            evidencePath = copied </> "domain/evidence.keiro"-            expectationsPath = out </> "keiro-dsl-conformance.workspace.workspace-proof/src/KeiroConformance/Expectations.hs"-        copyTextTree fixtureRoot copied-        acceptedExpectations <- TIO.readFile expectationsPath-        TIO.readFile evidencePath-          >>= TIO.writeFile evidencePath . T.replace "name \"workspace-proof-workflow\"" "name \"workspace-proof-workflow-v2\""-        (scaffoldCode, scaffoldOut, scaffoldErr) <- runKeiroDsl ["scaffold", copied </> "service.keiro-workspace", "--out", out]-        unless (scaffoldCode == ExitSuccess) (expectationFailure (scaffoldOut <> scaffoldErr))-        TIO.readFile expectationsPath `shouldReturn` acceptedExpectations-        let repositoryRoot = takeDirectory (takeDirectory (takeDirectory fixtureRoot))-            projectPath = base </> "mutation.project"-            buildDirectory = base </> "dist-newstyle"-            packageRoot = out </> "keiro-dsl-conformance.workspace.workspace-proof"-        TIO.writeFile-          projectPath-          ( T.unlines-              [ "packages:",-                "  " <> T.pack (repositoryRoot </> "keiro"),-                "  " <> T.pack (repositoryRoot </> "keiro-core"),-                "  " <> T.pack (copied </> "runtime"),-                "  " <> T.pack packageRoot,-                "",-                "source-repository-package",-                "  type: git",-                "  location: https://github.com/shinzui/keiki.git",-                "  tag: 9714d37033c37595e3aaa3319ca0ca77466782e0",-                "",-                "source-repository-package",-                "  type: git",-                "  location: https://github.com/shinzui/keiki.git",-                "  tag: 9714d37033c37595e3aaa3319ca0ca77466782e0",-                "  subdir: keiki-codec-json",-                "",-                "allow-newer:",-                "  haxl:time"-              ]-          )-        (testCode, testOut, testErr) <--          readProcessWithExitCode-            "cabal"-            [ "test",-              "--project-file=" <> projectPath,-              "--builddir=" <> buildDirectory,-              "keiro-workspace-proof-conformance"-            ]-            ""-        testCode `shouldNotBe` ExitSuccess-        (testOut <> testErr)-          `shouldSatisfy` isInfixOfString "FAIL  workflow/WorkspaceProofWorkflow/name expected=\"workspace-proof-workflow\" actual=\"workspace-proof-workflow-v2\""--  describe "new <kind> skeletons (M5)" $ do-    forM_ skeletonKinds $ \skeletonKind ->-      it ("the " <> T.unpack skeletonKind <> " skeleton selects and preserves the registered stable language") $-        assertSkeletonUsesStableLanguage skeletonKind-    it "every skeleton parses and validates with zero error diagnostics" $-      mapM_ assertSkeletonValid skeletonKinds-    it "every skeleton passes the scaffold refusal gates" $-      mapM_ assertSkeletonScaffoldable skeletonKinds-    -- `derive … hole` is mandatory emit grammar. While it carried a warning, a-    -- freshly generated emit service could never satisfy the documented CI-    -- recipe, no matter what its author did. See ExecPlan 199.-    it "every skeleton without a confirmed benign inversion satisfies the documented --deny-warnings CI gate" $-      withTempDirectory "keiro-dsl-skeleton-deny" $ \out ->-        -- router and process are deliberately absent: their idiomatic-        -- on-duplicate/on-reject spellings are confirmed benign inversions-        -- (RouterBenignInversion/ProcessBenignInversion), so those services-        -- gate CI with a selective --deny list rather than --deny-warnings.-        forM_ ["emit", "intake", "aggregate", "contract", "workqueue", "workflow"] $ \kind ->-          case skeletonFor kind of-            Left err -> expectationFailure (T.unpack err)-            Right source -> do-              let specPath = out </> T.unpack kind <> ".keiro"-              TIO.writeFile specPath source-              (exitCode, stdoutText, stderrText) <--                runKeiroDsl ["check", specPath, "--min-language", "4", "--deny-warnings"]-              unless (exitCode == ExitSuccess) $-                expectationFailure (T.unpack kind <> " skeleton failed the gate:\n" <> stdoutText <> stderrText)-              stderrText `shouldNotContain` "escalated to failure"-    it "stable skeleton scaffolds match the committed compiling modules" $-      mapM_ (uncurry assertStableSkeletonMatchesCommitted) skeletonModuleRoots-    it "rejects an unknown kind with a helpful message" $-      case skeletonFor "bogus" of-        Left msg -> ("Valid kinds:" `T.isInfixOf` msg) `shouldBe` True-        Right _ -> expectationFailure "expected an error for an unknown kind"--  describe "firewall self-check (M3)" $ do-    it "flags a forbidden operator in a Generated module" $ do-      let m = ScaffoldModule {modulePath = "Gen/Foo.hs", moduleText = "x = a ./= b", kind = Generated, origin = "test"}-      firewallBreaches [m] `shouldBe` [("Gen/Foo.hs", "./=", 1)]-    it "ignores forbidden operators in a HoleStub module (holes own them)" $ do-      let m = ScaffoldModule {modulePath = "Foo/Holes.hs", moduleText = "x = lit 1 .== y", kind = HoleStub, origin = "test"}-      firewallBreaches [m] `shouldBe` []-    it "matches `lit` as a word, not a substring of quality/split" $ do-      let clean = ScaffoldModule {modulePath = "Gen/Q.hs", moduleText = "quality = split facility", kind = Generated, origin = "test"}-          dirty = ScaffoldModule {modulePath = "Gen/L.hs", moduleText = "v = lit foo", kind = Generated, origin = "test"}-      firewallBreaches [clean] `shouldBe` []-      firewallBreaches [dirty] `shouldBe` [("Gen/L.hs", "lit", 1)]-    it "skips strings and comments and maximal-munches symbolic tokens" $ do-      let clean = syntheticGenerated "Gen/Clean.hs" "wire = \"lit .== B.slot\"\n-- x =: y\nx = a .<= b"-          dirty = syntheticGenerated "Gen/Dirty.hs" "x = a .< b\ny = c =: d"-      firewallBreaches [clean] `shouldBe` [("Gen/Clean.hs", ".<=", 3)]-      firewallBreaches [dirty] `shouldBe` [("Gen/Dirty.hs", ".<", 1), ("Gen/Dirty.hs", "=:", 2)]-    it "guards keiki imports while allowing the generated Core allowlist" $ do-      let forbidden = syntheticGenerated "Gen/Builder.hs" "import Keiki.Builder"-          restricted = syntheticGenerated "Gen/CoreBad.hs" "import Keiki.Core (lit)"-          allowed = syntheticGenerated "Gen/CoreGood.hs" "import Keiki.Core (RegFile (..), HsPred, step)"-      firewallBreaches [forbidden] `shouldBe` [("Gen/Builder.hs", "import:Keiki.Builder", 1)]-      firewallBreaches [restricted] `shouldBe` [("Gen/CoreBad.hs", "import:Keiki.Core", 1)]-      firewallBreaches [allowed] `shouldBe` []-    it "exempts only the authoritative generated transducer module path" $ do-      let expressions = syntheticGenerated "Gen/Aggregate/Expressions.hs" "import Keiki.Core qualified as K\nx = K.lit 1"-          transducer = syntheticGenerated "Gen/Aggregate/Transducer.hs" "import Keiki.Builder qualified as B\nx = B.slot"-          ordinary = syntheticGenerated "Gen/Aggregate/Projection.hs" "import Keiki.Builder qualified as B"-      firewallBreaches [expressions, transducer]-        `shouldBe` [("Gen/Aggregate/Expressions.hs", "import:Keiki.Core", 1)]-      firewallBreaches [ordinary] `shouldBe` [("Gen/Aggregate/Projection.hs", "import:Keiki.Builder", 1)]-    it "finds no breach in real scaffolder output (aggregate + process fixtures)" $ do-      aggMods <- scaffoldFixture "test/fixtures/reservation.keiro"-      procMods <- legacyScaffoldProcessFixture "test/fixtures/hospital-surge.keiro"-      firewallBreaches (aggMods <> procMods) `shouldBe` []--  describe "generated provenance banners (plan 182 M4)" $ do-    it "stamps the running package version, effective language, and module origin" $ do-      service <- checkedServiceOf "test/fixtures/contract-v4.keiro"-      let ctx = defaultContext (specContext (checkedSpec service))-      case planServiceScaffold ctx service of-        Left refusals -> expectationFailure (show refusals)-        Right modules -> do-          let generated = [moduleValue | moduleValue <- modules, kind moduleValue == Generated]-          generated `shouldSatisfy` (not . null)-          forM_ generated $ \moduleValue -> do-            let recognized = filter isGeneratedBannerLine (T.lines (moduleText moduleValue))-                expected = generatedBannerFor (checkedLanguageContract service) (origin moduleValue)-            recognized `shouldBe` [expected]-            expected-              `shouldSatisfy` T.isInfixOf-                ( "keiro-dsl "-                    <> T.pack (showVersion Package.version)-                    <> " (language keiro-dsl 4) from contract emergency"-                )-      workspace <- shouldComposeWorkspace canonicalWorkspacePath-      workspacePlan <- shouldPlanWorkspaceSpec workspace-      forM_ [moduleValue | (moduleValue, _) <- wpModules workspacePlan, kind moduleValue == Generated] $ \moduleValue ->-        filter isGeneratedBannerLine (T.lines (moduleText moduleValue))-          `shouldBe` [generatedBannerFor (checkedLanguageContract (checkedWorkspace workspace)) (origin moduleValue)]-    it "recognizes only the historical banner and the stamped format" $ do-      let contract = effectiveLanguageContract LegacyUnversioned-      isGeneratedBannerLine generatedBanner `shouldBe` True-      isGeneratedBannerLine (generatedBannerFor contract "aggregate Counter (line 2)") `shouldBe` True-      isGeneratedBannerLine "-- @generated by another tool" `shouldBe` False-      isGeneratedBannerLine codecComparisonBanner `shouldBe` False-    it "migrates a legacy-banner file and keeps repeated scaffold bytes stable" $-      withTempDirectory "keiro-dsl-stamped-banner" $ \out -> do-        spec <- parseInlineSpec "<stamped-banner>" loweringAggregateSpec-        let ctx = defaultContext (specContext spec)-        modules <- case planScaffold ctx spec of-          Left refusals -> expectationFailure (show refusals) >> pure []-          Right planned -> pure planned-        case [moduleValue | moduleValue <- modules, kind moduleValue == Generated] of-          target : _ -> do-            let path = out </> modulePath target-                stamped = generatedBannerFor (effectiveLanguageContract LegacyUnversioned) (origin target)-                legacyText = T.replace stamped generatedBanner (moduleText target)-            createDirectoryIfMissing True (takeDirectory path)-            TIO.writeFile path legacyText-            first <- executeScaffold out False "counter.keiro" ctx spec modules-            first `shouldSatisfy` isSuccessfulScaffold-            firstTree <- treeSnapshot out-            second <- executeScaffold out False "counter.keiro" ctx spec modules-            second `shouldSatisfy` isSuccessfulScaffold-            treeSnapshot out `shouldReturn` firstTree-            TIO.readFile path `shouldReturn` moduleText target-          [] -> expectationFailure "counter scaffold has no Generated module"--  describe "service-aware fixture helpers" $ do-    it "retains version-4 contract TypeIDs and their durable admission identities" $ do-      service <- checkedServiceOf "test/fixtures/contract-v4.keiro"-      modules <- scaffoldFixture "test/fixtures/contract-v4.keiro"-      let contractModule = generatedTextEndingIn "Contract.hs" modules-          identities = idDomainIdentitiesForService service-      contractModule `shouldSatisfy` T.isInfixOf "incidentId :: !(KindID \"inc\")"-      contractModule `shouldSatisfy` T.isInfixOf "reservationId :: !(KindID \"rsv\")"-      identities-        `shouldContain` ["id-domain|name=contract:emergency.IncidentTransferNeedDeclared.incidentId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=inc|separator=_|json=canonical-json-text"]--  describe "scaffold gates" $ do-    it "reports case-folded generated paths through the complete check diagnostics" $ do-      spec <- specOf "test/fixtures/reservation.keiro"-      case [aggregate | NAggregate aggregate <- specNodes spec] of-        aggregate : _ -> do-          let caseVariant =-                spec-                  { specNodes =-                      [ NAggregate aggregate,-                        NAggregate aggregate {aggName = T.toUpper (aggName aggregate)}-                      ]-                  }-              diagnostics =-                checkServiceDiagnostics-                  Nothing-                  (defaultContext (specContext caseVariant))-                  (legacyCheckedService caseVariant)-          map code diagnostics `shouldContain` [GeneratedPathCollision]-          case [ diagnostic-               | diagnostic <- diagnostics,-                 code diagnostic == GeneratedPathCollision,-                 "Domain.hs" `T.isInfixOf` message diagnostic-               ] of-            [diagnostic] -> do-              line diagnostic `shouldBe` unLoc (aggLoc aggregate)-              relatedLocations diagnostic `shouldSatisfy` (not . null)-              message diagnostic `shouldSatisfy` T.isInfixOf "case-insensitive filesystem"-            found -> expectationFailure ("expected one generated-path diagnostic, got " <> show found)-          withTempDirectory "keiro-dsl-check-path-collision" $ \root -> do-            let sourcePath = root </> "collision.keiro"-            version <- maybe (expectationFailure "language version 4 missing" >> fail "unreachable") pure (languageVersion 4)-            TIO.writeFile sourcePath (renderSource (ParsedSource (DeclaredLanguage version noLoc) caseVariant))-            (exitCode, out, err) <- runKeiroDsl ["check", sourcePath]-            exitCode `shouldBe` ExitFailure 1-            out `shouldBe` ""-            err `shouldContain` "error[GeneratedPathCollision]"-        [] -> expectationFailure "reservation fixture has no aggregate"-    it "uses lowering before module planning in both scaffold planners" $ do-      spec <- specOf "test/fixtures/emit.keiro"-      case [contract | NContract contract <- specNodes spec] of-        contract : _ -> do-          let defective =-                mapPublisher-                  (\publisher -> publisher {pubBackoff = BackoffSpec "exponential" "2s" Nothing Nothing})-                  spec-                    { specNodes = NContract contract : specNodes spec-                    }-              ctx = defaultContext (specContext defective)-              workspace = oneMemberWorkspace "emit.keiro" defective-          case (planScaffold ctx defective, planWorkspaceScaffold "goldens" ctx workspace) of-            (Left (LoweringRefusal singleReasons : _), Left (LoweringRefusal workspaceReasons : _)) ->-              workspaceReasons `shouldBe` singleReasons-            results -> expectationFailure ("expected lowering first from both planners, got " <> show results)-        [] -> expectationFailure "emit fixture has no contract"-    it "maps import cycles and planner invariants into stable check codes" $ do-      planningRefusalDiagnostics [ImportCycle ["A", "B", "A"]]-        `shouldSatisfy` any ((== GeneratedImportCycle) . code)-      planningRefusalDiagnostics [BehaviorRefusal [Behavior.DuplicateBehaviorIdentity "duplicate" [Loc 9]]]-        `shouldSatisfy` any (\diagnostic -> code diagnostic == BehaviorDerivationInvalid && line diagnostic == 9)-      planningRefusalDiagnostics [DuplicateConformanceFactKeys [DuplicateServiceFactKey "duplicate"]]-        `shouldSatisfy` any ((== ConformanceFactKeyCollision) . code)-      planningRefusalDiagnostics [SemanticContractMismatch "test mismatch"]-        `shouldSatisfy` any ((== GeneratedPlanningInvariantViolation) . code)-      spec <- specOf "test/fixtures/consumer-types.keiro"-      let cyclic = spec {specMapped = map moveArtifactBindingIntoGenerated (specMapped spec)}-      checkServiceDiagnostics Nothing (defaultContext (specContext cyclic)) (stableCheckedService cyclic)-        `shouldSatisfy` any ((== GeneratedImportCycle) . code)-    it "refuses duplicate and case-folded module paths with both origins" $ do-      spec <- specOf "test/fixtures/reservation.keiro"-      case [aggregate | NAggregate aggregate <- specNodes spec] of-        aggregate : _ -> do-          let duplicate = spec {specNodes = [NAggregate aggregate, NAggregate aggregate]}-              caseVariant = spec {specNodes = [NAggregate aggregate, NAggregate aggregate {aggName = T.toUpper (aggName aggregate)}]}-          planScaffold (defaultContext (specContext spec)) duplicate `shouldSatisfy` hasPathCollisionWithTwoOrigins-          planScaffold (defaultContext (specContext spec)) caseVariant `shouldSatisfy` hasPathCollisionWithTwoOrigins-        [] -> expectationFailure "reservation fixture has no aggregate"-    it "refuses a bannerless Generated target without changing its bytes" $-      withTempDirectory "keiro-dsl-banner" $ \out -> do-        spec <- specOf "test/fixtures/reservation.keiro"-        let ctx = defaultContext (specContext spec)-        case planScaffold ctx spec of-          Left refusals -> expectationFailure ("unexpected planning refusal: " <> show refusals)-          Right modules -> case [m | m <- modules, kind m == Generated] of-            generated : _ -> do-              let target = out </> modulePath generated-              createDirectoryIfMissing True (takeDirectory target)-              TIO.writeFile target "hand owned\n"-              result <- executeScaffold out False "test/fixtures/reservation.keiro" ctx spec modules-              result `shouldSatisfy` isMissingBannerRefusal-              TIO.readFile target `shouldReturn` "hand owned\n"-              forced <- executeScaffold out True "test/fixtures/reservation.keiro" ctx spec modules-              forced `shouldSatisfy` isSuccessfulScaffold-              TIO.readFile target `shouldReturn` moduleText generated-            [] -> expectationFailure "reservation scaffold has no Generated module"-    it "reports renamed-node modules as stale without deleting them" $-      withTempDirectory "keiro-dsl-stale-rename" $ \out -> do-        spec <- parseInlineSpec "<stale-rename>" loweringAggregateSpec-        first <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext spec)) spec-        let renamed = spec {specNodes = map renameCounter (specNodes spec)}-        second <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext renamed)) renamed-        let oldDomain = onlyPathEndingIn "Counter/Domain.hs" (map fst (reportDispositions first))-            oldHoles = onlyPathEndingIn "Counter/Holes.hs" (map fst (reportDispositions first))-        reportStale second `shouldSatisfy` \stale ->-          StaleModule Generated oldDomain (Just ExactGeneratedBannerPresent) `elem` stale-            && StaleModule HoleStub oldHoles Nothing `elem` stale-        doesFileExist (out </> oldDomain) `shouldReturn` True-        doesFileExist (out </> oldHoles) `shouldReturn` True-        renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "exact generated banner present; verify unchanged bytes before deleting")-        renderScaffoldReport second `shouldSatisfy` all (not . T.isInfixOf "safe to delete")-    it "preserves a stale generated path whose exact banner is missing" $-      withTempDirectory "keiro-dsl-stale-banner" $ \out -> do-        spec <- parseInlineSpec "<stale-banner>" loweringAggregateSpec-        first <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext spec)) spec-        let oldDomain = onlyPathEndingIn "Counter/Domain.hs" (map fst (reportDispositions first))-            renamed = spec {specNodes = map renameCounter (specNodes spec)}-        TIO.writeFile (out </> oldDomain) "-- generated by something else\n"-        second <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext renamed)) renamed-        reportStale second `shouldSatisfy` elem (StaleModule Generated oldDomain (Just ExactGeneratedBannerMissing))-        renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "exact generated banner missing; preserve and review")-        TIO.readFile (out </> oldDomain) `shouldReturn` "-- generated by something else\n"-    it "reports the entire old tree across a module-root flip" $-      withTempDirectory "keiro-dsl-stale-root" $ \out -> do-        spec <- parseInlineSpec "<stale-root>" loweringAggregateSpec-        let initialCtx = defaultContext (specContext spec)-            rootedCtx = initialCtx {moduleRoot = "Acme"}-        first <- executePlannedScaffold out "counter.keiro" initialCtx spec-        second <- executePlannedScaffold out "moved-counter.keiro" rootedCtx spec-        reportStale second-          `shouldMatchList` [ StaleModule (kind m) (modulePath m) (if kind m == Generated then Just ExactGeneratedBannerPresent else Nothing)-                            | (m, _) <- reportDispositions first-                            ]-        forM_ (reportStale second) $ \stale -> doesFileExist (out </> stalePath stale) `shouldReturn` True-        renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "previous scaffold record used spec counter.keiro")-    it "reports moved generated modules across a layout flip" $-      withTempDirectory "keiro-dsl-stale-layout" $ \out -> do-        spec <- parseInlineSpec "<stale-layout>" loweringAggregateSpec-        let initialCtx = defaultContext (specContext spec)-            collocatedCtx = initialCtx {placement = CollocatedLeaf}-        first <- executePlannedScaffold out "counter.keiro" initialCtx spec-        second <- executePlannedScaffold out "counter.keiro" collocatedCtx spec-        let oldGenerated = [StaleModule Generated (modulePath m) (Just ExactGeneratedBannerPresent) | (m, _) <- reportDispositions first, kind m == Generated]-        reportStale second `shouldSatisfy` all (`elem` oldGenerated)-        length (reportStale second) `shouldBe` length oldGenerated-    it "writes a parseable record and no stale section for a fresh output" $-      withTempDirectory "keiro-dsl-record" $ \out -> do-        spec <- parseInlineSpec "<fresh-record>" loweringAggregateSpec-        let ctx = defaultContext (specContext spec)-        report <- executePlannedScaffold out "counter.keiro" ctx spec-        reportStale report `shouldBe` []-        renderScaffoldReport report `shouldSatisfy` all (not . T.isPrefixOf "stale:")-        contents <- TIO.readFile (out </> recordFileName (specContext spec))-        requirements <- either (\errors -> expectationFailure (show errors) >> pure []) pure (Behavior.deriveBehaviorRequirements spec)-        let expected =-              ScaffoldRecord-                { recSpecPath = "counter.keiro",-                  recModuleRoot = "",-                  recLayout = "prefixed",-                  recSourceLanguage = LegacyUnversioned,-                  recLanguageContract = effectiveLanguageContract LegacyUnversioned,-                  recNamingEdition = IdiomaticNamingV1,-                  recModuleRoles = [ScaffoldModuleRoleRow (moduleRole m) (kind m) (modulePath m) | (m, _) <- reportDispositions report],-                  recFiles = [(kind m, modulePath m) | (m, _) <- reportDispositions report],-                  recMappings = [],-                  recIdDomains = [],-                  recNominalEqualities = [],-                  recBindingObligations = [],-                  recBehaviorRequirements = Behavior.behaviorRecordRows requirements-                }-            sourceRows = filter ("source-language " `T.isPrefixOf`) (T.lines contents)-            withoutSourceRows = T.unlines (filter (not . T.isPrefixOf "source-language ") (T.lines contents))-            semanticRows = filter ("semantic-contract " `T.isPrefixOf`) (T.lines contents)-            withoutSemanticRows = T.unlines (filter (not . T.isPrefixOf "semantic-contract ") (T.lines contents))-        parseRecord contents `shouldBe` Just expected-        parseRecord withoutSourceRows `shouldBe` Just expected-        parseRecord withoutSemanticRows `shouldBe` Just expected-        case sourceRows of-          [sourceRow] -> do-            parseRecord (T.replace sourceRow (sourceRow <> "\n" <> sourceRow) contents) `shouldBe` Nothing-            parseRecord (T.replace sourceRow "source-language {malformed}" contents) `shouldBe` Nothing-          _ -> expectationFailure "expected exactly one source-language row"-        case semanticRows of-          [semanticRow] -> do-            parseRecord (T.replace semanticRow (semanticRow <> "\n" <> semanticRow) contents) `shouldBe` Nothing-            parseRecord (T.replace semanticRow "semantic-contract {malformed}" contents) `shouldBe` Nothing-            parseRecord (T.replace "\"languageVersion\":1" "\"languageVersion\":2" contents) `shouldBe` Nothing-          _ -> expectationFailure "expected exactly one semantic-contract row"-        parseRecord (T.replace "spec: " "future-field: retained\nspec: " contents) `shouldBe` parseRecord contents-        parseRecord (T.replace "record v1" "record v2" contents) `shouldBe` Nothing-    it "records declared provenance and reports a header-only scaffold drift" $-      withTempDirectory "keiro-dsl-language-drift" $ \out -> do-        spec <- parseInlineSpec "<language-drift>" loweringAggregateSpec-        let ctx = defaultContext (specContext spec)-        modules <- case planScaffold ctx spec of-          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"-          Right planned -> pure planned-        _ <- executePlannedScaffold out "counter.keiro" ctx spec-        case languageVersion 1 of-          Nothing -> expectationFailure "version 1 was not constructible"-          Just version -> do-            let declared = DeclaredLanguage version noLoc-            result <- executeScaffoldWithLanguage out False "counter.keiro" declared ctx spec modules-            case result of-              Left refusals -> expectationFailure (show refusals)-              Right report -> do-                reportSourceLanguageDrift report-                  `shouldBe` Just (SourceLanguageDrift LegacyUnversioned declared)-                contents <- TIO.readFile (reportRecordPath report)-                recSourceLanguage <$> parseRecord contents `shouldBe` Just declared--  describe "faithful scaffold lowering" $ do-    it "escapes a trailing-backslash payload literal exactly once" $ do-      spec <- specOf "test/fixtures/hospital-surge.keiro"-      case [process | NProcess process <- specNodes spec] of-        process : _ -> do-          let timer = (procTimer process) {tmPayload = [FieldBinding "kind" (Just "\"follow-up\\\"")]}-              modules = scaffoldProcess (defaultContext (specContext spec)) process {procTimer = timer}-          generatedTextEndingIn "Process.hs" modules-            `shouldSatisfy` T.isInfixOf "\"kind\" .= (\"follow-up\\\\\" :: Value)"-        [] -> expectationFailure "hospital-surge fixture has no process"-    it "preserves quoted Text register initials and refuses unsafe register shapes" $ do-      spec <- parseInlineSpec "<register-initials>" loweringAggregateSpec-      let modules = scaffoldAggregate (defaultContext (specContext spec)) spec =<< [aggregate | NAggregate aggregate <- specNodes spec]-          domain = generatedTextEndingIn "Domain.hs" modules-      domain `shouldSatisfy` T.isInfixOf "RCons (Proxy @\"note\") \"hello world\""-      scaffoldRefusals spec `shouldBe` []-      bare <- parseInlineSpec "<bare-text-initial>" (T.replace "\"hello world\"" "hello" loweringAggregateSpec)-      scaffoldRefusals bare `shouldSatisfy` any (T.isInfixOf "RegTextInitialNotQuoted")-      unsupported <- parseInlineSpec "<unsupported-field>" (T.replace "count:Int" "count:Json" loweringAggregateSpec)-      scaffoldRefusals unsupported `shouldSatisfy` any (T.isInfixOf "FieldTypeUnrepresentable")-    it "lowers seconds, minutes, hours, and both backoff constructors faithfully" $ do-      windowSeconds "90s" `shouldBe` Right 90-      windowSeconds "5m" `shouldBe` Right 300-      windowSeconds "2h" `shouldBe` Right 7200-      emitSource <- readTestText "test/fixtures/emit.keiro"-      let exponentialSource = T.replace "backoff constant 2s" "backoff exponential 2s max=60s multiplier=2.0" emitSource-      exponential <- parseInlineSpec "<exponential-backoff>" exponentialSource-      case [publisher | NPublisher publisher <- specNodes exponential] of-        publisher : _ -> do-          let generated = generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext exponential)) publisher)-          generated `shouldSatisfy` T.isInfixOf "ExponentialBackoff ExponentialBackoffOptions { initial = 2, maxDelay = 60, multiplier = 2.0 }"-          parseSpec "<exponential-round-trip>" (renderSpec exponential) `shouldBe` Right exponential-        [] -> expectationFailure "emit fixture has no publisher"-      constant <- parseInlineSpec "<constant-backoff>" (T.replace "backoff constant 2s" "backoff constant 2m" emitSource)-      case [publisher | NPublisher publisher <- specNodes constant] of-        publisher : _ -> generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext constant)) publisher) `shouldSatisfy` T.isInfixOf "ConstantBackoff 120"-        [] -> expectationFailure "emit fixture has no publisher"-    it "refuses incomplete exponential backoff and rejects unknown window units" $ do-      emitSource <- readTestText "test/fixtures/emit.keiro"-      incomplete <- parseInlineSpec "<incomplete-backoff>" (T.replace "backoff constant 2s" "backoff exponential 2s" emitSource)-      scaffoldRefusals incomplete `shouldSatisfy` any (T.isInfixOf "BackoffExponentialIncomplete")-      parseSpec "<bad-window>" (T.replace "backoff constant 2s" "backoff constant 2x" emitSource)-        `shouldSatisfy` leftContains "time unit: s, m, or h"-    it "lowers workqueue retry windows in minutes to seconds" $ do-      queueSource <- readTestText "test/fixtures/reservation-work.keiro"-      queueSpec <- parseInlineSpec "<minute-queue>" (T.replace "5s" "5m" queueSource)-      case [workqueue | NWorkqueue workqueue <- specNodes queueSpec] of-        workqueue : _ -> do-          let policy = generatedTextEndingIn "QueuePolicy.hs" (scaffoldWorkqueue (defaultContext (specContext queueSpec)) workqueue)-          policy `shouldSatisfy` T.isInfixOf "defaultRetryDelay = RetryDelay 300"-          policy `shouldSatisfy` T.isInfixOf "Retry (RetryDelay 300)"-        [] -> expectationFailure "queue fixture has no workqueue"-    it "uses exact status-map keys and emits total Int harness samples" $ do-      statusSpec <- parseInlineSpec "<exact-status>" exactStatusSpec-      case [aggregate | NAggregate aggregate <- specNodes statusSpec] of-        aggregate : _ -> do-          let ctx = defaultContext (specContext statusSpec)-              projection = generatedTextEndingIn "Projection.hs" (scaffoldAggregate ctx statusSpec aggregate)-              harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx statusSpec aggregate)-          projection `shouldSatisfy` T.isInfixOf "ReservationUnHeld {} -> Just \"available\""-          harness `shouldSatisfy` T.isInfixOf "CountBumpedData 0"-          harness `shouldNotSatisfy` T.isInfixOf "sample: unsupported"-        [] -> expectationFailure "exact-status spec has no aggregate"--  describe "scaffold" $ do-    it "keeps field DSL names, generated selectors, and wire keys independent" $ do-      source <- readTestText "test/fixtures/aggregate-field-alias.keiro"-      service <- checkedServiceFromText "aggregate-field-alias.keiro" source-      let spec = checkedSpec service-          ctx = defaultContext (specContext spec)-          modules = scaffoldServiceModules ctx service-          domain = generatedTextEndingIn "Domain.hs" modules-          codec = generatedTextEndingIn "Codec.hs" modules-          workspace = oneMemberWorkspace "aggregate-field-alias.keiro" spec-      validateService service `shouldBe` []-      domain `shouldSatisfy` ((== 2) . T.count "payloadType :: !Text")-      domain `shouldSatisfy` ((== 2) . T.count "serviceRegion :: !Text")-      domain `shouldSatisfy` ((== 2) . T.count "family :: !Text")-      codec `shouldSatisfy` T.isInfixOf "\"type\" .= payload.payloadType"-      codec `shouldSatisfy` T.isInfixOf "\"region_code\" .= payload.serviceRegion"-      codec `shouldSatisfy` T.isInfixOf "o .: \"region_code\""-      scaffoldServiceModules ctx service `shouldBe` modules-      fmap (map fst . wpModules) (planWorkspaceScaffold "goldens" ctx workspace)-        `shouldBe` planScaffold ctx spec--      newSpec <- parseInlineSpec "aggregate-field-alias-v2.keiro" (T.replace "event FieldsCopied =" "event FieldsCopied v2 =" source)-      case goldensForDiff spec newSpec of-        [golden] -> do-          goldenJson golden `shouldSatisfy` T.isInfixOf "\"family\":\"sample\""-          goldenJson golden `shouldSatisfy` T.isInfixOf "\"type\":\"sample\""-          goldenJson golden `shouldSatisfy` T.isInfixOf "\"region_code\":\"sample\""-          goldenJson golden `shouldSatisfy` (not . T.isInfixOf "payloadType")-          goldenJson golden `shouldSatisfy` (not . T.isInfixOf "serviceRegion")-        goldens -> expectationFailure ("expected one field-alias golden, got " <> show goldens)--    it "keeps aggregate fold identity neutral across field aliases" $ do-      let sourceFor field =-            T.unlines-              [ "language keiro-dsl 4",-                "context field-alias-neutrality",-                "aggregate AliasNeutrality",-                "  regs",-                "  states Open",-                "  command Observe { " <> field <> " }",-                "  event Observed = fields(Observe)",-                "  wire kind=ctorName fields=camelCase schemaVersion=1"-              ]-      base <- checkedServiceFromText "field-alias-base.keiro" (sourceFor "region:Text")-      selectorAlias <- checkedServiceFromText "field-alias-selector.keiro" (sourceFor "region haskell serviceRegion:Text")-      wireAlias <- checkedServiceFromText "field-alias-wire.keiro" (sourceFor "region as \"region_code\":Text")-      let fingerprint service = aggregateFoldFingerprintForService service (onlyAggregate (checkedSpec service))-          codecFor service =-            generatedTextEndingIn-              "Codec.hs"-              (scaffoldServiceModules (defaultContext (specContext (checkedSpec service))) service)-      fingerprint selectorAlias `shouldBe` fingerprint base-      fingerprint wireAlias `shouldBe` fingerprint base-      codecFor base `shouldSatisfy` T.isInfixOf "\"region\" .= payload.region"-      codecFor selectorAlias `shouldSatisfy` T.isInfixOf "\"region\" .= payload.serviceRegion"-      codecFor selectorAlias `shouldSatisfy` (not . T.isInfixOf "region_code")-      codecFor wireAlias `shouldSatisfy` T.isInfixOf "\"region_code\" .= payload.region"--    it "synthesizes the exact old wire shape and embeds it in the harness" $ do-      oldSpec <- specOf "test/fixtures/reservation.keiro"-      newSpec <- specOf "test/fixtures/reservation-v2.keiro"-      case goldensForDiff oldSpec newSpec of-        [golden] -> do-          goldenRelativePath golden-            `shouldBe` "hospital-capacity/Reservation/TransferReservationCreated.v1.json"-          goldenJson golden-            `shouldBe` "{\"commandId\":\"cmd_01hzy3v7q2e8kaw2m5x0d41n9c\",\"divertStatus\":\"open\",\"hospitalId\":\"hosp_01hzy3v7q2e8kaw2m5x0d41n9c\",\"kind\":\"TransferReservationCreated\",\"lifeCriticalOverride\":true,\"patientAcuity\":\"red\",\"reservationId\":\"rsv_01hzy3v7q2e8kaw2m5x0d41n9c\"}\n"-          goldenEvidence golden `shouldBe` SynthesizedWeakStandIn-          let aggregate = onlyAggregate newSpec-              modules =-                harnessForWithGoldens-                  [golden]-                  (defaultContext (specContext newSpec))-                  newSpec-                  aggregate-              harness = generatedTextEndingIn "Harness.hs" modules-          harness `shouldSatisfy` T.isInfixOf "golden TransferReservationCreated.v1 decodes"-          harness `shouldSatisfy` T.isInfixOf "\\\"reservationId\\\":\\\"rsv_"-          harness `shouldSatisfy` (not . T.isInfixOf "current-shape stand-in")-        goldens -> expectationFailure ("expected one synthesized golden, got " <> show goldens)-    it "synthesizes complete nested mapped old shapes deterministically and never overwrites captured evidence" $ do-      oldSpec <- specOf "test/fixtures/consumer-types.keiro"-      newSpec <- specOf "test/fixtures/consumer-types-v2.keiro"-      case goldensForDiff oldSpec newSpec of-        [golden] -> do-          goldenEvidence golden `shouldBe` SynthesizedWeakStandIn-          goldenJson golden `shouldSatisfy` T.isInfixOf "\"artifact\":{"-          goldenJson golden `shouldSatisfy` T.isInfixOf "\"location\":{\"contents\":\"sample\",\"tag\":\"local_file\"}"-          goldenJson golden `shouldSatisfy` T.isInfixOf "\"labels\":[\"sample\"]"-          goldenJson golden `shouldSatisfy` T.isInfixOf "\"revision\":1"-          goldenJson golden `shouldSatisfy` T.isInfixOf "\"observedAt\":\"2026-01-01T00:00:00Z\""-          goldensForDiff oldSpec newSpec `shouldBe` [golden]-          withTempDirectory "keiro-golden-preserve" $ \root -> do-            let target = root </> goldenRelativePath golden-            createDirectoryIfMissing True (takeDirectory target)-            TIO.writeFile target "hand captured\n"-            emitGoldenPayloads root oldSpec newSpec `shouldReturn` []-            TIO.readFile target `shouldReturn` "hand captured\n"-          withTempDirectory "keiro-golden-write" $ \root -> do-            let target = root </> goldenRelativePath golden-            emitGoldenPayloads root oldSpec newSpec `shouldReturn` [target]-            TIO.readFile target `shouldReturn` goldenJson golden-        goldens -> expectationFailure ("expected one nested synthesized golden, got " <> show goldens)-    it "dispatches shared-version upcasters by wire event type and passes foreign kinds through" $ do-      parsed <- parsedSourceOf "test/fixtures/reservation-dup-upcast-source.keiro"-      let spec = parsedSpec parsed-      case [aggregate | NAggregate aggregate <- specNodes spec] of-        [_] -> do-          let modules = scaffoldServiceModules (defaultContext (specContext spec)) (checkedSource parsed)-              codec = generatedTextEndingIn "Codec.hs" modules-              holes = case [moduleText m | m <- modules, "/Holes.hs" `T.isSuffixOf` T.pack (modulePath m)] of-                [text] -> text-                _ -> ""-          codec `shouldSatisfy` T.isInfixOf "upcasters = [(1, upcastRungV1)]"-          codec `shouldSatisfy` T.isInfixOf "upcastRungV1 (EventType \"TransferReservationCreated\") value = upcastTransferReservationCreatedV1 value"-          codec `shouldSatisfy` T.isInfixOf "upcastRungV1 (EventType \"TransferReservationConfirmed\") value = upcastTransferReservationConfirmedV1 value"-          codec `shouldSatisfy` T.isInfixOf "upcastRungV1 _ value = Right value"-          holes `shouldSatisfy` T.isInfixOf "receives ONLY TransferReservationCreated payloads"-        _ -> expectationFailure "expected exactly one aggregate"-    it "keeps foreign payloads byte-for-byte and invokes both same-rung event upcasters" $ do-      let payloadA = object ["kind" .= ("AmountScaled" :: T.Text), "amount" .= (2 :: Int)]-          payloadB = object ["kind" .= ("AmountRenamed" :: T.Text), "amount" .= (3 :: Int)]-          foreignPayload = object ["kind" .= ("AmountObserved" :: T.Text), "amount" .= (7 :: Int)]-          upcastA _ = Right (object ["kind" .= ("AmountScaled" :: T.Text), "amount" .= (200 :: Int)])-          upcastB _ = Right (object ["kind" .= ("AmountRenamed" :: T.Text), "amountInCents" .= (300 :: Int)])-          rung (EventType "AmountScaled") = upcastA-          rung (EventType "AmountRenamed") = upcastB-          rung _ = Right-          codec =-            Codec-              { eventTypes = EventType "AmountScaled" :| [EventType "AmountRenamed", EventType "AmountObserved"],-                eventType = const (EventType "AmountObserved"),-                schemaVersion = 2,-                encode = id,-                decode = \_ -> Right,-                upcasters = [(1, rung)]-              } ::-              Codec Value-      decodeRaw codec (EventType "AmountObserved") 1 foreignPayload `shouldBe` Right foreignPayload-      decodeRaw codec (EventType "AmountScaled") 1 payloadA-        `shouldBe` Right (object ["kind" .= ("AmountScaled" :: T.Text), "amount" .= (200 :: Int)])-      decodeRaw codec (EventType "AmountRenamed") 1 payloadB-        `shouldBe` Right (object ["kind" .= ("AmountRenamed" :: T.Text), "amountInCents" .= (300 :: Int)])-    it "never emits a keiki symbolic operator into a Generated module (firewall)" $ do-      mods <- scaffoldFixture "test/fixtures/reservation.keiro"-      firewallBreaches mods `shouldBe` []-    it "marks the Holes module HoleStub and the rest Generated" $ do-      mods <- scaffoldFixture "test/fixtures/reservation.keiro"-      let holes = [m | m <- mods, kind m == HoleStub]-      map (takeFileName . modulePath) holes `shouldBe` ["BehaviorHoles.hs", "Holes.hs"]-      -- Context nominals/internal/replay plus the stable aggregate surface.-      length [m | m <- mods, kind m == Generated] `shouldBe` 10-    it "is deterministic (re-scaffolding yields byte-identical text)" $ do-      a <- scaffoldFixture "test/fixtures/reservation.keiro"-      b <- scaffoldFixture "test/fixtures/reservation.keiro"-      map moduleText a `shouldBe` map moduleText b-    it "keeps retiring as validator-only metadata in generated modules" $ do-      ordinary <- scaffoldFixture "test/fixtures/reservation.keiro"-      retiring <- scaffoldFixture "test/fixtures/reservation-retiring.keiro"-      map (\m -> (modulePath m, kind m, moduleText m)) retiring-        `shouldBe` map (\m -> (modulePath m, kind m, moduleText m)) ordinary-    it "matches the committed compiling Generated conformance modules (modulo whitespace)" $ do-      mods <- scaffoldFixture "test/fixtures/reservation.keiro"-      mapM_ assertMatchesCommitted [m | m <- mods, kind m == Generated]-    it "matches every committed new-surface Generated module (modulo formatting)" $ do-      modules <- scaffoldFixture "test/fixtures/transfer-routing.keiro"-      forM_ [m | m <- modules, kind m == Generated] $ \m -> do-        committed <- readTestText ("test/conformance-newsurface/" <> modulePath m)-        normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m)-    it "scaffolds the register-free OrderStream smoke target without error" $ do-      mods <- scaffoldFixture "test/fixtures/order.keiro"-      -- Stable context and aggregate modules plus both hand-owned hole surfaces.-      length mods `shouldBe` 12-      firewallBreaches mods `shouldBe` []-      let harness = generatedTextEndingIn "Harness.hs" mods-      harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: PlaceOrder from OrderNotStarted -- \""-      harness `shouldSatisfy` T.isInfixOf "prefix <> \"final vertex\""-      harness `shouldNotSatisfy` T.isInfixOf "prefix <> \"register "-    it "emits forward/replay checks with field-distinct Text samples" $ do-      spec <- parseInlineSpec "<forward-replay-samples>" (T.replace "command Bump { count:Int }" "command Bump { count:Int noteText:Text echo:Text }" loweringAggregateSpec)-      case [aggregate | NAggregate aggregate <- specNodes spec] of-        aggregate : _ -> do-          let ctx = defaultContext (specContext spec)-              harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx spec aggregate)-          harness `shouldSatisfy` T.isInfixOf "\"sample-noteText\" \"sample-echo\""-          harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: Bump from CounterPending -- \""-          harness `shouldSatisfy` T.isInfixOf "prefix <> \"register note\""-        [] -> expectationFailure "forward/replay sample spec has no aggregate"-    it "keeps inequality-guard samples distinct from register initials" $ do-      mods <- scaffoldFixture "test/fixtures/subscription.keiro"-      let harness = generatedTextEndingIn "Harness.hs" mods-      harness `shouldSatisfy` T.isInfixOf "ActivateSubscriptionData"-      harness `shouldSatisfy` T.isInfixOf "Paid"-      harness `shouldNotSatisfy` T.isInfixOf "ActivateSubscriptionData (case parseSubscriptionId \"sub_01h455vb4pex5vsknk084sn02q\" of Right parsed -> parsed; Left _ -> error \"generated valid ID sample failed to parse\") (case parseCustomerId \"cust_01h455vb4pex5vsknk084sn02q\" of Right parsed -> parsed; Left _ -> error \"generated valid ID sample failed to parse\") Free"-    it "uses consumer-owned nominal initials for equality-guard samples" $ do-      mods <- scaffoldFixture "test/fixtures/nominal-scalars.keiro"-      let harness = generatedTextEndingIn "Harness.hs" mods-      harness `shouldSatisfy` T.isInfixOf "Bindings.initialOrderId"-      harness `shouldSatisfy` (not . T.isInfixOf "NominalConformance.Bindings.initialOrderId")-      harness `shouldNotSatisfy` T.isInfixOf "case parseOrderId"-    it "emits the canonical reservation register checks" $ do-      mods <- scaffoldFixture "test/fixtures/reservation.keiro"-      let harness = generatedTextEndingIn "Harness.hs" mods-      harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: RequestTransferReservation from ReservationUnrequested -- \""-      harness `shouldSatisfy` T.isInfixOf "prefix <> \"register reservationId\""-      harness `shouldSatisfy` T.isInfixOf "prefix <> \"register hospitalId\""-      harness `shouldSatisfy` T.isInfixOf "prefix <> \"register patientAcuity\""-      harness `shouldNotSatisfy` T.isInfixOf "prefix <> \"register reservationState\""-    it "lowers a replay-only transition to B.replayOnly in the holes skeleton (plan 143)" $ do-      twinMods <- scaffoldFixture "test/fixtures/reservation-guard-tightened-twin.keiro"-      map moduleText twinMods `shouldSatisfy` any (T.isInfixOf "B.replayOnly")-      let twinHarness = generatedTextEndingIn "Harness.hs" twinMods-      T.count "forwardReplayRequestTransferReservation ::" twinHarness `shouldBe` 1-      plainMods <- scaffoldFixture "test/fixtures/reservation.keiro"-      map moduleText plainMods `shouldSatisfy` all (not . T.isInfixOf "B.replayOnly")--  describe "service workspace (EP-153)" $ do-    describe "manifest grammar" $ do-      it "round-trips the canonical fixture manifest byte-for-byte" $ do-        source <- readTestText canonicalWorkspacePath-        manifest <- shouldParseManifest canonicalWorkspacePath source-        wmfService manifest `shouldBe` "demo-project"-        wmfRuntimePackage manifest `shouldBe` Nothing-        wmfModuleRoot manifest `shouldBe` Just "Demo.Modules.Project"-        wmfLayout manifest `shouldBe` Just CollocatedLeaf-        map wmrPath (NE.toList (wmfMembers manifest))-          `shouldBe` [ "domain/project-artifact.keiro",-                       "domain/project.keiro",-                       "domain/shared.keiro"-                     ]-        renderWorkspaceManifest manifest-          `shouldBe` T.intercalate-            "\n"-            [ "service demo-project",-              "module Demo.Modules.Project",-              "layout collocated",-              "spec domain/project-artifact.keiro",-              "spec domain/project.keiro",-              "spec domain/shared.keiro"-            ]-      it "round-trips runtime-package canonically immediately after service" $ do-        manifest <--          shouldParseManifest "<runtime-package>" $-            T.unlines-              [ "service mori",-                "module Mori.Modules",-                "spec domain/mori.keiro",-                "runtime-package mori-core",-                "layout collocated"-              ]-        wmfRuntimePackage manifest `shouldBe` Just (RuntimePackageName "mori-core")-        effectiveRuntimePackage Nothing manifest `shouldBe` Just (RuntimePackageName "mori-core")-        effectiveRuntimePackage (Just (RuntimePackageName "mori-dev")) manifest-          `shouldBe` Just (RuntimePackageName "mori-dev")-        renderWorkspaceManifest manifest-          `shouldBe` T.intercalate-            "\n"-            [ "service mori",-              "runtime-package mori-core",-              "module Mori.Modules",-              "layout collocated",-              "spec domain/mori.keiro"-            ]-      it "validates runtime package names with the mapped-source Cabal grammar" $ do-        mkRuntimePackageName "mori-core" `shouldBe` Right (RuntimePackageName "mori-core")-        mkRuntimePackageName "mori_core" `shouldBe` Left "runtime package 'mori_core' does not follow Cabal package-name grammar"-      it "treats membership as a set: source order changes neither the AST nor the bytes" $ do-        canonical <- readTestText canonicalWorkspacePath >>= shouldParseManifest canonicalWorkspacePath-        reordered <--          shouldParseManifest "<reordered>" $-            T.unlines-              [ "service demo-project",-                "layout collocated",-                "spec domain/shared.keiro",-                "module Demo.Modules.Project",-                "spec domain/project.keiro",-                "spec ./domain/project-artifact.keiro"-              ]-        reordered `shouldBe` canonical-        renderWorkspaceManifest reordered `shouldBe` renderWorkspaceManifest canonical-      it "satisfies parse . render == id and render . parse . render == render" $-        property $-          forAll genWorkspaceManifest $ \manifest ->-            let rendered = renderWorkspaceManifest manifest-             in case parseWorkspaceManifest "<generated>" rendered of-                  Left err -> counterexample (T.unpack err) False-                  Right reparsed ->-                    counterexample (T.unpack rendered) $-                      reparsed == manifest && renderWorkspaceManifest reparsed == rendered-      it "recognizes a workspace manifest by extension, case-insensitively" $ do-        map-          isWorkspacePath-          [ "service.keiro-workspace",-            "a/b/Service.KEIRO-Workspace",-            "service.keiro",-            ".keiro-workspace",-            "keiro-workspace"-          ]-          `shouldBe` [True, True, False, False, False]-    describe "manifest refusals" $ do-      let rejects description source expected =-            it description $ case parseWorkspaceManifest "<manifest>" source of-              Right _ -> expectationFailure ("expected a refusal, got a manifest for:\n" <> T.unpack source)-              Left err -> T.unpack err `shouldContain` expected-      rejects-        "an empty manifest"-        "# only a comment\n"-        "must begin with a 'service <name>' clause"-      rejects-        "a manifest with no service clause"-        "spec domain/a.keiro\n"-        "first clause of a workspace manifest must be 'service <name>'"-      rejects-        "a manifest whose first clause is not service"-        "module Demo\nservice demo\nspec domain/a.keiro\n"-        "first clause of a workspace manifest must be 'service <name>'"-      rejects-        "a duplicate service clause"-        "service demo\nservice demo\nspec domain/a.keiro\n"-        "duplicate 'service' clause"-      rejects-        "a duplicate module clause"-        "service demo\nmodule Demo\nmodule Demo\nspec domain/a.keiro\n"-        "duplicate 'module' clause"-      rejects-        "a duplicate runtime-package clause"-        "service demo\nruntime-package demo-core\nruntime-package demo-api\nspec domain/a.keiro\n"-        "duplicate 'runtime-package' clause"-      it "locates a malformed runtime-package at its manifest line" $ case parseWorkspaceManifest "<manifest>" "service demo\nspec domain/a.keiro\nruntime-package demo_core\n" of-        Right _ -> expectationFailure "expected a malformed runtime package refusal"-        Left err -> do-          T.unpack err `shouldContain` "<manifest>:3:1"-          T.unpack err `shouldContain` "does not follow Cabal package-name grammar"-      rejects-        "a duplicate layout clause"-        "service demo\nlayout prefixed\nlayout prefixed\nspec domain/a.keiro\n"-        "duplicate 'layout' clause"-      rejects-        "a manifest with no members"-        "service demo\nmodule Demo\n"-        "must list at least one 'spec <path>.keiro' member"-      rejects-        "the same member listed twice"-        "service demo\nspec domain/a.keiro\nspec ./domain/a.keiro\n"-        "duplicate workspace member 'domain/a.keiro'"-      rejects-        "two members that differ only by case"-        "service demo\nspec domain/a.keiro\nspec domain/A.keiro\n"-        "differ only by case"-      rejects-        "an absolute member path"-        "service demo\nspec /etc/a.keiro\n"-        "must be relative, not absolute"-      rejects-        "a member path escaping the manifest directory"-        "service demo\nspec ../escape.keiro\n"-        "must not contain '..' segments"-      rejects-        "a member that is not a .keiro spec"-        "service demo\nspec domain/a.txt\n"-        "must name a .keiro spec"-      rejects-        "a manifest listing another manifest"-        "service demo\nspec domain/other.keiro-workspace\n"-        "must name a .keiro spec"-    describe "line relocation" $ do-      it "shifts every location the AST carries, and only the locations" $ do-        spec <- specOf "test/fixtures/reservation.keiro"-        let shifted = relocateLocs (+ 1000) spec-        collectLocs spec `shouldSatisfy` (not . null)-        collectLocs shifted `shouldBe` map (+ 1000) (collectLocs spec)-        -- Loc's Eq deliberately ignores the line, so relocation cannot-        -- change any equality-based behavior anywhere downstream.-        shifted `shouldBe` spec-      it "leaves the placeholder location alone so it never lands inside a member range" $ do-        spec <- specOf "test/fixtures/reservation.keiro"-        let blanked = relocateLocs (const 0) spec-            reshifted = relocateLocs (\n -> if n <= 0 then n else n + 500) blanked-        collectLocs reshifted `shouldBe` map (const 0) (collectLocs spec)-    describe "composition" $ do-      it "resolves cross-file ids, enums, mapped types, and read-model feeds" $ do-        workspace <- shouldComposeWorkspace canonicalWorkspacePath-        wsService workspace `shouldBe` "demo-project"-        wsContext workspace `shouldBe` "demo-project"-        wsModuleRoot workspace `shouldBe` Just "Demo.Modules.Project"-        wsLayout workspace `shouldBe` Just CollocatedLeaf-        map wmPath (wsMembers workspace)-          `shouldBe` [ "domain/project-artifact.keiro",-                       "domain/project.keiro",-                       "domain/shared.keiro"-                     ]-        -- Every member is individually incomplete; together they check.-        checkWorkspace workspace `shouldBe` []-      it "records which member owns each shared declaration and node" $ do-        workspace <- shouldComposeWorkspace canonicalWorkspacePath-        let ownership = wsOwnership workspace-        fmap fst (declarationOwner ownership "id" "ProjectId")-          `shouldBe` Just "domain/shared.keiro"-        fmap fst (declarationOwner ownership "enum" "ProjectPhase")-          `shouldBe` Just "domain/shared.keiro"-        fmap fst (declarationOwner ownership "rule" "phaseIsTerminal")-          `shouldBe` Just "domain/shared.keiro"-        fmap fst (declarationOwner ownership "mapped" "ProjectSummary")-          `shouldBe` Just "domain/shared.keiro"-        fmap fst (nodeOwner ownership "aggregate" "Project")-          `shouldBe` Just "domain/project.keiro"-        fmap fst (nodeOwner ownership "aggregate" "ProjectArtifact")-          `shouldBe` Just "domain/project-artifact.keiro"-        fmap fst (nodeOwner ownership "readmodel" "project_activity")-          `shouldBe` Just "domain/project-artifact.keiro"-      it "maps every merged line back to the member that wrote it" $ do-        workspace <- shouldComposeWorkspace canonicalWorkspacePath-        let bases = [(wmPath m, wmLineBase m, wmLineCount m) | m <- wsMembers workspace]-        -- Ranges are disjoint and contiguous from zero.-        map (\(_, base, _) -> base) bases `shouldBe` scanl (+) 0 (init [c | (_, _, c) <- bases])-        sequence_-          [ resolveWorkspaceLine workspace (base + offset) `shouldBe` Just (path, offset)-          | (path, base, memberLines) <- bases,-            offset <- [1, memberLines]-          ]-        resolveWorkspaceLine workspace 0 `shouldBe` Nothing-      it "is insensitive to the order members are listed in" $ do-        canonical <- shouldComposeWorkspace canonicalWorkspacePath-        reordered <- shouldComposeWorkspace reorderedWorkspacePath-        reordered {wsManifestPath = wsManifestPath canonical} `shouldBe` canonical-      it "checks a single .keiro file as a one-member workspace, diagnostic for diagnostic" $ do-        let fixtures =-              [ "test/fixtures/reservation.keiro",-                "test/fixtures/consumer-types.keiro",-                "test/fixtures/aggregate-bad-refs.keiro",-                "test/fixtures/readmodel.keiro"-              ]-        forM_ fixtures $ \path -> do-          spec <- specOf path-          let workspace = oneMemberWorkspace path spec-              viaWorkspace = map (renderWorkspaceDiagnostic path) (checkWorkspace workspace)-              direct = map (renderDiagnostic path) (validateSpec spec)-          viaWorkspace `shouldBe` direct-        -- At least one of those fixtures must actually produce errors,-        -- or the equivalence claim is vacuous.-        badRefs <- specOf "test/fixtures/aggregate-bad-refs.keiro"-        checkWorkspace (oneMemberWorkspace "test/fixtures/aggregate-bad-refs.keiro" badRefs)-          `shouldSatisfy` any ((== Error) . wdSeverity)-    describe "composition refusals" $ do-      let refusesWith path expectedCode expectedFiles = do-            diagnostics <- shouldRefuseWorkspace path-            map wdCode (NE.toList diagnostics) `shouldContain` [expectedCode]-            let cited =-                  [ wlFile location-                  | diagnostic <- NE.toList diagnostics,-                    wdCode diagnostic == expectedCode,-                    location <- NE.toList (wdLocations diagnostic)-                  ]-            sort (nubOrd cited) `shouldBe` sort expectedFiles-      it "refuses members that declare different contexts, citing every context clause" $-        refusesWith-          "test/fixtures/workspace-context-mismatch/service.keiro-workspace"-          WorkspaceContextMismatch-          [WorkspaceMemberFile "domain/a.keiro", WorkspaceMemberFile "domain/b.keiro"]-      it "refuses a member layout clause that contradicts the manifest authority" $-        refusesWith-          "test/fixtures/workspace-authority-conflict/service.keiro-workspace"-          WorkspaceAuthorityConflict-          [WorkspaceManifestFile, WorkspaceMemberFile "domain/b.keiro"]-      it "refuses a textually identical shared declaration owned by two members" $-        refusesWith-          "test/fixtures/workspace-dup-decl/service.keiro-workspace"-          WorkspaceDuplicateDeclaration-          [WorkspaceMemberFile "domain/project.keiro", WorkspaceMemberFile "domain/shared.keiro"]-      it "refuses one aggregate defined in two members" $-        refusesWith-          "test/fixtures/workspace-dup-node/service.keiro-workspace"-          WorkspaceDuplicateNodeName-          [WorkspaceMemberFile "domain/a.keiro", WorkspaceMemberFile "domain/b.keiro"]-      it "refuses generated paths that collide across members under case folding" $-        refusesWith-          "test/fixtures/workspace-path-collision/service.keiro-workspace"-          WorkspacePathCollision-          [WorkspaceMemberFile "domain/a.keiro", WorkspaceMemberFile "domain/b.keiro"]-      it "reports a listed member that is missing from disk" $-        refusesWith-          "test/fixtures/workspace-missing-member/service.keiro-workspace"-          WorkspaceMemberUnreadable-          [WorkspaceManifestFile]-      it "reports a member that does not parse" $-        refusesWith-          "test/fixtures/workspace-member-parse-failed/service.keiro-workspace"-          WorkspaceMemberParseFailed-          [WorkspaceManifestFile]-      it "surfaces a cross-file unresolved reference through the merged validator" $ do-        workspace <- shouldComposeWorkspace "test/fixtures/workspace-unresolved/service.keiro-workspace"-        let errors = [d | d <- checkWorkspace workspace, wdSeverity d == Error]-        map wdCode errors `shouldContain` [GuardAtomOutOfScope]-        [wlFile location | d <- errors, location <- NE.toList (wdLocations d)]-          `shouldContain` [WorkspaceMemberFile "domain/project.keiro"]-    describe "multi-file diagnostic rendering" $ do-      it "puts the primary location in the established shape and every other file on a note line" $ do-        diagnostics <- shouldRefuseWorkspace "test/fixtures/workspace-dup-decl/service.keiro-workspace"-        let manifest = "keiro-dsl/test/fixtures/workspace-dup-decl/service.keiro-workspace"-        map (renderWorkspaceDiagnostic manifest) (NE.toList diagnostics)-          `shouldBe` [ T.intercalate-                         "\n"-                         [ "keiro-dsl/test/fixtures/workspace-dup-decl/domain/project.keiro:4: error[WorkspaceDuplicateDeclaration]: duplicate declaration 'ProjectId': a shared declaration has exactly one owning member (identical duplicates do not merge)",-                           "  keiro-dsl/test/fixtures/workspace-dup-decl/domain/shared.keiro:4: note: also declared here, as id 'ProjectId'"-                         ]-                     ]-    describe "whole-service check through the CLI" $ do-      it "prints OK and exits zero for the composed fixture workspace" $ do-        (exitCode, out, err) <- runKeiroDsl ["check", canonicalWorkspacePath]-        unless (exitCode == ExitSuccess) (expectationFailure (out <> err))-        lines out `shouldBe` ["OK"]-      it "exits non-zero and names every involved file for a cross-file refusal" $ do-        (exitCode, _, err) <--          runKeiroDsl ["check", "test/fixtures/workspace-dup-decl/service.keiro-workspace"]-        exitCode `shouldBe` ExitFailure 1-        err `shouldContain` "error[WorkspaceDuplicateDeclaration]"-        err `shouldContain` "workspace-dup-decl/domain/project.keiro:4"-        err `shouldContain` "workspace-dup-decl/domain/shared.keiro:4"-      it "attributes a merged-graph validation error to the member that wrote it" $ do-        (exitCode, _, err) <--          runKeiroDsl ["check", "test/fixtures/workspace-unresolved/service.keiro-workspace"]-        exitCode `shouldBe` ExitFailure 1-        err `shouldContain` "workspace-unresolved/domain/project.keiro:12: error[GuardAtomOutOfScope]"-      it "produces byte-identical output for a manifest whose members are listed in reverse" $ do-        (canonicalCode, canonicalOut, _) <- runKeiroDsl ["check", canonicalWorkspacePath, "--emit"]-        (reorderedCode, reorderedOut, _) <- runKeiroDsl ["check", reorderedWorkspacePath, "--emit"]-        canonicalCode `shouldBe` ExitSuccess-        reorderedCode `shouldBe` ExitSuccess-        reorderedOut `shouldBe` canonicalOut-        (_, canonicalParse, _) <- runKeiroDsl ["parse", canonicalWorkspacePath]-        (_, reorderedParse, _) <- runKeiroDsl ["parse", reorderedWorkspacePath]-        reorderedParse `shouldBe` canonicalParse-      it "keeps the single-file path working, byte for byte" $ do-        (exitCode, out, err) <- runKeiroDsl ["check", "test/fixtures/reservation.keiro"]-        unless (exitCode == ExitSuccess) (expectationFailure (out <> err))-        lines out `shouldBe` ["OK"]-      it "explains bindings and reports coverage against the merged graph" $ do-        (bindingsCode, bindingsOut, _) <--          runKeiroDsl ["check", canonicalWorkspacePath, "--explain-bindings"]-        bindingsCode `shouldBe` ExitSuccess-        bindingsOut `shouldContain` "binding obligations for context demo-project"-        -- The obligation's use sites span both aggregate members, which-        -- is only possible because the graph was resolved once, merged.-        bindingsOut `shouldContain` "Project register summary : ProjectSummary"-        bindingsOut `shouldContain` "ProjectArtifact command RecordArtifact .artifactSummary : ProjectSummary"-        withTempDirectory "keiro-dsl-workspace-coverage" $ \out -> do-          let reportPath = out </> "coverage.json"-          (coverageCode, coverageOut, _) <--            runKeiroDsl ["check", canonicalWorkspacePath, "--coverage-report", reportPath]-          coverageCode `shouldBe` ExitSuccess-          coverageOut `shouldContain` "structural/opaque boundaries (reporting only)"-          report <- Aeson.eitherDecodeFileStrict reportPath-          case report of-            Left err -> expectationFailure err-            Right value -> coverageSpecPath value `shouldBe` Just (T.pack canonicalWorkspacePath)--  describe "workspace diff revision loading (EP-155 M1)" $ do-    it "composes added, removed, and renamed members through an in-memory content source" $ do-      project <- readTestText "test/fixtures/workspace/domain/project.keiro"-      artifact <- readTestText "test/fixtures/workspace/domain/project-artifact.keiro"-      shared <- readTestText "test/fixtures/workspace/domain/shared.keiro"-      let extra = "language keiro-dsl 4\ncontext demo-project\n\nid ExtraId prefix=extra\n"-          manifest members =-            T.unlines-              ( ["service demo-project", "module Demo.Modules.Project", "layout collocated"]-                  <> ["spec " <> T.pack member | member <- members]-              )-          baseFiles =-            Map.fromList-              [ ("domain/project.keiro", project),-                ("domain/project-artifact.keiro", artifact),-                ("domain/shared.keiro", shared)-              ]-          loadFrom members files =-            loadWorkspace-              (memoryContentSource (Map.insert "service.keiro-workspace" (manifest members) files))-              "service.keiro-workspace"-          baseMembers = ["domain/project.keiro", "domain/project-artifact.keiro", "domain/shared.keiro"]-          expectLoaded result = case result of-            Left failure -> expectationFailure (show failure) >> error "unreachable"-            Right workspace -> pure workspace--      oldAdded <- loadFrom baseMembers baseFiles >>= expectLoaded-      newAdded <--        loadFrom-          (baseMembers <> ["domain/extra.keiro"])-          (Map.insert "domain/extra.keiro" extra baseFiles)-          >>= expectLoaded-      map changeCode (diffSpecs (wsMergedSpec oldAdded) (wsMergedSpec newAdded))-        `shouldContain` [DeclarationAdded]--      oldRemoved <- loadFrom baseMembers baseFiles >>= expectLoaded-      newRemoved <--        loadFrom-          ["domain/project.keiro", "domain/shared.keiro"]-          (Map.delete "domain/project-artifact.keiro" baseFiles)-          >>= expectLoaded-      map changeCode (diffSpecs (wsMergedSpec oldRemoved) (wsMergedSpec newRemoved))-        `shouldContain` [EvtRemovedNotDeprecated]--      oldRenamed <- loadFrom baseMembers baseFiles >>= expectLoaded-      let renamedMembers = ["domain/project-renamed.keiro", "domain/project-artifact.keiro", "domain/shared.keiro"]-          renamedFiles = Map.insert "domain/project-renamed.keiro" project (Map.delete "domain/project.keiro" baseFiles)-      newRenamed <- loadFrom renamedMembers renamedFiles >>= expectLoaded-      diffSpecs (wsMergedSpec oldRenamed) (wsMergedSpec newRenamed) `shouldBe` []--  describe "workspace diff ownership and unified reports (EP-155 M2)" $ do-    it "classifies shared declarations at use sites across every member with owned citations" $ do-      old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace"-      new <- shouldComposeWorkspace "test/fixtures/workspace-diff-new/service.keiro-workspace"-      let changes = diffWorkspaces old new-          enumChanges = filter ((== EnumCtorAdded) . changeCode . wcChange) changes-          mappedChanges = filter ((== MappedFieldTypeChanged) . changeCode . wcChange) changes-          citedFiles workspaceChanges =-            [ osFile site-            | change <- workspaceChanges,-              (_, Just site) <- wcUseSites change-            ]-      enumChanges `shouldSatisfy` (not . null)-      mappedChanges `shouldSatisfy` (not . null)-      let enumWireChanges =-            [ change-            | workspaceChange <- enumChanges,-              let change = wcChange workspaceChange,-              OldBinaryReadNewEvents `elem` breakingSurfaces change-            ]-      enumWireChanges `shouldSatisfy` (not . null)-      enumWireChanges `shouldSatisfy` all (not . gatedBreaking defaultGate)-      enumWireChanges `shouldSatisfy` all (gatedBreaking (gateWith [OldBinaryReadNewEvents]))-      map (fmap osFile . wcDeclarationSite) (enumChanges <> mappedChanges)-        `shouldSatisfy` all (== Just "domain/shared.keiro")-      citedFiles enumChanges `shouldContain` ["domain/order.keiro", "domain/shipment.keiro"]-      citedFiles mappedChanges `shouldContain` ["domain/order.keiro", "domain/shipment.keiro"]-      let rendered = T.intercalate "\n" (map renderWorkspaceFinding (enumChanges <> mappedChanges))-      rendered `shouldSatisfy` T.isInfixOf "    declared: domain/shared.keiro:4"-      rendered `shouldSatisfy` T.isInfixOf "    use-site: Order"-      rendered `shouldSatisfy` T.isInfixOf "(domain/order.keiro:"-      rendered `shouldSatisfy` T.isInfixOf "(domain/shipment.keiro:"-      assertMatchesGolden "test/fixtures/workspace-diff-new/workspace.diff.golden" (T.unlines (map renderWorkspaceFinding changes))--    it "emits one additive version-1 report with workspace provenance" $ do-      old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace"-      new <- shouldComposeWorkspace "test/fixtures/workspace-diff-new/service.keiro-workspace"-      let changes = diffWorkspaces old new-          meta =-            WorkspaceMeta-              { wmIdentity = wsService new,-                wmManifest = "service.keiro-workspace",-                wmSince = "HEAD",-                wmMembersOld = map wmPath (wsMembers old),-                wmMembersNew = map wmPath (wsMembers new),-                wmAdoptionBaseline = False-              }-      case Aeson.toJSON (workspaceDiffReport meta defaultGate changes) of-        Aeson.Object report -> do-          KeyMap.lookup "schema" report `shouldBe` Just (Aeson.String "keiro-dsl/diff-report/1")-          case KeyMap.lookup "workspace" report of-            Just (Aeson.Object workspace) -> do-              KeyMap.lookup "identity" workspace `shouldBe` Just (Aeson.String "workspace-diff")-              KeyMap.lookup "adoptionBaseline" workspace `shouldBe` Just (Aeson.Bool False)-            other -> expectationFailure ("missing workspace report metadata: " <> show other)-          case KeyMap.lookup "findings" report of-            Just (Aeson.Array findings) -> do-              findings `shouldSatisfy` (not . null)-              let objects = [finding | Aeson.Object finding <- toList findings]-              objects `shouldSatisfy` any (KeyMap.member "declaration")-              objects `shouldSatisfy` any (KeyMap.member "useSites")-            other -> expectationFailure ("missing workspace findings: " <> show other)-        other -> expectationFailure ("workspace report was not an object: " <> show other)--    it "computes one replay-impact value over both aggregates" $ do-      old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace"-      new <- shouldComposeWorkspace "test/fixtures/workspace-diff-new/service.keiro-workspace"-      case replayImpactSpecs (wsMergedSpec old) (wsMergedSpec new) of-        ReplayAffected affected -> Map.keysSet affected `shouldBe` Set.fromList ["Order", "Shipment"]-        ReplayNeutral -> expectationFailure "shared mapped evolution unexpectedly reported replay-neutral"--  describe "workspace ownership and authority changes (EP-155 M3)" $ do-    it "reports an unchanged aggregate move once without wire evolution" $ do-      old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace"-      moved <- shouldComposeWorkspace "test/fixtures/workspace-diff-moved/service.keiro-workspace"-      let changes = diffWorkspaces old moved-      map (changeCode . wcChange) changes `shouldBe` [OwnershipMoved]-      forM_ changes $ \workspaceMove -> do-        let move = wcChange workspaceMove-        move `shouldSatisfy` isAdvisory-        move `shouldSatisfy` (not . gatedBreaking defaultGate)-        move `shouldSatisfy` (not . gatedBreaking (gateWith [minBound .. maxBound]))-        deriveLabel defaultGate (ckVector (workspaceChangeKind move)) `shouldBe` LabelAdvisory-        remediationFor (ckContext (workspaceChangeKind move)) OwnershipMoved-          `shouldBe` (RemedyRescaffoldWorkspace :| [])-        renderWorkspaceFinding workspaceMove-          `shouldSatisfy` T.isInfixOf "declaration moved domain/shipment.keiro -> domain/order.keiro"--    it "treats a member rename as the same owner-map change" $ do-      old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace"-      let ownership = wsOwnership old-          renamed =-            old-              { wsOwnership =-                  ownership-                    { oiNodes =-                        Map.adjust-                          (\(_, loc) -> ("domain/shipping.keiro", loc))-                          ("aggregate", "Shipment")-                          (oiNodes ownership)-                    }-              }-          moves = filter ((== OwnershipMoved) . changeCode . wcChange) (diffWorkspaces old renamed)-      length moves `shouldBe` 1-      forM_ moves $ \move ->-        renderWorkspaceFinding move `shouldSatisfy` T.isInfixOf "domain/shipment.keiro -> domain/shipping.keiro"--    it "reports ownership motion beside an independently classified wire edit" $ do-      old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace"-      edited <- shouldComposeWorkspace "test/fixtures/workspace-diff-new/service.keiro-workspace"-      let ownership = wsOwnership edited-          movedAndEdited =-            edited-              { wsOwnership =-                  ownership-                    { oiNodes =-                        Map.adjust-                          (\(_, loc) -> ("domain/order.keiro", loc))-                          ("aggregate", "Shipment")-                          (oiNodes ownership)-                    }-              }-          codes = map (changeCode . wcChange) (diffWorkspaces old movedAndEdited)-      codes `shouldContain` [OwnershipMoved]-      codes `shouldContain` [MappedFieldTypeChanged]--    it "reports context authority separately from derived read-model identity breaks" $ do-      old <- shouldComposeWorkspace canonicalWorkspacePath-      let newContext = "demo-project-renamed"-          renamed =-            old-              { wsContext = newContext,-                wsMergedSpec = (wsMergedSpec old) {specContext = newContext}-              }-          changes = diffWorkspaces old renamed-          codes = map (changeCode . wcChange) changes-      codes `shouldContain` [WorkspaceAuthorityChanged]-      codes `shouldContain` [DerivedIdentityChanged]-      map wcChange changes `shouldSatisfy` any (gatedBreaking defaultGate)--    it "keeps service, module-root, and layout authority advisories non-blocking" $ do-      old <- shouldComposeWorkspace canonicalWorkspacePath-      let changed =-            old-              { wsService = "demo-project-renamed",-                wsModuleRoot = Just "Demo.Modules.Renamed",-                wsLayout = Just GeneratedPrefix-              }-          authority = filter ((== WorkspaceAuthorityChanged) . changeCode . wcChange) (diffWorkspaces old changed)-      length authority `shouldBe` 3-      forM_ (map wcChange authority) $ \change -> do-        deriveLabel defaultGate (ckVector (workspaceChangeKind change)) `shouldBe` LabelAdvisory-        change `shouldSatisfy` (not . gatedBreaking (gateWith [minBound .. maxBound]))-        remediationFor (ckContext (workspaceChangeKind change)) WorkspaceAuthorityChanged-          `shouldBe` (RemedyRescaffoldWorkspace :| [RemedyRecompileConsumers])--  describe "workspace scaffold (EP-154)" $ do-    describe "workspace record" $ do-      it "round-trips modules, owners, members, mappings, obligations, and adoptions" $ do-        workspace <- shouldComposeWorkspace canonicalWorkspacePath-        let record = sampleWorkspaceRecord workspace-            rendered = renderWorkspaceRecord record-        parseWorkspaceRecord rendered `shouldBe` Just record-        -- The header pins the schema: a v1 context-keyed record and a-        -- workspace record can never be read as each other.-        T.lines rendered `shouldSatisfy` \case-          header : _ -> header == "keiro-dsl workspace scaffold record v1"-          [] -> False-        parseRecord rendered `shouldBe` Nothing-        parseWorkspaceRecord (T.replace "record v1" "record v2" rendered) `shouldBe` Nothing-      it "ignores unknown rows and unknown JSON keys, and keeps context-level rows ownerless" $ do-        workspace <- shouldComposeWorkspace canonicalWorkspacePath-        let record = sampleWorkspaceRecord workspace-            rendered = renderWorkspaceRecord record-        parseWorkspaceRecord (T.replace "service: " "future-row: retained\nservice: " rendered)-          `shouldBe` Just record-        parseWorkspaceRecord (T.replace "\"kind\":\"generated\"" "\"kind\":\"generated\",\"future\":1" rendered)-          `shouldBe` Just record-        [row | row <- wrModules record, wrmOwner row == Nothing]-          `shouldSatisfy` (not . null)-      it "rejects absent stable language rows and partial, duplicate, malformed, or inconsistent contracts" $ do-        workspace <- shouldComposeWorkspace canonicalWorkspacePath-        let record = sampleWorkspaceRecord workspace-            rendered = renderWorkspaceRecord record-            sourceRows = filter ("source-language " `T.isPrefixOf`) (T.lines rendered)-            withoutSourceRows = T.unlines (filter (not . T.isPrefixOf "source-language ") (T.lines rendered))-            semanticRows = filter ("semantic-contract " `T.isPrefixOf`) (T.lines rendered)-            withoutSemanticRows = T.unlines (filter (not . T.isPrefixOf "semantic-contract ") (T.lines rendered))-        parseWorkspaceRecord withoutSourceRows `shouldBe` Nothing-        case sourceRows of-          firstRow : secondRow : _ -> do-            parseWorkspaceRecord (T.unlines (filter (/= secondRow) (T.lines rendered))) `shouldBe` Nothing-            parseWorkspaceRecord (T.replace firstRow (firstRow <> "\n" <> firstRow) rendered) `shouldBe` Nothing-            parseWorkspaceRecord (T.replace firstRow "source-language {malformed}" rendered) `shouldBe` Nothing-          _ -> expectationFailure "expected multiple workspace source-language rows"-        parseWorkspaceRecord withoutSemanticRows `shouldBe` Just record-        case semanticRows of-          [semanticRow] -> do-            parseWorkspaceRecord (T.replace semanticRow (semanticRow <> "\n" <> semanticRow) rendered) `shouldBe` Nothing-            parseWorkspaceRecord (T.replace semanticRow "semantic-contract {malformed}" rendered) `shouldBe` Nothing-            parseWorkspaceRecord (T.replace "\"languageVersion\":4" "\"languageVersion\":3" rendered) `shouldBe` Nothing-          _ -> expectationFailure "expected one workspace semantic-contract row"-      it "rejects unsafe module, owner, member, and adoption paths" $ do-        workspace <- shouldComposeWorkspace canonicalWorkspacePath-        let rendered = renderWorkspaceRecord (sampleWorkspaceRecord workspace)-            corrupt from to = parseWorkspaceRecord (T.replace from to rendered)-        corrupt "member domain/shared.keiro" "member /etc/passwd" `shouldBe` Nothing-        corrupt "member domain/shared.keiro" "member ../escape.keiro" `shouldBe` Nothing-        corrupt "\"owner\":\"domain/shared.keiro\"" "\"owner\":\"../shared.keiro\"" `shouldBe` Nothing-        corrupt "\"path\":\"claimed/One.hs\"" "\"path\":\"/tmp/One.hs\"" `shouldBe` Nothing-      it "keys context and workspace history in structurally distinct explicit slots" $ do-        workspaceRecordFileName "demo-project"-          `shouldBe` workspaceLedgerFileName "demo-project"-        workspaceManifestFileName "demo-project"-          `shouldBe` workspaceCabalFragmentFileName "demo-project"-        workspaceRecordFileName "demo-project" `shouldNotBe` recordFileName "demo-project"-        contextLedgerFileName "workspace"-          `shouldNotBe` workspaceLedgerFileName "workspace"-        supersededByLine "demo-project"-          `shouldBe` "superseded-by: keiro-dsl-ledger.workspace.demo-project.txt"--    describe "workspace plan" $ do-      it "emits the context-level facade and replay-audit exactly once from the merged graph" $ do-        plan <- shouldPlanWorkspace canonicalWorkspacePath-        let modules = map fst (wpModules plan)-            facades = [m | m <- modules, "StructuralProjections.hs" `isSuffixOfPath` m]-            audits = [m | m <- modules, "ReplayAudit.hs" `isSuffixOfPath` m]-            shapes = [m | m <- modules, "Structural/Shape/ProjectSummary.hs" `isSuffixOfPath` m]-        length facades `shouldBe` 1-        length audits `shouldBe` 1-        length shapes `shouldBe` 1-        -- The audit assembles aggregates owned by two different member-        -- files, which is only possible from one merged graph.-        forM_ audits $ \audit -> do-          moduleText audit `shouldSatisfy` T.isInfixOf "Project.projectEventStream"-          moduleText audit `shouldSatisfy` T.isInfixOf "ProjectArtifact.projectArtifactEventStream"-      it "gives every generated ID and enum one context owner and imports only aggregate uses" $ do-        plan <- shouldPlanWorkspace canonicalWorkspacePath-        let ctx = wpContext plan-            modules = map fst (wpModules plan)-            nominalModules = [m | m <- modules, modulePath m == T.unpack (T.replace "." "/" (generatedNominalModule ctx) <> ".hs")]-            internalNominalModules = [m | m <- modules, modulePath m == T.unpack (T.replace "." "/" (generatedNominalModule ctx) <> "/Internal.hs")]-            domainFor suffix = case [m | m <- modules, suffix `isSuffixOfPath` m] of-              [m] -> pure m-              found -> expectationFailure ("expected one domain ending in " <> suffix <> ", got " <> show (map modulePath found)) >> fail "unreachable"-        ownerModule <- case nominalModules of-          [m] -> pure m-          found -> expectationFailure ("expected one generated nominal owner, got " <> show (map modulePath found)) >> fail "unreachable"-        internalOwnerModule <- case internalNominalModules of-          [m] -> pure m-          found -> expectationFailure ("expected one generated internal nominal owner, got " <> show (map modulePath found)) >> fail "unreachable"-        let nominalText = moduleText ownerModule-            internalNominalText = moduleText internalOwnerModule-        T.count "newtype ProjectId" nominalText `shouldBe` 0-        T.count "newtype ProjectId" internalNominalText `shouldBe` 1-        T.count "data ProjectPhase =" nominalText `shouldBe` 1-        T.count "data WorkspaceVisibility =" nominalText `shouldBe` 1-        projectDomain <- domainFor "Project/Generated/Domain.hs"-        artifactDomain <- domainFor "ProjectArtifact/Generated/Domain.hs"-        forM_ [projectDomain, artifactDomain] $ \domain -> do-          moduleText domain `shouldSatisfy` (not . T.isInfixOf "newtype ProjectId")-          moduleText domain `shouldSatisfy` (not . T.isInfixOf "data ProjectPhase")-          moduleText domain `shouldSatisfy` T.isInfixOf (generatedNominalModule ctx <> " (ProjectId, parseProjectId, ProjectPhase (..))")-          moduleText domain `shouldSatisfy` (not . T.isInfixOf "WorkspaceVisibility")-        singleFileModules <- case planServiceScaffold ctx (stableCheckedService (wsMergedSpec (wpWorkspace plan))) of-          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"-          Right values -> pure values-        let withoutOrigin m = (modulePath m, moduleText m, kind m)-        map withoutOrigin singleFileModules `shouldBe` map withoutOrigin modules-        owners <- case planNominalGeneration ctx (wsMergedSpec (wpWorkspace plan)) of-          Left errors -> expectationFailure (show errors) >> fail "unreachable"-          Right values -> pure values-        map (resolvedNominalName . nominalDeclaration) owners-          `shouldBe` ["ProjectId", "ProjectPhase", "WorkspaceVisibility"]-        case [owner | owner <- owners, resolvedNominalName (nominalDeclaration owner) == "ProjectId"] of-          [owner] -> do-            nominalModule owner `shouldBe` generatedNominalModule ctx-            Set.fromList [NominalUseSite "Project" RegisterUse, NominalUseSite "ProjectArtifact" EventFieldUse]-              `shouldSatisfy` (`Set.isSubsetOf` nominalUseSites owner)-          found -> expectationFailure ("expected one ProjectId owner, got " <> show (length found))-      it "attributes every module to its owning member and leaves shared ones context-level" $ do-        plan <- shouldPlanWorkspace canonicalWorkspacePath-        let memberPaths = map wmPath (wsMembers (wpWorkspace plan))-            ownerOf suffix =-              case [provenance | (m, provenance) <- wpModules plan, suffix `isSuffixOfPath` m] of-                [provenance] -> Just provenance-                _ -> Nothing-        ownerOf "StructuralProjections.hs" `shouldBe` Just ContextLevel-        ownerOf "Generated/Nominals.hs" `shouldBe` Just ContextLevel-        ownerOf "ReplayAudit.hs" `shouldBe` Just ContextLevel-        ownerOf "Structural/Shape/ProjectSummary.hs"-          `shouldBe` Just (MemberOwned "domain/shared.keiro")-        ownerOf "Project/Generated/Domain.hs"-          `shouldBe` Just (MemberOwned "domain/project.keiro")-        ownerOf "ProjectArtifact/Generated/Domain.hs"-          `shouldBe` Just (MemberOwned "domain/project-artifact.keiro")-        ownerOf "ProjectActivity/Generated/ReadModel.hs"-          `shouldBe` Just (MemberOwned "domain/project-artifact.keiro")-        -- No module may claim an owner that is not a member of the-        -- workspace: the record's owner column has to stay resolvable.-        map (provenanceOwner . snd) (wpModules plan)-          `shouldSatisfy` all (maybe True (`elem` memberPaths))-      it "keeps the compiled workspace nominal conformance tree byte-current" $ do-        workspace <- shouldComposeWorkspace "test/fixtures/workspace-nominals/service.keiro-workspace"-        plan <- shouldPlanWorkspaceSpec workspace-        let compiledPaths =-              [ "Generated/WorkspaceNominalProof/Nominals.hs",-                "Generated/WorkspaceNominalProof/Project/Domain.hs",-                "Generated/WorkspaceNominalProof/Project/Codec.hs",-                "Generated/WorkspaceNominalProof/Project/Transducer.hs",-                "Generated/WorkspaceNominalProof/Project/BehaviorContract.hs",-                "Generated/WorkspaceNominalProof/Project/EventStream.hs",-                "Generated/WorkspaceNominalProof/Project/Harness.hs",-                "Generated/WorkspaceNominalProof/Project/Projection.hs",-                "Generated/WorkspaceNominalProof/ProjectArtifact/Domain.hs",-                "Generated/WorkspaceNominalProof/ProjectArtifact/Codec.hs",-                "Generated/WorkspaceNominalProof/ProjectArtifact/Transducer.hs",-                "Generated/WorkspaceNominalProof/ProjectArtifact/BehaviorContract.hs",-                "Generated/WorkspaceNominalProof/ProjectArtifact/EventStream.hs",-                "Generated/WorkspaceNominalProof/ProjectArtifact/Harness.hs",-                "Generated/WorkspaceNominalProof/ProjectArtifact/Projection.hs",-                "Generated/WorkspaceNominalProof/ReplayAudit.hs"-              ]-        map fst (wpModules plan) `shouldSatisfy` all (not . isSuffixOfPath "/Holes.hs")-        forM_ compiledPaths $ \path ->-          case [m | (m, _) <- wpModules plan, modulePath m == path] of-            [generated] -> do-              committed <- readTestText ("test/conformance-workspace-nominals/" <> path)-              normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText generated)-            found -> expectationFailure ("expected one generated module at " <> path <> ", got " <> show (map modulePath found))-      it "plans a one-member workspace byte-identically to the single-file path" $ do-        let fixtures =-              [ "test/fixtures/reservation.keiro",-                "test/fixtures/consumer-types.keiro",-                "test/fixtures/readmodel.keiro",-                "test/fixtures/hospital-surge.keiro"-              ]-        -- Modules and refusals both: hospital-surge refuses on both-        -- paths, which proves the gates agree as well as the emitters.-        forM_ fixtures $ \path -> do-          spec <- specOf path-          let ctx = defaultContext (specContext spec)-              workspace = oneMemberWorkspace path spec-          fmap (map fst . wpModules) (planWorkspaceScaffold "goldens" ctx workspace)-            `shouldBe` planScaffold ctx spec-        -- The equality is not vacuous: at least one fixture plans, and-        -- its per-node modules are attributed to the single member.-        spec <- specOf "test/fixtures/reservation.keiro"-        let workspace = oneMemberWorkspace "test/fixtures/reservation.keiro" spec-        case planWorkspaceScaffold "goldens" (defaultContext (specContext spec)) workspace of-          Left refusals -> expectationFailure ("reservation should plan: " <> show refusals)-          Right plan -> do-            wpModules plan `shouldSatisfy` (not . null)-            map snd (wpModules plan)-              `shouldSatisfy` all (`elem` [ContextLevel, MemberOwned "reservation.keiro"])-            map snd (wpModules plan)-              `shouldSatisfy` elem (MemberOwned "reservation.keiro")-      it "computes obligations from the complete merged graph, spanning members" $ do-        workspace <- shouldComposeWorkspace canonicalWorkspacePath-        case bindingObligations (wsMergedSpec workspace) of-          Left graphErrors -> expectationFailure ("merged graph did not resolve: " <> show graphErrors)-          Right obligations ->-            case [o | o <- obligations, obligationMappedName o == "ProjectSummary", obligationKind o == BindingValue] of-              [obligation] -> do-                obligationUseSites obligation-                  `shouldSatisfy` any (T.isInfixOf "Project register summary")-                obligationUseSites obligation-                  `shouldSatisfy` any (T.isInfixOf "ProjectArtifact command RecordArtifact")-              found -> expectationFailure ("expected one ProjectSummary binding obligation, got " <> show (length found))-      it "refuses a case-folded path collision across members, naming both files" $ do-        workspace <- shouldComposeWorkspace canonicalWorkspacePath-        let collided = withCaseVariantAggregate workspace-        case planWorkspaceScaffold "goldens" (workspaceContext collided) collided of-          Right _ -> expectationFailure "expected a cross-member path collision refusal"-          Left refusals -> do-            let origins = concat [os | PathCollision _ os <- refusals]-            origins `shouldSatisfy` any (T.isInfixOf "domain/project.keiro: ")-            origins `shouldSatisfy` any (T.isInfixOf "domain/project-artifact.keiro: ")-      it "refuses golden fixtures stranded beside a member instead of under the workspace root" $-        withTempDirectory "keiro-dsl-workspace-goldens" $ \root -> do-          workspace <- writeGoldenWorkspace root-          let workspaceGoldens = root </> "golden-payloads"-              fixture = "hospital-capacity/Reservation/TransferReservationCreated.v1.json"-              beside = root </> "domain/golden-payloads" </> fixture-          goldenRootDivergence workspaceGoldens workspace `shouldReturn` []-          createDirectoryIfMissing True (takeDirectory beside)-          TIO.writeFile beside "{}\n"-          refusals <- goldenRootDivergence workspaceGoldens workspace-          refusals `shouldBe` [GoldenRootDivergence workspaceGoldens [beside]]-          renderRefusals refusals-            `shouldSatisfy` any (T.isInfixOf "one golden root per workspace")-          -- The same fixture under the workspace root is no divergence.-          let atRoot = workspaceGoldens </> fixture-          createDirectoryIfMissing True (takeDirectory atRoot)-          TIO.writeFile atRoot "{}\n"-          goldenRootDivergence workspaceGoldens workspace `shouldReturn` []--    describe "workspace scaffold" $ do-      it "writes workspace-keyed history and no context-keyed file at all" $-        withWorkspaceFixture "keiro-dsl-workspace-history" id $ \_ out workspace -> do-          report <- executePlannedWorkspaceScaffold out workspace-          wsrRecordPath report-            `shouldBe` out </> workspaceLedgerFileName "demo-project"-          wsrBuildManifestPath report-            `shouldBe` out </> workspaceCabalFragmentFileName "demo-project"-          doesFileExist (out </> recordFileName "demo-project") `shouldReturn` False-          doesFileExist (out </> contextCabalFragmentFileName "demo-project") `shouldReturn` False-          contents <- TIO.readFile (wsrRecordPath report)-          buildManifest <- TIO.readFile (wsrBuildManifestPath report)-          assertGeneratedHaskellContract "service.keiro-workspace" buildManifest-          case parseWorkspaceRecord contents of-            Nothing -> expectationFailure ("workspace record did not parse:\n" <> T.unpack contents)-            Just record -> do-              wrService record `shouldBe` "demo-project"-              wrManifest record `shouldBe` "service.keiro-workspace"-              wrMembers record-                `shouldBe` [ "domain/project-artifact.keiro",-                             "domain/project.keiro",-                             "domain/shared.keiro"-                           ]-              -- Context-level modules are ownerless; everything-              -- else names the member that produced it.-              [wrmPath row | row <- wrModules record, wrmOwner row == Nothing]-                `shouldSatisfy` \ownerless ->-                  length ownerless == 4-                    && any (T.isSuffixOf "StructuralProjections.hs" . T.pack) ownerless-                    && any (T.isSuffixOf "Nominals.hs" . T.pack) ownerless-                    && any (T.isSuffixOf "Nominals/Internal.hs" . T.pack) ownerless-                    && any (T.isSuffixOf "ReplayAudit.hs" . T.pack) ownerless-              [ wrmOwner row-                | row <- wrModules record,-                  "Project/Generated/Domain.hs" `T.isSuffixOf` T.pack (wrmPath row)-                ]-                `shouldBe` [Just "domain/project.keiro"]-      it "refuses and then applies old workspace sidecar names before reading history" $-        withWorkspaceFixture "keiro-dsl-workspace-sidecar-migration" id $ \_ out workspace -> do-          plan <- shouldPlanWorkspaceSpec workspace-          first <- executeWorkspaceScaffold out False plan-          either (\failure -> expectationFailure (show failure)) (const (pure ())) first-          let service = wsService workspace-              currentLedger = workspaceLedgerFileName service-              currentFragment = workspaceCabalFragmentFileName service-              oldLedger = legacyWorkspaceRecordFileName service-              oldFragment = legacyWorkspaceManifestFileName service-          renameFile (out </> currentLedger) (out </> oldLedger)-          renameFile (out </> currentFragment) (out </> oldFragment)-          migrationTreeBefore <- treeSnapshot out-          refused <- executeWorkspaceScaffoldWithNameMigrations out False False plan-          refused `shouldSatisfy` \case-            Left [SidecarMigrationRequired moves] ->-              length moves == 2 && all ((== RenameSidecar) . sidecarMoveDisposition) moves-            _ -> False-          treeSnapshot out `shouldReturn` migrationTreeBefore-          applied <- executeWorkspaceScaffoldWithNameMigrations out False True plan-          report <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure applied-          map sidecarMoveDisposition (wsrSidecarMoves report) `shouldBe` [RenameSidecar, RenameSidecar]-          wsrStale report `shouldBe` []-          doesFileExist (out </> oldLedger) `shouldReturn` False-          doesFileExist (out </> oldFragment) `shouldReturn` False-          doesFileExist (out </> currentLedger) `shouldReturn` True-          doesFileExist (out </> currentFragment) `shouldReturn` True-          rerun <- executeWorkspaceScaffoldWithNameMigrations out False True plan-          either (\failure -> expectationFailure (show failure)) (\value -> wsrSidecarMoves value `shouldBe` []) rerun-      it "is idempotent: an unchanged second run rewrites nothing and reports nothing" $-        withWorkspaceFixture "keiro-dsl-workspace-idempotent" id $ \_ out workspace -> do-          first <- executePlannedWorkspaceScaffold out workspace-          treeBefore <- treeSnapshot out-          second <- executePlannedWorkspaceScaffold out workspace-          treeAfter <- treeSnapshot out-          treeAfter `shouldBe` treeBefore-          map thd3 (wsrDispositions second)-            `shouldSatisfy` all (`elem` [Unchanged, Skipped])-          wsrStale second `shouldBe` []-          wsrOwnershipMoves second `shouldBe` []-          wsrMappingDrift second `shouldBe` []-          wsrNewHoles second `shouldBe` []-          -- The first run had to write; the claim is not vacuous.-          map thd3 (wsrDispositions first) `shouldSatisfy` any (== Overwritten)-          renderWorkspaceScaffoldReport second-            `shouldSatisfy` all (not . T.isPrefixOf "stale:")-      it "produces byte-identical output for members listed in reverse order" $-        withWorkspaceFixture "keiro-dsl-workspace-order-a" id $ \_ outA workspaceA ->-          withWorkspaceFixture "keiro-dsl-workspace-order-b" reverse $ \_ outB workspaceB -> do-            _ <- executePlannedWorkspaceScaffold outA workspaceA-            _ <- executePlannedWorkspaceScaffold outB workspaceB-            treeB <- treeSnapshot outB-            treeA <- treeSnapshot outA-            treeB `shouldBe` treeA-            map fst treeA `shouldSatisfy` elem (workspaceLedgerFileName "demo-project")-      it "reports stale files only for the member that changed" $-        withWorkspaceFixture "keiro-dsl-workspace-stale" id $ \root out workspace -> do-          first <- executePlannedWorkspaceScaffold out workspace-          let siblingPaths =-                [ modulePath m-                | (m, provenance, _) <- wsrDispositions first,-                  provenance == MemberOwned "domain/project-artifact.keiro"-                ]-          siblingsBefore <- traverse (TIO.readFile . (out </>)) siblingPaths-          renamed <- renameMemberAggregate root "domain/project.keiro" "Project" "Ledger"-          second <- executePlannedWorkspaceScaffold out renamed-          let stalePaths = map stalePath (wsrStale second)-          stalePaths `shouldSatisfy` (not . null)-          stalePaths `shouldSatisfy` all (T.isInfixOf "/Project/" . T.pack)-          -- Nothing the sibling member owns is stale, and nothing it-          -- owns changed on disk: no cross-member false positives.-          stalePaths `shouldSatisfy` all (`notElem` siblingPaths)-          siblingsAfter <- traverse (TIO.readFile . (out </>)) siblingPaths-          siblingsAfter `shouldBe` siblingsBefore-          forM_ stalePaths $ \path -> doesFileExist (out </> path) `shouldReturn` True-          wsrStale second-            `shouldSatisfy` all-              ( \stale -> case staleKind stale of-                  Generated -> staleGeneratedEvidence stale == Just ExactGeneratedBannerPresent-                  HoleStub -> staleGeneratedEvidence stale == Nothing-              )-          renderWorkspaceScaffoldReport second-            `shouldSatisfy` any (T.isInfixOf "keiro-dsl never deletes files.")-          renderWorkspaceScaffoldReport second-            `shouldSatisfy` any (T.isInfixOf "exact generated banner present; verify unchanged bytes before deleting")-          renderWorkspaceScaffoldReport second-            `shouldSatisfy` all (not . T.isInfixOf "safe to delete")-      it "reports an aggregate moved between members as an ownership move, not stale churn" $-        withWorkspaceFixture "keiro-dsl-workspace-move" id $ \root out workspace -> do-          _ <- executePlannedWorkspaceScaffold out workspace-          treeBefore <- treeSnapshot out-          moved <- moveArtifactAggregate root-          second <- executePlannedWorkspaceScaffold out moved-          wsrStale second `shouldBe` []-          let moves = wsrOwnershipMoves second-          moves `shouldSatisfy` (not . null)-          moves-            `shouldSatisfy` all-              ( \move ->-                  omPrevious move == Just "domain/project-artifact.keiro"-                    && omCurrent move == Just "domain/project.keiro"-              )-          map omPath moves-            `shouldSatisfy` any (T.isInfixOf "ProjectArtifact" . T.pack)-          -- Stable behavior contracts retain source-line attribution, so-          -- moving a declaration may rewrite only those attributed modules.-          -- Every unaffected module and the build manifest remain untouched.-          map thd3 (wsrDispositions second)-            `shouldSatisfy` all (`elem` [Unchanged, Skipped, Overwritten])-          let overwrittenPaths =-                [modulePath generatedModule | (generatedModule, _, Overwritten) <- wsrDispositions second]-          length overwrittenPaths `shouldBe` 2-          overwrittenPaths `shouldSatisfy` all (T.isSuffixOf "/Generated/BehaviorContract.hs" . T.pack)-          treeAfter <- treeSnapshot out-          map fst treeAfter `shouldBe` map fst treeBefore-          let unaffected (path, _) =-                path /= workspaceLedgerFileName "demo-project"-                  && path `notElem` overwrittenPaths-          filter unaffected treeAfter `shouldBe` filter unaffected treeBefore-          renderWorkspaceScaffoldReport second-            `shouldSatisfy` any (T.isInfixOf "changed owning member")-      it "leaves the tree, record, and manifest untouched when any member refuses" $-        withWorkspaceFixture "keiro-dsl-workspace-atomic" id $ \_ out workspace -> do-          _ <- executePlannedWorkspaceScaffold out workspace-          treeBefore <- treeSnapshot out-          let broken = withCaseVariantAggregate workspace-          case planWorkspaceScaffold "goldens" (workspaceContext broken) broken of-            Right _ -> expectationFailure "expected the broken workspace to refuse"-            Left refusals -> refusals `shouldSatisfy` any isPathCollision-          treeSnapshot out `shouldReturn` treeBefore-          -- A fresh output directory is never even created.-          withTempDirectory "keiro-dsl-workspace-atomic-fresh" $ \fresh -> do-            let target = fresh </> "out"-            case planWorkspaceScaffold "goldens" (workspaceContext broken) broken of-              Right _ -> expectationFailure "expected the broken workspace to refuse"-              Left _ -> doesDirectoryExist target `shouldReturn` False-      it "leaves prior workspace output byte-identical for parse, validation, and collision failures" $-        withWorkspaceFixture "keiro-dsl-workspace-atomic-cli" id $ \root out workspace -> do-          _ <- executePlannedWorkspaceScaffold out workspace-          treeBefore <- treeSnapshot out-          let member = root </> "domain/project-artifact.keiro"-              manifest = root </> "service.keiro-workspace"-          original <- TIO.readFile member-          let failures =-                [ ("parse", "context demo-project\naggregate !!!\n"),-                  ("validation", T.replace "ProjectId" "MissingProjectId" original),-                  ("collision", T.replace "aggregate ProjectArtifact" "aggregate PROJECT" original)-                ]-          forM_ failures $ \(failureKind, brokenSource) -> do-            TIO.writeFile member brokenSource-            (exitCode, stdoutText, stderrText) <--              runKeiroDsl ["scaffold", manifest, "--out", out]-            unless (exitCode == ExitFailure 1) $-              expectationFailure-                (failureKind <> " failure unexpectedly scaffolded:\n" <> stdoutText <> stderrText)-            treeSnapshot out `shouldReturn` treeBefore-            TIO.writeFile member original-      it "refuses the whole workspace for one bannerless Generated target, changing nothing" $-        withWorkspaceFixture "keiro-dsl-workspace-banner" id $ \_ out workspace -> do-          plan <- shouldPlanWorkspaceSpec workspace-          let generated = [m | (m, _) <- wpModules plan, kind m == Generated]-          case generated of-            [] -> expectationFailure "workspace fixture has no Generated module"-            target : _ -> do-              let path = out </> modulePath target-              createDirectoryIfMissing True (takeDirectory path)-              TIO.writeFile path "hand owned\n"-              treeBefore <- treeSnapshot out-              refused <- executeWorkspaceScaffold out False plan-              refused `shouldSatisfy` isMissingBannerRefusal-              treeSnapshot out `shouldReturn` treeBefore-              forced <- executeWorkspaceScaffold out True plan-              forced `shouldSatisfy` isSuccessfulScaffold-              TIO.readFile path `shouldReturn` moduleText target-      it "scaffolds a whole workspace through the CLI" $-        withTempDirectory "keiro-dsl-workspace-cli" $ \out -> do-          (exitCode, stdoutText, stderrText) <--            runKeiroDsl ["scaffold", canonicalWorkspacePath, "--out", out]-          unless (exitCode == ExitSuccess) (expectationFailure (stdoutText <> stderrText))-          stderrText `shouldContain` "workspace: demo-project"-          doesFileExist (out </> workspaceLedgerFileName "demo-project")-            `shouldReturn` True-          tree <- treeSnapshot out-          length [path | (path, _) <- tree, "StructuralProjections.hs" `T.isSuffixOf` T.pack path]-            `shouldBe` 1-          length [path | (path, _) <- tree, "ReplayAudit.hs" `T.isSuffixOf` T.pack path]-            `shouldBe` 1-          (secondCode, _, secondErr) <--            runKeiroDsl ["scaffold", canonicalWorkspacePath, "--out", out]-          secondCode `shouldBe` ExitSuccess-          secondErr `shouldSatisfy` (not . isInfixOfString "(overwritten)")-          treeSnapshot out `shouldReturn` tree-      it "accepts a validated runtime-package override and generates exactly one service package" $-        withTempDirectory "keiro-dsl-workspace-runtime-package-cli" $ \out -> do-          (exitCode, stdoutText, stderrText) <--            runKeiroDsl ["scaffold", canonicalWorkspacePath, "--out", out, "--runtime-package", "demo-runtime"]-          unless (exitCode == ExitSuccess) (expectationFailure (stdoutText <> stderrText))-          tree <- treeSnapshot out-          length [path | (path, _) <- tree, takeExtension path == ".cabal", "keiro-dsl-conformance.workspace.demo-project" `isInfixOfString` path]-            `shouldBe` 1-          stderrText `shouldSatisfy` isInfixOfString "conformance-target: cabal test keiro-demo-project-conformance"--    describe "workspace adoption" $ do-      it "replaces embedded 0.6 nominal declarations only in generated files" $-        withWorkspaceFixture "keiro-dsl-workspace-nominal-adopt" id $ \_ out workspace -> do-          plan <- shouldPlanWorkspaceSpec workspace-          let pathEndingIn suffix selectedKind =-                case [modulePath m | (m, _) <- wpModules plan, kind m == selectedKind, suffix `isSuffixOfPath` m] of-                  [path] -> pure path-                  found -> expectationFailure ("expected one path ending in " <> suffix <> ", got " <> show found) >> fail "unreachable"-          domainPath <- pathEndingIn "Project/Generated/Domain.hs" Generated-          nominalPath <- pathEndingIn "Generated/Nominals.hs" Generated-          internalNominalPath <- pathEndingIn "Generated/Nominals/Internal.hs" Generated-          holePath <- pathEndingIn "Project/Holes.hs" HoleStub-          writeFileWithParents-            (out </> domainPath)-            (generatedBanner <> "\n-- legacy 0.6 fixture\nmodule LegacyDomain where\nnewtype ProjectId = ProjectId String\ndata ProjectPhase = Draft | Active\n")-          writeFileWithParents (out </> holePath) "-- hand-owned 0.6 implementation\n"--          report <- executePlannedWorkspaceScaffold out workspace-          wsrStale report `shouldBe` []-          [disposition | (m, _, disposition) <- wsrDispositions report, modulePath m == domainPath]-            `shouldBe` [Overwritten]-          [disposition | (m, _, disposition) <- wsrDispositions report, modulePath m == nominalPath]-            `shouldBe` [Overwritten]-          newDomain <- TIO.readFile (out </> domainPath)-          newDomain `shouldSatisfy` (not . T.isInfixOf "newtype ProjectId")-          newDomain `shouldSatisfy` T.isInfixOf "Generated.Nominals (ProjectId, parseProjectId, ProjectPhase (..))"-          newNominals <- TIO.readFile (out </> nominalPath)-          T.count "newtype ProjectId" newNominals `shouldBe` 0-          T.count "data ProjectPhase =" newNominals `shouldBe` 1-          newInternalNominals <- TIO.readFile (out </> internalNominalPath)-          T.count "newtype ProjectId" newInternalNominals `shouldBe` 1-          TIO.readFile (out </> holePath) `shouldReturn` "-- hand-owned 0.6 implementation\n"-      it "adopts an overwritten same-context record pair by record and by banner" $-        withInlineWorkspace "keiro-dsl-workspace-adopt" adoptionMembers $ \_ out workspace -> do-          -- Reproduce today's defect first: two same-context specs-          -- scaffolded independently into one directory, the second-          -- replacing the first's record and calling its files stale.-          specA <- parseInlineSpec "domain/a.keiro" adoptionMemberA-          specB <- parseInlineSpec "domain/b.keiro" adoptionMemberB-          let ctx = defaultContext "adoption-demo"-          legacyA <- executePlannedScaffold out "domain/a.keiro" ctx specA-          legacyB <- executePlannedScaffold out "domain/b.keiro" ctx specB-          reportStale legacyB `shouldSatisfy` (not . null)-          legacyBefore <- TIO.readFile (out </> recordFileName "adoption-demo")--          report <- executePlannedWorkspaceScaffold out workspace-          wsrStale report `shouldBe` []-          case wsrMigration report of-            Nothing -> expectationFailure "expected the first workspace run to adopt"-            Just migration -> do-              let generatedOf run = sort [modulePath m | (m, _) <- reportDispositions run, kind m == Generated]-                  claimedBy evidence = sort [cfPath entry | entry <- mrClaimed migration, cfEvidence entry == evidence]-              -- The surviving record attributes B's files; A's-              -- files survived only as banners, which is exactly-              -- the orphan case the overwrite created.-              claimedBy ClaimedFromRecord `shouldBe` generatedOf legacyB-              claimedBy ClaimedFromBanner `shouldBe` sort (generatedOf legacyA \\ generatedOf legacyB)-              claimedBy ClaimedFromBanner `shouldSatisfy` (not . null)-              mrLikelyStale migration `shouldBe` []-              mrLegacyRecord migration-                `shouldBe` Just (recordFileName "adoption-demo", "domain/b.keiro")-              -- Provenance is persisted, not merely printed.-              recorded <- parseWorkspaceRecord <$> TIO.readFile (wsrRecordPath report)-              fmap (sort . map adPath . wrAdopted) recorded-                `shouldBe` Just (sort (map cfPath (mrClaimed migration)))-              fmap (sort . nubOrd . map adEvidence . wrAdopted) recorded-                `shouldBe` Just ["banner", "record"]-              persisted <- TIO.readFile (out </> "keiro-dsl-migration-report.workspace.adoption-demo.txt")-              persisted `shouldBe` T.unlines (renderMigrationReport migration)-              renderWorkspaceScaffoldReport report-                `shouldSatisfy` any (T.isInfixOf "adopting pre-workspace scaffold output")--          -- The legacy record gained one line and nothing else: it-          -- still parses to the same value for an old binary.-          legacyAfter <- TIO.readFile (out </> recordFileName "adoption-demo")-          T.lines legacyAfter `shouldSatisfy` elem (supersededByLine "adoption-demo")-          parseRecord legacyAfter `shouldBe` parseRecord legacyBefore-          T.lines legacyAfter-            `shouldBe` T.lines legacyBefore <> [supersededByLine "adoption-demo"]--          -- Adoption is not a content change: the generated tree is-          -- what a fresh workspace scaffold of the same members emits.-          withInlineWorkspace "keiro-dsl-workspace-adopt-fresh" adoptionMembers $ \_ fresh freshWorkspace -> do-            freshReport <- executePlannedWorkspaceScaffold fresh freshWorkspace-            wsrMigration freshReport `shouldBe` Nothing-            adoptedTree <- treeSnapshot out-            freshTree <- treeSnapshot fresh-            haskellOnly adoptedTree `shouldBe` haskellOnly freshTree-      it "adopts and marks context history under the legacy record name" $-        withInlineWorkspace "keiro-dsl-workspace-adopt-legacy-name" adoptionMembers $ \_ out workspace -> do-          specA <- parseInlineSpec "domain/a.keiro" adoptionMemberA-          _ <- executePlannedScaffold out "domain/a.keiro" (defaultContext "adoption-demo") specA-          let current = contextLedgerFileName "adoption-demo"-              legacy = legacyContextRecordFileName "adoption-demo"-          renameFile (out </> current) (out </> legacy)-          ledgerBefore <- TIO.readFile (out </> legacy)-          report <- executePlannedWorkspaceScaffold out workspace-          case wsrMigration report of-            Nothing -> expectationFailure "expected legacy-name context history to be adopted"-            Just migration -> mrLegacyRecord migration `shouldBe` Just (legacy, "domain/a.keiro")-          doesFileExist (out </> current) `shouldReturn` False-          ledgerAfter <- TIO.readFile (out </> legacy)-          T.lines ledgerAfter `shouldBe` T.lines ledgerBefore <> [supersededByLine "adoption-demo"]-          parseRecord ledgerAfter `shouldBe` parseRecord ledgerBefore-      it "lists hand-written files as unclaimed and leaves their bytes alone" $-        withInlineWorkspace "keiro-dsl-workspace-unclaimed" adoptionMembers $ \_ out workspace -> do-          plan <- shouldPlanWorkspaceSpec workspace-          case [modulePath m | (m, _) <- wpModules plan, kind m == HoleStub] of-            [] -> expectationFailure "adoption fixture emits no hole module"-            holePath : _ -> do-              writeFileWithParents (out </> holePath) "-- hand filled\n"-              writeFileWithParents (out </> "Notes.hs") "module Notes where\n"-              report <- executePlannedWorkspaceScaffold out workspace-              case wsrMigration report of-                Nothing -> expectationFailure "expected a report for a directory holding hand-written files"-                Just migration -> do-                  mrLegacyRecord migration `shouldBe` Nothing-                  mrClaimed migration `shouldBe` []-                  mrUnclaimed migration `shouldBe` sort [holePath, "Notes.hs"]-              TIO.readFile (out </> holePath) `shouldReturn` "-- hand filled\n"-              TIO.readFile (out </> "Notes.hs") `shouldReturn` "module Notes where\n"-      it "never claims a bannerless file at a planned Generated path" $-        withInlineWorkspace "keiro-dsl-workspace-unattributable" adoptionMembers $ \_ out workspace -> do-          plan <- shouldPlanWorkspaceSpec workspace-          case [modulePath m | (m, _) <- wpModules plan, kind m == Generated] of-            [] -> expectationFailure "adoption fixture emits no Generated module"-            target : _ -> do-              writeFileWithParents (out </> target) "hand owned\n"-              refused <- executeWorkspaceScaffold out False plan-              refused `shouldSatisfy` isMissingBannerRefusal-              TIO.readFile (out </> target) `shouldReturn` "hand owned\n"-              doesFileExist (out </> "keiro-dsl-migration-report.workspace.adoption-demo.txt")-                `shouldReturn` False-      it "adopts at most once, and the second run is an ordinary idempotent run" $-        withInlineWorkspace "keiro-dsl-workspace-adopt-once" adoptionMembers $ \_ out workspace -> do-          specA <- parseInlineSpec "domain/a.keiro" adoptionMemberA-          _ <- executePlannedScaffold out "domain/a.keiro" (defaultContext "adoption-demo") specA-          first <- executePlannedWorkspaceScaffold out workspace-          wsrMigration first `shouldSatisfy` \case Just _ -> True; Nothing -> False-          treeBefore <- treeSnapshot out-          reportBefore <- TIO.readFile (out </> "keiro-dsl-migration-report.workspace.adoption-demo.txt")-          legacyBefore <- TIO.readFile (out </> recordFileName "adoption-demo")--          second <- executePlannedWorkspaceScaffold out workspace-          wsrMigration second `shouldBe` Nothing-          wsrStale second `shouldBe` []-          map thd3 (wsrDispositions second) `shouldSatisfy` all (`elem` [Unchanged, Skipped])-          treeSnapshot out `shouldReturn` treeBefore-          TIO.readFile (out </> "keiro-dsl-migration-report.workspace.adoption-demo.txt")-            `shouldReturn` reportBefore-          legacyAfter <- TIO.readFile (out </> recordFileName "adoption-demo")-          legacyAfter `shouldBe` legacyBefore-          length (filter (== supersededByLine "adoption-demo") (T.lines legacyAfter))-            `shouldBe` 1--comparisonProvenance :: CompareProvenance-comparisonProvenance =-  CompareProvenance-    { cpHistoricalCodecIdentity = "example.historical",-      cpHistoricalCodecVersion = "legacy-v1",-      cpCanonicalType = CanonicalTypeId "example.Artifact.v1",-      cpBindingSymbol = QualifiedValueName "Example.Bindings.artifactBinding",-      cpBindingVersion = BindingVersion "1",-      cpWireFingerprint = "deadbeef"-    }--syntheticGenerated :: FilePath -> T.Text -> ScaffoldModule-syntheticGenerated path contents =-  ScaffoldModule {modulePath = path, moduleText = contents, kind = Generated, origin = "test"}--generatedTextEndingIn :: T.Text -> [ScaffoldModule] -> T.Text-generatedTextEndingIn suffix modules = case [moduleText m | m <- modules, kind m == Generated, suffix `T.isSuffixOf` T.pack (modulePath m)] of-  contents : _ -> contents-  [] -> ""--generatedExtensionsEndingIn :: T.Text -> [ScaffoldModule] -> [T.Text]-generatedExtensionsEndingIn suffix modules = case [generatedModule | generatedModule <- modules, kind generatedModule == Generated, suffix `T.isSuffixOf` T.pack (modulePath generatedModule)] of-  [generatedModule] -> generatedLocalExtensions generatedModule-  matches -> error ("expected one generated module ending in " <> T.unpack suffix <> ", got " <> show (map modulePath matches))--generatedLocalExtensions :: ScaffoldModule -> [T.Text]-generatedLocalExtensions generatedModule =-  [ extension-  | line <- takeWhile (T.isPrefixOf languagePrefix) (T.lines (moduleText generatedModule)),-    Just extensionWithSuffix <- [T.stripPrefix languagePrefix line],-    Just extension <- [T.stripSuffix languageSuffix extensionWithSuffix]-  ]-  where-    languagePrefix = "{-# LANGUAGE "-    languageSuffix = " #-}"--holeTextEndingIn :: T.Text -> [ScaffoldModule] -> T.Text-holeTextEndingIn suffix modules = case [moduleText m | m <- modules, kind m == HoleStub, suffix `T.isSuffixOf` T.pack (modulePath m), not ("BehaviorHoles.hs" `T.isSuffixOf` T.pack (modulePath m))] of-  contents : _ -> contents-  [] -> ""--onlyAggregate :: Spec -> Aggregate-onlyAggregate spec = case [aggregate | NAggregate aggregate <- specNodes spec] of-  [aggregate] -> aggregate-  aggregates -> error ("expected one aggregate, got " <> show (length aggregates))--loweringAggregateSpec :: T.Text-loweringAggregateSpec =-  T.unlines-    [ "context samples",-      "",-      "aggregate Counter",-      "  regs",-      "    note Text = \"hello world\"",-      "    count Int = 0",-      "    state CounterVertex = Pending",-      "  states Pending Done!",-      "  command Bump { count:Int }",-      "  event CountBumped { count:Int }",-      "  Pending -- Bump --> emit CountBumped ; goto Done"-    ]--scalarRegisterCases :: [(T.Text, T.Text)]-scalarRegisterCases =-  [ ("Text", "\"sample\""),-    ("Int", "0"),-    ("Bool", "False"),-    ("Time", "\"2026-01-02T03:04:05.123456789012Z\""),-    ("Natural", "0")-  ]--cleanScalarAggregateSpec :: T.Text -> T.Text -> T.Text-cleanScalarAggregateSpec typeName initialValue =-  T.unlines-    [ "context clean-scalar",-      "",-      "aggregate Scalar",-      "  regs",-      "    value " <> typeName <> " = " <> initialValue,-      "  states Empty Done!",-      "  command Set { value:" <> typeName <> " }",-      "  event SetDone { value:" <> typeName <> " }",-      "  Empty -- Set --> write value := value ; emit SetDone ; goto Done"-    ]--exactStatusSpec :: T.Text-exactStatusSpec =-  T.unlines-    [ "context samples",-      "",-      "aggregate Reservation",-      "  regs",-      "    state ReservationVertex = Open",-      "  states Open Closed!",-      "  command Bump { count:Int }",-      "  event ReservationHeld { count:Int }",-      "  event ReservationUnHeld { count:Int }",-      "  event CountBumped { count:Int }",-      "  Open -- Bump --> emit CountBumped ; goto Closed",-      "  projection reservation_status consistency=Eventual key=count",-      "    status-map { ReservationHeld=>held ReservationUnHeld=>available CountBumped=>bumped }"-    ]--hasPathCollisionWithTwoOrigins :: Either [Refusal] [ScaffoldModule] -> Bool-hasPathCollisionWithTwoOrigins = \case-  Left refusals -> any hasTwo refusals-  Right _ -> False-  where-    hasTwo (PathCollision _ origins) = length origins == 2-    hasTwo _ = False--isMissingBannerRefusal :: Either [Refusal] a -> Bool-isMissingBannerRefusal = \case-  Left [MissingGeneratedBanner paths] -> not (null paths)-  _ -> False--isSuccessfulScaffold :: Either [Refusal] a -> Bool-isSuccessfulScaffold = \case-  Right _ -> True-  Left _ -> False--executePlannedScaffold :: FilePath -> FilePath -> Context -> Spec -> IO ScaffoldReport-executePlannedScaffold out specPath ctx spec = case planScaffold ctx spec of-  Left refusals -> expectationFailure ("unexpected scaffold refusal: " <> show refusals) >> error "unreachable"-  Right modules -> do-    result <- executeScaffold out False specPath ctx spec modules-    case result of-      Left refusals -> expectationFailure ("unexpected execution refusal: " <> show refusals) >> error "unreachable"-      Right report -> pure report--renameCounter :: Node -> Node-renameCounter (NAggregate aggregate) =-  NAggregate-    aggregate-      { aggName = "Widget",-        aggRegs = [reg {regType = if regType reg == TRef "CounterVertex" then TRef "WidgetVertex" else regType reg} | reg <- aggRegs aggregate]-      }-renameCounter node = node--onlyPathEndingIn :: FilePath -> [ScaffoldModule] -> FilePath-onlyPathEndingIn suffix modules = case [modulePath m | m <- modules, T.pack suffix `T.isSuffixOf` T.pack (modulePath m)] of-  [path] -> path-  paths -> error ("expected one path ending in " <> suffix <> ", got " <> show paths)--withTempDirectory :: String -> (FilePath -> IO a) -> IO a-withTempDirectory template = bracket acquire removePathForcibly-  where-    acquire = do-      base <- getTemporaryDirectory-      (path, handle) <- openTempFile base template-      hClose handle-      removeFile path-      createDirectory path-      pure path---- | Parse a fixture and return the validator's diagnostic codes (failing the--- test on a parse error).-diagnosticCodesOf :: FilePath -> IO [DiagnosticCode]-diagnosticCodesOf path = do-  map code <$> diagnosticsOf path---- | Parse a fixture and return all validator diagnostics.-diagnosticsOf :: FilePath -> IO [Diagnostic]-diagnosticsOf path = do-  service <- checkedServiceOf path-  pure (validateService service)---- | Like 'diagnosticCodesOf' but only the Error-severity codes (warnings, e.g.--- the benign-inversion notices, are excluded).-errorCodesOf :: FilePath -> IO [DiagnosticCode]-errorCodesOf path = do-  diagnostics <- diagnosticsOf path-  pure [code d | d <- diagnostics, severity d == Error]---- | Parse two fixtures and diff them (old, new).--- | Plan 143: render an Expr in concrete guard syntax by printing a dummy--- transition through the real pretty-printer and slicing its guard clause,--- so the test exercises the exact printer the diff advisory uses.-renderExprText :: Expr -> T.Text-renderExprText e =-  case [T.strip l | l <- T.lines rendered, "guard " `T.isPrefixOf` T.strip l] of-    [guardLine] -> T.strip (T.drop (T.length "guard ") guardLine)-    _ -> error ("renderExprText: unexpected printer output: " <> T.unpack rendered)-  where-    rendered =-      renderTransition-        Transition-          { tSource = "S",-            tCommand = "C",-            tImplementation = LegacyHoleImplementation,-            tGuard = Just e,-            tWrites = [],-            tEmits = [],-            tGoto = "S",-            tMode = TmLive,-            tLoc = noLoc-          }---- | Plan 143: a minimal spec whose only transition is replay-only, with the--- supplied clause lines spliced into its body.-replayOnlySpecWith :: [T.Text] -> T.Text-replayOnlySpecWith clauseLines =-  T.unlines $-    [ "context hospital-capacity",-      "",-      "id TransferReservationId prefix=rsv",-      "",-      "aggregate Reservation",-      "  regs",-      "    reservationId    TransferReservationId = placeholder",-      "    reservationState ReservationVertex     = Unrequested",-      "  states Unrequested Held",-      "",-      "  command RequestTransferReservation { reservationId }",-      "",-      "  event TransferReservationCreated = fields(RequestTransferReservation)",-      "",-      "  replay-only Unrequested -- RequestTransferReservation -->"-    ]-      ++ clauseLines--diffFixtures :: FilePath -> FilePath -> IO [Change]-diffFixtures oldP newP = do-  old <- parsedSourceOf oldP-  new <- parsedSourceOf newP-  pure (diffSources old new)--kindOfChange :: Change -> ChangeKind-kindOfChange (Additive kind) = kind-kindOfChange (Advisory kind) = kind-kindOfChange (Breaking kind) = kind--generatedHaskellNameFindings :: [Change] -> [Change]-generatedHaskellNameFindings = filter ((== GeneratedHaskellNameChanged) . ckCode . kindOfChange)--assertGeneratedHaskellNameFinding :: Change -> Expectation-assertGeneratedHaskellNameFinding change = do-  change `shouldSatisfy` isAdvisory-  let kind = kindOfChange change-      compatibility = ckVector kind-      nonBuildVerdicts =-        [ verdictFor surface compatibility-        | surface <- [PrivateHistoryRead, OldBinaryReadNewEvents, SnapshotHydration, PublicConsumer, PersistedIdentity]-        ]-  nonBuildVerdicts `shouldBe` replicate 5 VCompatible-  verdictFor ConsumerBuild compatibility `shouldBe` VAdvisory-  cvRollout compatibility `shouldBe` Set.empty-  renderFinding change `shouldSatisfy` T.isInfixOf "consumer-build=advisory"-  remediationFor (ckContext kind) (ckCode kind)-    `shouldBe` RemedyRescaffoldGenerated :| [RemedyRecompileConsumers, RemedyRunConformance]--labelOfChange :: Change -> Label-labelOfChange Additive {} = LabelAdditive-labelOfChange Advisory {} = LabelAdvisory-labelOfChange Breaking {} = LabelBreaking--genSurfaceSet :: Gen (Set.Set CompatibilitySurface)-genSurfaceSet = Set.fromList <$> listOf (elements [minBound .. maxBound])--genCompatibilityVector :: Gen CompatibilityVector-genCompatibilityVector =-  CompatibilityVector-    <$> genVerdict-    <*> genVerdict-    <*> genVerdict-    <*> genVerdict-    <*> genVerdict-    <*> genVerdict-    <*> (Set.fromList <$> listOf (elements rolloutConstraints))-  where-    genVerdict = elements [VCompatible, VAdvisory, VBreaking, VNotApplicable]-    rolloutConstraints =-      [ RolloutStopTheWorld,-        RolloutWorkersFirst,-        RolloutDrainRequired,-        RolloutProducerLast,-        RolloutProducerFirst-      ]--replayImpactFixtures :: FilePath -> FilePath -> IO ReplayImpact-replayImpactFixtures oldPath newPath = do-  old <- checkedServiceOf oldPath-  new <- checkedServiceOf newPath-  pure (resolvedFold (ReplayImpact.replayImpactServices old new))--modifyAggregate :: Name -> (Aggregate -> Aggregate) -> Spec -> Spec-modifyAggregate target update spec =-  spec-    { specNodes =-        [ case node of-            NAggregate aggregate | aggName aggregate == target -> NAggregate (update aggregate)-            _ -> node-        | node <- specNodes spec-        ]-    }--modifyReadModel :: Name -> (ReadModelNode -> ReadModelNode) -> Spec -> Spec-modifyReadModel target update spec =-  spec-    { specNodes =-        [ case node of-            NReadModel readModel | rmName readModel == target -> NReadModel (update readModel)-            _ -> node-        | node <- specNodes spec-        ]-    }--mapContract :: (ContractNode -> ContractNode) -> Spec -> Spec-mapContract update spec =-  spec-    { specNodes =-        [ case node of-            NContract contract -> NContract (update contract)-            _ -> node-        | node <- specNodes spec-        ]-    }--mapIntake :: (IntakeNode -> IntakeNode) -> Spec -> Spec-mapIntake update spec =-  spec-    { specNodes =-        [ case node of-            NIntake intake -> NIntake (update intake)-            _ -> node-        | node <- specNodes spec-        ]-    }--mapPgmqDispatch :: (PgmqDispatchNode -> PgmqDispatchNode) -> Spec -> Spec-mapPgmqDispatch update spec =-  spec-    { specNodes =-        [ case node of-            NPgmqDispatch dispatch -> NPgmqDispatch (update dispatch)-            _ -> node-        | node <- specNodes spec-        ]-    }--mapRouter :: (RouterNode -> RouterNode) -> Spec -> Spec-mapRouter update spec =-  spec-    { specNodes =-        [ case node of-            NRouter router -> NRouter (update router)-            _ -> node-        | node <- specNodes spec-        ]-    }--mapEmit :: (EmitNode -> EmitNode) -> Spec -> Spec-mapEmit update spec =-  spec-    { specNodes =-        [ case node of-            NEmit emitNode -> NEmit (update emitNode)-            _ -> node-        | node <- specNodes spec-        ]-    }--mapWorkflow :: (WorkflowNode -> WorkflowNode) -> Spec -> Spec-mapWorkflow update spec =-  spec-    { specNodes =-        [ case node of-            NWorkflow workflow -> NWorkflow (update workflow)-            _ -> node-        | node <- specNodes spec-        ]-    }--mapWorkqueue :: (WorkqueueNode -> WorkqueueNode) -> Spec -> Spec-mapWorkqueue update spec =-  spec-    { specNodes =-        [ case node of-            NWorkqueue queue -> NWorkqueue (update queue)-            _ -> node-        | node <- specNodes spec-        ]-    }--mapDispatch :: (PgmqDispatchNode -> PgmqDispatchNode) -> Spec -> Spec-mapDispatch update spec =-  spec-    { specNodes =-        [ case node of-            NPgmqDispatch dispatch -> NPgmqDispatch (update dispatch)-            _ -> node-        | node <- specNodes spec-        ]-    }--mapOperation :: (OperationNode -> OperationNode) -> Spec -> Spec-mapOperation update spec =-  spec-    { specNodes =-        [ case node of-            NOperation operation -> NOperation (update operation)-            _ -> node-        | node <- specNodes spec-        ]-    }--mapPublisher :: (PublisherNode -> PublisherNode) -> Spec -> Spec-mapPublisher update spec =-  spec-    { specNodes =-        [ case node of-            NPublisher publisher -> NPublisher (update publisher)-            _ -> node-        | node <- specNodes spec-        ]-    }--serviceErrorCodes :: Int -> Spec -> [DiagnosticCode]-serviceErrorCodes versionNumber spec =-  [code diagnostic | diagnostic <- validateService service, severity diagnostic == Error]-  where-    service = case languageVersion (fromIntegral versionNumber) >>= effectiveLanguageContractForVersion of-      Nothing -> error ("unsupported test language version " <> show versionNumber)-      Just languageContract -> CheckedService languageContract spec---- | Codes emitted at 'Warning' severity under the given released language.--- Pairs with 'serviceErrorCodes' to assert a surface's warn-then-error tiering--- from both sides, rather than only proving it is not an error.-serviceWarningCodes :: Int -> Spec -> [DiagnosticCode]-serviceWarningCodes versionNumber spec =-  [code diagnostic | diagnostic <- validateService service, severity diagnostic == Warning]-  where-    service = case languageVersion (fromIntegral versionNumber) >>= effectiveLanguageContractForVersion of-      Nothing -> error ("unsupported test language version " <> show versionNumber)-      Just languageContract -> CheckedService languageContract spec--duplicateFirst :: [a] -> [a]-duplicateFirst = \case-  [] -> []-  first : rest -> first : first : rest--updateFirst :: (a -> a) -> [a] -> [a]-updateFirst update = \case-  [] -> []-  first : rest -> update first : rest--removeReadModel :: Name -> Spec -> Spec-removeReadModel target spec =-  spec {specNodes = [node | node <- specNodes spec, not (isTarget node)]}-  where-    isTarget (NReadModel readModel) = rmName readModel == target-    isTarget _ = False--modifyRouter :: Name -> (RouterNode -> RouterNode) -> Spec -> Spec-modifyRouter target update spec =-  spec-    { specNodes =-        [ case node of-            NRouter router | rtId router == target -> NRouter (update router)-            _ -> node-        | node <- specNodes spec-        ]-    }--routerErrorCodes :: (RouterNode -> RouterNode) -> Spec -> [DiagnosticCode]-routerErrorCodes update = errorCodes . modifyRouter "PagingRouter" update--modifyProcess :: Name -> (ProcessNode -> ProcessNode) -> Spec -> Spec-modifyProcess target update spec =-  spec-    { specNodes =-        [ case node of-            NProcess process | procId process == target -> NProcess (update process)-            _ -> node-        | node <- specNodes spec-        ]-    }--processErrorCodes :: (ProcessNode -> ProcessNode) -> Spec -> [DiagnosticCode]-processErrorCodes update = errorCodes . modifyProcess "HospitalSurge" update--errorCodes :: Spec -> [DiagnosticCode]-errorCodes spec = [code diagnostic | diagnostic <- validateSpec spec, severity diagnostic == Error]--diagnosticCodes :: Spec -> [DiagnosticCode]-diagnosticCodes = map code . validateSpec--changeReadModelShape :: ReadModelNode -> ReadModelNode-changeReadModelShape readModel =-  readModel-    { rmColumns = rmColumns readModel <> [RmColumn "reviewed_by" "text" False],-      rmShape = "fnv1a:0000000000000000"-    }---- | Assert a @new \<kind\>@ skeleton parses and validates with zero--- error-severity diagnostics.-assertSkeletonValid :: T.Text -> IO ()-assertSkeletonValid kind = case skeletonFor kind of-  Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err))-  Right src -> case parseSpec ("new:" <> T.unpack kind) src of-    Left perr -> expectationFailure (T.unpack ("skeleton for " <> kind <> " failed to parse: " <> perr))-    Right spec ->-      [code d | d <- validateSpec spec, severity d == Error]-        `shouldBe` ([] :: [DiagnosticCode])--assertSkeletonUsesStableLanguage :: T.Text -> IO ()-assertSkeletonUsesStableLanguage kind = case skeletonFor kind of-  Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err))-  Right source -> case parseSource ("new:" <> T.unpack kind) source of-    Left failure -> expectationFailure (T.unpack (renderParseFailure failure))-    Right parsed -> do-      let service = checkedSource parsed-      effectiveContractLanguageVersion (checkedLanguageContract service) `shouldBe` currentStableLanguageVersion-      effectiveLanguageSupport (checkedLanguageContract service) `shouldBe` Stable-      [code diagnostic | diagnostic <- validateService service, severity diagnostic == Error]-        `shouldBe` ([] :: [DiagnosticCode])-      scaffoldServiceModules (defaultContext (specContext (checkedSpec service))) service-        `shouldSatisfy` (not . null)--assertSkeletonScaffoldable :: T.Text -> IO ()-assertSkeletonScaffoldable kind = case skeletonFor kind of-  Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err))-  Right src -> case parseSpec ("new:" <> T.unpack kind) src of-    Left perr -> expectationFailure (T.unpack perr)-    Right spec -> planScaffold (defaultContext (specContext spec)) spec `shouldSatisfy` isSuccessfulScaffold--skeletonModuleRoots :: [(T.Text, T.Text)]-skeletonModuleRoots =-  [ ("aggregate", "SkelAggregate"),-    ("process", "SkelProcess"),-    ("router", "SkelRouter"),-    ("contract", "SkelContract"),-    ("intake", "SkelIntake"),-    ("emit", "SkelEmit"),-    ("workqueue", "SkelQueue"),-    ("workflow", "SkelWorkflow")-  ]--assertStableSkeletonMatchesCommitted :: T.Text -> T.Text -> IO ()-assertStableSkeletonMatchesCommitted kind root = case skeletonFor kind of-  Left err -> expectationFailure (T.unpack err)-  Right source -> case parseSource ("new:" <> T.unpack kind) source of-    Left err -> expectationFailure (T.unpack (renderParseFailure err))-    Right parsed -> do-      let service = checkedSource parsed-          spec = checkedSpec service-      let ctx = (defaultContext (specContext spec)) {moduleRoot = root}-      forM_ [m | m <- scaffoldServiceModules ctx service, kindOf m == Generated] $ \m -> do-        committed <- readTestText ("test/conformance-skeletons/" <> modulePath m)-        normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m)-  where-    kindOf = Keiro.Dsl.Scaffold.kind--bumpArtifactBindingVersion :: MappedDecl -> MappedDecl-bumpArtifactBindingVersion declaration@MappedStructural {msName = "ArtifactInfo"} =-  declaration {msBindingVersion = Just "2"}-bumpArtifactBindingVersion declaration = declaration--addArtifactSummaryField :: MappedDecl -> MappedDecl-addArtifactSummaryField declaration@MappedStructural {msName = "ArtifactInfo", msShape = ShapeRecord constructor unknownFields fields} =-  declaration-    { msShape =-        ShapeRecord-          constructor-          unknownFields-          ( fields-              <> [ WireField-                     { wfHaskell = "summary",-                       wfKey = "summary",-                       wfType = TText,-                       wfPresence = PRequired,-                       wfOnMissing = Nothing,-                       wfLoc = Loc 0-                     }-                 ]-          )-    }-addArtifactSummaryField declaration = declaration--expectGenericCompileFailure :: FilePath -> String -> Expectation-expectGenericCompileFailure fixture expectedDiagnostic = do-  let fixtureDir = "../keiro-core/test/compile-fail" </> fixture-      fixtureSource = fixtureDir </> "Fixture.hs"-  (exitCode, standardOutput, standardError) <--    readProcessWithExitCode-      "cabal"-      [ "exec",-        "--",-        "ghc",-        "-XGHC2024",-        "-fno-code",-        "-fforce-recomp",-        "-i../keiro-core/src",-        "-i" <> fixtureDir,-        fixtureSource-      ]-      ""-  exitCode `shouldSatisfy` (/= ExitSuccess)-  let compilerOutput = standardOutput <> standardError-  compilerOutput `shouldContain` expectedDiagnostic-  compilerOutput `shouldContain` "Run keiro-dsl scaffold and fill the binding by hand at this error location in the scaffolded module."-  compilerOutput `shouldContain` fixtureSource--moveArtifactBindingIntoGenerated :: MappedDecl -> MappedDecl-moveArtifactBindingIntoGenerated declaration@MappedStructural {msName = "ArtifactInfo"} =-  declaration {msBinding = Just "Generated.ConsumerDemo.Bindings.artifactInfoBinding"}-moveArtifactBindingIntoGenerated declaration = declaration--removeMappedRegisterRequirements :: Spec -> Spec-removeMappedRegisterRequirements spec =-  spec-    { specMapped = map removeInitial (specMapped spec),-      specNodes = map removeRegisters (specNodes spec)-    }-  where-    removeInitial declaration@MappedStructural {} = declaration {msInitial = Nothing}-    removeInitial declaration@MappedOpaque {} = declaration {moInitial = Nothing}-    removeRegisters (NAggregate aggregate) =-      NAggregate-        aggregate-          { aggRegs = [],-            aggTransitions = [transition {tWrites = []} | transition <- aggTransitions aggregate]-          }-    removeRegisters node = node--isImportCycle :: Refusal -> Bool-isImportCycle ImportCycle {} = True-isImportCycle _ = False--isFoldSurfaceRefusal :: Either [Refusal] modules -> Bool-isFoldSurfaceRefusal (Left refusals) = any isFold refusals-  where-    isFold FoldSurfaceRefusal {} = True-    isFold _ = False-isFoldSurfaceRefusal (Right _) = False---- | The canonical positive workspace fixture: three members under one context.-canonicalWorkspacePath :: FilePath-canonicalWorkspacePath = "test/fixtures/workspace/service.keiro-workspace"---- | Deterministic workspace source used to model git blobs without invoking git.-memoryContentSource :: Map.Map FilePath T.Text -> ContentSource-memoryContentSource files =-  ContentSource-    { csRead = \path ->-        pure $ maybe (Left ("missing in-memory content: " <> T.pack path)) Right (Map.lookup path files)-    }--changeCode :: Change -> DiagnosticCode-changeCode (Additive kind) = ckCode kind-changeCode (Advisory kind) = ckCode kind-changeCode (Breaking kind) = ckCode kind--breakingSurfaces :: Change -> [CompatibilitySurface]-breakingSurfaces change =-  [ surface-  | surface <- [minBound .. maxBound],-    verdictFor surface (ckVector kind) == VBreaking-  ]-  where-    kind = case change of-      Additive value -> value-      Advisory value -> value-      Breaking value -> value--workspaceChangeKind :: Change -> ChangeKind-workspaceChangeKind (Additive kind) = kind-workspaceChangeKind (Advisory kind) = kind-workspaceChangeKind (Breaking kind) = kind---- | The same members as 'canonicalWorkspacePath', listed in reverse order.-reorderedWorkspacePath :: FilePath-reorderedWorkspacePath = "test/fixtures/workspace/service-reordered.keiro-workspace"---- | Load and compose a workspace fixture, failing the test on a refusal. The--- fixture path is package-relative; the loader is rooted at the manifest's own--- directory, exactly as the CLI roots it.-shouldComposeWorkspace :: FilePath -> IO WorkspaceSpec-shouldComposeWorkspace path = do-  resolved <- resolveTestPath path-  loaded <- loadWorkspace (fileContentSource (takeDirectory resolved)) resolved-  case loaded of-    Left failure ->-      expectationFailure (T.unpack (T.intercalate "\n" (renderWorkspaceFailure resolved failure)))-        >> error "unreachable"-    Right workspace -> pure workspace {wsManifestPath = path}---- | The 'Context' a workspace scaffolds under, with no CLI overrides: the--- members' unanimous context name, the manifest's module-root and layout--- authority, and the built-in defaults where the manifest is silent.-workspaceContext :: WorkspaceSpec -> Context-workspaceContext workspace =-  Context-    { contextName = wsContext workspace,-      moduleRoot = maybe "" id (wsModuleRoot workspace),-      placement = maybe GeneratedPrefix id (wsLayout workspace)-    }---- | Compose and plan a workspace fixture, failing the test on any refusal.-shouldPlanWorkspace :: FilePath -> IO WorkspacePlan-shouldPlanWorkspace path = do-  workspace <- shouldComposeWorkspace path-  case planWorkspaceScaffold "goldens" (workspaceContext workspace) workspace of-    Left refusals -> expectationFailure ("unexpected workspace plan refusal: " <> show refusals) >> error "unreachable"-    Right plan -> pure plan---- | Does a scaffolded module's path end in this suffix?-isSuffixOfPath :: FilePath -> ScaffoldModule -> Bool-isSuffixOfPath suffix m = T.pack suffix `T.isSuffixOf` T.pack (modulePath m)---- | A workspace record built from real composed data plus two synthetic--- adoption rows, so the round-trip test exercises every row kind including the--- JSON encodings shared with the v1 record.-sampleWorkspaceRecord :: WorkspaceSpec -> WorkspaceRecord-sampleWorkspaceRecord workspace =-  WorkspaceRecord-    { wrService = wsService workspace,-      wrManifest = "service.keiro-workspace",-      wrContext = wsContext workspace,-      wrModuleRoot = maybe "" id (wsModuleRoot workspace),-      wrLayout = "collocated",-      wrMembers = map wmPath (wsMembers workspace),-      wrSourceLanguages =-        [ WorkspaceSourceLanguageRow (wmPath member) (wmSourceLanguage member)-        | member <- wsMembers workspace-        ],-      wrLanguageContract = wsLanguageContract workspace,-      wrNamingEdition = IdiomaticNamingV1,-      wrModules =-        [ WorkspaceModuleRow Generated "Demo/Generated/StructuralProjections.hs" Nothing Nothing,-          WorkspaceModuleRow Generated "Demo/Project/Generated/Domain.hs" (Just "domain/project.keiro") Nothing,-          WorkspaceModuleRow HoleStub "Demo/Project/Holes.hs" (Just "domain/shared.keiro") Nothing-        ],-      wrMappings = consumerMappings (consumerPlan (wsMergedSpec workspace)),-      wrIdDomains = [],-      wrNominalEqualities = nominalEqualityIdentities (wsMergedSpec workspace),-      wrBindingObligations = either (const []) id (bindingHoles (wsMergedSpec workspace)),-      wrBehaviorRequirements = [],-      wrAdopted =-        [ AdoptedRow "claimed/One.hs" "record" (Just "keiro-dsl-ledger.context.demo-project.txt") (Just "project.keiro"),-          AdoptedRow "claimed/Two.hs" "banner" Nothing Nothing-        ]-    }---- | The canonical workspace with a case-variant copy of one member's aggregate--- grafted onto another member. Composition refuses this shape (EP-153 catches it--- at the earliest boundary), so the planner's own cross-member collision gate can--- only be exercised by constructing the graph directly — which is exactly what--- this does, mirroring the single-file @caseVariant@ construction.-withCaseVariantAggregate :: WorkspaceSpec -> WorkspaceSpec-withCaseVariantAggregate workspace = case [aggregate | NAggregate aggregate <- specNodes merged, aggName aggregate == "Project"] of-  [] -> error "canonical workspace fixture has no Project aggregate"-  aggregate : _ ->-    let shouted = aggregate {aggName = T.toUpper (aggName aggregate)}-        ownership = wsOwnership workspace-     in workspace-          { wsMergedSpec = merged {specNodes = specNodes merged <> [NAggregate shouted]},-            wsOwnership =-              ownership-                { oiNodes =-                    Map.insert-                      ("aggregate", aggName shouted)-                      ("domain/project-artifact.keiro", Loc 1)-                      (oiNodes ownership)-                }-          }-  where-    merged = wsMergedSpec workspace---- | Write a one-member workspace whose member declares an upcaster, so its--- golden payload fixture has a canonical location. Returns the composed--- workspace; the caller decides where the fixture lives.-writeGoldenWorkspace :: FilePath -> IO WorkspaceSpec-writeGoldenWorkspace root = do-  source <- readTestText "test/fixtures/reservation-v2.keiro"-  createDirectoryIfMissing True (root </> "domain")-  TIO.writeFile (root </> "domain/reservation.keiro") source-  let manifestPath = root </> "service.keiro-workspace"-  TIO.writeFile manifestPath "service gold-demo\nspec domain/reservation.keiro\n"-  loaded <- loadWorkspace (fileContentSource root) manifestPath-  case loaded of-    Left failure ->-      expectationFailure (T.unpack (T.intercalate "\n" (renderWorkspaceFailure manifestPath failure)))-        >> error "unreachable"-    Right workspace -> pure workspace---- | Materialize the canonical fixture workspace in a fresh temporary directory--- and hand the callback its root, a sibling output directory, and the composed--- workspace. Working on a copy is what lets a test edit a member and re-scaffold.------ The manifest's @spec@ lines are passed through the given function first, so a--- caller can list the same members in a different order; the manifest __file--- name__ stays the same, which is what makes two runs comparable byte for byte.-withWorkspaceFixture ::-  String ->-  ([FilePath] -> [FilePath]) ->-  (FilePath -> FilePath -> WorkspaceSpec -> IO a) ->-  IO a-withWorkspaceFixture template orderMembers act =-  withTempDirectory template $ \base -> do-    let root = base </> "workspace"-        out = base </> "out"-        members =-          [ "domain/project-artifact.keiro",-            "domain/project.keiro",-            "domain/shared.keiro"-          ]-    createDirectoryIfMissing True (root </> "domain")-    forM_ members $ \relative -> do-      source <- readTestText ("test/fixtures/workspace" </> relative)-      TIO.writeFile (root </> relative) source-    TIO.writeFile-      (root </> "service.keiro-workspace")-      ( T.unlines-          ( ["service demo-project", "module Demo.Modules.Project", "layout collocated"]-              <> ["spec " <> T.pack relative | relative <- orderMembers members]-          )-      )-    workspace <- loadTempWorkspace root-    act root out workspace---- | Materialize an inline workspace — a manifest plus literal member sources —--- in a fresh temporary directory, and hand the callback its root, a sibling output--- directory, and the composed workspace.-withInlineWorkspace ::-  String ->-  (T.Text, [(FilePath, T.Text)]) ->-  (FilePath -> FilePath -> WorkspaceSpec -> IO a) ->-  IO a-withInlineWorkspace template (service, members) act =-  withTempDirectory template $ \base -> do-    let root = base </> "workspace"-        out = base </> "out"-    forM_ members $ \(relative, source) -> writeFileWithParents (root </> relative) source-    TIO.writeFile-      (root </> "service.keiro-workspace")-      ( T.unlines-          (("service " <> service) : ["spec " <> T.pack relative | (relative, _) <- members])-      )-    workspace <- loadTempWorkspace root-    act root out workspace---- | Two independently valid members under one context. Each is a complete spec--- that the pre-workspace single-file scaffolder accepts, which is what lets a test--- reproduce the overwritten-record defect before adopting.-adoptionMembers :: (T.Text, [(FilePath, T.Text)])-adoptionMembers = ("adoption-demo", [("domain/a.keiro", adoptionMemberA), ("domain/b.keiro", adoptionMemberB)])--adoptionMemberA :: T.Text-adoptionMemberA =-  T.unlines-    [ "context adoption-demo",-      "",-      "aggregate Counter",-      "  regs",-      "    count Int = 0",-      "    state CounterVertex = Pending",-      "  states Pending Done!",-      "  command Bump { count:Int }",-      "  event CountBumped { count:Int }",-      "  Pending -- Bump --> emit CountBumped ; goto Done"-    ]--adoptionMemberB :: T.Text-adoptionMemberB =-  T.unlines-    [ "context adoption-demo",-      "",-      "aggregate Widget",-      "  regs",-      "    size Int = 0",-      "    state WidgetVertex = Draft",-      "  states Draft Shipped!",-      "  command Ship { size:Int }",-      "  event WidgetShipped { size:Int }",-      "  Draft -- Ship --> emit WidgetShipped ; goto Shipped"-    ]--writeFileWithParents :: FilePath -> T.Text -> IO ()-writeFileWithParents path contents = do-  createDirectoryIfMissing True (takeDirectory path)-  TIO.writeFile path contents---- | Only the Haskell sources of a tree snapshot, dropping bookkeeping files.-haskellOnly :: [(FilePath, T.Text)] -> [(FilePath, T.Text)]-haskellOnly entries = [entry | entry@(path, _) <- entries, ".hs" `T.isSuffixOf` T.pack path]---- | Compose a workspace that a test just wrote to disk.-loadTempWorkspace :: FilePath -> IO WorkspaceSpec-loadTempWorkspace root = do-  let manifestPath = root </> "service.keiro-workspace"-  loaded <- loadWorkspace (fileContentSource root) manifestPath-  case loaded of-    Left failure ->-      expectationFailure (T.unpack (T.intercalate "\n" (renderWorkspaceFailure manifestPath failure)))-        >> error "unreachable"-    Right workspace -> pure workspace---- | Plan an already-composed workspace, failing the test on a refusal.-shouldPlanWorkspaceSpec :: WorkspaceSpec -> IO WorkspacePlan-shouldPlanWorkspaceSpec workspace =-  case planWorkspaceScaffold "goldens" (workspaceContext workspace) workspace of-    Left refusals -> expectationFailure ("unexpected workspace plan refusal: " <> show refusals) >> error "unreachable"-    Right plan -> pure plan---- | Plan then execute a whole-workspace scaffold, failing loudly on either.-executePlannedWorkspaceScaffold :: FilePath -> WorkspaceSpec -> IO WorkspaceScaffoldReport-executePlannedWorkspaceScaffold out workspace = do-  plan <- shouldPlanWorkspaceSpec workspace-  result <- executeWorkspaceScaffold out False plan-  case result of-    Left refusals -> expectationFailure ("unexpected workspace execution refusal: " <> show refusals) >> error "unreachable"-    Right report -> pure report---- | Rename one member's aggregate in place and recompose. Only the--- @aggregate \<Name\>@ header is rewritten, so declarations that merely share the--- prefix (@ProjectId@, @ProjectSummary@) are untouched.-renameMemberAggregate :: FilePath -> FilePath -> T.Text -> T.Text -> IO WorkspaceSpec-renameMemberAggregate root member from to = do-  source <- TIO.readFile (root </> member)-  TIO.writeFile (root </> member) (T.replace ("aggregate " <> from <> "\n") ("aggregate " <> to <> "\n") source)-  loadTempWorkspace root---- | Move the @ProjectArtifact@ aggregate from the artifact member into the--- project member, and recompose.------ It is prepended, so the merged spec's node order — and therefore every emitted--- byte, including the replay-audit assembly's aggregate list — is exactly what it--- was. That isolates the change to ownership, which is the point of the test.-moveArtifactAggregate :: FilePath -> IO WorkspaceSpec-moveArtifactAggregate root = do-  artifact <- TIO.readFile (root </> "domain/project-artifact.keiro")-  project <- TIO.readFile (root </> "domain/project.keiro")-  case T.breakOn "aggregate ProjectArtifact" artifact of-    (kept, moved) | not (T.null moved) -> do-      TIO.writeFile (root </> "domain/project-artifact.keiro") kept-      TIO.writeFile-        (root </> "domain/project.keiro")-        (T.replace "aggregate Project\n" (moved <> "\naggregate Project\n") project)-      loadTempWorkspace root-    _ -> expectationFailure "artifact member has no ProjectArtifact aggregate" >> error "unreachable"---- | Every regular file under a directory, as @(relative path, contents)@ sorted--- by path — the comparison unit for "byte-identical output".-treeSnapshot :: FilePath -> IO [(FilePath, T.Text)]-treeSnapshot root = do-  exists <- doesDirectoryExist root-  if not exists then pure [] else sort <$> walk ""-  where-    walk relative = do-      entries <- listDirectory (root </> relative)-      fmap concat . forM (sort entries) $ \entry -> do-        let child = if null relative then entry else relative </> entry-        isDirectory <- doesDirectoryExist (root </> child)-        if isDirectory-          then walk child-          else do-            contents <- TIO.readFile (root </> child)-            pure [(child, contents)]--copyTextTree :: FilePath -> FilePath -> IO ()-copyTextTree source destination =-  treeSnapshot source >>= mapM_ (\(relative, contents) -> writeFileWithParents (destination </> relative) contents)--thd3 :: (a, b, c) -> c-thd3 (_, _, value) = value--isPathCollision :: Refusal -> Bool-isPathCollision PathCollision {} = True-isPathCollision _ = False--isInfixOfString :: String -> String -> Bool-isInfixOfString needle haystack = T.isInfixOf (T.pack needle) (T.pack haystack)---- | Load a workspace fixture expecting a compose refusal, and return it.-shouldRefuseWorkspace :: FilePath -> IO (NonEmpty WorkspaceDiagnostic)-shouldRefuseWorkspace path = do-  resolved <- resolveTestPath path-  loaded <- loadWorkspace (fileContentSource (takeDirectory resolved)) resolved-  case loaded of-    Left (WorkspaceRefused diagnostics) -> pure diagnostics-    Left other ->-      expectationFailure-        ("expected compose refusals, got:\n" <> T.unpack (T.intercalate "\n" (renderWorkspaceFailure resolved other)))-        >> error "unreachable"-    Right _ -> expectationFailure ("expected " <> path <> " to be refused") >> error "unreachable"---- | Invoke the built @keiro-dsl@ executable. Fixture paths are resolved first,--- so the test works whether it runs from the package directory or the repository--- root.-runKeiroDsl :: [String] -> IO (ExitCode, String, String)-runKeiroDsl arguments = do-  resolved <- traverse resolveArgument arguments-  readProcessWithExitCode "cabal" (["run", "-v0", "keiro-dsl", "--"] <> resolved) ""-  where-    resolveArgument argument-      | "test/fixtures/" `isPrefixOfString` argument = resolveTestPath argument-      | otherwise = pure argument-    isPrefixOfString prefix value = take (length prefix) value == prefix---- | The @spec@ field of a coverage report, i.e. what the report says it covers.-coverageSpecPath :: Value -> Maybe T.Text-coverageSpecPath value = case value of-  Aeson.Object fields -> case KeyMap.lookup "spec" fields of-    Just (Aeson.String path) -> Just path-    _ -> Nothing-  _ -> Nothing--decodeJsonValue :: FilePath -> IO Value-decodeJsonValue path = do-  decoded <- Aeson.eitherDecodeFileStrict path-  case decoded of-    Left err -> expectationFailure (path <> ": " <> err) >> fail "unreachable"-    Right value -> pure value--jsonField :: T.Text -> Value -> Maybe Value-jsonField name = \case-  Aeson.Object fields -> KeyMap.lookup (Key.fromText name) fields-  _ -> Nothing---- | Order-preserving deduplication for comparing cited file sets.-nubOrd :: (Eq a) => [a] -> [a]-nubOrd = go []-  where-    go seen [] = reverse seen-    go seen (x : xs) = if x `elem` seen then go seen xs else go (x : seen) xs---- | Parse a workspace manifest, failing the test on a refusal.-shouldParseManifest :: FilePath -> T.Text -> IO WorkspaceManifest-shouldParseManifest path source = case parseWorkspaceManifest path source of-  Left err -> expectationFailure (T.unpack err) >> error "unreachable"-  Right manifest -> pure manifest---- | Generate a canonical workspace manifest. Members are drawn from a pool of--- paths that are distinct even under case folding and are held sorted, which is--- the invariant every parsed manifest satisfies.-genWorkspaceManifest :: Gen WorkspaceManifest-genWorkspaceManifest = do-  service <- elements ["demo-project", "mori", "kotei", "a1", "svc-2"]-  runtimePackage <- elements [Nothing, Just (RuntimePackageName "demo-core"), Just (RuntimePackageName "mori2")]-  moduleRoot <- elements [Nothing, Just "Demo", Just "Demo.Modules.Project"]-  layout <- elements [Nothing, Just GeneratedPrefix, Just CollocatedLeaf]-  chosen <--    sublistOf-      [ "a.keiro",-        "d-e_f.keiro",-        "domain/b.keiro",-        "domain/sub/c.keiro",-        "x1.keiro"-      ]-      `suchThat` (not . null)-  pure-    WorkspaceManifest-      { wmfService = service,-        wmfServiceLoc = Loc 1,-        wmfRuntimePackage = runtimePackage,-        wmfRuntimePackageLoc = Loc 2,-        wmfModuleRoot = moduleRoot,-        wmfModuleRootLoc = Loc 2,-        wmfLayout = layout,-        wmfLayoutLoc = Loc 3,-        wmfMembers = NE.fromList [WorkspaceMemberRef path (Loc 4) | path <- sort chosen]-      }---- | Parse a fixture while retaining its released language contract.-parsedSourceOf :: FilePath -> IO ParsedSource-parsedSourceOf path = do-  input <- readTestText path-  case parseSource path input of-    Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"-    Right parsed -> pure parsed--checkedServiceOf :: FilePath -> IO CheckedService-checkedServiceOf = fmap checkedSource . parsedSourceOf--renderFoldBaseline :: T.Text -> CheckedService -> T.Text-renderFoldBaseline fixture service =-  T.intercalate-    "\n\n"-    [ T.unlines-        ( [ "fixture=" <> fixture,-            "aggregate=" <> aggName aggregate,-            "fingerprint=" <> aggregateFoldFingerprintForService service aggregate,-            "surface-begin"-          ]-            <> T.lines (aggregateFoldSurfaceForService service aggregate)-            <> ["surface-end"]-        )-    | NAggregate aggregate <- specNodes (checkedSpec service)-    ]---- | Parse a fixture through the source-aware boundary and return its graph.-specOf :: FilePath -> IO Spec-specOf = fmap checkedSpec . checkedServiceOf---- | Parse a fixture and scaffold its checked semantic service.-scaffoldFixture :: FilePath -> IO [ScaffoldModule]-scaffoldFixture path = do-  service <- checkedServiceOf path-  pure (scaffoldServiceModules (defaultContext (specContext (checkedSpec service))) service)--legacyScaffoldProcessFixture :: FilePath -> IO [ScaffoldModule]-legacyScaffoldProcessFixture path = do-  spec <- specOf path-  pure $ concat [scaffoldProcess (ctx spec) process | NProcess process <- specNodes spec]-  where-    ctx spec = defaultContext (specContext spec)---- | Assert a freshly-scaffolded Generated module matches its committed copy--- under test/conformance/ (whitespace-normalized). The committed copies are the--- ones the keiro-dsl-conformance suite compiles, so this pins the live scaffolder--- to known-compiling output.-assertMatchesCommitted :: ScaffoldModule -> IO ()-assertMatchesCommitted m = do-  let committedPath = "test/conformance/" <> modulePath m-  committed <- readTestText committedPath-  normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m)--normalizeGenerated :: T.Text -> (T.Text, [T.Text])-normalizeGenerated text =-  let (orderInsensitiveLines, body) = partition isOrderInsensitive (T.lines text)-   in (normalizeBody body, sort (map normalizeImport orderInsensitiveLines))-  where-    -- Compare the deterministic body exactly as before and imports/language-    -- pragmas as a sorted, whitespace-normalized list. Sorting tolerates-    -- formatter reordering while additions, removals, and renamed entries still-    -- fail the pin.-    isOrderInsensitive line = isImport line || "{-# LANGUAGE " `T.isPrefixOf` line-    normalizeBody =-      -- Fourmolu parenthesizes a single class constraint while the emitter's-      -- compact spelling remains valid Haskell.  Treat that formatter-only-      -- rewrite like the whitespace and comma placement normalized below.-      T.replace "(Show value) =>" "Show value =>"-        . T.replace "( " "("-        . T.replace " )" ")"-        . T.replace " , )" " )"-        . T.unwords-        . T.words-        . T.replace "}" " } "-        . T.replace "{" " { "-        . T.replace "]" " ] "-        . T.replace "[" " [ "-        . T.replace "," " , "-        . T.unlines-        . map normalizeBanner-    normalizeBanner line-      | isGeneratedBannerLine line = generatedBanner-      | otherwise = line-    normalizeImport line =-      let reordered = case T.words line of-            "import" : "qualified" : moduleName : rest -> T.unwords ("import" : moduleName : "qualified" : rest)-            wordsInImport -> T.unwords wordsInImport-          (prefix, explicit) = T.breakOn " (" reordered-       in if T.null explicit-            then prefix-            else-              let members =-                    sort-                      . map (T.replace " (" "(" . T.unwords . T.words)-                      . T.splitOn ","-                      . T.dropEnd 1-                      $ T.drop 2 explicit-               in prefix <> " (" <> T.intercalate "," members <> ")"-    isImport line = case T.words line of-      "import" : _ -> True-      _ -> False---- | Locate and read a test fixture or committed conformance source regardless--- of whether the suite was launched from the package directory or repo root.-readTestText :: FilePath -> IO T.Text-readTestText path = resolveTestPath path >>= TIO.readFile--assertMatchesGolden :: FilePath -> T.Text -> IO ()-assertMatchesGolden path actual = do-  resolved <- resolveTestPath path-  update <- lookupEnv "KEIRO_DSL_UPDATE_GOLDENS"-  if update == Just "1"-    then TIO.writeFile resolved (T.stripEnd actual <> "\n")-    else do-      golden <- TIO.readFile resolved-      T.stripEnd actual `shouldBe` T.stripEnd golden---- | Locate a repo file regardless of the test process's current directory.-resolveTestPath :: FilePath -> IO FilePath-resolveTestPath rel = do-  override <- lookupEnv "KEIRO_DSL_TEST_ROOT"-  let candidates = [rel, "keiro-dsl" </> rel] <> maybe [] (\root -> [root </> rel]) override-  existing <- filterM doesFileExist candidates-  case existing of-    path : _ -> pure path-    [] ->-      fail $-        "unable to locate keiro-dsl test file "-          <> show rel-          <> "; tried "-          <> show candidates--leftContains :: T.Text -> Either T.Text a -> Bool-leftContains needle = \case-  Left err -> needle `T.isInfixOf` err-  Right _ -> False--parseInlineSpec :: FilePath -> T.Text -> IO Spec-parseInlineSpec sourceName src = case parseSpec sourceName src of-  Left err -> expectationFailure (T.unpack err) >> error "unreachable"-  Right spec -> pure spec--checkedServiceFromText :: FilePath -> T.Text -> IO CheckedService-checkedServiceFromText sourceName src = case parseSource sourceName src of-  Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> error "unreachable"-  Right parsed -> pure (checkedSource parsed)--parseStableRenderedSpec :: FilePath -> Spec -> Either T.Text Spec-parseStableRenderedSpec sourceName spec =-  case parseSource sourceName stableSource of-    Left failure -> Left (renderParseFailure failure)-    Right parsed -> Right (parsedSpec parsed)-  where-    stableSource =-      "language keiro-dsl "-        <> T.pack (show (languageVersionNumber currentStableLanguageVersion))-        <> "\n"-        <> renderSpec spec--shouldParseStableRenderedSpec :: FilePath -> Spec -> IO Spec-shouldParseStableRenderedSpec sourceName spec =-  case parseStableRenderedSpec sourceName spec of-    Left failure -> expectationFailure (T.unpack failure) >> fail "unreachable"-    Right reparsed -> pure reparsed--shouldResolveTypeGraph :: Spec -> IO TypeGraph-shouldResolveTypeGraph spec = case resolveTypeGraph spec of-  Left errors -> expectationFailure ("type graph failed: " <> show errors) >> error "unreachable"-  Right graph -> pure graph--shouldResolveCoverage :: FilePath -> Spec -> IO Coverage.CoverageReport-shouldResolveCoverage path spec = case Coverage.coverageReport path spec of-  Left errors -> expectationFailure ("coverage graph failed: " <> show errors) >> error "unreachable"-  Right report -> pure report--withoutVendorGeometry :: Spec -> Spec-withoutVendorGeometry spec =-  spec-    { specMapped = filter (not . isVendorGeometry) (specMapped spec),-      specNodes = map stripNode (specNodes spec)-    }-  where-    isVendorGeometry MappedOpaque {moName = "VendorGeometry"} = True-    isVendorGeometry _ = False-    stripNode (NAggregate aggregate) =-      NAggregate-        aggregate-          { aggRegs = filter ((/= TRef "VendorGeometry") . regType) (aggRegs aggregate),-            aggCommands = map stripCommand (aggCommands aggregate),-            aggEvents = map stripEvent (aggEvents aggregate)-          }-    stripNode node = node-    stripCommand command = command {cmdFields = filter ((/= Just (TRef "VendorGeometry")) . aggregateFieldType) (cmdFields command)}-    stripEvent event = event {evBody = case evBody event of EventFields fields -> EventFields (filter ((/= Just (TRef "VendorGeometry")) . aggregateFieldType) fields); body -> body}--withMetadataJson :: Spec -> Spec-withMetadataJson spec = spec {specMapped = map updateDeclaration (specMapped spec)}-  where-    updateDeclaration declaration@MappedStructural {msName = "ArtifactMetadata", msShape = ShapeRecord constructor unknownFields fields} =-      declaration-        { msShape =-            ShapeRecord-              constructor-              unknownFields-              [if wfHaskell field == "note" then field {wfType = TJson} else field | field <- fields]-        }-    updateDeclaration declaration = declaration--expressionTags :: TypeExprAlgebra [T.Text]-expressionTags =-  TypeExprAlgebra-    { onText = ["text"],-      onInt = ["int"],-      onInteger = ["integer"],-      onBool = ["bool"],-      onNatural = ["natural"],-      onTime = ["time"],-      onJson = ["json"],-      onOptional = ("optional" :),-      onList = ("list" :),-      onMap = ("map" :),-      onRef = \key -> ["ref:" <> unMappedKey key]-    }--hasTypeGraphError :: (TypeGraphError -> Bool) -> Either (NonEmpty TypeGraphError) TypeGraph -> Bool-hasTypeGraphError predicate = \case-  Left errors -> any predicate errors-  Right _ -> False--isRecursive :: TypeGraphError -> Bool-isRecursive TGRecursive {} = True-isRecursive _ = False--isUnresolved :: TypeGraphError -> Bool-isUnresolved TGUnresolvedRef {} = True-isUnresolved _ = False--mappedSpec :: [MappedDecl] -> Spec-mappedSpec declarations = Spec "mapped-test" Nothing Nothing [] [] [] [] declarations []--completeStructural :: Name -> MappedShape -> MappedDecl-completeStructural name shape =-  MappedStructural-    { msName = name,-      msHaskell = Just (HaskellSource "mapped-test" "Example.Mapped" name),-      msBinding = Just ("Example.Mapped." <> T.toLower name <> "Binding"),-      msBindingVersion = Just "1",-      msCanonical = Just ("example.mapped." <> name),-      msFixtures = Just ("Example.Mapped." <> T.toLower name <> "Cases"),-      msInitial = Nothing,-      msShape = shape,-      msLoc = noLoc-    }--recordShape :: [TypeExpr] -> MappedShape-recordShape types =-  ShapeRecord-    "MappedRecord"-    RejectUnknown-    [ WireField-        { wfHaskell = "field" <> T.pack (show index),-          wfKey = "field" <> T.pack (show index),-          wfType = fieldType,-          wfPresence = PRequired,-          wfOnMissing = Nothing,-          wfLoc = noLoc-        }-    | (index, fieldType) <- zip [(1 :: Int) ..] types-    ]--mapArtifactField :: (WireField -> WireField) -> Spec -> Spec-mapArtifactField = mapArtifactNamedField "key"--mapArtifactNamedField :: Name -> (WireField -> WireField) -> Spec -> Spec-mapArtifactNamedField target transform spec = spec {specMapped = map updateDeclaration (specMapped spec)}-  where-    updateDeclaration declaration@MappedStructural {msName = "ArtifactInfo", msShape = ShapeRecord constructor unknownFields fields} =-      declaration-        { msShape =-            ShapeRecord-              constructor-              unknownFields-              [if wfHaskell field == target then transform field else field | field <- fields]-        }-    updateDeclaration declaration = declaration--mapMappedStructural :: Name -> (MappedDecl -> MappedDecl) -> Spec -> Spec-mapMappedStructural target transform spec =-  spec-    { specMapped =-        [ case declaration of-            MappedStructural {msName = name}-              | name == target -> transform declaration-            _ -> declaration-        | declaration <- specMapped spec-        ]-    }--renameRecordConstructor :: MappedShape -> MappedShape-renameRecordConstructor (ShapeRecord _ unknownFields fields) = ShapeRecord "ArtifactInfoV2" unknownFields fields-renameRecordConstructor shape = shape--renameMappedRecordConstructor :: MappedDecl -> MappedDecl-renameMappedRecordConstructor declaration@MappedStructural {msShape = shape} =-  declaration {msShape = renameRecordConstructor shape}-renameMappedRecordConstructor declaration = declaration--changeMappedCanonical :: MappedDecl -> MappedDecl-changeMappedCanonical declaration@MappedStructural {} =-  declaration {msCanonical = Just "example.artifact.ArtifactInfo.v2"}-changeMappedCanonical declaration = declaration--data MappedMutation = MappedMutation-  { mmCandidate :: !Spec,-    mmCode :: !DiagnosticCode,-    mmExpectedSubjects :: !(Set.Set T.Text)-  }-  deriving stock (Show)--mappedWireMutations :: Spec -> [MappedMutation]-mappedWireMutations spec = case resolveTypeGraph spec of-  Left _ -> []-  Right graph -> concatMap (uncurry (declarationMutations graph)) (zip [0 :: Int ..] (specMapped spec))-  where-    declarationMutations graph declarationIndex declaration = case declaration of-      MappedStructural {msName = declarationName, msShape = shape} -> case shape of-        ShapeRecord _ _ fields ->-          concat-            [ [ mutation-                  graph-                  declarationName-                  MappedWireKeyChanged-                  (fieldSubject field {wfKey = wfKey field <> "__mutated"})-                  (mutateRecordField declarationIndex fieldIndex (\value -> value {wfKey = wfKey value <> "__mutated"}) spec),-                mutation-                  graph-                  declarationName-                  MappedPresenceChanged-                  (fieldSubject field)-                  (mutateRecordField declarationIndex fieldIndex (\value -> value {wfPresence = flipPresence (wfPresence value)}) spec)-              ]-                <> [ mutation-                       graph-                       declarationName-                       defaultCode-                       (fieldSubject field)-                       (mutateRecordField declarationIndex fieldIndex (\value -> value {wfOnMissing = changedDefault}) spec)-                   | oldDefault <- maybeToListTest (wfOnMissing field),-                     let (changedDefault, defaultCode) = mutateDefault oldDefault-                   ]-            | (fieldIndex, field) <- zip [0 :: Int ..] fields-            ]-        ShapeEnum entries ->-          [ mutation-              graph-              declarationName-              MappedEnumSpellingChanged-              (enumSubject entry {weTag = weTag entry <> "__mutated"})-              (mutateEnumEntry declarationIndex entryIndex (\value -> value {weTag = weTag value <> "__mutated"}) spec)-          | (entryIndex, entry) <- zip [0 :: Int ..] entries-          ]-        ShapeUnion _ arms ->-          [ mutation-              graph-              declarationName-              MappedArmTagChanged-              (armSubject arm {waTag = waTag arm <> "__mutated"})-              (mutateUnionArm declarationIndex armIndex (\value -> value {waTag = waTag value <> "__mutated"}) spec)-          | (armIndex, arm) <- zip [0 :: Int ..] arms-          ]-      MappedOpaque {moName = declarationName, moCodecVersion = version} ->-        [ mutation-            graph-            declarationName-            MappedOpaqueCodecChanged-            "codec"-            ( updateMappedAt-                declarationIndex-                ( \case-                    value@MappedOpaque {} -> value {moCodecVersion = fmap (<> "__mutated") version}-                    value -> value-                )-                spec-            )-        ]--    mutation graph declarationName diagnosticCode leaf candidate =-      MappedMutation-        { mmCandidate = candidate,-          mmCode = diagnosticCode,-          mmExpectedSubjects =-            Set.fromList-              [ renderUsePath path <> " " <> leaf-              | path <- usePaths graph declarationName-              ]-        }--fieldSubject :: WireField -> T.Text-fieldSubject field = ".field " <> wfHaskell field <> "[\"" <> wfKey field <> "\"]"--enumSubject :: WireEnum -> T.Text-enumSubject entry = ".enum " <> weCtor entry <> "[\"" <> weTag entry <> "\"]"--armSubject :: WireArm -> T.Text-armSubject arm = ".arm " <> waCtor arm <> "[\"" <> waTag arm <> "\"]"--flipPresence :: Presence -> Presence-flipPresence PRequired = POptional-flipPresence POptional = PRequired--mutateDefault :: OnMissing -> (Maybe OnMissing, DiagnosticCode)-mutateDefault = \case-  OmNull -> (Nothing, MappedDefaultRemoved)-  OmText value -> (Just (OmText (value <> "__mutated")), MappedDefaultChanged)-  OmInt value -> (Just (OmInt (value + 1)), MappedDefaultChanged)-  OmBool value -> (Just (OmBool (not value)), MappedDefaultChanged)-  OmEmptyList -> (Nothing, MappedDefaultRemoved)-  OmEmptyMap -> (Nothing, MappedDefaultRemoved)-  OmCtor constructor -> (Just (OmCtor (constructor <> "Mutated")), MappedDefaultChanged)--mutateRecordField :: Int -> Int -> (WireField -> WireField) -> Spec -> Spec-mutateRecordField declarationIndex fieldIndex transform =-  updateMappedAt declarationIndex $ \case-    declaration@MappedStructural {msShape = ShapeRecord constructor unknownFields fields} ->-      declaration {msShape = ShapeRecord constructor unknownFields (updateAt fieldIndex transform fields)}-    declaration -> declaration--mutateEnumEntry :: Int -> Int -> (WireEnum -> WireEnum) -> Spec -> Spec-mutateEnumEntry declarationIndex entryIndex transform =-  updateMappedAt declarationIndex $ \case-    declaration@MappedStructural {msShape = ShapeEnum entries} ->-      declaration {msShape = ShapeEnum (updateAt entryIndex transform entries)}-    declaration -> declaration--mutateUnionArm :: Int -> Int -> (WireArm -> WireArm) -> Spec -> Spec-mutateUnionArm declarationIndex armIndex transform =-  updateMappedAt declarationIndex $ \case-    declaration@MappedStructural {msShape = ShapeUnion encoding arms} ->-      declaration {msShape = ShapeUnion encoding (updateAt armIndex transform arms)}-    declaration -> declaration--updateMappedAt :: Int -> (MappedDecl -> MappedDecl) -> Spec -> Spec-updateMappedAt declarationIndex transform spec =-  spec {specMapped = updateAt declarationIndex transform (specMapped spec)}--updateAt :: Int -> (a -> a) -> [a] -> [a]-updateAt target transform values =-  [if index == target then transform value else value | (index, value) <- zip [0 :: Int ..] values]--maybeToListTest :: Maybe a -> [a]-maybeToListTest = maybe [] pure--isAdditiveChange :: Change -> Bool-isAdditiveChange Additive {} = True-isAdditiveChange Advisory {} = False-isAdditiveChange Breaking {} = False--mappedIngredientMutations :: Spec -> [(Spec, DiagnosticCode)]-mappedIngredientMutations spec =-  [ (mapMappedStructural "ArtifactInfo" clearStructuralHaskell spec, MappedMissingIngredient),-    (mapMappedStructural "ArtifactInfo" clearStructuralBinding spec, MappedMissingIngredient),-    (mapMappedStructural "ArtifactInfo" clearStructuralBindingVersion spec, MappedMissingIngredient),-    (mapMappedStructural "ArtifactInfo" clearStructuralCanonical spec, MappedMissingIngredient),-    (mapMappedStructural "ArtifactInfo" clearStructuralFixtures spec, MappedMissingIngredient),-    (mapMappedStructural "ArtifactInfo" clearStructuralInitial spec, MappedMissingInitialValue),-    (mapMappedDeclaration "VendorGeometry" clearOpaqueHaskell spec, MappedMissingIngredient),-    (mapMappedDeclaration "VendorGeometry" clearOpaqueCodec spec, MappedMissingIngredient),-    (mapMappedDeclaration "VendorGeometry" clearOpaqueCodecVersion spec, MappedMissingIngredient),-    (mapMappedDeclaration "VendorGeometry" clearOpaqueFixtures spec, MappedMissingIngredient)-  ]-  where-    clearStructuralHaskell declaration@MappedStructural {} = declaration {msHaskell = Nothing}-    clearStructuralHaskell declaration = declaration-    clearStructuralBinding declaration@MappedStructural {} = declaration {msBinding = Nothing}-    clearStructuralBinding declaration = declaration-    clearStructuralBindingVersion declaration@MappedStructural {} = declaration {msBindingVersion = Nothing}-    clearStructuralBindingVersion declaration = declaration-    clearStructuralCanonical declaration@MappedStructural {} = declaration {msCanonical = Nothing}-    clearStructuralCanonical declaration = declaration-    clearStructuralFixtures declaration@MappedStructural {} = declaration {msFixtures = Nothing}-    clearStructuralFixtures declaration = declaration-    clearStructuralInitial declaration@MappedStructural {} = declaration {msInitial = Nothing}-    clearStructuralInitial declaration = declaration-    clearOpaqueHaskell declaration@MappedOpaque {} = declaration {moHaskell = Nothing}-    clearOpaqueHaskell declaration = declaration-    clearOpaqueCodec declaration@MappedOpaque {} = declaration {moCodecId = Nothing}-    clearOpaqueCodec declaration = declaration-    clearOpaqueCodecVersion declaration@MappedOpaque {} = declaration {moCodecVersion = Nothing}-    clearOpaqueCodecVersion declaration = declaration-    clearOpaqueFixtures declaration@MappedOpaque {} = declaration {moFixtures = Nothing}-    clearOpaqueFixtures declaration = declaration--mapMappedDeclaration :: Name -> (MappedDecl -> MappedDecl) -> Spec -> Spec-mapMappedDeclaration target transform spec =-  spec-    { specMapped =-        [ if mappedDeclarationName declaration == target then transform declaration else declaration-        | declaration <- specMapped spec-        ]-    }--mappedDeclarationName :: MappedDecl -> Name-mappedDeclarationName MappedStructural {msName = name} = name-mappedDeclarationName MappedOpaque {moName = name} = name--statusMapSpec :: T.Text -> T.Text-statusMapSpec marker =-  T.unlines-    [ "context svc",-      "",-      "aggregate Thing",-      "  regs",-      "  states Open",-      "",-      "  event Created { }",-      "  event Changed { }",-      "",-      "  projection things consistency=Eventual key=thingId",-      "    status-map" <> marker <> " { Created=>held }"-    ]--parseErrorOf :: FilePath -> T.Text -> IO T.Text-parseErrorOf sourceName src = case parseSpec sourceName src of-  Left err -> pure err-  Right _ -> expectationFailure ("expected parse failure for " <> sourceName) >> error "unreachable"--duplicateGotoSpec :: T.Text-duplicateGotoSpec =-  T.unlines-    [ "context svc",-      "",-      "aggregate Thing",-      "  regs",-      "  states A B C",-      "",-      "  command Go { }",-      "  A -- Go -->",-      "    goto B",-      "    goto C"-    ]--missingGotoSpec :: T.Text-missingGotoSpec =-  T.unlines-    [ "context svc",-      "",-      "aggregate Thing",-      "  regs",-      "  states A B",-      "",-      "  command Go { }",-      "  A -- Go -->",-      "    emit Changed"-    ]--duplicateWireSpec :: T.Text-duplicateWireSpec =-  T.unlines-    [ "context svc",-      "",-      "aggregate Thing",-      "  regs",-      "  states Open",-      "",-      "  wire kind=ctorName fields=camelCase schemaVersion=1",-      "  wire kind=typeName fields=snakeCase schemaVersion=2"-    ]--duplicateProjectionSpec :: T.Text-duplicateProjectionSpec =-  T.unlines-    [ "context svc",-      "",-      "aggregate Thing",-      "  regs",-      "  states Open",-      "",-      "  projection first consistency=Strong key=thingId",-      "    status-map partial { }",-      "  projection second consistency=Eventual key=thingId"-    ]--projectionWithoutConsistencySpec :: T.Text-projectionWithoutConsistencySpec =-  T.unlines-    [ "context svc",-      "",-      "aggregate Thing",-      "  regs",-      "  states Open",-      "",-      "  projection things key=thingId"-    ]--malformedRegisterSpec :: T.Text-malformedRegisterSpec =-  T.unlines-    [ "context svc",-      "",-      "aggregate Thing",-      "  regs",-      "    status Status",-      "  states Open"-    ]--misplacedDispatchIdSpec :: T.Text-misplacedDispatchIdSpec =-  T.replace-    "    schedule timer\n\n  dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)\n"-    "    dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)\n    schedule timer\n"-    (renderSpec (Spec "svc" Nothing Nothing [] [] [] [] [] [NProcess (processWithLiteral "literal")]))--lineNumberContaining :: T.Text -> T.Text -> Int-lineNumberContaining needle = go 1 . T.lines-  where-    go current = \case-      [] -> current-      lineText : rest-        | needle `T.isInfixOf` lineText -> current-        | otherwise -> go (current + 1) rest--decimalOverflow :: T.Text-decimalOverflow = "18446744073709551617"--decimalOverflowSpecs :: [(String, T.Text)]-decimalOverflowSpecs =-  [ ("event-version", eventVersionDecimalSpec decimalOverflow),-    ("wire-schema", wireDecimalSpec decimalOverflow),-    ("contract-schema", contractDecimalSpec decimalOverflow),-    ("decode-schema", decodeDecimalSpec decimalOverflow),-    ("publisher-attempts", publisherDecimalSpec decimalOverflow),-    ("workqueue-retries", workqueueDecimalSpec decimalOverflow),-    ("timer-attempts", timerDecimalSpec decimalOverflow)-  ]--eventVersionDecimalSpec :: T.Text -> T.Text-eventVersionDecimalSpec value =-  T.unlines-    [ "context svc",-      "",-      "aggregate Thing",-      "  regs",-      "  states Open",-      "",-      "  event Changed v" <> value <> " { }"-    ]--wireDecimalSpec :: T.Text -> T.Text-wireDecimalSpec value =-  T.unlines-    [ "context svc",-      "",-      "aggregate Thing",-      "  regs",-      "  states Open",-      "",-      "  wire kind=ctorName fields=camelCase schemaVersion=" <> value-    ]--contractDecimalSpec :: T.Text -> T.Text-contractDecimalSpec value =-  T.unlines-    [ "context svc",-      "",-      "contract Contract {",-      "  schemaVersion " <> value,-      "  discriminator kind",-      "}"-    ]--decodeDecimalSpec :: T.Text -> T.Text-decodeDecimalSpec value =-  T.unlines-    [ "context svc",-      "",-      "intake Inbox {",-      "  contract Contract",-      "  topic events",-      "  accept Event",-      "  dedupe key messageId policy PreferIntegrationMessageId",-      "  decode { envelope strict-required lenient-optional body strict schemaVersion == " <> value <> " }",-      "  disposition { }",-      "}"-    ]--publisherDecimalSpec :: T.Text -> T.Text-publisherDecimalSpec value =-  T.unlines-    [ "context svc",-      "",-      "publisher Publisher {",-      "  emit Emit",-      "  ordering PerKeyHeadOfLine",-      "  maxAttempts " <> value,-      "  backoff constant 2s",-      "  outboxId stable from messageId",-      "}"-    ]--workqueueDecimalSpec :: T.Text -> T.Text-workqueueDecimalSpec value =-  T.unlines-    [ "context svc",-      "",-      "workqueue Queue {",-      "  queue logical = \"queue\"",-      "  derive physical = \"queue\"",-      "    dlq = \"queue_dlq\"",-      "    table = \"pgmq.q_queue\"",-      "  payload Job { }",-      "  retry maxRetries = " <> value <> " delay = 5s dlq = on",-      "  disposition { }",-      "}"-    ]--timerDecimalSpec :: T.Text -> T.Text-timerDecimalSpec value =-  T.replace-    "max-attempts 5"-    ("max-attempts " <> value)-    (renderSpec (Spec "svc" Nothing Nothing [] [] [] [] [] [NProcess (processWithLiteral "literal")]))--identifierHygieneSpec :: T.Text-identifierHygieneSpec =-  T.unlines-    [ "context svc",-      "",-      "aggregate thing",-      "  regs",-      "  states Open",-      "",-      "  command DoIt { data }"-    ]--vertexCollisionSpec :: T.Text-vertexCollisionSpec =-  T.unlines-    [ "context svc",-      "",-      "aggregate Reservation",-      "  regs",-      "  states Created",-      "",-      "  event ReservationCreated { }"-    ]--underscoreNodeSpec :: T.Text-underscoreNodeSpec =-  T.unlines-    [ "context svc",-      "",-      "contract _contract {",-      "  schemaVersion 1",-      "  discriminator kind",-      "}"-    ]--normalizedCollisionSpec :: T.Text-normalizedCollisionSpec =-  T.unlines-    [ "context svc",-      "",-      "contract fooBar {",-      "  schemaVersion 1",-      "  discriminator kind",-      "}",-      "",-      "contract foo_bar {",-      "  schemaVersion 1",-      "  discriminator kind",-      "}"-    ]--unicodeIdentifierSpec :: T.Text-unicodeIdentifierSpec =-  T.unlines-    [ "context svc",-      "",-      "aggregate Résumé",-      "  regs",-      "  states Open"-    ]--emptyStatesSpec :: Spec-emptyStatesSpec =-  Spec-    "svc"-    Nothing-    Nothing-    []-    []-    []-    []-    []-    [NAggregate (Aggregate "Thing" [] [] [] [] [] Nothing Nothing Nothing noLoc)]--crossFamilyBoundarySpec :: T.Text-crossFamilyBoundarySpec =-  T.unlines-    [ "context svc",-      "",-      "aggregate First",-      "  regs",-      "  states A B",-      "  command Go { }",-      "  A -- Go -->",-      "    emit Changed",-      "    goto B",-      "",-      "emit Output {",-      "  contract Contract",-      "  topic events",-      "  source \"source\"",-      "  key thingId",-      "  map status { _ => skip }",-      "  messageId derive hole",-      "  idempotencyKey derive hole",-      "}",-      "",-      "aggregate Second",-      "  regs",-      "  states",-      "",-      "dispatch QueueDispatch {",-      "  source readModel = source key = thingId",-      "  fanout body = resolveFanout",-      "  dedup key = thingId",-      "    seenIn readModel = seen field = thingId",-      "    seenIn queue = workQueue field = thingId",-      "  enqueue to = workQueue",-      "}"-    ]------------------------------------------------------------------------------------- Generators (bounded; restricted to valid, non-reserved identifiers)------------------------------------------------------------------------------------- | Text that exercises every supported escape plus notation punctuation that--- used to be able to split one emit-map row into several rows.-genAdversarialText :: Gen T.Text-genAdversarialText =-  T.concat-    <$> resize-      20-      (listOf (elements ["a", "Z", "\"", "\\", "\n", "\t", "\r", "=>", "#", "{", "}", " "]))---- | One spec carrying the same adversarial value through three distinct--- printer paths: a contract topic, an emit-map value, and a quote-wrapped--- field-binding literal.-escapedSpec :: T.Text -> Spec-escapedSpec value =-  Spec-    "escape"-    Nothing-    Nothing-    []-    []-    []-    []-    []-    [ NContract-        ContractNode-          { ctrName = "Contract",-            ctrSchemaVersion = 1,-            ctrDiscriminator = "kind",-            ctrTopics = [("events", value)],-            ctrEvents = [],-            ctrLoc = noLoc-          },-      NEmit-        EmitNode-          { emName = "Emit",-            emContract = "Contract",-            emTopic = "events",-            emSource = "source",-            emKey = "key",-            emDiscriminant = "status",-            emMap = [EmitMapRow value "Event" noLoc],-            emSkip = True,-            emMessageId = DeriveSpec Nothing,-            emIdempotencyKey = DeriveSpec Nothing,-            emLoc = noLoc-          },-      NProcess (processWithLiteral value)-    ]--processWithLiteral :: T.Text -> ProcessNode-processWithLiteral value =-  ProcessNode-    { procId = "Process",-      procName = "process",-      procInput = InputDecl "Input" [],-      procCorrelate = CorrelateDecl "key" "idText",-      procSaga = SagaRef "Saga" "saga",-      procTarget = "Target",-      procProjections = [],-      procHandle =-        HandleNode-          { hOn = "Input",-            hAdvance = AdvanceNode "Advance" [FieldBinding "literal" (Just ("\"" <> value <> "\""))],-            hDispatch = [],-            hSchedule = "timer"-          },-      procRejected = PolHalt,-      procPoison = PolHalt,-      procTimer =-        TimerNode-          { tmName = "timer",-            tmId = IdExpr UuidV5Id "timer:" "correlationId",-            tmFireAt = FireAtExpr "observedAt" "5m",-            tmPayload = [],-            tmFire =-              FireNode-                { fireTarget = "Target",-                  fireKey = "correlationId",-                  fireCommand = "Fire",-                  fireFields = [],-                  fireFiredEventId = IdExpr UuidV5Id "fired:" "correlationId",-                  fireDisposition = FireDisposition OFired OFired ORetry ORetry ORetry-                },-            tmDecodeUnknown = "Cancelled",-            tmMaxAttempts = 5,-            tmDeadLetter = "exhausted",-            tmLoc = noLoc-          },-      procLoc = noLoc-    }--genName :: Gen Name-genName =-  frequency-    [ ( 3,-        do-          base <- elements ["Aa", "Bb", "Cc", "Dd", "St", "Cmd", "Ev", "Reg", "Fld", "Foo", "Bar", "Qux"]-          n <- choose (0, 9 :: Int)-          pure (T.pack (base <> show n))-      ),-      (1, elements ["data1", "typeA", "whereX", "gotoX", "guardY", "emitZ", "_lead"])-    ]--genWire :: Gen T.Text-genWire = do-  base <- elements ["red", "blue", "green", "ctorName", "camelCase", "rsv", "hosp", "held", "partial-divert", "1st"]-  n <- choose (0, 9 :: Int)-  pure (T.pack (base <> show n))--genWireWord :: Gen T.Text-genWireWord = genWire--smallList :: Gen a -> Gen [a]-smallList g = choose (0, 3 :: Int) >>= \n -> vectorOf n g--nonEmptyList :: Gen a -> Gen [a]-nonEmptyList g = choose (1, 3 :: Int) >>= \n -> vectorOf n g--genMaybe :: Gen a -> Gen (Maybe a)-genMaybe g = oneof [pure Nothing, Just <$> g]--genCmp :: Gen CmpOp-genCmp = elements [OpEq, OpNeq, OpLt, OpLe, OpGt, OpGe]--genAtom :: Gen Expr-genAtom = EAtom <$> oneof [AName <$> genName, ABool <$> arbitrary]--genExpr :: Gen Expr-genExpr = go (3 :: Int)-  where-    go 0 = genAtom-    go d =-      oneof-        [ genAtom,-          EOr <$> go (d - 1) <*> go (d - 1),-          EAnd <$> go (d - 1) <*> go (d - 1),-          ECmp <$> genCmp <*> go (d - 1) <*> go (d - 1)-        ]--genField :: Gen Field-genField = Field <$> genName <*> oneof [pure Nothing, Just <$> genName]--genAggregateField :: Gen AggregateField-genAggregateField = AggregateField <$> genName <*> pure Nothing <*> pure Nothing <*> genMaybe (genTypeExpr []) <*> pure noLoc--genReg :: Gen RegDecl-genReg = RegDecl <$> genName <*> genTypeExpr [] <*> genRegInitial <*> pure noLoc--genRegInitial :: Gen RegInitial-genRegInitial = oneof [RegInitBare <$> genName, RegInitText <$> genAdversarialText]--genState :: Gen StateDecl-genState = StateDecl <$> genName <*> arbitrary <*> pure noLoc--genCommand :: Gen Command-genCommand = Command <$> genName <*> smallList genAggregateField <*> pure noLoc--genEvent :: Gen Event-genEvent = do-  name <- genName-  eventBody <- body-  version <- choose (1, 3)-  upcast <- genMaybe ((,) <$> choose (0, 3) <*> pure Hole)-  (retiring, deprecated) <- elements [(False, False), (True, False), (False, True)]-  pure-    Event-      { evName = name,-        evBody = eventBody,-        evVersion = version,-        evUpcastFrom = upcast,-        evRetiring = retiring,-        evDeprecated = deprecated,-        evLoc = noLoc-      }-  where-    body = oneof [EventFromCommand <$> genName, EventFields <$> smallList genAggregateField]--genTransition :: Gen Transition-genTransition =-  Transition-    <$> genName-    <*> genName-    <*> pure LegacyHoleImplementation-    <*> genMaybe genExpr-    <*> smallList ((,) <$> genName <*> genExpr)-    <*> smallList genName-    <*> genName-    <*> elements [TmLive, TmReplayOnly]-    <*> pure noLoc--genWireSpec :: Gen WireSpec-genWireSpec = WireSpec <$> genWire <*> genWire <*> (getNonNegative <$> arbitrary)--genProjection :: Gen ProjectionSpec-genProjection =-  ProjectionSpec-    <$> genName-    <*> genMaybe (elements [Strong, Eventual])-    <*> genName-    <*> genMaybe (Mapping <$> smallList ((,) <$> genName <*> genWire) <*> arbitrary)-    <*> pure noLoc--genAggregate :: Gen Aggregate-genAggregate =-  Aggregate-    <$> genName-    <*> smallList genReg-    <*> smallList genState-    <*> smallList genCommand-    <*> smallList genEvent-    <*> smallList genTransition-    <*> genMaybe genWireSpec-    <*> genMaybe genProjection-    <*> genMaybe (SnapshotSpec <$> oneof [SnapEvery <$> choose (0, 5), pure SnapOnTerminal] <*> choose (0, 5) <*> genAdversarialText <*> pure noLoc)-    <*> pure noLoc--genDottedRef :: Gen T.Text-genDottedRef = elements ["input.id", "input.hospitalId", "timer.id", "correlationId", "payload.messageId"]--genWindow :: Gen T.Text-genWindow = elements ["0s", "5s", "2m", "1h"]--genFieldBinding :: Gen FieldBinding-genFieldBinding =-  FieldBinding-    <$> genName-    <*> oneof-      [ pure Nothing,-        Just <$> genDottedRef,-        Just . (\raw -> "\"" <> raw <> "\"") <$> genAdversarialText-      ]--genDispatchDisposition :: Gen DispatchDisposition-genDispatchDisposition = DispatchDisposition <$> genDisp <*> genDisp <*> genDisp-  where-    genDisp = oneof [pure DAckOk, pure DRetry, DDeadLetter <$> genAdversarialText]--genDispatchNode :: Gen DispatchNode-genDispatchNode =-  DispatchNode-    <$> genName-    <*> genDottedRef-    <*> genName-    <*> smallList genFieldBinding-    <*> genDispatchDisposition-    <*> pure noLoc--genFireDisposition :: Gen FireDisposition-genFireDisposition =-  FireDisposition-    <$> elements [OFired, ORetry]-    <*> elements [OFired, ORetry]-    <*> elements [OFired, ORetry]-    <*> elements [OFired, ORetry]-    <*> elements [OFired, ORetry]--genIdExpr :: Gen IdExpr-genIdExpr = IdExpr UuidV5Id <$> genAdversarialText <*> pure "correlationId"--genFireNode :: Gen FireNode-genFireNode =-  FireNode-    <$> genName-    <*> genDottedRef-    <*> genName-    <*> smallList genFieldBinding-    <*> genIdExpr-    <*> genFireDisposition--genTimerNode :: Gen TimerNode-genTimerNode =-  TimerNode-    <$> genName-    <*> genIdExpr-    <*> (FireAtExpr <$> genName <*> genWindow)-    <*> smallList genFieldBinding-    <*> genFireNode-    <*> genName-    <*> choose (0, 5)-    <*> genAdversarialText-    <*> pure noLoc--genProcess :: Gen ProcessNode-genProcess =-  ProcessNode-    <$> genName-    <*> genAdversarialText-    <*> (InputDecl <$> genName <*> smallList genField)-    <*> (CorrelateDecl <$> genName <*> genName)-    <*> (SagaRef <$> genName <*> genAdversarialText)-    <*> genName-    <*> smallList genName-    <*> (HandleNode <$> genName <*> (AdvanceNode <$> genName <*> smallList genFieldBinding) <*> smallList genDispatchNode <*> genName)-    <*> elements [PolHalt, PolDeadLetter, PolSkip]-    <*> elements [PolHalt, PolDeadLetter, PolSkip]-    <*> genTimerNode-    <*> pure noLoc--genResolveSource :: Gen ResolveSource-genResolveSource = oneof [ResolveReadModel <$> genName, pure ResolveHole]--genRouter :: Gen RouterNode-genRouter =-  RouterNode-    <$> genName-    <*> genAdversarialText-    <*> (InputDecl <$> genName <*> smallList genField)-    <*> (CorrelateDecl <$> genName <*> genName)-    <*> (ResolveDecl <$> genResolveSource <*> smallList genName <*> pure noLoc)-    <*> genName-    <*> smallList genName-    <*> (RouterDispatchNode <$> genName <*> smallList genFieldBinding <*> genDispatchDisposition <*> pure noLoc)-    <*> elements [PolHalt, PolDeadLetter, PolSkip]-    <*> elements [PolHalt, PolDeadLetter, PolSkip]-    <*> pure noLoc--genContractField :: Gen ContractField-genContractField = ContractField <$> genName <*> pure Nothing <*> pure Nothing <*> oneof [CTypeId <$> genAdversarialText, pure CText, pure CInt] <*> pure noLoc--genContractEvent :: Gen ContractEvent-genContractEvent = ContractEvent <$> genName <*> genName <*> smallList genContractField--genContract :: Gen ContractNode-genContract =-  ContractNode-    <$> genName-    <*> choose (0, 5)-    <*> genName-    <*> smallList ((,) <$> genName <*> genAdversarialText)-    <*> smallList genContractEvent-    <*> pure noLoc--genWireSource :: Gen WireSource-genWireSource = oneof [SrcHeader <$> genAdversarialText, pure SrcBody, pure SrcKafkaKey, pure SrcKafkaCursor]--genInboxAction :: Gen InboxAction-genInboxAction = oneof [pure IAckOk, IRetry <$> genWindow, IDeadLetter <$> genMaybe genAdversarialText]--genDispositionRow :: Gen DispositionRow-genDispositionRow = DispositionRow <$> genName <*> genInboxAction <*> pure noLoc--genDecodeSpec :: Gen DecodeSpec-genDecodeSpec =-  DecodeSpec-    <$> ((\first second -> first <> " " <> second) <$> genWireWord <*> genWireWord)-    <*> arbitrary-    <*> choose (0, 5)--genIntake :: Gen IntakeNode-genIntake =-  IntakeNode-    <$> genName-    <*> genName-    <*> genName-    <*> nonEmptyList genName-    <*> smallList (BindRow <$> genName <*> genWireSource <*> arbitrary <*> arbitrary)-    <*> genName-    <*> genName-    <*> elements [InkPersistFull, InkPersistDedupeOnly]-    <*> genDecodeSpec-    <*> smallList genDispositionRow-    <*> pure noLoc--genDeriveSpec :: Gen DeriveSpec-genDeriveSpec = DeriveSpec <$> genMaybe genAdversarialText--genEmit :: Gen EmitNode-genEmit =-  EmitNode-    <$> genName-    <*> genName-    <*> genName-    <*> genAdversarialText-    <*> genName-    <*> genName-    <*> smallList (EmitMapRow <$> genAdversarialText <*> genName <*> pure noLoc)-    <*> arbitrary-    <*> genDeriveSpec-    <*> genDeriveSpec-    <*> pure noLoc--genPublisher :: Gen PublisherNode-genPublisher =-  PublisherNode-    <$> genName-    <*> genName-    <*> genName-    <*> choose (0, 5)-    <*> (BackoffSpec <$> genName <*> genWindow <*> genMaybe genWindow <*> genMaybe (elements ["1.0", "2.0", "3"]))-    <*> genName-    <*> pure noLoc--genWqField :: Gen WqField-genWqField = WqField <$> genName <*> genAdversarialText <*> genName--genWqDispRow :: Gen WqDispRow-genWqDispRow = WqDispRow <$> genName <*> genInboxAction <*> pure noLoc--genWorkqueue :: Gen WorkqueueNode-genWorkqueue =-  WorkqueueNode-    <$> genName-    <*> genAdversarialText-    <*> genAdversarialText-    <*> genAdversarialText-    <*> genAdversarialText-    <*> elements [WqUnordered, WqFifoThroughput, WqFifoRoundRobin]-    <*> genMaybe (WqGroupKey <$> genName <*> genName <*> genMaybe genAdversarialText)-    <*> oneof [pure WqStandard, pure WqUnlogged, WqPartitioned <$> genAdversarialText <*> genAdversarialText]-    <*> genName-    <*> smallList genWqField-    <*> choose (0, 5)-    <*> genWindow-    <*> arbitrary-    <*> smallList genWqDispRow-    <*> pure noLoc--genReadModel :: Gen ReadModelNode-genReadModel =-  ReadModelNode-    <$> genName-    <*> genAdversarialText-    <*> genAdversarialText-    <*> smallList (RmColumn <$> genWireWord <*> genName <*> arbitrary)-    <*> choose (0, 5)-    <*> genAdversarialText-    <*> elements [Strong, Eventual]-    <*> genMaybe (oneof [pure RmEntireLog, RmCategory <$> genAdversarialText])-    <*> elements [RmInline, RmSubscription]-    <*> genMaybe genAdversarialText-    <*> pure noLoc--genPgmqDispatch :: Gen PgmqDispatchNode-genPgmqDispatch =-  PgmqDispatchNode-    <$> genName-    <*> genName-    <*> genName-    <*> genName-    <*> genName-    <*> genName-    <*> genName-    <*> genName-    <*> genName-    <*> genName-    <*> pure noLoc--genWfBodyItem :: Gen WfBodyItem-genWfBodyItem = sized go-  where-    go size =-      oneof $-        [ WfStep <$> genWireWord <*> genName <*> pure noLoc,-          WfAwait <$> genWireWord <*> genName <*> pure noLoc,-          WfSleep <$> genWireWord <*> genName <*> pure noLoc,-          WfChild <$> genWireWord <*> genName <*> genName <*> pure noLoc,-          WfContinueAsNew <$> genName <*> pure noLoc-        ]-          ++ [ WfPatch <$> genWireWord <*> resize (size `div` 2) (smallList genWfBodyItem) <*> pure noLoc-             | size > 0-             ]--genWorkflow :: Gen WorkflowNode-genWorkflow =-  WorkflowNode-    <$> genName-    <*> genAdversarialText-    <*> genName-    <*> smallList genField-    <*> genName-    <*> genMaybe genName-    <*> genName-    <*> smallList genWfBodyItem-    <*> pure noLoc--genOperationShape :: Gen OperationShape-genOperationShape =-  oneof-    [ CommandOp <$> genName <*> genName <*> genName <*> smallList genName,-      QueryOp <$> genName <*> genName <*> ((\parts -> T.unwords parts) <$> nonEmptyList genName) <*> genName,-      SignalOp <$> genWireWord <*> genName <*> genName <*> genName <*> genName,-      RunOp <$> genName <*> genName <*> genName-    ]--genOperation :: Gen OperationNode-genOperation = OperationNode <$> genName <*> genOperationShape <*> pure noLoc--allNodeTags :: [String]-allNodeTags = ["aggregate", "process", "router", "contract", "intake", "emit", "publisher", "workqueue", "pgmq-dispatch", "readmodel", "workflow", "operation"]--nodeTag :: Node -> String-nodeTag = \case-  NAggregate _ -> "aggregate"-  NProcess _ -> "process"-  NRouter _ -> "router"-  NContract _ -> "contract"-  NIntake _ -> "intake"-  NEmit _ -> "emit"-  NPublisher _ -> "publisher"-  NWorkqueue _ -> "workqueue"-  NPgmqDispatch _ -> "pgmq-dispatch"-  NReadModel _ -> "readmodel"+import Data.List (find, partition, permutations, sort, (\\))+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Data.Text.Lazy qualified as LazyText+import Data.Text.Lazy.Encoding qualified as LazyTextEncoding+import Data.Version (showVersion)+import Keiki.ProjectionDomain (matchesTextPattern)+import Keiro.Codec (Codec (..), EventType (..), decodeRaw)+import Keiro.Codec.IdDomain (IdDomainFailure (..), idDomainSampleText, idDomainTextPattern, parseKindIdV7Text, parseKindIdV7Value, typeIdV7Domain, validateIdDomainText)+import Keiro.Dsl.AggregateType+import Keiro.Dsl.BehaviorCoverage qualified as Behavior+import Keiro.Dsl.BehaviorSourceMap qualified as BehaviorSource+import Keiro.Dsl.CanonicalEncoding (foldFingerprint128)+import Keiro.Dsl.CodecCompare+import Keiro.Dsl.ConformanceBaseline (conformanceBaselineSpec)+import Keiro.Dsl.ConformancePackage+import Keiro.Dsl.ConsumerTypePlan+import Keiro.Dsl.CoordinationImpact+import Keiro.Dsl.Coverage qualified as Coverage+import Keiro.Dsl.Diff (Change (..), ChangeKind (..), CompatibilitySurface (..), CompatibilityVector (..), FamilyDiff (..), Label (..), MappedPersistedImpact (..), MappedPersistedSurface (..), NodeFamily, RolloutConstraint (..), SurfaceVerdict (..), defaultGate, deriveLabel, familyRegistry, gateWith, gatedBreaking, isAdvisory, isBreaking, verdictFor)+import Keiro.Dsl.Diff qualified as CheckedDiff+import Keiro.Dsl.DiffReport (Remedy (..), diffReport, diffReportWithImpacts, diffReportWithSemanticImpact, parseSurfaceName, remediationFor, renderExplainBlock, renderFinding, renderSemanticImpact)+import Keiro.Dsl.EventOutput+import Keiro.Dsl.ExplainBindings (BindingHole (..), BindingObligation (..), BindingObligationKind (..), bindingHoles, bindingObligations, bindingObligationsForService, renderBindingObligations)+import Keiro.Dsl.Expression+import Keiro.Dsl.FoldFingerprint (FoldSurfaceError (..))+import Keiro.Dsl.FoldFingerprint qualified as CheckedFold+import Keiro.Dsl.Frontend (FrontendErrorCode (..), FrontendFailure (..), LoweringFailure (..), LoweringFailureCode (..), lowerSurfaceDocument, parseSurfaceSource)+import Keiro.Dsl.FrontendCompatibility (frontendCompatibilitySpec)+import Keiro.Dsl.FrontendProfiles (frontendProfilesSpec)+import Keiro.Dsl.FrontendSurface (frontendSurfaceSpec)+import Keiro.Dsl.Goldens (GoldenEvidence (..), GoldenPayload (..), emitGoldenPayloads, goldenRelativePath, goldensForDiff)+import Keiro.Dsl.Grammar+import Keiro.Dsl.Harness (harnessFor, harnessForService, harnessForWithGoldens, harnessReadModel, harnessRouter, harnessWorkflow)+import Keiro.Dsl.HaskellImport+import Keiro.Dsl.HaskellSourceMove+import Keiro.Dsl.IdDomain (IdDomainContract (..), contractIdDomainContractFor, idDomainContractFor, idDomainIdentitiesForService)+import Keiro.Dsl.LanguageVersion+import Keiro.Dsl.Manifest (manifestDependencies, manifestDependenciesForService, moduleNameOf, renderManifest, renderManifestForService, renderManifestForServiceWithFacade)+import Keiro.Dsl.MappedCodecPlan+import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), MappingIdentity (..), consumerPlan)+import Keiro.Dsl.MappedDiff (diffMapped)+import Keiro.Dsl.NominalType hiding (NominalInvalidHaskellSource, NominalInvalidIdPrefix, NominalInvalidIdentity, NominalMissingIngredient)+import Keiro.Dsl.Parser (parseSource, parseSourceDocument, parseSpec)+import Keiro.Dsl.PrettyPrint (renderSource, renderSpec, renderTransition)+import Keiro.Dsl.ProjectionMappedImpact qualified as ProjectionImpact+import Keiro.Dsl.ProjectionSupply+import Keiro.Dsl.ReadModelQueryContract (QueryContractDrift (..), QueryContractIdentity (..), QueryContractPosition (..), queryContractIdentities)+import Keiro.Dsl.ReadModelShape (canonicalShape, deriveShapeHash, registryNameFor, subscriptionNameFor)+import Keiro.Dsl.ReplayImpact (AggregateImpact (..), CatalogReplayImpact (..), ReplayImpact (..))+import Keiro.Dsl.ReplayImpact qualified as ReplayImpact+import Keiro.Dsl.RouterSelection qualified as RouterSelection+import Keiro.Dsl.Scaffold (Context (..), ModuleKind (..), ModuleRole (..), NominalGenerationOwner (..), NominalUseSite (..), ScaffoldModule (..), StructuralProjection (..), codecComparisonBanner, codecComparisonModule, defaultContext, firewallBreaches, genPrefixFor, generatedBanner, generatedBannerFor, generatedNominalModule, holePrefixFor, isGeneratedBannerLine, moduleRole, obsoleteGeneratedOutputHooks, planNominalGeneration, projectionSpecs, scaffoldAggregate, scaffoldAggregateForService, scaffoldContract, scaffoldContractForService, scaffoldIntake, scaffoldProcess, scaffoldProjectionCatalog, scaffoldPublisher, scaffoldReadModel, scaffoldReadModelForService, scaffoldRefusals, scaffoldReplayAudit, scaffoldRouter, scaffoldStructural, scaffoldWorkqueue, scaffoldWorkqueueForService, windowSeconds)+import Keiro.Dsl.ScaffoldRecord (GeneratedHaskellNamingEdition (..), ScaffoldModuleRoleRow (..), ScaffoldRecord (..), parseRecord, projectionCatalogFacts, projectionCatalogFactsForService, recordFileName, renderRecord)+import Keiro.Dsl.ScaffoldRun (GeneratedArtifactCategory (..), GeneratedArtifactImpact (..), MappingDrift (..), QueryContractMigration (..), Refusal (..), ScaffoldReport (..), SourceLanguageDrift (..), StaleGeneratedEvidence (..), StaleModule (..), WriteDisposition (..), auditGeneratedHaskell, checkIndexedServiceDiagnostics, executeScaffold, executeScaffoldWithLanguage, executeServiceScaffold, executeServiceScaffoldWithRuntimePackage, executeServiceScaffoldWithRuntimePackageAndNameMigrations, planIndexedServiceScaffold, planIndexedServiceScaffoldWithRuntimePackage, planningRefusalDiagnostics, renderRefusals, renderScaffoldReport, renderSemanticImpactReport, scaffoldModules, scaffoldServiceModules)+import Keiro.Dsl.SemanticContract+import Keiro.Dsl.SemanticImpact+import Keiro.Dsl.ServiceHarness+import Keiro.Dsl.SidecarMigration+import Keiro.Dsl.SidecarNames+import Keiro.Dsl.Skeleton (skeletonFor, skeletonKinds)+import Keiro.Dsl.Source (SourcePoint (..), SourceSpan (..))+import Keiro.Dsl.SourceIndex+import Keiro.Dsl.TypeGraph+import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), Severity (..), derivedQueueTrio, diagnosticCodeText, parseDiagnosticCode, renderDiagnostic, validateService, validateSpec)+import Keiro.Dsl.Workspace+import Keiro.Dsl.WorkspaceAdoption+import Keiro.Dsl.WorkspaceDiff hiding (diffWorkspaces)+import Keiro.Dsl.WorkspaceDiff qualified as CheckedWorkspaceDiff+import Keiro.Dsl.WorkspaceRecord+import Keiro.Dsl.WorkspaceScaffold+import Paths_keiro_dsl qualified as Package+import System.Directory (canonicalizePath, createDirectory, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getTemporaryDirectory, listDirectory, removeFile, removePathForcibly, renameFile)+import System.Environment (lookupEnv)+import System.Exit (ExitCode (..))+import System.FilePath (takeDirectory, takeExtension, takeFileName, (</>))+import System.IO (hClose, openTempFile)+import System.Process (readProcessWithExitCode)+import Test.Hspec hiding (Spec)+import Test.QuickCheck++resolvedFold :: Either FoldSurfaceError value -> value+resolvedFold = either (error . ("unexpected fold-surface failure in checked fixture: " <>) . show) id++aggregateFoldFingerprintForService :: CheckedService -> Aggregate -> T.Text+aggregateFoldFingerprintForService service aggregate = resolvedFold (CheckedFold.aggregateFoldFingerprintForService service aggregate)++aggregateFoldSurfaceForService :: CheckedService -> Aggregate -> T.Text+aggregateFoldSurfaceForService service aggregate = resolvedFold (CheckedFold.aggregateFoldSurfaceForService service aggregate)++aggregateFoldFingerprint :: Spec -> Aggregate -> T.Text+aggregateFoldFingerprint spec aggregate = aggregateFoldFingerprintForService (stableCheckedService spec) aggregate++aggregateFoldSurface :: Spec -> Aggregate -> T.Text+aggregateFoldSurface spec aggregate = aggregateFoldSurfaceForService (stableCheckedService spec) aggregate++legacyAggregateFoldFingerprint :: Spec -> Aggregate -> T.Text+legacyAggregateFoldFingerprint spec aggregate = aggregateFoldFingerprintForService (legacyCheckedService spec) aggregate++legacyAggregateFoldSurface :: Spec -> Aggregate -> T.Text+legacyAggregateFoldSurface spec aggregate = aggregateFoldSurfaceForService (legacyCheckedService spec) aggregate++diffServices :: CheckedService -> CheckedService -> [Change]+diffServices old new = resolvedFold (CheckedDiff.diffServices old new)++diffSources :: ParsedSource -> ParsedSource -> [Change]+diffSources old new = resolvedFold (CheckedDiff.diffSources old new)++diffSpecs :: Spec -> Spec -> [Change]+diffSpecs old new = diffServices (stableCheckedService old) (stableCheckedService new)++legacyDiffSpecs :: Spec -> Spec -> [Change]+legacyDiffSpecs old new = diffServices (legacyCheckedService old) (legacyCheckedService new)++diffWorkspaces :: WorkspaceSpec -> WorkspaceSpec -> [WorkspaceChange]+diffWorkspaces old new = resolvedFold (CheckedWorkspaceDiff.diffWorkspaces old new)++replayImpactSpecs :: Spec -> Spec -> ReplayImpact+replayImpactSpecs old new =+  resolvedFold (ReplayImpact.replayImpactServices (stableCheckedService old) (stableCheckedService new))++legacyReplayImpactSpecs :: Spec -> Spec -> ReplayImpact+legacyReplayImpactSpecs old new =+  resolvedFold (ReplayImpact.replayImpactServices (legacyCheckedService old) (legacyCheckedService new))++nominalEqualityIdentities :: Spec -> [T.Text]+nominalEqualityIdentities = nominalEqualityIdentitiesForService . stableCheckedService++stableCheckedService :: Spec -> CheckedService+stableCheckedService = checkedService stableSourceLanguage++stableSourceLanguage :: SourceLanguage+stableSourceLanguage =+  DeclaredLanguage+    { declaredLanguageVersion = currentStableLanguageVersion,+      languageVersionLoc = noLoc+    }++main :: IO ()+main = hspec $ do+  conformanceBaselineSpec+  frontendCompatibilitySpec+  frontendSurfaceSpec+  frontendProfilesSpec++  describe "mapped consumer surface" $ do+    it "parses and canonically round-trips Language 5 queue and query expressions as atomic forms" $ do+      source <- mappedConsumerSurfaceSource+      parsed <- case parseSource "<mapped-consumer>" source of+        Left failure -> expectationFailure (show failure) >> fail "unreachable"+        Right value -> pure value+      parseSource "<mapped-consumer-roundtrip>" (renderSource parsed) `shouldBe` Right parsed+      let spec = parsedSpec parsed+      case [field | NWorkqueue workqueue <- specNodes spec, field <- wqPayload workqueue] of+        [field] -> do+          wqfType field `shouldBe` TypedQueueExpression (TList (TOptional (TRef "ArtifactInfo")))+          unLoc (wqfLoc field) `shouldSatisfy` (> 0)+        fields -> expectationFailure ("unexpected mapped queue fields: " <> show fields)+      case [types | NReadModel readModel <- specNodes spec, Just types <- [queryTypes readModel]] of+        [ReadModelQueryTypes {input, result}] -> do+          input `shouldBe` TRef "ArtifactInfo"+          result `shouldBe` TOptional (TRef "ArtifactLocation")+        queryPairs -> expectationFailure ("unexpected mapped query pairs: " <> show queryPairs)+      let missingInput = T.replace "  query input = ArtifactInfo\n" "" source+          missingResult = T.replace "  query result = Optional ArtifactLocation\n" "" source+      parseSource "<mapped-consumer-missing-input>" missingInput `shouldSatisfy` isLeft+      parseSource "<mapped-consumer-missing-result>" missingResult `shouldSatisfy` isLeft++    it "resolves nested queue and query roots and plans one deterministic consumer-facing Haskell type" $ do+      source <- mappedConsumerSurfaceSource+      spec <- parseInlineSpec "<mapped-consumer-graph>" source+      graph <- shouldResolveTypeGraph spec+      map renderUsePath (usePaths graph "ArtifactLocation")+        `shouldContain` [ "workqueue ArtifactJobs payload .jobData : ArtifactInfo [] optional .location : ArtifactLocation",+                          "readmodel ArtifactLookup query input : ArtifactInfo .location : ArtifactLocation",+                          "readmodel ArtifactLookup query result : ArtifactLocation optional"+                        ]+      planConsumerType graph (RList (ROptional (RRef (MappedKey "ArtifactInfo"))))+        `shouldBe` Right+          ConsumerTypePlan+            { haskellType = HaskellTypeOccurrence "[Maybe ArtifactInfo]",+              imports =+                [ ImportRequirement "artifact-domain" "Example.Artifact.Domain" "ArtifactInfo",+                  ImportRequirement "base" "Data.Maybe" "Maybe"+                ],+              dependencies = Set.fromList [MappedKey "ArtifactInfo", MappedKey "ArtifactKind", MappedKey "ArtifactLocation"]+            }+      unresolved <-+        parseInlineSpec+          "<mapped-consumer-unresolved>"+          (T.replace "List (Optional ArtifactInfo)" "List (Optional MissingPayload)" source)+      case resolveTypeGraph unresolved of+        Left errors ->+          NE.toList errors+            `shouldSatisfy` any+              ( \case+                  TGUnresolvedConsumerRef owner missing loc ->+                    owner == "workqueue 'ArtifactJobs' payload field 'jobData'"+                      && missing == "MissingPayload"+                      && unLoc loc > 0+                  _ -> False+              )+        Right _ -> expectationFailure "unresolved mapped queue reference unexpectedly resolved"++    it "plans one recursive mapped codec algebra for consumer and structural boundaries" $ do+      source <- mappedConsumerSurfaceSource+      spec <- parseInlineSpec "<mapped-codec-plan>" source+      graph <- shouldResolveTypeGraph spec+      let expression = RList (ROptional (RRef (MappedKey "ArtifactInfo")))+      case planMappedCodec graph expression of+        Left failure -> expectationFailure (show failure)+        Right planned -> do+          authority planned `shouldBe` Set.singleton (StructuralAuthority (MappedKey "ArtifactInfo"))+          renderMappedEncode graph ConsumerValueBoundary planned "payload.jobs"+            `shouldBe` "toJSON (map (\\item -> maybe Null (\\item -> encodeArtifactInfoMapped item) (item)) (payload.jobs))"+          renderMappedParse graph ConsumerValueBoundary planned+            `shouldBe` "\\value -> (parseJSON value :: Parser [Value]) >>= traverse (\\value -> case value of Null -> pure Nothing; other -> Just <$> parseArtifactInfoMapped other)"+          let references = consumerTypeReferences (consumerType planned)+          case planHaskellImports (ImportEnvironment "Generated.Test.Queue" (Set.singleton "Payload") Set.empty) references of+            Left failure -> expectationFailure (show failure)+            Right importPlan ->+              renderConsumerType importPlan graph expression+                `shouldBe` Right (HaskellTypeOccurrence "[Maybe ArtifactInfo]")++    it "derives mapped projection impact from aggregate event authority and exposes heterogeneous boundaries" $ do+      source <- mappedConsumerSurfaceSource+      base <- parseInlineSpec "<mapped-consumer-projections>" source+      let projection = ProjectionSpec "artifact_view" (Just Eventual) "key" Nothing noLoc+          withInlineProjection node = case node of+            NAggregate aggregate -> NAggregate aggregate {aggProjection = Just projection}+            NReadModel readModel@ReadModelNode {rmName = "ArtifactLookup"} ->+              NReadModel+                readModel+                  { rmGroup = Just "artifact_group",+                    rmObservedTargets = ["artifact_target"]+                  }+            other -> other+          owner name sourceKind feed groupName targetNames replayPolicy =+            NProjectionOwner+              ProjectionOwnerNode+                { poName = name,+                  poSources = [sourceKind],+                  poDelivery = case feed of RmInline -> DeliveryInline; RmSubscription -> DeliverySubscription,+                  poGroup = groupName,+                  poTargets = targetNames,+                  poOrder = 1,+                  poSubscription = if feed == RmSubscription then Just (name <> "-subscription") else Nothing,+                  poDedup = if feed == RmSubscription then Just (name <> "-dedup") else Nothing,+                  poCheckpointOnMissing = if feed == RmSubscription then [CheckpointFromBeginning] else [],+                  poReplay = replayPolicy,+                  poLoc = noLoc+                }+          target name = NProjectionTarget (ProjectionTargetNode name "public" name TargetClear [] noLoc)+          groupNode name targetName = NRebuildGroup (RebuildGroupNode name [targetName] [targetName] noLoc)+          disjointReadModel =+            NReadModel+              ReadModelNode+                { rmName = "DisjointLookup",+                  rmTable = "disjoint_lookup",+                  rmSchema = "public",+                  rmColumns = [],+                  rmVersion = 1,+                  rmShape = "fixture",+                  rmFreshness = FreshnessImmediate,+                  rmSupply = LegacyReadModelSupply Eventual Nothing RmSubscription (Just "disjoint-lookup"),+                  rmGroup = Just "disjoint_group",+                  rmObservedTargets = ["disjoint_target"],+                  rmBackingTarget = Nothing,+                  queryTypes = Nothing,+                  rmLoc = noLoc+                }+          spec =+            base+              { specNodes =+                  map withInlineProjection (specNodes base)+                    <> [ target "artifact_target",+                         target "disjoint_target",+                         groupNode "artifact_group" "artifact_target",+                         groupNode "disjoint_group" "disjoint_target",+                         owner "artifactProjection" (CatalogAggregate "Catalog") RmSubscription "artifact_group" ["artifact_target"] ProjectionReplayExplicit,+                         owner "liveProjection" (CatalogAggregate "Catalog") RmInline "disjoint_group" ["disjoint_target"] (ProjectionLiveOnly "live only"),+                         owner "categoryProjection" (CatalogCategory "artifact") RmSubscription "artifact_group" ["artifact_target"] ProjectionReplayExplicit,+                         owner "allProjection" CatalogAll RmInline "disjoint_group" ["disjoint_target"] (ProjectionLiveOnly "heterogeneous"),+                         disjointReadModel+                       ]+              }+      impact <- semanticImpact <$> shouldResolveTypeGraph spec+      Set.fromList (mappedDeclarationConsumers impact (MappedKey "ArtifactLocation"))+        `shouldBe` Set.fromList+          [ AggregateConsumer "Catalog",+            WorkqueueConsumer "ArtifactJobs",+            ReadModelQueryConsumer "ArtifactLookup" MappedQueryInput,+            ReadModelQueryConsumer "ArtifactLookup" MappedQueryResult,+            DerivedProjectionConsumer (AggregateInlineProjectionConsumer "Catalog" "artifact_view"),+            DerivedProjectionConsumer (CatalogProjectionConsumer "artifactProjection" "Catalog"),+            DerivedProjectionConsumer (CatalogProjectionConsumer "liveProjection" "Catalog")+          ]+      Set.fromList (impactUnsupportedProjectionSources impact)+        `shouldBe` Set.fromList+          [ UnsupportedCatalogCategory "categoryProjection" "artifact",+            UnsupportedCatalogAll "allProjection"+          ]+      let projected = ProjectionImpact.projectionMappedImpact (stableCheckedService spec) impact+          locationConsumers = ProjectionImpact.projectionConsumersFor projected (MappedKey "ArtifactLocation")+      locationConsumers+        `shouldBe` Set.fromList+          [ AggregateInlineProjectionConsumer "Catalog" "artifact_view",+            CatalogProjectionConsumer "artifactProjection" "Catalog",+            CatalogProjectionConsumer "liveProjection" "Catalog"+          ]+      ( [ renderUsePath inheritedPath+        | ProjectionImpact.ProjectionMappedRoot derived declarationKey inheritedPath <- ProjectionImpact.roots projected,+          derived == CatalogProjectionConsumer "artifactProjection" "Catalog",+          declarationKey == MappedKey "ArtifactLocation"+        ]+        )+        `shouldBe` ["Catalog event ArtifactObserved .artifact : ArtifactInfo .location : ArtifactLocation"]+      ProjectionImpact.projectionOperationsFor projected (MappedKey "ArtifactLocation")+        `shouldBe` [ ProjectionImpact.ProjectionOperationalImpact+                       (AggregateInlineProjectionConsumer "Catalog" "artifact_view")+                       Nothing+                       (Set.singleton "artifact_view")+                       Set.empty+                       False+                       (ProjectionImpact.projectionAggregateSourceFingerprint spec "Catalog"),+                     ProjectionImpact.ProjectionOperationalImpact+                       (CatalogProjectionConsumer "artifactProjection" "Catalog")+                       (Just "artifact_group")+                       (Set.singleton "artifact_target")+                       (Set.singleton "ArtifactLookup")+                       True+                       (ProjectionImpact.projectionAggregateSourceFingerprint spec "Catalog"),+                     ProjectionImpact.ProjectionOperationalImpact+                       (CatalogProjectionConsumer "liveProjection" "Catalog")+                       (Just "disjoint_group")+                       (Set.singleton "disjoint_target")+                       (Set.singleton "DisjointLookup")+                       False+                       (ProjectionImpact.projectionAggregateSourceFingerprint spec "Catalog")+                   ]+      ProjectionImpact.unsupported projected+        `shouldBe` [ ProjectionImpact.UnsupportedProjectionImpact+                       (UnsupportedCatalogCategory "categoryProjection" "artifact")+                       "artifact_group"+                       (Set.singleton "artifact_target")+                       (Set.singleton "ArtifactLookup")+                       True,+                     ProjectionImpact.UnsupportedProjectionImpact+                       (UnsupportedCatalogAll "allProjection")+                       "disjoint_group"+                       (Set.singleton "disjoint_target")+                       (Set.singleton "DisjointLookup")+                       False+                   ]+      let baseFingerprint = ProjectionImpact.projectionAggregateSourceFingerprint spec "Catalog"+          wireChanged = mapMappedDeclaration "ArtifactLocation" changeProjectionMappedWire spec+          commandOnly = projectionEventWithoutGeometry spec+          commandOnlyChanged = mapMappedDeclaration "VendorGeometry" changeProjectionMappedWire commandOnly+      ProjectionImpact.projectionAggregateSourceFingerprint wireChanged "Catalog" `shouldNotBe` baseFingerprint+      ProjectionImpact.projectionAggregateSourceFingerprint commandOnlyChanged "Catalog"+        `shouldBe` ProjectionImpact.projectionAggregateSourceFingerprint commandOnly "Catalog"+      let generatedCatalog candidate =+            generatedTextEndingIn "ProjectionCatalog.hs" (scaffoldProjectionCatalog (defaultContext (specContext candidate)) candidate)+          baseCatalog = generatedCatalog spec+      baseCatalog `shouldSatisfy` T.isInfixOf (T.pack (show baseFingerprint))+      generatedCatalog wireChanged `shouldNotBe` baseCatalog+      generatedCatalog commandOnlyChanged `shouldBe` generatedCatalog commandOnly+      let projectionChanges =+            [ kindOfChange change+            | change <- diffSpecs spec wireChanged,+              ckFacet (kindOfChange change) == "mapped-projection"+            ]+      map ckNode projectionChanges `shouldBe` ["Catalog", "artifactProjection", "liveProjection"]+      map ckSubject projectionChanges+        `shouldBe` [ "aggregate-projection:Catalog:artifact_view inherits ArtifactLocation",+                     "catalog-projection:artifactProjection:Catalog inherits ArtifactLocation",+                     "catalog-projection:liveProjection:Catalog inherits ArtifactLocation"+                   ]+      map ckPaths projectionChanges+        `shouldBe` replicate 3 ["Catalog event ArtifactObserved .artifact : ArtifactInfo .location : ArtifactLocation"]+      projectionChanges `shouldSatisfy` all ((== VAdvisory) . cvConsumerBuild . ckVector)+      map ckDetail projectionChanges+        `shouldSatisfy` any (T.isInfixOf "group=artifact_group, targets=[artifact_target], read-models=[ArtifactLookup], replayable=yes")+      [kindOfChange change | change <- diffSpecs commandOnly commandOnlyChanged, ckFacet (kindOfChange change) == "mapped-projection"]+        `shouldBe` []+      case ReplayImpact.catalogReplayImpactServices (stableCheckedService spec) (stableCheckedService wireChanged) of+        CatalogReplayAffected groups targets sources adapters invalidates -> do+          groups `shouldBe` Set.singleton "artifact_group"+          targets `shouldBe` Set.singleton "artifact_target"+          sources `shouldBe` Set.singleton "aggregate:Catalog"+          adapters `shouldBe` Set.singleton "artifactProjection"+          invalidates `shouldBe` True+        CatalogReplayNeutral -> expectationFailure "mapped event wire change was catalog replay-neutral"+      ReplayImpact.catalogReplayImpactServices (stableCheckedService commandOnly) (stableCheckedService commandOnlyChanged)+        `shouldBe` CatalogReplayNeutral+      let snapshot = semanticImpactSnapshot impact+      Aeson.decode (Aeson.encode snapshot) `shouldBe` Just snapshot++    it "lowers mapped queues and checked read-model query contracts" $ do+      source <- mappedConsumerSurfaceSource+      parsed <- case parseSource "<mapped-consumer-pending>" source of+        Left failure -> expectationFailure (show failure) >> fail "unreachable"+        Right value -> pure value+      let codes = map code (validateService (checkedSource parsed))+      codes `shouldNotContain` [MappedReadModelLoweringPending]+      codes `shouldNotContain` [MappedQueueLoweringPending]+      case [workqueue | NWorkqueue workqueue <- specNodes (parsedSpec parsed)] of+        [workqueue] -> do+          let modules = scaffoldWorkqueueForService (defaultContext (specContext (parsedSpec parsed))) (checkedSource parsed) workqueue+              queue = generatedTextEndingIn "Queue.hs" modules+          queue `shouldSatisfy` T.isInfixOf "jobData :: ![Maybe ArtifactInfo]"+          queue `shouldSatisfy` T.isInfixOf "encodeArtifactInfoMapped"+          queue `shouldSatisfy` T.isInfixOf "explicitParseField (\\value -> (parseJSON value :: Parser [Value])"+          queue `shouldNotSatisfy` T.isInfixOf "Vendor.Geometry"+        workqueues -> expectationFailure ("unexpected workqueues: " <> show workqueues)+      case [readModel | NReadModel readModel <- specNodes (parsedSpec parsed)] of+        [readModel] -> do+          let ctx = defaultContext (specContext (parsedSpec parsed))+              modules = scaffoldReadModelForService ctx (checkedSource parsed) readModel+              contract = generatedTextEndingIn "QueryContract.hs" modules+              generatedReadModel = generatedTextEndingIn "ReadModel.hs" modules+              holes = T.intercalate "\n" [moduleText value | value <- modules, kind value == HoleStub]+          contract `shouldSatisfy` T.isInfixOf "type ArtifactLookupQueryInput = ArtifactInfo"+          contract `shouldSatisfy` T.isInfixOf "type ArtifactLookupQueryResult = Maybe ArtifactLocation"+          contract `shouldSatisfy` T.isInfixOf "import Example.Artifact.Domain (ArtifactInfo, ArtifactLocation)"+          contract `shouldNotSatisfy` T.isInfixOf "Vendor.Geometry"+          generatedReadModel `shouldSatisfy` T.isInfixOf ".QueryContract (ArtifactLookupQueryInput, ArtifactLookupQueryResult)"+          generatedReadModel `shouldSatisfy` T.isInfixOf ".ReadModelHoles (artifactLookupQuery)"+          generatedReadModel `shouldNotSatisfy` T.isInfixOf "applyArtifactLookup"+          holes `shouldSatisfy` T.isInfixOf ".QueryContract (ArtifactLookupQueryInput, ArtifactLookupQueryResult)"+          holes `shouldNotSatisfy` T.isInfixOf "type ArtifactLookupQueryInput = ()"+        readModels -> expectationFailure ("unexpected mapped read models: " <> show readModels)+      queryContractIdentities (parsedSpec parsed)+        `shouldBe` Right+          [ QueryContractIdentity+              { qciReadModel = "ArtifactLookup",+                qciPosition = QueryInputConsumer,+                qciTypeExpression = "ArtifactInfo",+                qciMappedDependencies = ["ArtifactInfo", "ArtifactKind", "ArtifactLocation"]+              },+            QueryContractIdentity+              { qciReadModel = "ArtifactLookup",+                qciPosition = QueryResultConsumer,+                qciTypeExpression = "Optional ArtifactLocation",+                qciMappedDependencies = ["ArtifactLocation"]+              }+          ]++    it "reports a retained legacy query hole until the application adopts the generated aliases" $+      withTempDirectory "keiro-dsl-query-contract-migration" $ \out -> do+        source <- mappedConsumerSurfaceSource+        parsed <- case parseSource "<mapped-query-migration>" source of+          Left failure -> expectationFailure (show failure) >> fail "unreachable"+          Right value -> pure value+        let service = checkedSource parsed+            spec = checkedSpec service+            ctx = defaultContext (specContext spec)+        modules <- case planTestServiceScaffold ctx service of+          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"+          Right values -> pure values+        readModel <- case [value | NReadModel value <- specNodes spec] of+          [value] -> pure value+          values -> expectationFailure ("unexpected mapped read models: " <> show values) >> fail "unreachable"+        let typedHole = case [value | value <- modules, kind value == HoleStub, "ReadModelHoles.hs" `T.isSuffixOf` T.pack (modulePath value)] of+              [value] -> value+              values -> error ("expected one query hole, got " <> show (map modulePath values))+            legacyHole = case [value | value <- scaffoldReadModel ctx readModel, kind value == HoleStub] of+              [value] -> value+              values -> error ("expected one legacy query hole, got " <> show (map modulePath values))+            holePath = out </> modulePath typedHole+            run = executeServiceScaffold out False "mapped-query.keiro" (parsedSourceLanguage parsed) ctx service modules+        createDirectoryIfMissing True (takeDirectory holePath)+        TIO.writeFile holePath (moduleText legacyHole)+        TIO.writeFile+          (out </> recordFileName (specContext spec))+          ( renderRecord+              ScaffoldRecord+                { recSpecPath = "mapped-query.keiro",+                  recModuleRoot = "",+                  recLayout = "prefixed",+                  recSourceLanguage = parsedSourceLanguage parsed,+                  recLanguageContract = checkedLanguageContract service,+                  recNamingEdition = IdiomaticNamingV1,+                  recModuleRoles = [],+                  recFiles = [],+                  recMappings = [],+                  recIdDomains = [],+                  recNominalEqualities = [],+                  recBindingObligations = [],+                  recBehaviorRequirements = [],+                  recProjectionCatalogFacts = [],+                  recQueryContractBaseline = False,+                  recQueryContracts = [],+                  recRouterSelections = [],+                  recSemanticImpact = Nothing+                }+          )+        first <- run >>= either (\refusals -> expectationFailure (show refusals) >> fail "unreachable") pure+        reportQueryContractBaselineUnavailable first `shouldBe` True+        reportQueryContractMigrations first+          `shouldBe` [ QueryContractMigration+                         { qcmOwner = "ArtifactLookup",+                           qcmHolePath = modulePath typedHole,+                           qcmRequiredImport = "import Generated.ConsumerDemo.ArtifactLookup.QueryContract (ArtifactLookupQueryInput, ArtifactLookupQueryResult)"+                         }+                     ]+        renderScaffoldReport first `shouldSatisfy` any (T.isInfixOf "remove the local QueryInput/QueryResult type aliases")+        renderScaffoldReport first `shouldSatisfy` any (T.isInfixOf "baseline unavailable")+        currentLedger <- TIO.readFile (reportRecordPath first)+        case parseRecord currentLedger of+          Just record -> do+            recQueryContractBaseline record `shouldBe` True+            length (recQueryContracts record) `shouldBe` 2+          Nothing -> expectationFailure "standalone query-contract ledger did not parse"+        case filter ("query-contract " `T.isPrefixOf`) (T.lines currentLedger) of+          row : _ -> parseRecord (currentLedger <> row <> "\n") `shouldBe` Nothing+          [] -> expectationFailure "expected standalone query-contract rows"+        TIO.writeFile holePath (moduleText typedHole)+        second <- run >>= either (\refusals -> expectationFailure (show refusals) >> fail "unreachable") pure+        reportQueryContractMigrations second `shouldBe` []+        [disposition | (value, disposition) <- reportDispositions second, modulePath value == modulePath typedHole]+          `shouldBe` [Skipped]++        changedParsed <- case parseSource "<mapped-query-drift>" (T.replace "query result = Optional ArtifactLocation" "query result = ArtifactLocation" source) of+          Left failure -> expectationFailure (show failure) >> fail "unreachable"+          Right value -> pure value+        let changedService = checkedSource changedParsed+        changedModules <- case planTestServiceScaffold ctx changedService of+          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"+          Right values -> pure values+        third <-+          executeServiceScaffold out False "mapped-query.keiro" (parsedSourceLanguage changedParsed) ctx changedService changedModules+            >>= either (\refusals -> expectationFailure (show refusals) >> fail "unreachable") pure+        reportQueryContractDrift third+          `shouldSatisfy` \case+            [QueryContractDrift {qcdKey = ("ArtifactLookup", QueryResultConsumer)}] -> True+            _ -> False+        renderScaffoldReport third `shouldSatisfy` any (T.isInfixOf "query contract drift: 1")++        let withoutQuerySource =+              T.unlines+                [ line+                | line <- T.lines source,+                  not ("  query input =" `T.isPrefixOf` line),+                  not ("  query result =" `T.isPrefixOf` line)+                ]+        withoutQueryParsed <- case parseSource "<mapped-query-removed>" withoutQuerySource of+          Left failure -> expectationFailure (show failure) >> fail "unreachable"+          Right value -> pure value+        let withoutQueryService = checkedSource withoutQueryParsed+        withoutQueryModules <- case planTestServiceScaffold ctx withoutQueryService of+          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"+          Right values -> pure values+        fourth <-+          executeServiceScaffold out False "mapped-query.keiro" (parsedSourceLanguage withoutQueryParsed) ctx withoutQueryService withoutQueryModules+            >>= either (\refusals -> expectationFailure (show refusals) >> fail "unreachable") pure+        length (reportQueryContractDrift fourth) `shouldBe` 2+        removedLedger <- TIO.readFile (reportRecordPath fourth)+        case parseRecord removedLedger of+          Just record -> do+            recQueryContractBaseline record `shouldBe` True+            recQueryContracts record `shouldBe` []+          Nothing -> expectationFailure "removed query-contract ledger did not parse"++    it "plans and records the same typed query contract across workspace members" $+      withTempDirectory "keiro-dsl-mapped-query-workspace" $ \out -> do+        plan <- shouldPlanWorkspace "test/fixtures/mapped-readmodel-workspace/service.keiro-workspace"+        let contractRows =+              [ (scaffoldModule, provenance)+              | (scaffoldModule, provenance) <- wpModules plan,+                "QueryContract.hs" `T.isSuffixOf` T.pack (modulePath scaffoldModule)+              ]+        case contractRows of+          [(contract, MemberOwned owner)] -> do+            owner `shouldBe` "readmodel.keiro"+            moduleText contract `shouldSatisfy` T.isInfixOf "type AccountSummaryQueryInput = AccountLookup"+            moduleText contract `shouldSatisfy` T.isInfixOf "type AccountSummaryQueryResult = Maybe AccountSummary"+          values -> expectationFailure ("unexpected workspace query contracts: " <> show values)+        report <- executeWorkspaceScaffold out False plan >>= either (\refusals -> expectationFailure (show refusals) >> fail "unreachable") pure+        wsrQueryContractMigrations report `shouldBe` []+        recordText <- TIO.readFile (wsrRecordPath report)+        case parseWorkspaceRecord recordText of+          Just record -> do+            wrQueryContractBaseline record `shouldBe` True+            length (wrQueryContracts record) `shouldBe` 2+          Nothing -> expectationFailure "workspace query-contract ledger did not parse"++  describe "complete mapped surfaces" $ do+    it "projects exact queue, query, event, snapshot, and replayable projection consequences" $ do+      aggregateSpec <- specOf "test/fixtures/semantic-impact.keiro"+      queueSpec <- specOf "test/fixtures/mapped-workqueue.keiro"+      querySpec <- specOf "test/fixtures/mapped-readmodel.keiro"+      projectionSpec <- specOf "test/fixtures/projection-catalog.keiro"+      let aggregateImpact = semanticImpactForSpec aggregateSpec+          queueImpact = semanticImpactForSpec queueSpec+          queryImpact = semanticImpactForSpec querySpec+          projectionImpact = semanticImpactForSpec projectionSpec+          consequences impact declaration = Map.findWithDefault Set.empty (MappedKey declaration) (impactDeclarationConsequences impact)+      consequences aggregateImpact "CommandPayload"+        `shouldBe` Set.singleton (MappedConsumerBuild (AggregateConsumer "Alpha"))+      consequences aggregateImpact "EventPayload"+        `shouldBe` Set.fromList [MappedConsumerBuild (AggregateConsumer "Alpha"), MappedPrivateEventHistory "Alpha"]+      consequences aggregateImpact "RegisterPayload"+        `shouldBe` Set.fromList [MappedConsumerBuild (AggregateConsumer "Alpha"), MappedSnapshotHydration "Alpha"]+      consequences queueImpact "JobPayload"+        `shouldBe` Set.fromList [MappedConsumerBuild (WorkqueueConsumer "mapped_jobs"), MappedWorkqueueHistory "mapped_jobs"]+      consequences queryImpact "AccountLookup"+        `shouldBe` Set.fromList [MappedConsumerBuild (ReadModelQueryConsumer "account_summary" MappedQueryInput), MappedQueryApi "account_summary" MappedQueryInput]+      consequences queryImpact "AccountSummary"+        `shouldBe` Set.fromList [MappedConsumerBuild (ReadModelQueryConsumer "account_summary" MappedQueryResult), MappedQueryApi "account_summary" MappedQueryResult]+      consequences projectionImpact "OrderPayload"+        `shouldBe` Set.fromList+          [ MappedConsumerBuild (AggregateConsumer "Orders"),+            MappedPrivateEventHistory "Orders",+            MappedConsumerBuild (DerivedProjectionConsumer (CatalogProjectionConsumer "order_summary_writer" "Orders")),+            MappedProjectionHandlerReview (CatalogProjectionConsumer "order_summary_writer" "Orders"),+            MappedProjectionRebuild (CatalogProjectionConsumer "order_summary_writer" "Orders") "reporting"+          ]++    it "reports every surface independently without inventing Json or heterogeneous typed roots" $ do+      queueSpec <- specOf "test/fixtures/mapped-workqueue.keiro"+      querySpec <- specOf "test/fixtures/mapped-readmodel.keiro"+      projectionSpec <- specOf "test/fixtures/projection-catalog.keiro"+      queueCoverage <- shouldResolveCoverage "mapped-workqueue.keiro" queueSpec+      queryCoverage <- shouldResolveCoverage "mapped-readmodel.keiro" querySpec+      projectionCoverage <- shouldResolveCoverage "projection-catalog.keiro" projectionSpec+      Coverage.workqueuePayloads (Coverage.coverageSummary queueCoverage)+        `shouldBe` Coverage.CoverageCounts 2 2 0 1+      Coverage.readModelQueryInputs (Coverage.coverageSummary queryCoverage)+        `shouldBe` Coverage.CoverageCounts 1 1 0 0+      Coverage.readModelQueryResults (Coverage.coverageSummary queryCoverage)+        `shouldBe` Coverage.CoverageCounts 1 1 0 0+      Coverage.projectionTypedConsumers (Coverage.coverageSummary projectionCoverage)+        `shouldBe` Coverage.CoverageCounts 3 0 3 0+      map Coverage.rootConsumer [root | root <- Coverage.coverageRoots queryCoverage, Coverage.rootSurface root `elem` [Coverage.ReadModelQueryInput, Coverage.ReadModelQueryResult]]+        `shouldBe` ["read-model-query:account_summary:input", "read-model-query:account_summary:result"]+      map Coverage.unsupportedSurface (Coverage.coverageUnsupportedSurfaces projectionCoverage)+        `shouldContain` ["projection-category:audit_writer:audit"]++    it "places one deterministic surface/consumer/root/path fact set behind the service facade" $ do+      services <- mapM checkedServiceOf ["test/fixtures/mapped-workqueue.keiro", "test/fixtures/mapped-readmodel.keiro", "test/fixtures/projection-catalog.keiro"]+      let facts = concatMap serviceConformanceFactValues services+          surfaceFacts = [(key, value) | (key, value) <- facts, "mapped-surface/" `T.isPrefixOf` key]+          keys = map fst surfaceFacts+      length keys `shouldBe` Set.size (Set.fromList keys)+      keys `shouldSatisfy` any (T.isInfixOf "/workqueue-payload/workqueue:mapped_jobs/JobPayload/workqueue mapped_jobs payload .job : JobPayload")+      keys `shouldSatisfy` any (T.isInfixOf "/read-model-query-input/read-model-query:account_summary:input/AccountLookup/readmodel account_summary query input : AccountLookup")+      keys `shouldSatisfy` any (T.isInfixOf "/projection-event-consumer/catalog-projection:order_summary_writer:Orders/OrderPayload/Orders event OrderRecorded .orderPayload : OrderPayload")+      map snd surfaceFacts `shouldSatisfy` any (T.isInfixOf "workqueue-history:mapped_jobs")+      map snd surfaceFacts `shouldSatisfy` any (T.isInfixOf "projection-rebuild:catalog-projection:order_summary_writer:Orders:reporting")++    it "keeps predecessor facades byte-stable while extending the Language 5 facade" $ do+      published <- checkedServiceOf "test/fixtures/semantic-impact.keiro"+      candidate <- checkedServiceOf "test/fixtures/mapped-workqueue.keiro"+      serviceConformanceFactKeys published+        `shouldSatisfy` all (not . T.isPrefixOf "mapped-surface/")+      serviceConformanceFactKeys candidate+        `shouldSatisfy` any (T.isPrefixOf "mapped-surface/")++    it "detects replay policy and observer relation drift without fabricating mapped declaration changes" $ do+      projectionSpec <- specOf "test/fixtures/projection-catalog.keiro"+      let makeLiveOnly node = case node of+            NProjectionOwner owner@ProjectionOwnerNode {poName = "order_summary_writer"} ->+              NProjectionOwner owner {poReplay = ProjectionLiveOnly "candidate is intentionally live-only"}+            other -> other+          moveObserver node = case node of+            NReadModel readModel@ReadModelNode {rmName = "catalogAudit"} ->+              NReadModel readModel {rmObservedTargets = ["order_summary"]}+            other -> other+          liveOnly = projectionSpec {specNodes = map makeLiveOnly (specNodes projectionSpec)}+          observerMoved = projectionSpec {specNodes = map moveObserver (specNodes projectionSpec)}+          liveDeltas = CheckedDiff.mappedSemanticImpact projectionSpec liveOnly+          observerDeltas = CheckedDiff.mappedSemanticImpact projectionSpec observerMoved+      map impactDeclaration liveDeltas `shouldBe` [MappedKey "OrderPayload", MappedKey "SharedReference"]+      map impactCurrentConsequences liveDeltas+        `shouldSatisfy` all (maybe False (not . any (\case MappedProjectionRebuild (CatalogProjectionConsumer "order_summary_writer" "Orders") _ -> True; _ -> False) . Set.toList))+      map impactDeclaration observerDeltas `shouldBe` [MappedKey "OrderPayload", MappedKey "SharedReference"]+      map impactCurrentEvidence observerDeltas+        `shouldSatisfy` any (maybe False (any (maybe False (T.isInfixOf "catalogAudit") . evidenceOperation) . Set.toList))+      diffMapped projectionSpec liveOnly `shouldBe` []++  describe "mapped surface ledger" $ do+    it "round-trips complete evidence, treats aggregate-only history as unknown, and rejects corrupt known tags" $ do+      spec <- specOf "test/fixtures/semantic-impact.keiro"+      let snapshot = semanticImpactSnapshotForSpec spec+          legacy = snapshot {snapshotMappedEvidence = Nothing, snapshotMappedConsequences = Nothing}+          declaration = MappedKey "EventPayload"+          report = semanticImpactReport (Just legacy) snapshot [declaration]+          encoded = LazyText.toStrict (LazyTextEncoding.decodeUtf8 (Aeson.encode snapshot))+          corrupt = T.replace "\"surface\":\"aggregate-command\"" "\"surface\":\"future-surface\"" encoded+      Aeson.decode (Aeson.encode snapshot) `shouldBe` Just snapshot+      Aeson.decode (Aeson.encode legacy) `shouldBe` Just legacy+      semanticReportDeltas report `shouldSatisfy` \case+        [delta] -> impactPreviousEvidence delta == Nothing && impactCurrentEvidence delta /= Nothing+        _ -> False+      renderSemanticImpactReport report `shouldSatisfy` any (T.isInfixOf "previous roots: baseline unavailable")+      corrupt `shouldNotBe` encoded+      (Aeson.decode (LazyTextEncoding.encodeUtf8 (LazyText.fromStrict corrupt)) :: Maybe SemanticImpactSnapshot) `shouldBe` Nothing++  describe "mapped compatibility vectors" $ do+    it "keeps queue, query, event, snapshot, and projection consequences orthogonal" $ do+      queueSpec <- specOf "test/fixtures/mapped-workqueue.keiro"+      querySpec <- specOf "test/fixtures/mapped-readmodel.keiro"+      aggregateSpec <- specOf "test/fixtures/semantic-impact.keiro"+      projectionSpec <- specOf "test/fixtures/projection-catalog.keiro"+      let changeQueue node = case node of+            NWorkqueue queue ->+              NWorkqueue queue {wqPayload = [if wqfName field == "job" then field {wqfType = TypedQueueExpression (TRef "JobMetadata")} else field | field <- wqPayload queue]}+            other -> other+          queueChanged = queueSpec {specNodes = map changeQueue (specNodes queueSpec)}+          changeQuery node = case node of+            NReadModel readModel@ReadModelNode {queryTypes = Just queryPair} -> NReadModel readModel {queryTypes = Just queryPair {input = TRef "TenantKey"}}+            other -> other+          queryChanged = querySpec {specNodes = map changeQuery (specNodes querySpec)}+          findKind predicate changes = case [kindOfChange change | change <- changes, predicate (kindOfChange change)] of+            value : _ -> value+            [] -> error "expected mapped compatibility finding"+          queueKind = findKind ((== WqPayloadFieldChanged) . ckCode) (diffSpecs queueSpec queueChanged)+          queryKind = findKind ((== ReadModelQueryInputChanged) . ckCode) (diffSpecs querySpec queryChanged)+          eventKind = findKind ((== "mapped-event") . ckFacet) [change | mutation <- mappedWireMutations aggregateSpec, change <- diffSpecs aggregateSpec (mmCandidate mutation)]+          snapshotKind = findKind ((== "mapped-register") . ckFacet) [change | mutation <- mappedWireMutations aggregateSpec, change <- diffSpecs aggregateSpec (mmCandidate mutation)]+          projectionChanged = mapMappedDeclaration "OrderPayload" changeProjectionMappedWire projectionSpec+          projectionKind = findKind ((== "mapped-projection") . ckFacet) (diffSpecs projectionSpec projectionChanged)+      ckMappedConsequences queueKind+        `shouldBe` Set.fromList [MappedConsumerBuild (WorkqueueConsumer "mapped_jobs"), MappedWorkqueueHistory "mapped_jobs"]+      cvPrivateHistoryRead (ckVector queueKind) `shouldBe` VNotApplicable+      cvConsumerBuild (ckVector queueKind) `shouldBe` VBreaking+      ckMappedConsequences queryKind+        `shouldBe` Set.fromList [MappedConsumerBuild (ReadModelQueryConsumer "account_summary" MappedQueryInput), MappedQueryApi "account_summary" MappedQueryInput]+      cvSnapshotHydration (ckVector queryKind) `shouldBe` VNotApplicable+      ckMappedConsequences eventKind `shouldSatisfy` Set.member (MappedPrivateEventHistory "Alpha")+      ckMappedConsequences snapshotKind `shouldSatisfy` Set.member (MappedSnapshotHydration "Alpha")+      ckMappedConsequences projectionKind `shouldSatisfy` Set.member (MappedProjectionHandlerReview (CatalogProjectionConsumer "order_summary_writer" "Orders"))+      ckMappedConsequences projectionKind+        `shouldSatisfy` Set.member (MappedProjectionRebuild (CatalogProjectionConsumer "order_summary_writer" "Orders") "reporting")++  describe "mapped surface qualification" $ do+    it "selects every explicit and derived surface from one integrated Language 5 authority" $ do+      service <- checkedServiceOf "test/fixtures/projection-catalog.keiro"+      workspace <- shouldComposeWorkspace "test/fixtures/projection-catalog.keiro-workspace"+      coverage <- shouldResolveCoverage "projection-catalog.keiro" (checkedSpec service)+      let impact = semanticImpactForSpec (checkedSpec service)+          qualify name = qualifyMappedSurface impact (MappedKey name)+          orderPayload = qualify "OrderPayload"+          sharedReference = qualify "SharedReference"+          qualificationPayload = qualify "QualificationPayload"+          queueMetadata = qualify "QueueMetadata"+          queryCriteria = qualify "QueryCriteria"+          qualificationResult = qualify "QualificationResult"+          registerState = qualify "RegisterState"+          unused = qualify "UnusedQualification"+          standaloneSnapshot = semanticImpactSnapshot impact+      standaloneSnapshot `shouldBe` semanticImpactSnapshotForSpec (wsMergedSpec workspace)+      Aeson.decode (Aeson.encode standaloneSnapshot) `shouldBe` Just standaloneSnapshot+      consumers orderPayload+        `shouldBe` Set.fromList+          [ AggregateConsumer "Orders",+            DerivedProjectionConsumer (CatalogProjectionConsumer "order_summary_writer" "Orders")+          ]+      Set.map evidenceRootKind (evidence orderPayload)+        `shouldBe` Set.fromList [MappedCommandFieldRoot, MappedEventFieldRoot, MappedProjectionEventRoot]+      consequences orderPayload+        `shouldSatisfy` Set.member (MappedProjectionRebuild (CatalogProjectionConsumer "order_summary_writer" "Orders") "reporting")+      consumers sharedReference+        `shouldBe` Set.fromList+          [ AggregateConsumer "Orders",+            AggregateConsumer "Shipments",+            WorkqueueConsumer "qualification_jobs",+            DerivedProjectionConsumer (CatalogProjectionConsumer "order_summary_writer" "Orders"),+            DerivedProjectionConsumer (CatalogProjectionConsumer "shipment_writer" "Shipments")+          ]+      consumers qualificationPayload `shouldBe` Set.singleton (WorkqueueConsumer "qualification_jobs")+      consequences qualificationPayload+        `shouldBe` Set.fromList [MappedConsumerBuild (WorkqueueConsumer "qualification_jobs"), MappedWorkqueueHistory "qualification_jobs"]+      consumers queueMetadata `shouldBe` Set.singleton (WorkqueueConsumer "qualification_jobs")+      consumers queryCriteria `shouldBe` Set.singleton (ReadModelQueryConsumer "order_inline" MappedQueryInput)+      consequences queryCriteria+        `shouldBe` Set.fromList [MappedConsumerBuild (ReadModelQueryConsumer "order_inline" MappedQueryInput), MappedQueryApi "order_inline" MappedQueryInput]+      consumers qualificationResult `shouldBe` Set.singleton (ReadModelQueryConsumer "order_inline" MappedQueryResult)+      consequences qualificationResult+        `shouldBe` Set.fromList [MappedConsumerBuild (ReadModelQueryConsumer "order_inline" MappedQueryResult), MappedQueryApi "order_inline" MappedQueryResult]+      consumers registerState `shouldBe` Set.singleton (AggregateConsumer "Orders")+      consequences registerState+        `shouldBe` Set.fromList [MappedConsumerBuild (AggregateConsumer "Orders"), MappedSnapshotHydration "Orders"]+      consumers unused `shouldBe` Set.empty+      evidence unused `shouldBe` Set.empty+      consequences unused `shouldBe` Set.empty+      Coverage.workqueuePayloads (Coverage.coverageSummary coverage) `shouldBe` Coverage.CoverageCounts 4 1 3 1+      Coverage.readModelQueryInputs (Coverage.coverageSummary coverage) `shouldBe` Coverage.CoverageCounts 1 0 1 0+      Coverage.readModelQueryResults (Coverage.coverageSummary coverage) `shouldBe` Coverage.CoverageCounts 1 0 1 0+      Coverage.projectionTypedConsumers (Coverage.coverageSummary coverage) `shouldBe` Coverage.CoverageCounts 3 0 3 0+      map Coverage.unsupportedSurface (Coverage.coverageUnsupportedSurfaces coverage)+        `shouldContain` ["projection-category:audit_writer:audit"]++    it "aligns every mapping diff with the authority's exact consequence set" $ do+      service <- checkedServiceOf "test/fixtures/projection-catalog.keiro"+      let spec = checkedSpec service+          impact = semanticImpactForSpec spec+          opaqueMutation name = mapMappedDeclaration name changeProjectionMappedWire spec+          mutations =+            [ ("OrderPayload", opaqueMutation "OrderPayload"),+              ("SharedReference", opaqueMutation "SharedReference"),+              ("QualificationPayload", addMappedOptionalTextField "QualificationPayload" "addedNote" spec),+              ("QueueMetadata", opaqueMutation "QueueMetadata"),+              ("QueryCriteria", opaqueMutation "QueryCriteria"),+              ("QualificationResult", opaqueMutation "QualificationResult"),+              ("RegisterState", opaqueMutation "RegisterState"),+              ("UnusedQualification", opaqueMutation "UnusedQualification")+            ]+          actualConsequences candidate =+            Set.unions+              [ ckMappedConsequences (kindOfChange change)+              | change <- diffServices service (checkedServiceWithSpec candidate service)+              ]+          expectedConsequences name = consequences (qualifyMappedSurface impact (MappedKey name))+      forM_ mutations $ \(name, candidate) ->+        actualConsequences candidate `shouldBe` expectedConsequences name++    it "pins exact generated locality and keeps it constant under unrelated workspace growth" $ do+      service <- checkedServiceOf "test/fixtures/projection-catalog.keiro"+      grown <- shouldComposeWorkspace "test/fixtures/projection-catalog-grown.keiro-workspace"+      let spec = checkedSpec service+          ctx = defaultContext (specContext spec)+          baseline = scaffoldServiceModules ctx service+          modulesFor candidate = scaffoldServiceModules ctx (checkedServiceWithSpec candidate service)+          deltaFor candidate = generatedTreeDelta baseline (modulesFor candidate)+          opaqueDelta name = deltaFor (mapMappedDeclaration name changeProjectionMappedWire spec)+          structuralDelta = deltaFor (addMappedOptionalTextField "QualificationPayload" "addedNote" spec)+          structuralPaths =+            Set.fromList+              [ "Generated/CatalogDemo/QualificationJobs/Queue.hs",+                "Generated/CatalogDemo/Structural/Shape/QualificationPayload.hs",+                "Generated/CatalogDemo/StructuralConformance.hs"+              ]+          projectionPaths =+            Set.fromList+              [ "Generated/CatalogDemo/ProjectionCatalog.hs",+                "Generated/CatalogDemo/StructuralConformance.hs"+              ]+          registerPaths =+            Set.fromList+              [ "Generated/CatalogDemo/Orders/Transducer.hs",+                "Generated/CatalogDemo/StructuralConformance.hs"+              ]+          serviceOnly = Set.singleton "Generated/CatalogDemo/StructuralConformance.hs"+          assertExact delta paths = do+            changedPaths delta `shouldBe` paths+            addedPaths delta `shouldBe` Set.empty+            removedPaths delta `shouldBe` Set.empty+      assertExact structuralDelta structuralPaths+      assertExact (opaqueDelta "OrderPayload") projectionPaths+      assertExact (opaqueDelta "SharedReference") projectionPaths+      assertExact (opaqueDelta "RegisterState") registerPaths+      forM_ ["QueueMetadata", "QueryCriteria", "QualificationResult", "UnusedQualification"] $ \name ->+        assertExact (opaqueDelta name) serviceOnly+      let grownCandidate = mapWorkspaceSpec (mapMappedDeclaration "OrderPayload" changeProjectionMappedWire) grown+      grownBaselinePlan <- shouldPlanWorkspaceSpec grown+      grownCandidatePlan <- shouldPlanWorkspaceSpec grownCandidate+      let grownDelta = generatedTreeDelta (map fst (wpModules grownBaselinePlan)) (map fst (wpModules grownCandidatePlan))+      changedPaths grownDelta `shouldBe` changedPaths (opaqueDelta "OrderPayload")+      addedPaths grownDelta `shouldBe` Set.empty+      removedPaths grownDelta `shouldBe` Set.empty++    it "keeps Language 5 syntax gated and predecessor service facades unchanged" $ do+      candidate <- checkedServiceOf "test/fixtures/projection-catalog.keiro"+      published <- checkedServiceOf "test/fixtures/consumer-types.keiro"+      source <- readTestText "test/fixtures/projection-catalog.keiro"+      let candidateKeys = serviceConformanceFactKeys candidate+          candidateValues = map snd (serviceConformanceFactValues candidate)+      candidateKeys `shouldSatisfy` any (T.isPrefixOf "mapped-surface/")+      length candidateKeys `shouldBe` Set.size (Set.fromList candidateKeys)+      candidateValues `shouldSatisfy` any (T.isInfixOf "workqueue-history:qualification_jobs")+      candidateValues `shouldSatisfy` any (T.isInfixOf "query-api:order_inline:input")+      candidateValues `shouldSatisfy` any (T.isInfixOf "projection-handler-review:catalog-projection:order_summary_writer:Orders")+      serviceConformanceFactKeys published `shouldSatisfy` all (not . T.isPrefixOf "mapped-surface/")+      parseSource "<published-mapped-surfaces>" (T.replace "language keiro-dsl 5" "language keiro-dsl 4" source)+        `shouldSatisfy` isLeft++  describe "language support" $ do+    it "serializes support from the registered version and decodes older records" $ do+      v1Contract <- maybe (expectationFailure "missing v1 contract" >> fail "unreachable") pure (effectiveLanguageContractForVersion =<< languageVersion 1)+      v4Contract <- maybe (expectationFailure "missing v4 contract" >> fail "unreachable") pure (effectiveLanguageContractForVersion =<< languageVersion 4)+      v5Contract <- maybe (expectationFailure "missing v5 contract" >> fail "unreachable") pure (effectiveLanguageContractForVersion =<< languageVersion 5)+      effectiveLanguageSupport v1Contract `shouldBe` CompatibilityOnly+      effectiveLanguageSupport v4Contract `shouldBe` CompatibilityOnly+      effectiveLanguageSupport v5Contract `shouldBe` Stable+      Aeson.toJSON v5Contract+        `shouldBe` object+          [ "languageVersion" .= (5 :: Int),+            "runtimeSemantics" .= ("keiro-dsl/runtime-semantics/4" :: T.Text),+            "languageSupport" .= ("stable" :: T.Text)+          ]+      Aeson.eitherDecode "{\"languageVersion\":1,\"runtimeSemantics\":\"keiro-dsl/runtime-semantics/1\"}"+        `shouldBe` Right v1Contract++    it "reports stable and compatibility-only support through source inspection" $ do+      (stableCode, stableOut, stableErr) <- runKeiroDsl ["inspect", "test/fixtures/projection-catalog.keiro", "--format=json"]+      stableCode `shouldBe` ExitSuccess+      stableErr `shouldBe` ""+      stableOut `shouldContain` "\"languageVersion\":5"+      stableOut `shouldContain` "\"languageSupport\":\"stable\""+      (predecessorCode, predecessorOut, predecessorErr) <- runKeiroDsl ["inspect", "test/fixtures/contract-v4.keiro", "--format=json"]+      predecessorCode `shouldBe` ExitSuccess+      predecessorErr `shouldBe` ""+      predecessorOut `shouldContain` "\"languageVersion\":4"+      predecessorOut `shouldContain` "\"languageSupport\":\"compatibility-only\""+      (compatibilityCode, compatibilityOut, compatibilityErr) <- runKeiroDsl ["inspect", "test/fixtures/language-v1.keiro", "--format=json"]+      compatibilityCode `shouldBe` ExitSuccess+      compatibilityErr `shouldBe` ""+      compatibilityOut `shouldContain` "\"languageVersion\":1"+      compatibilityOut `shouldContain` "\"languageSupport\":\"compatibility-only\""++    it "surfaces non-stable contracts and enforces a released minimum language" $ do+      let legacyPath = "test/fixtures/language-legacy.keiro"+          stablePath = "test/fixtures/projection-catalog.keiro"+      (legacyCode, legacyOut, legacyErr) <- runKeiroDsl ["check", legacyPath]+      legacyCode `shouldBe` ExitSuccess+      legacyOut `shouldBe` "OK\n"+      legacyErr `shouldContain` "language contract: effective keiro-dsl 1 (legacy-unversioned, compatibility-only, runtime semantics keiro-dsl/runtime-semantics/1)"+      legacyErr `shouldContain` "language-5 strict spec-surface validation is not applied"++      (stableCode, stableOut, stableErr) <- runKeiroDsl ["check", stablePath]+      stableCode `shouldBe` ExitSuccess+      stableOut `shouldBe` "OK\n"+      stableErr `shouldBe` ""++      (floorCode, floorOut, floorErr) <- runKeiroDsl ["check", legacyPath, "--min-language", "4"]+      floorCode `shouldBe` ExitFailure 1+      floorOut `shouldBe` ""+      floorErr `shouldContain` "language-legacy.keiro:1: error[LanguageVersionBelowMinimum]"+      floorErr `shouldContain` "effective language version 1 (legacy-unversioned) is below the required minimum 4"++      (metCode, metOut, _) <- runKeiroDsl ["check", legacyPath, "--min-language", "1"]+      metCode `shouldBe` ExitSuccess+      metOut `shouldBe` "OK\n"++      (unsupportedCode, _, unsupportedErr) <- runKeiroDsl ["check", legacyPath, "--min-language", "9"]+      unsupportedCode `shouldBe` ExitFailure 1+      unsupportedErr `shouldContain` "supported versions: 1, 2, 3, 4, 5"++    it "attributes a workspace language floor to its manifest and every member" $ do+      let v1Member = T.unlines ["language keiro-dsl 1", "context language-floor"]+      withInlineWorkspace+        "keiro-dsl-language-floor"+        ( "language-floor",+          [ ("domain/a.keiro", v1Member),+            ("domain/b.keiro", v1Member)+          ]+        )+        $ \root _ _ -> do+          let manifest = root </> "service.keiro-workspace"+          (floorCode, floorOut, floorErr) <- runKeiroDsl ["check", manifest, "--min-language", "4"]+          floorCode `shouldBe` ExitFailure 1+          floorOut `shouldBe` ""+          floorErr `shouldContain` (manifest <> ":1: error[LanguageVersionBelowMinimum]")+          floorErr `shouldContain` "domain/a.keiro:1: note: member selects effective language version 1"+          floorErr `shouldContain` "domain/b.keiro:1: note: member selects effective language version 1"+          floorErr `shouldContain` "workspace, 0 legacy-unversioned member(s)"++          (metCode, metOut, _) <- runKeiroDsl ["check", manifest, "--min-language", "1"]+          metCode `shouldBe` ExitSuccess+          metOut `shouldBe` "OK\n"++  describe "warning enforcement" $ do+    it "round-trips every stable diagnostic code spelling" $ do+      forM_ [minBound .. maxBound] $ \diagnosticCode ->+        parseDiagnosticCode (diagnosticCodeText diagnosticCode) `shouldBe` Just diagnosticCode++    it "fails only the warnings selected by invocation policy" $ do+      let fixture = "test/fixtures/deny-unlogged.keiro"+          warningText = "warning[WqUnloggedDurability]"+          summaryText = "check: 1 warning(s) escalated to failure (denied: WqUnloggedDurability)"++      (plainCode, plainOut, plainErr) <- runKeiroDsl ["check", fixture]+      plainCode `shouldBe` ExitSuccess+      plainOut `shouldBe` "OK\n"+      plainErr `shouldContain` warningText+      plainErr `shouldNotContain` "escalated to failure"++      (allCode, allOut, allErr) <- runKeiroDsl ["check", fixture, "--deny-warnings"]+      allCode `shouldBe` ExitFailure 1+      allOut `shouldBe` ""+      allErr `shouldContain` warningText+      allErr `shouldContain` summaryText++      (selectedCode, selectedOut, selectedErr) <- runKeiroDsl ["check", fixture, "--deny", "WqUnloggedDurability"]+      selectedCode `shouldBe` ExitFailure 1+      selectedOut `shouldBe` ""+      selectedErr `shouldContain` warningText+      selectedErr `shouldContain` summaryText++      (otherCode, otherOut, otherErr) <- runKeiroDsl ["check", fixture, "--deny", "WireSchemaVersionMismatch"]+      otherCode `shouldBe` ExitSuccess+      otherOut `shouldBe` "OK\n"+      otherErr `shouldContain` warningText+      otherErr `shouldNotContain` "escalated to failure"++      (unionCode, unionOut, unionErr) <-+        runKeiroDsl+          [ "check",+            fixture,+            "--deny-warnings",+            "--deny",+            "WireSchemaVersionMismatch,WqUnloggedDurability"+          ]+      unionCode `shouldBe` ExitFailure 1+      unionOut `shouldBe` ""+      unionErr `shouldContain` warningText+      unionErr `shouldContain` summaryText++      (unknownCode, _, unknownErr) <- runKeiroDsl ["check", fixture, "--deny", "NotACode"]+      unknownCode `shouldBe` ExitFailure 1+      unknownErr `shouldContain` "unknown diagnostic code `NotACode`"+      unknownErr `shouldContain` "warning[Code]"++    -- A denial that can never match reads like a CI gate and is not one. Every+    -- code `check` cannot emit is refused at the point of use instead.+    it "refuses a denial of a code check can never emit" $ do+      let fixture = "test/fixtures/deny-unlogged.keiro"++      (diffCode, _, diffErr) <- runKeiroDsl ["check", fixture, "--deny", "EvtFieldWireKeyChanged"]+      diffCode `shouldBe` ExitFailure 1+      diffErr `shouldContain` "`EvtFieldWireKeyChanged` is emitted by `keiro-dsl diff`"+      diffErr `shouldContain` "would never match"++      -- Rejection survives being hidden inside a comma-separated list.+      (mixedCode, _, mixedErr) <-+        runKeiroDsl ["check", fixture, "--deny", "WqUnloggedDurability,WorkflowShapeChanged"]+      mixedCode `shouldBe` ExitFailure 1+      mixedErr `shouldContain` "`WorkflowShapeChanged` is emitted by `keiro-dsl diff`"++      (codecCode, _, codecErr) <- runKeiroDsl ["check", fixture, "--deny", "CodecCompareDifference"]+      codecCode `shouldBe` ExitFailure 1+      codecErr `shouldContain` "generated codec-comparison path"++      -- A coverage code is emittable, but only by an invocation that asks for+      -- the coverage pass, so the requirement is stated rather than ignored.+      (noPassCode, _, noPassErr) <- runKeiroDsl ["check", fixture, "--deny", "CoverageOpaqueSurface"]+      noPassCode `shouldBe` ExitFailure 1+      noPassErr `shouldContain` "add --coverage-report FILE or drop the code"++      -- CoverageOpaqueGateExceeded is the error --fail-on-opaque itself raises,+      -- never a warning, so denying it is a silent no-op in every invocation —+      -- with or without the coverage pass it is refused with the real spelling.+      withTempDirectory "keiro-dsl-gate-exceeded-deny" $ \out -> do+        (gateCode, _, gateErr) <-+          runKeiroDsl+            ["check", fixture, "--coverage-report", out </> "coverage.json", "--deny", "CoverageOpaqueGateExceeded"]+        gateCode `shouldBe` ExitFailure 1+        gateErr `shouldContain` "pass --fail-on-opaque instead of denying it"+      (gateNoPassCode, _, gateNoPassErr) <- runKeiroDsl ["check", fixture, "--deny", "CoverageOpaqueGateExceeded"]+      gateNoPassCode `shouldBe` ExitFailure 1+      gateNoPassErr `shouldContain` "pass --fail-on-opaque instead of denying it"++    it "applies the warning policy to structural-coverage findings" $ do+      withTempDirectory "keiro-dsl-coverage-deny" $ \out -> do+        let fixture = "test/fixtures/structural-conformance.keiro"+            coveragePath = out </> "coverage.json"+            reportPath = out </> "nested" </> "dir" </> "check.json"+            warningText = "warning[CoverageOpaqueSurface]"++        -- Reporting-only by default: the finding prints and the check passes.+        (plainCode, _, plainErr) <-+          runKeiroDsl ["check", fixture, "--coverage-report", coveragePath]+        plainCode `shouldBe` ExitSuccess+        plainErr `shouldContain` warningText+        plainErr `shouldNotContain` "escalated to failure"++        -- Before ExecPlan 199 this combination exited 0 with the warning printed.+        (deniedCode, _, deniedErr) <-+          runKeiroDsl+            [ "check",+              fixture,+              "--coverage-report",+              coveragePath,+              "--deny-warnings",+              -- The nested path also proves --report-out creates parent dirs.+              "--report-out",+              reportPath+            ]+        deniedCode `shouldBe` ExitFailure 1+        deniedErr `shouldContain` warningText+        deniedErr `shouldContain` "escalated to failure (denied: CoverageOpaqueSurface)"++        report <- decodeJsonValue reportPath+        jsonField "ok" report `shouldBe` Just (Aeson.Bool False)+        (jsonField "summary" report >>= jsonField "deniedWarnings") `shouldBe` Just (Aeson.Number 1)+        case jsonField "diagnostics" report of+          Just (Aeson.Array entries) ->+            [entry | entry <- toList entries, jsonField "code" entry == Just (Aeson.String "CoverageOpaqueSurface")]+              `shouldSatisfy` \matching -> case matching of+                entry : _ ->+                  jsonField "severity" entry == Just (Aeson.String "warning")+                    && jsonField "denied" entry == Just (Aeson.Bool True)+                [] -> False+          other -> expectationFailure ("expected diagnostics array, got " <> show other)++        -- Selecting the code by name gates it just as precisely.+        (selectedCode, _, _) <-+          runKeiroDsl+            ["check", fixture, "--coverage-report", coveragePath, "--deny", "CoverageOpaqueSurface"]+        selectedCode `shouldBe` ExitFailure 1++    it "spells warning severity the same way in both JSON reports" $ do+      withTempDirectory "keiro-dsl-severity-vocabulary" $ \out -> do+        let coveragePath = out </> "coverage.json"+        (exitCode, _, _) <-+          runKeiroDsl+            ["check", "test/fixtures/structural-conformance.keiro", "--coverage-report", coveragePath]+        exitCode `shouldBe` ExitSuccess+        coverage <- decodeJsonValue coveragePath+        case jsonField "findings" coverage of+          Just (Aeson.Array entries) -> case toList entries of+            entry : _ -> jsonField "severity" entry `shouldBe` Just (Aeson.String "warning")+            [] -> expectationFailure "coverage report had no findings"+          other -> expectationFailure ("expected findings array, got " <> show other)++    it "writes the machine report when a workspace is refused during composition" $ do+      withTempDirectory "keiro-dsl-workspace-refusal-report" $ \out -> do+        let reportPath = out </> "made" </> "up" </> "refusal.json"+        (exitCode, stdoutText, _) <-+          runKeiroDsl+            [ "check",+              "test/fixtures/workspace-dup-decl/service.keiro-workspace",+              "--report-out",+              reportPath+            ]+        exitCode `shouldBe` ExitFailure 1+        stdoutText `shouldBe` ""+        report <- decodeJsonValue reportPath+        jsonField "schema" report `shouldBe` Just (Aeson.String "keiro-dsl/check-report/1")+        jsonField "kind" report `shouldBe` Just (Aeson.String "workspace")+        jsonField "ok" report `shouldBe` Just (Aeson.Bool False)+        -- No service graph was composed, so there is no language contract.+        jsonField "language" report `shouldBe` Just Aeson.Null+        case jsonField "diagnostics" report of+          Just (Aeson.Array entries) -> case toList entries of+            entry : _ -> do+              jsonField "code" entry `shouldBe` Just (Aeson.String "WorkspaceDuplicateDeclaration")+              jsonField "severity" entry `shouldBe` Just (Aeson.String "error")+            [] -> expectationFailure "workspace refusal report had no diagnostics"+          other -> expectationFailure ("expected diagnostics array, got " <> show other)++    it "applies the same warning policy to a composed workspace" $ do+      warningSource <- readTestText "test/fixtures/deny-unlogged.keiro"+      withInlineWorkspace+        "keiro-dsl-warning-policy"+        ("warning-policy", [("domain/jobs.keiro", warningSource)])+        $ \root _ _ -> do+          let manifest = root </> "service.keiro-workspace"+          (plainCode, plainOut, plainErr) <- runKeiroDsl ["check", manifest]+          plainCode `shouldBe` ExitSuccess+          plainOut `shouldBe` "OK\n"+          plainErr `shouldContain` "domain/jobs.keiro:4: warning[WqUnloggedDurability]"++          (deniedCode, deniedOut, deniedErr) <- runKeiroDsl ["check", manifest, "--deny", "WqUnloggedDurability"]+          deniedCode `shouldBe` ExitFailure 1+          deniedOut `shouldBe` ""+          deniedErr `shouldContain` "domain/jobs.keiro:4: warning[WqUnloggedDurability]"+          deniedErr `shouldContain` "check: 1 warning(s) escalated to failure (denied: WqUnloggedDurability)"++  describe "check report" $ do+    it "writes the source failure report and matches the public-CLI golden" $ do+      withTempDirectory "keiro-dsl-check-report-floor" $ \out -> do+        let reportPath = out </> "report.json"+        (exitCode, stdoutText, _) <-+          runKeiroDsl+            [ "check",+              "test/fixtures/language-legacy.keiro",+              "--min-language",+              "4",+              "--report-out",+              reportPath+            ]+        exitCode `shouldBe` ExitFailure 1+        stdoutText `shouldBe` ""+        report <- decodeJsonValue reportPath+        goldenPath <- resolveTestPath "test/fixtures/check-report/legacy-min-language.golden.json"+        golden <- decodeJsonValue goldenPath+        report `shouldBe` golden+        jsonField "schema" report `shouldBe` Just (Aeson.String "keiro-dsl/check-report/1")+        jsonField "kind" report `shouldBe` Just (Aeson.String "source")+        jsonField "ok" report `shouldBe` Just (Aeson.Bool False)+        (jsonField "language" report >>= jsonField "stable") `shouldBe` Just (Aeson.Bool False)+        (jsonField "summary" report >>= jsonField "errors") `shouldBe` Just (Aeson.Number 1)+        case jsonField "diagnostics" report of+          Just (Aeson.Array entries) -> case toList entries of+            entry : _ -> do+              jsonField "code" entry `shouldBe` Just (Aeson.String "LanguageVersionBelowMinimum")+              jsonField "severity" entry `shouldBe` Just (Aeson.String "error")+              jsonField "line" entry `shouldBe` Just (Aeson.Number 1)+            [] -> expectationFailure "check report had no diagnostics"+          other -> expectationFailure ("expected diagnostics array, got " <> show other)++    it "marks denied warnings without changing their severity" $ do+      withTempDirectory "keiro-dsl-check-report-deny" $ \out -> do+        let deniedPath = out </> "denied.json"+            allowedPath = out </> "allowed.json"+            fixture = "test/fixtures/deny-unlogged.keiro"+        (deniedCode, _, _) <- runKeiroDsl ["check", fixture, "--deny-warnings", "--report-out", deniedPath]+        deniedCode `shouldBe` ExitFailure 1+        deniedReport <- decodeJsonValue deniedPath+        jsonField "ok" deniedReport `shouldBe` Just (Aeson.Bool False)+        (jsonField "summary" deniedReport >>= jsonField "deniedWarnings") `shouldBe` Just (Aeson.Number 1)+        case jsonField "diagnostics" deniedReport of+          Just (Aeson.Array entries) -> case toList entries of+            entry : _ -> do+              jsonField "severity" entry `shouldBe` Just (Aeson.String "warning")+              jsonField "denied" entry `shouldBe` Just (Aeson.Bool True)+            [] -> expectationFailure "denied-warning report had no diagnostics"+          other -> expectationFailure ("expected diagnostics array, got " <> show other)++        (allowedCode, _, _) <- runKeiroDsl ["check", fixture, "--report-out", allowedPath]+        allowedCode `shouldBe` ExitSuccess+        allowedReport <- decodeJsonValue allowedPath+        jsonField "ok" allowedReport `shouldBe` Just (Aeson.Bool True)+        (jsonField "summary" allowedReport >>= jsonField "deniedWarnings") `shouldBe` Just (Aeson.Number 0)+        case jsonField "diagnostics" allowedReport of+          Just (Aeson.Array entries) -> case toList entries of+            entry : _ -> jsonField "denied" entry `shouldBe` Just (Aeson.Bool False)+            [] -> expectationFailure "allowed-warning report had no diagnostics"+          other -> expectationFailure ("expected diagnostics array, got " <> show other)++    it "reports canonical workspace members and writes nothing before parse success" $ do+      withTempDirectory "keiro-dsl-check-report-workspace" $ \out -> do+        let workspacePath = out </> "workspace.json"+            parseFailurePath = out </> "parse-failure.json"+            unregisteredPath = out </> "language-unregistered.keiro"+        (workspaceCode, _, _) <- runKeiroDsl ["check", canonicalWorkspacePath, "--report-out", workspacePath]+        workspaceCode `shouldBe` ExitSuccess+        workspaceReport <- decodeJsonValue workspacePath+        jsonField "kind" workspaceReport `shouldBe` Just (Aeson.String "workspace")+        jsonField "ok" workspaceReport `shouldBe` Just (Aeson.Bool True)+        (jsonField "language" workspaceReport >>= jsonField "sourceForm") `shouldBe` Just (Aeson.String "workspace-composed")+        case jsonField "members" workspaceReport of+          Just (Aeson.Array members) -> length members `shouldBe` 3+          other -> expectationFailure ("expected members array, got " <> show other)++        let v1Member = T.unlines ["language keiro-dsl 1", "context report-floor"]+        withInlineWorkspace+          "keiro-dsl-check-report-workspace-floor"+          ( "report-floor",+            [ ("domain/a.keiro", v1Member),+              ("domain/b.keiro", v1Member)+            ]+          )+          $ \root _ _ -> do+            let manifest = root </> "service.keiro-workspace"+                floorReportPath = out </> "workspace-floor.json"+            (floorCode, _, _) <-+              runKeiroDsl ["check", manifest, "--min-language", "4", "--report-out", floorReportPath]+            floorCode `shouldBe` ExitFailure 1+            floorReport <- decodeJsonValue floorReportPath+            case jsonField "diagnostics" floorReport of+              Just (Aeson.Array entries) -> case toList entries of+                entry : _ -> do+                  jsonField "file" entry `shouldBe` Just (Aeson.String (T.pack manifest))+                  jsonField "code" entry `shouldBe` Just (Aeson.String "LanguageVersionBelowMinimum")+                  case jsonField "related" entry of+                    Just (Aeson.Array related) -> length related `shouldBe` 2+                    other -> expectationFailure ("expected related-location array, got " <> show other)+                [] -> expectationFailure "workspace-floor report had no diagnostics"+              other -> expectationFailure ("expected diagnostics array, got " <> show other)++        TIO.writeFile unregisteredPath "language keiro-dsl 999999\nthis is intentionally not valid body syntax\n"+        (parseCode, _, _) <-+          runKeiroDsl+            [ "check",+              unregisteredPath,+              "--report-out",+              parseFailurePath+            ]+        parseCode `shouldBe` ExitFailure 1+        doesFileExist parseFailurePath `shouldReturn` False++  describe "runtime capability and fold identity baseline (plan 181)" $ do+    it "pins the fold-only FNV-1a-128 UTF-8 encoding" $ do+      foldFingerprint128 "" `shouldBe` "6c62272e07bb014262b821756295c58d"+      foldFingerprint128 "雪" `shouldBe` "a68afaae758b5822836dbc787bb233bd"++    it "pins complete fold surfaces and fingerprints across representative aggregates" $ do+      scalar <- checkedServiceOf "test/fixtures/aggregate-scalar-expressions-v2.keiro"+      nominal <- checkedServiceOf "test/fixtures/nominal-scalars.keiro"+      idDomain <- checkedServiceOf "test/fixtures/id-domain-migration-v3.keiro"+      behavior <- checkedServiceOf "test/fixtures/behavior-complete.keiro"+      workspace <- shouldComposeWorkspace "test/fixtures/workspace-nominals/service.keiro-workspace"+      let actual =+            T.intercalate+              "\n\n"+              [ renderFoldBaseline "aggregate-scalar-expressions-v2" scalar,+                renderFoldBaseline "nominal-scalars" nominal,+                renderFoldBaseline "id-domain-migration-v3" idDomain,+                renderFoldBaseline "behavior-complete" behavior,+                renderFoldBaseline "workspace-nominals" (checkedWorkspace workspace)+              ]+      assertMatchesGolden "test/fixtures/fold-identity-baseline.golden" actual++    it "pins all four runtime gates and fingerprint segment projections" $ do+      nominalSpec <- specOf "test/fixtures/id-domain-migration-v3.keiro"+      nominalRegistry <- case resolveNominalTypes nominalSpec of+        Left errors -> expectationFailure (show errors) >> fail "unreachable"+        Right value -> pure value+      nominal <- case lookupNominalType "OrderId" nominalRegistry of+        Nothing -> expectationFailure "missing OrderId nominal" >> fail "unreachable"+        Just value -> pure value+      strictSpec <-+        parseInlineSpec+          "<strict-profile>"+          ( T.unlines+              [ "context strict-profile",+                "aggregate DuplicateRegister",+                "  regs",+                "    value Int = 0",+                "    value Int = 0",+                "  states Open"+              ]+          )+      rows <- forM [1 .. 4 :: Int] $ \number -> do+        contract <- case languageVersion (fromIntegral number) >>= effectiveLanguageContractForVersion of+          Nothing -> expectationFailure ("missing released language contract " <> show number) >> fail "unreachable"+          Just value -> pure value+        let hasAggregateIdDomain = maybe False (const True) (idDomainContractFor contract "ord")+            hasContractIdDomain = maybe False (const True) (contractIdDomainContractFor contract "ord")+            nominalContract = equalityContractVersion <$> nominalEqualityContractForService contract nominal+            strictService = checkedServiceForContract contract strictSpec+            hasStrictValidation = any ((== AggregateDuplicateRegister) . code) (validateService strictService)+        pure+          ( number,+            effectiveRuntimeSemantics contract,+            runtimeSemanticsFingerprintSegments contract,+            hasAggregateIdDomain,+            hasContractIdDomain,+            nominalContract,+            hasStrictValidation+          )+      rows+        `shouldBe` [ (1, "keiro-dsl/runtime-semantics/1", [], False, False, Just "keiro-dsl/nominal-equality/1", False),+                     (2, "keiro-dsl/runtime-semantics/1", [], False, False, Just "keiro-dsl/nominal-equality/1", False),+                     (3, "keiro-dsl/runtime-semantics/2", ["semantic-contract:keiro-dsl/runtime-semantics/2"], True, False, Just "keiro-dsl/nominal-equality/2", False),+                     (4, "keiro-dsl/runtime-semantics/3", ["semantic-contract:keiro-dsl/runtime-semantics/2"], True, True, Just "keiro-dsl/nominal-equality/2", True)+                   ]++    it "explains a serialized runtime-profile mismatch" $ do+      case (Aeson.eitherDecode "{\"languageVersion\":4,\"runtimeSemantics\":\"keiro-dsl/runtime-semantics/2\"}" :: Either String EffectiveLanguageContract) of+        Left message -> do+          message `shouldContain` "runtimeSemantics does not match language version 4"+          message `shouldContain` "keiro-dsl/runtime-semantics/3"+          message `shouldContain` "keiro-dsl/runtime-semantics/2"+        Right _ -> expectationFailure "expected a runtime-profile mismatch"++    it "reports every formerly silent fold-resolution failure and propagates it" $ do+      baseService <- checkedServiceOf "test/fixtures/id-domain-migration-v3.keiro"+      recursiveMapped <- specOf "test/fixtures/mapped-recursive.keiro"+      brokenNominal <- specOf "test/fixtures/nominal-missing-facts.keiro"+      missingInitial <- specOf "test/fixtures/mapped-missing-initial.keiro"+      let contract = checkedLanguageContract baseService+          baseSpec = checkedSpec baseService+          baseAggregate = onlyAggregate baseSpec+          withAggregate transform =+            baseSpec+              { specNodes =+                  [ NAggregate (transform aggregate)+                  | NAggregate aggregate <- specNodes baseSpec+                  ]+              }+          replaceFirstTransition transform aggregate =+            aggregate+              { aggTransitions = case aggTransitions aggregate of+                  transition : rest -> transform transition : rest+                  [] -> []+              }+          guardSpec = withAggregate (replaceFirstTransition (\transition -> transition {tGuard = Just (EAtom (AName "missingGuardRoot"))}))+          outputSpec = withAggregate (replaceFirstTransition (\transition -> transition {tEmits = ["MissingEvent"]}))+          typeGraphSpec = baseSpec {specMapped = specMapped recursiveMapped}+          nominalSpec = baseSpec {specNominalScalars = specNominalScalars brokenNominal}+          cases =+            [ (checkedServiceForContract contract typeGraphSpec, baseAggregate, \case FoldTypeGraphResolutionFailed {} -> True; _ -> False),+              (checkedServiceForContract contract nominalSpec, baseAggregate, \case FoldNominalResolutionFailed {} -> True; _ -> False),+              (checkedServiceForContract contract missingInitial, onlyAggregate missingInitial, \case FoldRegisterInitialResolutionFailed {} -> True; _ -> False),+              (checkedServiceForContract contract guardSpec, onlyAggregate guardSpec, \case FoldGuardResolutionFailed {} -> True; _ -> False),+              (checkedServiceForContract contract outputSpec, onlyAggregate outputSpec, \case FoldEventOutputResolutionFailed {} -> True; _ -> False)+            ]+      forM_ cases $ \(service, aggregate, matches) -> do+        CheckedFold.aggregateFoldSurfaceForService service aggregate+          `shouldSatisfy` either matches (const False)+        CheckedFold.aggregateFoldFingerprintForService service aggregate+          `shouldSatisfy` either matches (const False)+      let brokenService = checkedServiceForContract contract guardSpec+      CheckedDiff.diffServices brokenService baseService `shouldSatisfy` isLeft+      ReplayImpact.replayImpactServices brokenService baseService `shouldSatisfy` isLeft+      planTestServiceScaffold (defaultContext (specContext guardSpec)) brokenService+        `shouldSatisfy` \case+          Left refusals -> any (\case FoldSurfaceRefusal {} -> True; _ -> False) refusals+          Right _ -> False++    it "pins representative diff and replay-impact rendering" $ do+      old <- parsedSourceOf "test/fixtures/reservation.keiro"+      new <- parsedSourceOf "test/fixtures/reservation-guard-tightened.keiro"+      let changes = diffSources old new+          impact = resolvedFold (ReplayImpact.replayImpactServices (checkedSource old) (checkedSource new))+          actual =+            T.intercalate+              "\n"+              ( "diff:"+                  : map renderFinding changes+                    <> ["replay:", ReplayImpact.renderReplayImpact impact]+              )+      assertMatchesGolden "test/fixtures/fold-identity-diff-replay.golden" actual++    it "pins unrelated public 64-bit identities outside the fold digest" $ do+      readModelSpec <- specOf "test/fixtures/readmodel.keiro"+      wireSpec <- specOf "test/fixtures/consumer-types.keiro"+      behaviorSpec <- specOf "test/fixtures/behavior-complete.keiro"+      readModel <- case [value | NReadModel value <- specNodes readModelSpec] of+        value : _ -> pure value+        [] -> expectationFailure "missing read-model fixture" >> fail "unreachable"+      graph <- shouldResolveTypeGraph wireSpec+      behaviorKey <- case Behavior.deriveBehaviorRequirements behaviorSpec of+        Right (requirement : _) -> pure (Behavior.unBehaviorKey (Behavior.requirementKey requirement))+        result -> expectationFailure ("missing behavior requirement: " <> show result) >> fail "unreachable"+      deriveShapeHash readModel `shouldBe` "fnv1a:3717f6d9e3c44bd6"+      wireFingerprint graph "ArtifactInfo" `shouldBe` "2bd99b3e57bcde9b"+      behaviorKey `shouldBe` "behavior-v1-0128e858fee6f2b3"++  describe "source language version" $ do+    let legacy = "context hospital-capacity\n"+        declared = "# leading comment\n\nlanguage keiro-dsl 1\ncontext hospital-capacity\n"+        failureCode source = case parseSource "source.keiro" source of+          Left (SourceLanguageFailure diagnostic) -> Just (sourceLanguageErrorCode diagnostic)+          _ -> Nothing+        parseRight name source = case parseSource name source of+          Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+          Right value -> pure value+        declaredVersionOf DeclaredLanguage {declaredLanguageVersion = version} = Just version+        declaredVersionOf LegacyUnversioned = Nothing+        orderedSubstrings needles haystack = go (map T.pack needles) (T.pack haystack)+          where+            go [] _ = True+            go (needle : rest) remaining =+              let (_, suffix) = T.breakOn needle remaining+               in not (T.null suffix) && go rest (T.drop (T.length needle) suffix)++    it "selects declared v1 after comments while preserving semantic equality" $ do+      legacySource <- parseRight "legacy.keiro" legacy+      declaredSource <- parseRight "declared.keiro" declared+      parsedSpec legacySource `shouldBe` parsedSpec declaredSource+      parsedSourceLanguage legacySource `shouldBe` LegacyUnversioned+      declaredVersionOf (parsedSourceLanguage declaredSource) `shouldBe` languageVersion 1+      effectiveLanguageVersion (parsedSourceLanguage legacySource)+        `shouldBe` effectiveLanguageVersion (parsedSourceLanguage declaredSource)++    it "threads paired released versions through one checked semantic boundary" $ do+      let body = T.unlines ["context semantic-pair", "aggregate Counter", "  regs", "  states Open"]+          v1Text = "language keiro-dsl 1\n" <> body+          v2Text = "language keiro-dsl 2\n" <> body+      v1Source <- parseRight "reservation-v1.keiro" v1Text+      v2Source <- parseRight "reservation-v2.keiro" v2Text+      let v1Service = checkedSource v1Source+          v2Service = checkedSource v2Source+          v1Spec = checkedSpec v1Service+          v2Spec = checkedSpec v2Service+          ctx = defaultContext (specContext v1Spec)+          aggregates spec = [aggregate | NAggregate aggregate <- specNodes spec]+      v1Spec `shouldBe` v2Spec+      Just (effectiveContractLanguageVersion (checkedLanguageContract v1Service)) `shouldBe` languageVersion 1+      Just (effectiveContractLanguageVersion (checkedLanguageContract v2Service)) `shouldBe` languageVersion 2+      effectiveRuntimeSemantics (checkedLanguageContract v1Service)+        `shouldBe` effectiveRuntimeSemantics (checkedLanguageContract v2Service)+      validateService v1Service `shouldBe` validateService v2Service+      scaffoldServiceModules ctx v1Service `shouldBe` scaffoldServiceModules ctx v2Service+      case (aggregates v1Spec, aggregates v2Spec) of+        ([v1Aggregate], [v2Aggregate]) -> do+          aggregateFoldSurfaceForService v1Service v1Aggregate+            `shouldBe` aggregateFoldSurfaceForService v2Service v2Aggregate+          aggregateFoldFingerprintForService v1Service v1Aggregate+            `shouldBe` aggregateFoldFingerprintForService v2Service v2Aggregate+        other -> expectationFailure ("expected one aggregate per paired source, got " <> show (fmap length other))+      diffServices v1Service v2Service `shouldBe` []+      resolvedFold (ReplayImpact.replayImpactServices v1Service v2Service) `shouldBe` ReplayNeutral++    it "retains one effective contract for same-version workspaces and refuses mixed versions" $ do+      let manifest = "service semantic-workspace\nspec domain/a.keiro\nspec domain/b.keiro\n"+          v1Body = "language keiro-dsl 1\ncontext semantic-workspace\n"+          v2Body = "language keiro-dsl 2\ncontext semantic-workspace\n"+          sourceWith b =+            memoryContentSource+              ( Map.fromList+                  [ ("service.keiro-workspace", manifest),+                    ("domain/a.keiro", b),+                    ("domain/b.keiro", b)+                  ]+              )+          mixedSource =+            memoryContentSource+              ( Map.fromList+                  [ ("service.keiro-workspace", manifest),+                    ("domain/a.keiro", v1Body),+                    ("domain/b.keiro", v2Body)+                  ]+              )+      sameVersion <- loadWorkspace (sourceWith v2Body) "service.keiro-workspace"+      case sameVersion of+        Right workspace -> do+          Just (effectiveContractLanguageVersion (checkedLanguageContract (checkedWorkspace workspace))) `shouldBe` languageVersion 2+          validateService (checkedWorkspace workspace) `shouldBe` []+        Left failure -> expectationFailure (show failure)+      mixed <- loadWorkspace mixedSource "service.keiro-workspace"+      case mixed of+        Left (WorkspaceRefused diagnostics) ->+          map wdCode (NE.toList diagnostics) `shouldContain` [WorkspaceLanguageVersionMismatch]+        other -> expectationFailure ("expected a mixed-version refusal, got " <> show other)++    it "refuses a source/service contract mismatch before creating the output directory" $ do+      v1Version <- maybe (expectationFailure "version 1 missing" >> fail "unreachable") pure (languageVersion 1)+      parsed <- parseRight "semantic-v2.keiro" "language keiro-dsl 2\ncontext semantic-refusal\n"+      let service = checkedSource parsed+          ctx = defaultContext "semantic-refusal"+      modules <- case planTestServiceScaffold ctx service of+        Left refusals -> expectationFailure (show refusals) >> fail "unreachable"+        Right planned -> pure planned+      withTempDirectory "keiro-dsl-semantic-refusal" $ \root -> do+        let out = root </> "not-created"+        result <- executeServiceScaffold out False "semantic-v2.keiro" (DeclaredLanguage v1Version noLoc) ctx service modules+        result `shouldBe` Left [SemanticContractMismatch "source provenance and checked service selected different effective language contracts"]+        doesDirectoryExist out `shouldReturn` False++    it "retains explicit declarations in source rendering and leaves legacy unversioned" $ do+      legacySource <- parseRight "legacy.keiro" legacy+      declaredSource <- parseRight "declared.keiro" declared+      renderSource legacySource `shouldBe` "context hospital-capacity\n"+      renderSource declaredSource `shouldBe` "language keiro-dsl 1\ncontext hospital-capacity\n"+      parseSpec "declared.keiro" declared `shouldBe` Right (parsedSpec declaredSource)++    it "classifies invalid, unsupported, duplicate, and misplaced preambles" $ do+      failureCode "language keiro-dsl 0\ncontext hospital-capacity\n" `shouldBe` Just InvalidLanguageVersion+      failureCode "language keiro-dsl nope\ncontext hospital-capacity\n" `shouldBe` Just InvalidLanguageVersion+      failureCode "language keiro-dsl -1\ncontext hospital-capacity\n" `shouldBe` Just InvalidLanguageVersion+      failureCode "language keiro-dsl 999999\ncontext hospital-capacity\n" `shouldBe` Just UnsupportedLanguageVersion+      failureCode "language keiro-dsl 1\nlanguage keiro-dsl 1\ncontext hospital-capacity\n" `shouldBe` Just DuplicateLanguagePreamble+      failureCode "context hospital-capacity\nlanguage keiro-dsl 1\n" `shouldBe` Just MisplacedLanguagePreamble++    it "treats language and successor spellings as data in nested grammar positions" $ do+      forM_ ["language-identifier-v1.keiro", "language-identifier-v2.keiro"] $ \fixture -> do+        source <- readTestText ("test/fixtures/" <> fixture)+        parsed <- parseRight fixture source+        validateSpec (parsedSpec parsed) `shouldBe` []+      v1 <- readTestText "test/fixtures/language-identifier-v1.keiro"+      let manifest = "service language-collisions\nspec domain/collisions.keiro\n"+          workspaceSource = memoryContentSource (Map.fromList [("service.keiro-workspace", manifest), ("domain/collisions.keiro", v1)])+      loaded <- loadWorkspace workspaceSource "service.keiro-workspace"+      loaded `shouldSatisfy` isRight++    it "keeps duplicate and misplaced preamble diagnostics on their grammar lines" $ do+      let sourceFailureAt expectedCode expectedLine source =+            case parseSource "located.keiro" source of+              Left (SourceLanguageFailure diagnostic) -> do+                sourceLanguageErrorCode diagnostic `shouldBe` expectedCode+                unLoc (sourceLanguageLoc diagnostic) `shouldBe` expectedLine+              other -> expectationFailure ("expected located source-language failure, got " <> show other)+      sourceFailureAt DuplicateLanguagePreamble 2 "language keiro-dsl 1\nlanguage keiro-dsl 1\ncontext located\n"+      sourceFailureAt MisplacedLanguagePreamble 3 "context located\nid language prefix=lang\nlanguage keiro-dsl 1\n"++    it "rejects a future version before parsing an invalid v1 body" $+      case parseSource "unregistered.keiro" "language keiro-dsl 999999\nthis is not a v2 body\n" of+        Left failure@(SourceLanguageFailure diagnostic) -> do+          sourceLanguageErrorCode diagnostic `shouldBe` UnsupportedLanguageVersion+          renderParseFailure failure `shouldSatisfy` T.isInfixOf "supported versions: 1, 2, 3, 4, 5"+          renderParseFailure failure `shouldNotSatisfy` T.isInfixOf "expecting `context`"+        other -> expectationFailure ("expected source-language failure, got " <> show other)++    it "accepts and canonically round-trips nominal declarations only in v2" $ do+      let nominalSource =+            T.unlines+              [ "language keiro-dsl 2",+                "context orders",+                "id OrderId prefix=ord using {",+                "  haskell package=orders-domain module=Orders.Id type=OrderId",+                "  binding = \"Orders.KeiroBindings.orderIdBinding\"",+                "  binding-version = \"1\"",+                "  canonical-type = \"orders.OrderId.v1\"",+                "  fixtures = \"Orders.KeiroBindings.orderIdFixtures\"",+                "}",+                "enum OrderStatus { Draft=draft Submitted=submitted } using {",+                "  haskell package=orders-domain module=Orders.Order type=OrderStatus",+                "  binding = \"Orders.KeiroBindings.orderStatusBinding\"",+                "  binding-version = \"1\"",+                "  canonical-type = \"orders.OrderStatus.v1\"",+                "  fixtures = \"Orders.KeiroBindings.orderStatusFixtures\"",+                "}",+                "mapped nominal AccountNumber : Text {",+                "  haskell package=orders-domain module=Orders.Account type=AccountNumber",+                "  binding = \"Orders.KeiroBindings.accountNumberBinding\"",+                "  binding-version = \"1\"",+                "  canonical-type = \"orders.AccountNumber.v1\"",+                "  fixtures = \"Orders.KeiroBindings.accountNumberFixtures\"",+                "  initial = \"Orders.KeiroBindings.initialAccountNumber\"",+                "}"+              ]+      parsed <- parseRight "nominal.keiro" nominalSource+      length (specIds (parsedSpec parsed)) `shouldBe` 1+      length (specEnums (parsedSpec parsed)) `shouldBe` 1+      length (specNominalScalars (parsedSpec parsed)) `shouldBe` 1+      parseSource "nominal-round-trip.keiro" (renderSource parsed) `shouldBe` Right parsed++    it "reports successor nominal syntax as one language-version diagnostic under v1 and legacy" $ do+      let body = "context orders\nmapped nominal AccountNumber : Text {}\n"+      failureCode ("language keiro-dsl 1\n" <> body) `shouldBe` Just LanguageFeatureRequiresVersion+      failureCode body `shouldBe` Just LanguageFeatureRequiresVersion++    it "parses and canonically round-trips field aliases only in language 4" $ do+      let v4Source =+            T.unlines+              [ "language keiro-dsl 4",+                "context aliases",+                "aggregate Order",+                "  regs",+                "  states Open",+                "  command Change { type haskell payloadType as \"type\":Text haskell as }",+                "contract publicOrder {",+                "  schemaVersion 1",+                "  discriminator kind",+                "  topic changes \"orders.v1\"",+                "  event Changed on changes {",+                "    region haskell serviceRegion as \"region_code\": text",+                "  }",+                "}"+              ]+          v3Source = T.replace "language keiro-dsl 4" "language keiro-dsl 3" v4Source+      parsed <- parseRight "field-aliases.keiro" v4Source+      parseSource "field-aliases-round-trip.keiro" (renderSource parsed) `shouldBe` Right parsed+      case specNodes (parsedSpec parsed) of+        [NAggregate aggregate, NContract contract] -> do+          case cmdFields =<< aggCommands aggregate of+            aliased : haskellField : asField : _ -> do+              (aggregateFieldName aliased, aggregateFieldSelector aliased, aggregateFieldWireKey aliased)+                `shouldBe` ("type", Just "payloadType", Just "type")+              map aggregateFieldName [haskellField, asField] `shouldBe` ["haskell", "as"]+            fields -> expectationFailure ("unexpected aggregate alias fields: " <> show fields)+          case ceFields =<< ctrEvents contract of+            [field] ->+              (cfName field, cfSelector field, cfWireKey field, cfLoc field)+                `shouldBe` ("region", Just "serviceRegion", Just "region_code", Loc 12)+            fields -> expectationFailure ("unexpected contract alias fields: " <> show fields)+        nodes -> expectationFailure ("unexpected alias nodes: " <> show nodes)+      failureCode v3Source `shouldBe` Just LanguageFeatureRequiresVersion++    it "attributes every successor feature gate to its owning grammar production" $ do+      let featureFailureAt expectedLine source =+            case parseSource "feature.keiro" source of+              Left (SourceLanguageFailure diagnostic) -> do+                sourceLanguageErrorCode diagnostic `shouldBe` LanguageFeatureRequiresVersion+                unLoc (sourceLanguageLoc diagnostic) `shouldBe` expectedLine+              other -> expectationFailure ("expected a located feature gate, got " <> show other)+          aggregateWith clause =+            T.unlines+              [ "language keiro-dsl 1",+                "context feature-gates",+                "aggregate Account",+                "  regs",+                "    balance Text = \"0\"",+                "  states Open",+                "  command Adjust { amount:Text }",+                "  event Adjusted = fields(Adjust)",+                "  Open -- Adjust --> " <> clause <> " ; emit Adjusted ; goto Open"+              ]+      featureFailureAt 3 (T.unlines ["language keiro-dsl 1", "context feature-gates", "id AccountId prefix=acct using {"])+      featureFailureAt 3 (T.unlines ["language keiro-dsl 1", "context feature-gates", "mapped nominal AccountNumber : Text {}"])+      featureFailureAt 5 (T.unlines ["language keiro-dsl 1", "context feature-gates", "aggregate Account", "  regs", "    balance Integer = 0", "  states Open"])+      featureFailureAt 9 (aggregateWith "guard reg.balance == cmd.amount")+      featureFailureAt 9 (aggregateWith "implementation hole")++    it "reports a declaration-only rewrite without semantic, generated, fold, or replay impact" $ do+      fixture <- readTestText "test/fixtures/language-v1.keiro"+      let legacyFixture = T.unlines (drop 1 (T.lines fixture))+      legacySource <- parseRight "legacy.keiro" legacyFixture+      declaredSource <- parseRight "declared.keiro" fixture+      let oldSpec = parsedSpec legacySource+          newSpec = parsedSpec declaredSource+          changes = diffSources legacySource declaredSource+          vectors = [ckVector kind | change <- changes, let kind = workspaceChangeKind change]+      map changeCode changes `shouldBe` [SourceLanguageDeclarationChanged]+      legacyDiffSpecs oldSpec newSpec `shouldBe` []+      vectors `shouldSatisfy` all (\compatibility -> all ((== VCompatible) . (`verdictFor` compatibility)) [minBound .. maxBound])+      case changes of+        [change] ->+          remediationFor (ckContext (workspaceChangeKind change)) SourceLanguageDeclarationChanged+            `shouldBe` (RemedyNoSemanticAction :| [])+        _ -> expectationFailure "expected one source-language change"+      let legacyGeneratedSurface spec =+            [ (modulePath scaffoldModule, moduleText scaffoldModule, kind scaffoldModule)+            | scaffoldModule <- scaffoldModules (defaultContext (specContext spec)) spec+            ]+          legacyFoldFingerprint spec aggregate = aggregateFoldFingerprintForService (legacyCheckedService spec) aggregate+      legacyGeneratedSurface oldSpec `shouldBe` legacyGeneratedSurface newSpec+      [legacyFoldFingerprint oldSpec aggregate | NAggregate aggregate <- specNodes oldSpec]+        `shouldBe` [legacyFoldFingerprint newSpec aggregate | NAggregate aggregate <- specNodes newSpec]+      legacyReplayImpactSpecs oldSpec newSpec `shouldBe` ReplayNeutral++    it "exposes published support in source and workspace JSON inspection" $ do+      (sourceCode, sourceOut, sourceErr) <- runKeiroDsl ["inspect", "test/fixtures/reservation.keiro", "--format=json"]+      sourceCode `shouldBe` ExitSuccess+      sourceErr `shouldBe` ""+      sourceOut `shouldContain` "\"schema\":\"keiro-dsl/source-inspection/1\""+      sourceOut `shouldContain` "\"kind\":\"source\""+      sourceOut `shouldContain` "\"sourceForm\":\"declared\""+      sourceOut `shouldContain` "\"declaredLanguageVersion\":4"+      sourceOut `shouldContain` "\"effectiveLanguageVersion\":4"+      sourceOut `shouldContain` "\"effectiveSemanticContract\":{"+      sourceOut `shouldContain` "\"runtimeSemantics\":\"keiro-dsl/runtime-semantics/3\""+      sourceOut `shouldContain` "\"languageSupport\":\"compatibility-only\""+      (workspaceCode, workspaceOut, workspaceErr) <- runKeiroDsl ["inspect", canonicalWorkspacePath, "--format=json"]+      workspaceCode `shouldBe` ExitSuccess+      workspaceErr `shouldBe` ""+      workspaceOut `shouldContain` "\"kind\":\"workspace\""+      workspaceOut `shouldContain` "\"service\":\"demo-project\""+      workspaceOut `shouldContain` "\"effectiveSemanticContract\":{"+      workspaceOut `shouldContain` "\"languageSupport\":\"compatibility-only\""+      workspaceOut `shouldSatisfy` orderedSubstrings ["domain/project-artifact.keiro", "domain/project.keiro", "domain/shared.keiro"]+      (stableCode, stableOut, stableErr) <- runKeiroDsl ["inspect", "test/fixtures/workflow-evolution.keiro", "--format=json"]+      stableCode `shouldBe` ExitSuccess+      stableErr `shouldBe` ""+      stableOut `shouldContain` "\"declaredLanguageVersion\":5"+      stableOut `shouldContain` "\"effectiveLanguageVersion\":5"+      stableOut `shouldContain` "\"languageSupport\":\"stable\""++    it "keeps only the named source-version fixtures outside published Language 4" $ do+      fixtureTree <- treeSnapshot "test/fixtures"+      let outsideStableV4 =+            sort+              [ path+              | (path, contents) <- fixtureTree,+                takeExtension path == ".keiro",+                "language keiro-dsl 4" `notElem` T.lines contents+              ]+      outsideStableV4+        `shouldBe` sort+          [ "aggregate-collection-expressions-v2-rejects.keiro",+            "aggregate-scalar-expressions-v1-rejects.keiro",+            "catalog-readmodel-backing-required.keiro",+            "catalog-readmodel-backing-unobserved.keiro",+            "catalog-readmodel-physical-override.keiro",+            "catalog-readmodel-reorder-a.keiro",+            "catalog-readmodel-reorder-b.keiro",+            "contract-v1-compat.keiro",+            "declarative-router/unbounded.keiro",+            "declarative-router/valid.keiro",+            "domain-command-outcomes.keiro",+            "id-domain-migration-v3.keiro",+            "language-duplicate.keiro",+            "language-identifier-v1.keiro",+            "language-identifier-v2.keiro",+            "language-legacy.keiro",+            "language-malformed.keiro",+            "language-misplaced.keiro",+            "language-v1.keiro",+            "language-zero.keiro",+            "mapped-readmodel-workspace/readmodel.keiro",+            "mapped-readmodel-workspace/types.keiro",+            "mapped-readmodel.keiro",+            "mapped-workqueue.keiro",+            "nominal-v1.keiro",+            "outcome-identifier-legacy.keiro",+            "outcome-identifier-v5.keiro",+            "projection-catalog-unrelated.keiro",+            "projection-catalog.keiro",+            "projection-owner-multi-query.keiro",+            "workflow-evolution.keiro"+          ]++    it "checks v1 and inspects legacy explicitly" $ do+      (v1Code, v1Out, v1Err) <- runKeiroDsl ["check", "test/fixtures/language-v1.keiro"]+      v1Code `shouldBe` ExitSuccess+      v1Out `shouldBe` "OK\n"+      v1Err `shouldContain` "language contract: effective keiro-dsl 1 (declared, compatibility-only, runtime semantics keiro-dsl/runtime-semantics/1)"+      (legacyCode, legacyOut, legacyErr) <- runKeiroDsl ["inspect", "test/fixtures/language-legacy.keiro", "--format=json"]+      legacyCode `shouldBe` ExitSuccess+      legacyErr `shouldBe` ""+      legacyOut `shouldContain` "\"sourceForm\":\"legacy-unversioned\""+      legacyOut `shouldContain` "\"declaredLanguageVersion\":null"+      legacyOut `shouldContain` "\"effectiveLanguageVersion\":1"+      legacyOut `shouldContain` "\"languageSupport\":\"compatibility-only\""++    it "checks and scaffolds contextual language identifiers through the CLI" $ do+      forM_ ["language-identifier-v1.keiro", "language-identifier-v2.keiro"] $ \fixture -> do+        let sourcePath = "test/fixtures/" <> fixture+        (checkCode, checkOut, checkErr) <- runKeiroDsl ["check", sourcePath]+        checkCode `shouldBe` ExitSuccess+        checkOut `shouldBe` "OK\n"+        checkErr `shouldContain` "language contract: effective keiro-dsl"+        withTempDirectory ("keiro-dsl-" <> fixture) $ \out -> do+          (scaffoldCode, _, scaffoldErr) <- runKeiroDsl ["scaffold", sourcePath, "--out", out]+          scaffoldCode `shouldBe` ExitSuccess+          scaffoldErr `shouldContain` "language contract: effective keiro-dsl"+          scaffoldErr `shouldContain` "firewall: OK"++    it "notices only the working-tree contract during diff" $ do+      (diffCode, _, diffErr) <- runKeiroDsl ["diff", "test/fixtures/language-v1.keiro", "--since", "HEAD"]+      diffCode `shouldBe` ExitSuccess+      T.count "language contract:" (T.pack diffErr) `shouldBe` 1+      diffErr `shouldContain` "language contract: effective keiro-dsl 1 (declared, compatibility-only, runtime semantics keiro-dsl/runtime-semantics/1)"++    it "preserves a workspace member's source-selection code beneath outer attribution" $ do+      let manifest = "service demo\nspec domain/future.keiro\n"+          futureSource = "language keiro-dsl 999999\nthis body must not parse\n"+          source = memoryContentSource (Map.fromList [("service.keiro-workspace", manifest), ("domain/future.keiro", futureSource)])+      loaded <- loadWorkspace source "service.keiro-workspace"+      case loaded of+        Left (WorkspaceRefused (diagnostic :| [])) -> do+          wdCode diagnostic `shouldBe` WorkspaceMemberParseFailed+          sourceLanguageErrorCode <$> wdSourceLanguageCause diagnostic+            `shouldBe` Just UnsupportedLanguageVersion+          renderWorkspaceDiagnostic "service.keiro-workspace" diagnostic+            `shouldSatisfy` T.isInfixOf "UnsupportedLanguageVersion"+        other -> expectationFailure ("expected one attributed source-language refusal, got " <> show other)++    it "attributes a workspace provenance-only diff to the changed member" $ do+      workspace <- shouldComposeWorkspace canonicalWorkspacePath+      case wsMembers workspace of+        firstMember : remaining -> do+          let changedMember = firstMember {wmSourceLanguage = LegacyUnversioned}+              changedWorkspace = workspace {wsMembers = changedMember : remaining}+              changes = diffWorkspaces workspace changedWorkspace+          map (changeCode . wcChange) changes `shouldBe` [SourceLanguageDeclarationChanged]+          map (fmap osFile . wcDeclarationSite) changes `shouldBe` [Just (wmPath firstMember)]+          map wcChange changes `shouldSatisfy` all (not . gatedBreaking (gateWith [minBound .. maxBound]))+        _ -> expectationFailure "canonical workspace had no member"++  describe "typed-domain-outcomes" $ do+    it "parses, validates, and canonically round-trips the complete language-5 fixture" $ do+      source <- readTestText "test/fixtures/domain-command-outcomes.keiro"+      parsed <- case parseSource "domain-command-outcomes.keiro" source of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      validateService (checkedSource parsed) `shouldBe` []+      parseSource "domain-command-outcomes-rendered.keiro" (renderSource parsed) `shouldBe` Right parsed+      let outcomeKind :: TransitionOutcome -> T.Text+          outcomeKind outcome = case outcome of+            OutcomeAccepted {} -> "accepted"+            OutcomeRejected {} -> "rejected"+            OutcomeNoOp {} -> "no-op"+      case [aggregate | NAggregate aggregate <- specNodes (parsedSpec parsed)] of+        [aggregate] -> do+          fmap (\types -> (rejectionType types, noOpType types)) (aggDomainOutcomeTypes aggregate)+            `shouldBe` Just ("ReservationRejection", "ReservationNoOp")+          map (fmap outcomeKind . tOutcome) (aggTransitions aggregate)+            `shouldBe` map Just ["accepted", "rejected", "no-op"]+        aggregates -> expectationFailure ("unexpected outcome aggregates: " <> show aggregates)++    it "gates the syntax to Language 5" $ do+      source <- readTestText "test/fixtures/domain-command-outcomes.keiro"+      case parseSource "domain-command-outcomes-v4.keiro" (T.replace "language keiro-dsl 5" "language keiro-dsl 4" source) of+        Left (SourceLanguageFailure diagnostic) -> sourceLanguageErrorCode diagnostic `shouldBe` LanguageFeatureRequiresVersion+        other -> expectationFailure ("expected language feature refusal, got " <> show other)++    it "generates one direct exact-edge classifier arm per silent outcome" $ do+      source <- readTestText "test/fixtures/domain-command-outcomes.keiro"+      parsed <- case parseSource "domain-command-outcomes.keiro" source of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      aggregate <- case [value | NAggregate value <- specNodes (parsedSpec parsed)] of+        [value] -> pure value+        values -> expectationFailure ("unexpected outcome aggregates: " <> show values) >> fail "unreachable"+      let scaffoldContext = defaultContext (specContext (parsedSpec parsed))+          modules = scaffoldAggregateForService scaffoldContext (checkedSource parsed) aggregate+          modulesAgain = scaffoldAggregateForService scaffoldContext (checkedSource parsed) aggregate+          eventStream = case [moduleText value | value <- modules, "/EventStream.hs" `T.isSuffixOf` T.pack (modulePath value)] of+            [value] -> value+            values -> error ("unexpected outcome event-stream modules: " <> show values)+          behaviorContract = case [moduleText value | value <- modules, "/BehaviorContract.hs" `T.isSuffixOf` T.pack (modulePath value)] of+            [value] -> value+            values -> error ("unexpected outcome behavior-contract modules: " <> show values)+      map moduleText modulesAgain `shouldBe` map moduleText modules+      firewallBreaches modules `shouldBe` []+      eventStream `shouldSatisfy` T.isInfixOf "reservationDomainCommandHandler"+      eventStream `shouldSatisfy` T.isInfixOf "case edgeSource of"+      eventStream `shouldSatisfy` T.isInfixOf "case edgeIndex of"+      T.count " -> SilentRejected" eventStream `shouldBe` 1+      T.count " -> SilentNoOp" eventStream `shouldBe` 1+      T.count "K.evalTerm" eventStream `shouldBe` 2+      eventStream `shouldSatisfy` T.isInfixOf "0 -> SilentRejected"+      eventStream `shouldSatisfy` T.isInfixOf "1 -> SilentNoOp"+      forM_ ["Data.Map", "lookup", "find", "edgesOut", "Keiro.Command.Domain"] $ \forbidden ->+        eventStream `shouldSatisfy` (not . T.isInfixOf forbidden)+      behaviorContract `shouldSatisfy` T.isInfixOf "RejectedWith ReservationRejection"+      behaviorContract `shouldSatisfy` T.isInfixOf "NoOpWith ReservationNoOp"+      behaviorContract `shouldSatisfy` T.isInfixOf "runSilentDecision"+      behaviorContract `shouldSatisfy` T.isInfixOf "reservationDomainCommandHandler"++    it "reports complete, typed, and state-preserving outcome diagnostics" $ do+      source <- readTestText "test/fixtures/domain-command-outcomes.keiro"+      let codes changed = do+            case parseSource "domain-outcome-mutation.keiro" changed of+              Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> pure []+              Right parsed -> pure (map code (validateService (checkedSource parsed)))+          expectCode expected changed = codes changed >>= (`shouldContain` [expected])+      expectCode+        DomainOutcomeDeclarationDuplicate+        (T.replace "  domain-outcomes rejection=ReservationRejection no-op=ReservationNoOp\n" "  domain-outcomes rejection=ReservationRejection no-op=ReservationNoOp\n  domain-outcomes rejection=ReservationRejection no-op=ReservationNoOp\n" source)+      expectCode+        DomainOutcomeDeclarationMissing+        (T.replace "  domain-outcomes rejection=ReservationRejection no-op=ReservationNoOp\n" "" source)+      expectCode+        DomainOutcomeClauseMissing+        (T.replace "    outcome accepted\n" "" source)+      expectCode+        DomainOutcomeClauseDuplicate+        (T.replace "    outcome accepted\n" "    outcome accepted\n    outcome accepted\n" source)+      expectCode+        DomainOutcomeTypeUnresolved+        (T.replace "rejection=ReservationRejection" "rejection=MissingRejection" source)+      expectCode+        DomainOutcomeReasonTypeMismatch+        (T.replace "ReservationRejection.AlreadyCancelled" "ReservationNoOp.DuplicateRequest" source)+      expectCode+        DomainOutcomeAcceptedWithoutEvents+        (T.replace "    emit Cancelled\n" "" source)+      expectCode+        DomainOutcomeSilentEmits+        (T.replace "    outcome rejected ReservationRejection.AlreadyCancelled\n" "    outcome rejected ReservationRejection.AlreadyCancelled\n    emit Cancelled\n" source)+      expectCode+        DomainOutcomeSilentWrites+        (T.replace "    outcome no-op ReservationNoOp.DuplicateRequest\n" "    outcome no-op ReservationNoOp.DuplicateRequest\n    write lastRequestId := cmd.requestId\n" source)+      expectCode+        DomainOutcomeSilentStateChange+        (T.replace "    outcome no-op ReservationNoOp.DuplicateRequest\n    goto CancelledState\n" "    outcome no-op ReservationNoOp.DuplicateRequest\n    goto Eligible\n" source)+      expectCode+        DomainOutcomeReplayOnlyClause+        (T.replace "  CancelledState -- Cancel -->\n    guard cmd.requestId != reg.lastRequestId" "  replay-only CancelledState -- Cancel -->\n    guard cmd.requestId != reg.lastRequestId" source)++    it "changes behavior identity and semantic diff without moving fold or replay identity" $ do+      source <- readTestText "test/fixtures/domain-command-outcomes.keiro"+      let changedSource = T.replace "ReservationRejection.AlreadyCancelled" "ReservationRejection.CapacityUnavailable" source+      oldParsed <- case parseSource "domain-outcomes-old.keiro" source of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      newParsed <- case parseSource "domain-outcomes-new.keiro" changedSource of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      validateService (checkedSource newParsed) `shouldBe` []+      oldAggregate <- case [aggregate | NAggregate aggregate <- specNodes (parsedSpec oldParsed)] of+        [aggregate] -> pure aggregate+        aggregates -> expectationFailure ("unexpected old outcome aggregates: " <> show aggregates) >> fail "unreachable"+      newAggregate <- case [aggregate | NAggregate aggregate <- specNodes (parsedSpec newParsed)] of+        [aggregate] -> pure aggregate+        aggregates -> expectationFailure ("unexpected new outcome aggregates: " <> show aggregates) >> fail "unreachable"+      let changes = diffSources oldParsed newParsed+          oldBehavior = Behavior.deriveAggregateBehaviorRequirements (parsedSpec oldParsed) oldAggregate+          newBehavior = Behavior.deriveAggregateBehaviorRequirements (parsedSpec newParsed) newAggregate+          changeKind change = case change of+            Additive value -> value+            Advisory value -> value+            Breaking value -> value+      map (ckCode . changeKind) changes `shouldContain` [DomainTransitionOutcomeChanged]+      map (ckCode . changeKind) changes `shouldNotContain` [AggFoldSurfaceChanged]+      aggregateFoldFingerprintForService (checkedSource oldParsed) oldAggregate+        `shouldBe` aggregateFoldFingerprintForService (checkedSource newParsed) newAggregate+      oldBehavior `shouldNotBe` newBehavior+      ReplayImpact.replayImpactServices (checkedSource oldParsed) (checkedSource newParsed)+        `shouldBe` Right ReplayImpact.ReplayNeutral++  describe "outcome identifier compatibility" $ do+    it "parses outcome as an ordinary identifier under legacy and declared language 1" $ do+      source <- readTestText "test/fixtures/outcome-identifier-legacy.keiro"+      case parseSource "outcome-identifier-legacy.keiro" source of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure))+        Right _ -> pure ()+      case parseSource "outcome-identifier-v1.keiro" ("language keiro-dsl 1\n" <> source) of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure))+        Right _ -> pure ()++    it "parses outcome as an ordinary identifier under languages 2, 3, and 4" $ do+      source <- readTestText "test/fixtures/outcome-identifier.keiro"+      forM_ ["2", "3", "4"] $ \version ->+        case parseSource+          ("outcome-identifier-v" <> T.unpack version <> ".keiro")+          (T.replace "language keiro-dsl 4" ("language keiro-dsl " <> version) source) of+          Left failure -> expectationFailure (T.unpack (renderParseFailure failure))+          Right parsed+            | version == "4" -> validateService (checkedSource parsed) `shouldBe` []+            | otherwise -> pure ()++    it "parses outcome as an enum constructor, state, and transition source" $ do+      source <- readTestText "test/fixtures/outcome-identifier-positions.keiro"+      case parseSource "outcome-identifier-positions.keiro" source of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure))+        Right parsed -> validateService (checkedSource parsed) `shouldBe` []++    it "round-trips outcome identifiers through the canonical renderer" $ do+      source <- readTestText "test/fixtures/outcome-identifier.keiro"+      parsed <- case parseSource "outcome-identifier.keiro" source of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      parseSource "outcome-identifier-rendered.keiro" (renderSource parsed) `shouldBe` Right parsed++    it "keeps outcome usable as an identifier alongside language-5 outcome clauses" $ do+      source <- readTestText "test/fixtures/outcome-identifier-v5.keiro"+      case parseSource "outcome-identifier-v5.keiro" source of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure))+        Right parsed -> validateService (checkedSource parsed) `shouldBe` []++  describe "language-5 projection catalogs" $ do+    it "rejects explicit physical coordinates on a catalog-bound read model" $ do+      errorCodesOf "test/fixtures/catalog-readmodel-physical-override.keiro"+        `shouldReturn` [CatalogReadModelPhysicalOverride]++    it "requires an observed backing target for multi-target read models" $ do+      errorCodesOf "test/fixtures/catalog-readmodel-backing-required.keiro"+        `shouldReturn` [CatalogReadModelBackingRequired]+      errorCodesOf "test/fixtures/catalog-readmodel-backing-unobserved.keiro"+        `shouldReturn` [CatalogReadModelBackingUnobserved]++    it "binds catalog read models by name and ignores observed-target order" $ do+      sourceA <- readTestText "test/fixtures/catalog-readmodel-reorder-a.keiro"+      sourceB <- readTestText "test/fixtures/catalog-readmodel-reorder-b.keiro"+      parsedA <- case parseSource "catalog-readmodel-reorder-a.keiro" sourceA of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      case parseSource "catalog-readmodel-reorder-a-rendered.keiro" (renderSource parsedA) of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure))+        Right rendered -> parsedSpec rendered `shouldBe` parsedSpec parsedA+      serviceA <- checkedServiceFromText "catalog-readmodel-reorder-a.keiro" sourceA+      serviceB <- checkedServiceFromText "catalog-readmodel-reorder-b.keiro" sourceB+      validateService serviceA `shouldBe` []+      validateService serviceB `shouldBe` []+      let ctx = defaultContext (specContext (checkedSpec serviceA))+          modulesA = scaffoldServiceModules ctx serviceA+          modulesB = scaffoldServiceModules ctx serviceB+          generatedBytes modules = sort [(modulePath moduleValue, moduleText moduleValue) | moduleValue <- modules]+          tableA = generatedTextEndingIn "Generated/BindingDemo/LedgerView/ReadModelTable.hs" modulesA+      generatedBytes modulesA `shouldBe` generatedBytes modulesB+      tableA `shouldSatisfy` T.isInfixOf "qualifyTable \"billing\" \"ledger_entries\""+      map (ckCode . kindOfChange) (diffServices serviceA serviceB)+        `shouldNotContain` [CatalogQueryBindingChanged]++    it "emits grouped harness facts against the generated projection catalog" $ do+      source <- readTestText "test/fixtures/projection-catalog.keiro"+      service <- checkedServiceFromText "projection-catalog.keiro" source+      let spec = checkedSpec service+          modules = scaffoldServiceModules (defaultContext (specContext spec)) service+          auditHarness = generatedTextEndingIn "Generated/CatalogDemo/CatalogAudit/ReadModelHarness.hs" modules+          totalsHarness = generatedTextEndingIn "Generated/CatalogDemo/OrderTotalsLookup/ReadModelHarness.hs" modules+          shipmentHarness = generatedTextEndingIn "Generated/CatalogDemo/ShipmentLookup/ReadModelHarness.hs" modules+      auditHarness `shouldSatisfy` T.isInfixOf "import Generated.CatalogDemo.ProjectionCatalog qualified as ProjectionCatalog"+      auditHarness `shouldSatisfy` T.isInfixOf "ProjectionCatalog.projectionCatalogAsyncRegistrations"+      auditHarness `shouldSatisfy` T.isInfixOf "ProjectionCatalog.projectionCatalogQuerySupplies"+      auditHarness `shouldSatisfy` T.isInfixOf "catalog-demo-catalogAudit|1|fnv1a:9682af3ada04bf50|reporting"+      auditHarness `shouldSatisfy` T.isInfixOf "asyncRegistration:audit_writer"+      auditHarness `shouldSatisfy` T.isInfixOf "querySupply"+      auditHarness `shouldSatisfy` T.isInfixOf "projectionDelivery"+      auditHarness `shouldSatisfy` T.isInfixOf "(\"freshness\", \"Immediate\""+      auditHarness `shouldSatisfy` T.isInfixOf "(\"cursorAuthority\", \"DurableQueryCursor \\\"catalog-demo-audit\\\"\""+      auditHarness `shouldSatisfy` T.isInfixOf "catalog-demo-audit|catalog-demo-audit-v1"+      auditHarness `shouldNotSatisfy` T.isInfixOf "\"catalog-managed\", \"catalog-managed\""+      totalsHarness `shouldSatisfy` T.isInfixOf "order_summary_writer|reporting|order_totals"+      shipmentHarness `shouldSatisfy` T.isInfixOf "catalogRegistration"+      shipmentHarness `shouldNotSatisfy` T.isInfixOf "asyncRegistration:"++    it "parses, validates, and canonically round-trips the closed-world catalog graph" $ do+      source <- readTestText "test/fixtures/projection-catalog.keiro"+      parsed <- case parseSource "projection-catalog.keiro" source of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      validateService (checkedSource parsed) `shouldBe` []+      case parseSource "projection-catalog-rendered.keiro" (renderSource parsed) of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure))+        Right rendered -> parsedSpec rendered `shouldBe` parsedSpec parsed++      let spec = parsedSpec parsed+          targets = [target | NProjectionTarget target <- specNodes spec]+          groups = [groupNode | NRebuildGroup groupNode <- specNodes spec]+          externalReads = [externalRead | NExternalRead externalRead <- specNodes spec]+          owners = [owner | NProjectionOwner owner <- specNodes spec]+      map ptName targets `shouldBe` ["order_summary", "audit_log", "order_totals", "shipment_summary"]+      map rgName groups `shouldBe` ["reporting", "shipping"]+      map (\externalRead -> (erName externalRead, erVersion externalRead, erQueryModel externalRead)) externalReads+        `shouldBe` [("order_totals_reader", 1, "order_totals_lookup")]+      map poName owners `shouldBe` ["order_summary_writer", "shipment_writer", "audit_writer"]+      map poCheckpointOnMissing owners `shouldBe` [[], [], [CheckpointFromCurrentHead]]++    it "validates and truthfully lowers every Language 5 delivery/freshness capability" $ do+      entireSource <- readTestText "test/fixtures/mapped-readmodel.keiro"+      categorySource <- readTestText "test/fixtures/declarative-router/valid.keiro"+      immediateSource <- readTestText "test/fixtures/projection-catalog.keiro"+      entireService <- checkedServiceFromText "projection-freshness-entire.keiro" entireSource+      categoryService <- checkedServiceFromText "projection-freshness-category.keiro" categorySource+      immediateService <- checkedServiceFromText "projection-freshness-immediate.keiro" immediateSource+      let errorsOf service = [diagnostic | diagnostic <- validateService service, severity diagnostic == Error]+      errorsOf entireService `shouldBe` []+      errorsOf categoryService `shouldBe` []+      errorsOf immediateService `shouldBe` []+      let generatedReadModel suffix service =+            generatedTextEndingIn suffix (scaffoldServiceModules (defaultContext (specContext (checkedSpec service))) service)+          entireReadModel = generatedReadModel "AccountSummary/ReadModel.hs" entireService+          categoryReadModel = generatedReadModel "HospitalLoad/ReadModel.hs" categoryService+          immediateReadModelText = generatedReadModel "CatalogAudit/ReadModel.hs" immediateService+          inlineReadModel = generatedReadModel "OrderInline/ReadModel.hs" immediateService+      entireReadModel `shouldSatisfy` T.isInfixOf "headWaitingReadModel EntireVisibleLog"+      entireReadModel `shouldSatisfy` T.isInfixOf "DurableQueryCursor \"mapped-readmodel-account-summary\""+      categoryReadModel `shouldSatisfy` T.isInfixOf "headWaitingReadModel (CategoryVisibleHead \"hospitalLoad\")"+      categoryReadModel `shouldSatisfy` T.isInfixOf "DurableQueryCursor \"declarative-router-hospital-load\""+      immediateReadModelText `shouldSatisfy` T.isInfixOf "immediateReadModel catalogAuditReadModelBlueprint"+      immediateReadModelText `shouldSatisfy` T.isInfixOf "DurableQueryCursor \"catalog-demo-audit\""+      inlineReadModel `shouldSatisfy` T.isInfixOf "immediateReadModel orderInlineReadModelBlueprint"+      inlineReadModel `shouldSatisfy` T.isInfixOf "cursorAuthority = NoQueryCursor"+      forM_ [entireReadModel, categoryReadModel, immediateReadModelText, inlineReadModel] $ \generated -> do+        generated `shouldNotSatisfy` T.isInfixOf "defaultConsistency"+        generated `shouldNotSatisfy` T.isInfixOf "strongScope"+        generated `shouldNotSatisfy` T.isInfixOf "subscriptionName ="++    it "rejects unavailable or unreachable head waits before generation" $ do+      catalogSource <- readTestText "test/fixtures/projection-catalog.keiro"+      categorySource <- readTestText "test/fixtures/declarative-router/valid.keiro"+      let codesFor name source = do+            service <- checkedServiceFromText name source+            pure [code diagnostic | diagnostic <- validateService service, severity diagnostic == Error]+          inlineWait =+            T.replace+              "shape = \"fnv1a:784e511a19f74c58\"\n  freshness = immediate\n  group = reporting\n  targets = [ order_summary ]"+              "shape = \"fnv1a:784e511a19f74c58\"\n  freshness = wait-for-head category \"orders\"\n  group = reporting\n  targets = [ order_summary ]"+              catalogSource+          mismatchedCategory =+            T.replace+              "freshness = wait-for-head category \"hospitalLoad\""+              "freshness = wait-for-head category \"other\""+              categorySource+          missingCursor = T.replace "  subscription = \"declarative-router-hospital-load\"\n" "" categorySource+      codesFor "projection-freshness-inline-wait.keiro" inlineWait+        `shouldReturn` [CatalogQueryWaitWithoutCompatibleCursor]+      codesFor "projection-freshness-mismatched-category.keiro" mismatchedCategory+        `shouldReturn` [CatalogQueryWaitWithoutCompatibleCursor]+      missingCursorCodes <- codesFor "projection-freshness-missing-cursor.keiro" missingCursor+      missingCursorCodes `shouldContain` [CatalogAsyncIdentityMissing]+      missingCursorCodes `shouldContain` [CatalogQueryWaitWithoutCompatibleCursor]++      mappedSource <- mappedConsumerSurfaceSource+      let implicitOwner =+            T.replace+              "  wire kind=ctorName fields=camelCase schemaVersion=1\n"+              "  wire kind=ctorName fields=camelCase schemaVersion=1\n\n  projection ArtifactLookup key=currentArtifact\n    status-map { ArtifactObserved=>observed }\n"+              ( T.replace+                  "freshness = immediate"+                  "freshness = wait-for-head category \"catalog\""+                  mappedSource+              )+      implicitCodes <- codesFor "projection-freshness-implicit-owner.keiro" implicitOwner+      implicitCodes `shouldContain` [CatalogQueryWaitWithoutCompatibleCursor]++    it "rejects the earlier Language 5 spellings with migration guidance" $ do+      source <- readTestText "test/fixtures/projection-catalog.keiro"+      let failureText name candidate = case parseSource name candidate of+            Left failure -> pure (renderParseFailure failure)+            Right _ -> expectationFailure (name <> " unexpectedly parsed") >> fail "unreachable"+      readModelFailure <-+        failureText+          "projection-freshness-legacy-readmodel.keiro"+          ( T.replace+              "  freshness = immediate"+              "  consistency = Strong\n  scope = entire-log\n  feed = subscription\n  subscription = \"catalog-demo-audit\""+              source+          )+      readModelFailure `shouldSatisfy` T.isInfixOf "remove legacy `consistency`"+      ownerFailure <-+        failureText+          "projection-freshness-legacy-owner.keiro"+          (T.replace "  delivery = subscription" "  feed = subscription" source)+      ownerFailure `shouldSatisfy` T.isInfixOf "replace legacy `feed`"++      mappedSource <- mappedConsumerSurfaceSource+      aggregateFailure <-+        failureText+          "projection-freshness-legacy-inner.keiro"+          ( T.replace+              "  wire kind=ctorName fields=camelCase schemaVersion=1\n"+              "  wire kind=ctorName fields=camelCase schemaVersion=1\n\n  projection ArtifactLookup consistency=Eventual key=currentArtifact\n    status-map { ArtifactObserved=>observed }\n"+              mappedSource+          )+      aggregateFailure `shouldSatisfy` T.isInfixOf "put `freshness` on the referenced readmodel"++    it "isolates freshness evolution from delivery, table shape, sources, and aggregate folds" $ do+      source <- readTestText "test/fixtures/projection-catalog.keiro"+      baseline <- checkedServiceFromText "projection-freshness-baseline.keiro" source+      changed <-+        checkedServiceFromText+          "projection-freshness-changed.keiro"+          ( T.replace+              "shape = \"fnv1a:9682af3ada04bf50\"\n  freshness = immediate\n  group = reporting\n  targets = [ audit_log ]"+              "shape = \"fnv1a:9682af3ada04bf50\"\n  freshness = wait-for-head category \"audit\"\n  group = reporting\n  targets = [ audit_log ]"+              source+          )+      validateService changed `shouldBe` []+      let changeCodes = map (ckCode . kindOfChange) (diffServices baseline changed)+          foldIdentities service =+            [ (aggName aggregate, aggregateFoldFingerprintForService service aggregate)+            | NAggregate aggregate <- specNodes (checkedSpec service)+            ]+          sourceIdentities service =+            [ (aggName aggregate, ProjectionImpact.projectionAggregateSourceFingerprintForService service (aggName aggregate))+            | NAggregate aggregate <- specNodes (checkedSpec service)+            ]+          catalogAudit service = case [readModel | NReadModel readModel <- specNodes (checkedSpec service), rmName readModel == "catalogAudit"] of+            [readModel] -> readModel+            values -> error ("expected one catalogAudit read model, got " <> show (length values))+          nonFreshnessFacts = filter (not . T.isPrefixOf "freshness|") . projectionCatalogFactsForService+          freshnessFacts = filter (T.isPrefixOf "freshness|") . projectionCatalogFactsForService+      changeCodes `shouldContain` [QueryFreshnessChanged]+      changeCodes `shouldNotContain` [ProjectionDeliveryChanged, ReadModelShapeChangedWithoutBump, CatalogSourceChanged]+      foldIdentities changed `shouldBe` foldIdentities baseline+      sourceIdentities changed `shouldBe` sourceIdentities baseline+      deriveShapeHash (catalogAudit changed) `shouldBe` deriveShapeHash (catalogAudit baseline)+      nonFreshnessFacts changed `shouldBe` nonFreshnessFacts baseline+      freshnessFacts changed `shouldNotBe` freshnessFacts baseline++    it "resolves one inline owner for several query models without legacy aggregate clauses" $ do+      source <- readTestText "test/fixtures/projection-owner-multi-query.keiro"+      service <- checkedServiceFromText "projection-owner-multi-query.keiro" source+      validateService service `shouldBe` []+      let analysis = analyzeProjectionSupplies (checkedSpec service)+          supplies = resolvedProjectionSupplies analysis+      projectionSupplyIssues analysis `shouldBe` []+      map supplyQueryModel supplies+        `shouldBe` ["catalog_administration", "catalog_validation"]+      map supplyProjectionOwner supplies+        `shouldBe` ["catalog_writer", "catalog_writer"]+      map (NE.toList . supplyObservedTargets) supplies+        `shouldBe` [["catalog_keys"], ["catalog_layouts", "catalog_state"]]++      reordered <-+        checkedServiceFromText+          "projection-owner-multi-query-reordered.keiro"+          ( T.replace+              "targets = [ catalog_state catalog_layouts ]"+              "targets = [ catalog_layouts catalog_state ]"+              ( T.replace+                  "targets = [ catalog_state catalog_layouts catalog_keys ]\n  order = 10"+                  "targets = [ catalog_keys catalog_layouts catalog_state ]\n  order = 10"+                  source+              )+          )+      validateService reordered `shouldBe` []+      resolvedProjectionSupplies (analyzeProjectionSupplies (checkedSpec reordered))+        `shouldBe` supplies++    it "diagnoses invalid query supply and catalog/legacy double ownership deterministically" $ do+      source <- readTestText "test/fixtures/projection-owner-multi-query.keiro"+      let diagnosticsForSource caseName mutated = do+            service <- checkedServiceFromText caseName mutated+            pure (validateService service)+          codesForSource caseName mutated = map code <$> diagnosticsForSource caseName mutated+          splitOwnerMutation =+            T.replace+              "targets = [ catalog_state catalog_layouts ]\n  backing = catalog_state"+              "targets = [ catalog_state catalog_layouts catalog_keys ]\n  backing = catalog_state"+              . T.replace+                "  replay = explicit\n}\n\nreadmodel catalog_validation"+                "  replay = explicit\n}\n\nprojection-owner catalog_keys_writer {\n  source = aggregate Catalog\n  delivery = inline\n  group = catalog_group\n  targets = [ catalog_keys ]\n  order = 20\n  replay = explicit\n}\n\nreadmodel catalog_validation"+              . T.replace+                "targets = [ catalog_state catalog_layouts catalog_keys ]\n  order = 10"+                "targets = [ catalog_state catalog_layouts ]\n  order = 10"+      emptyCodes <- codesForSource "projection-owner-empty-query.keiro" (T.replace "targets = [ catalog_keys ]" "targets = [ ]" source)+      emptyCodes `shouldContain` [CatalogReadModelBindingMissing]+      unknownCodes <- codesForSource "projection-owner-unknown-query-target.keiro" (T.replace "targets = [ catalog_keys ]" "targets = [ missing_target ]" source)+      unknownCodes `shouldContain` [CatalogTargetUnknown]+      missingCodes <- codesForSource "projection-owner-missing-query-owner.keiro" (T.replace "targets = [ catalog_state catalog_layouts catalog_keys ]\n  order = 10" "targets = [ catalog_state catalog_layouts ]\n  order = 10" source)+      missingCodes `shouldContain` [CatalogTargetUnowned]++      splitDiagnostics <- diagnosticsForSource "projection-owner-split-query.keiro" (splitOwnerMutation source)+      map code splitDiagnostics `shouldContain` [CatalogReadModelMultipleSuppliers]+      let splitSupplyDiagnostics = filter ((== CatalogReadModelMultipleSuppliers) . code) splitDiagnostics+      map (map snd . relatedLocations) splitSupplyDiagnostics+        `shouldBe` [ [ "projection owner 'catalog_keys_writer' supplies part of the observed target set",+                       "projection owner 'catalog_writer' supplies part of the observed target set"+                     ]+                   ]+      reorderedSplitDiagnostics <-+        diagnosticsForSource+          "projection-owner-split-query-reordered.keiro"+          ( T.replace+              "targets = [ catalog_state catalog_layouts catalog_keys ]"+              "targets = [ catalog_keys catalog_layouts catalog_state ]"+              (splitOwnerMutation source)+          )+      map (\diagnostic -> (code diagnostic, map snd (relatedLocations diagnostic))) reorderedSplitDiagnostics+        `shouldContain` map (\diagnostic -> (code diagnostic, map snd (relatedLocations diagnostic))) splitSupplyDiagnostics++      groupMismatchCodes <-+        codesForSource+          "projection-owner-group-mismatch.keiro"+          ( T.replace+              "targets = [ catalog_state catalog_layouts catalog_keys ]\n  order = [ catalog_state catalog_layouts catalog_keys ]\n}"+              "targets = [ catalog_state catalog_layouts ]\n  order = [ catalog_state catalog_layouts ]\n}\n\nrebuild-group catalog_keys_group {\n  targets = [ catalog_keys ]\n  order = [ catalog_keys ]\n}"+              source+          )+      groupMismatchCodes `shouldContain` [CatalogReadModelTargetOutsideGroup]+      groupMismatchCodes `shouldContain` [CatalogProjectionTargetOutsideGroup]++      conflictDiagnostics <-+        diagnosticsForSource+          "projection-owner-legacy-conflict.keiro"+          ( T.replace+              "  wire kind=ctorName fields=camelCase schemaVersion=1"+              "  wire kind=ctorName fields=camelCase schemaVersion=1\n\n  projection catalog_validation key=version\n    status-map { Activated=>active }"+              source+          )+      let conflicts = filter ((== CatalogReadModelLegacyProjectionConflict) . code) conflictDiagnostics+      length conflicts `shouldBe` 1+      conflicts `shouldSatisfy` all ((== 1) . length . relatedLocations)+      conflicts `shouldSatisfy` all (T.isInfixOf "remove the legacy aggregate projection clause" . message)++    it "derives and restores mapped projection impact for the compiled A/B catalog fixture" $ do+      source <- readTestText "test/fixtures/projection-catalog.keiro"+      service <- checkedServiceFromText "projection-catalog.keiro" source+      baseImpact <- case ProjectionImpact.projectionMappedImpactForService service of+        Nothing -> expectationFailure "projection fixture type graph did not resolve" >> fail "unreachable"+        Just value -> pure value+      ProjectionImpact.projectionConsumersFor baseImpact (MappedKey "OrderPayload")+        `shouldBe` Set.singleton (CatalogProjectionConsumer "order_summary_writer" "Orders")+      ProjectionImpact.projectionConsumersFor baseImpact (MappedKey "SharedReference")+        `shouldBe` Set.fromList+          [ CatalogProjectionConsumer "order_summary_writer" "Orders",+            CatalogProjectionConsumer "shipment_writer" "Shipments"+          ]+      ProjectionImpact.unsupported baseImpact+        `shouldBe` [ ProjectionImpact.UnsupportedProjectionImpact+                       (UnsupportedCatalogCategory "audit_writer" "audit")+                       "reporting"+                       (Set.singleton "audit_log")+                       (Set.singleton "catalogAudit")+                       True+                   ]+      let rendered = ProjectionImpact.renderProjectionMappedImpact baseImpact+      rendered `shouldContain` ["      inherited event roots: Orders event OrderRecorded .orderPayload : OrderPayload"]+      rendered+        `shouldContain` ["      operation: group=shipping; targets=shipment_summary; read-models=shipmentLookup; replayable=no; source-fingerprint=aggregate:Shipments/generated-codec/v1/mapped-9456a95e380c74b5"]+      rendered `shouldContain` ["    catalog-category:audit_writer:audit"]++      eventChanged <- checkedServiceFromText "projection-catalog-event-changed.keiro" (T.replace "version = \"1\"" "version = \"2\"" source)+      sourceChanged <- checkedServiceFromText "projection-catalog-source-changed.keiro" (T.replace "source = aggregate Orders" "source = aggregate Shipments" source)+      replayChanged <- checkedServiceFromText "projection-catalog-replay-changed.keiro" (T.replace "replay = live-only \"carrier events cannot be replayed\"" "replay = explicit" source)+      observationChanged <- checkedServiceFromText "projection-catalog-observation-changed.keiro" (T.replace "targets = [ order_summary ]" "targets = [ audit_log ]" source)+      categoryChanged <- checkedServiceFromText "projection-catalog-category-changed.keiro" (T.replace "source = category \"audit\"" "source = category \"archive-audit\"" source)+      let requireImpact caseLabel candidate = case ProjectionImpact.projectionMappedImpactForService candidate of+            Nothing -> expectationFailure (caseLabel <> " type graph did not resolve") >> fail "unreachable"+            Just value -> pure value+          findOperation derived impact =+            Map.lookup derived (ProjectionImpact.operations impact)+          operationReplay (ProjectionImpact.ProjectionOperationalImpact _ _ _ _ canReplay _) = canReplay+          operationObservers (ProjectionImpact.ProjectionOperationalImpact _ _ _ observers _ _) = observers+          operationFingerprint (ProjectionImpact.ProjectionOperationalImpact _ _ _ _ _ fingerprint) = fingerprint+      eventImpact <- requireImpact "event mutation" eventChanged+      sourceImpact <- requireImpact "source mutation" sourceChanged+      replayImpact <- requireImpact "replay mutation" replayChanged+      observationImpact <- requireImpact "observation mutation" observationChanged+      categoryImpact <- requireImpact "category mutation" categoryChanged+      operationFingerprint <$> findOperation (CatalogProjectionConsumer "order_summary_writer" "Orders") eventImpact+        `shouldNotBe` operationFingerprint <$> findOperation (CatalogProjectionConsumer "order_summary_writer" "Orders") baseImpact+      ProjectionImpact.projectionConsumersFor sourceImpact (MappedKey "OrderPayload")+        `shouldBe` Set.empty+      operationReplay <$> findOperation (CatalogProjectionConsumer "shipment_writer" "Shipments") replayImpact+        `shouldBe` Just True+      operationObservers <$> findOperation (CatalogProjectionConsumer "order_summary_writer" "Orders") observationImpact+        `shouldBe` Just (Set.singleton "order_totals_lookup")+      map ProjectionImpact.source (ProjectionImpact.unsupported categoryImpact)+        `shouldBe` [UnsupportedCatalogCategory "audit_writer" "archive-audit"]+      restored <- checkedServiceFromText "projection-catalog-restored.keiro" source >>= requireImpact "restored fixture"+      restored `shouldBe` baseImpact++    it "feature-gates catalog declarations before validation in languages 1-4" $ do+      source <- readTestText "test/fixtures/projection-catalog.keiro"+      case parseSource "projection-catalog-v4.keiro" (T.replace "language keiro-dsl 5" "language keiro-dsl 4" source) of+        Left failure -> do+          renderParseFailure failure `shouldSatisfy` T.isInfixOf "LanguageFeatureRequiresVersion"+          renderParseFailure failure `shouldSatisfy` T.isInfixOf "requires keiro-dsl language version 5"+        Right _ -> expectationFailure "language 4 accepted projection-catalog syntax"++    it "keeps the catalog structural guards live" $ do+      source <- readTestText "test/fixtures/projection-catalog.keiro"+      let mutationCodes mutation = do+            service <- checkedServiceFromText "projection-catalog-mutation.keiro" (mutation source)+            pure (map code (validateService service))+          revisionV2AuditBlock =+            T.unlines+              [ "  target audit_log {",+                "    schema-version = \"v2\"",+                "    provisioner = \"reporting-v2-audit-log\"",+                "    provisioner-version = 1",+                "    expected-shape = \"audit-log-v2\"",+                "    validator = \"reporting-v2-audit-log-validator\"",+                "    validator-version = 1",+                "    promotion owned-sequence \"audit_log_id_seq__v2\" -> \"audit_log_id_seq\"",+                "  }"+              ]+      missingAsyncIdentity <- mutationCodes (T.replace "  subscription = \"catalog-demo-audit\"\n" "")+      missingAsyncIdentity `shouldContain` [CatalogAsyncIdentityMissing]+      missingCheckpointPolicy <- mutationCodes (T.replace "  checkpoint-on-missing = from-current-head\n" "")+      missingCheckpointPolicy `shouldContain` [CatalogCheckpointPolicyMissing]+      duplicateCheckpointPolicy <- mutationCodes (T.replace "  checkpoint-on-missing = from-current-head\n" "  checkpoint-on-missing = from-current-head\n  checkpoint-on-missing = fail\n")+      duplicateCheckpointPolicy `shouldContain` [CatalogCheckpointPolicyDuplicate]+      unexpectedInlineCheckpointPolicy <- mutationCodes (T.replace "  order = 10\n  replay = explicit" "  order = 10\n  checkpoint-on-missing = from-beginning\n  replay = explicit")+      unexpectedInlineCheckpointPolicy `shouldContain` [CatalogCheckpointPolicyUnexpected]+      replayUnsafeCheckpointPolicy <- mutationCodes (T.replace "table = \"audit_log\"\n  reset = preserve" "table = \"audit_log\"\n  reset = clear")+      replayUnsafeCheckpointPolicy `shouldContain` [CatalogCheckpointPolicyReplayUnsafe]+      case parseSource "projection-catalog-unknown-checkpoint-policy.keiro" (T.replace "checkpoint-on-missing = from-current-head" "checkpoint-on-missing = newest" source) of+        Left failure -> do+          let rendered = renderParseFailure failure+          rendered `shouldSatisfy` T.isInfixOf "unknown checkpoint-on-missing policy"+          rendered `shouldSatisfy` T.isInfixOf "from-beginning"+          rendered `shouldSatisfy` T.isInfixOf "from-current-head"+          rendered `shouldSatisfy` T.isInfixOf "fail"+        Right _ -> expectationFailure "unknown checkpoint-on-missing value parsed successfully"+      forM_ ["from-beginning", "fail"] $ \policy -> do+        acceptedPolicy <- mutationCodes (T.replace "checkpoint-on-missing = from-current-head" ("checkpoint-on-missing = " <> policy))+        acceptedPolicy `shouldNotContain` [CatalogCheckpointPolicyMissing, CatalogCheckpointPolicyDuplicate, CatalogCheckpointPolicyUnexpected, CatalogCheckpointPolicyReplayUnsafe]+        acceptedClearPolicy <- mutationCodes (T.replace "table = \"audit_log\"\n  reset = preserve" "table = \"audit_log\"\n  reset = clear" . T.replace "checkpoint-on-missing = from-current-head" ("checkpoint-on-missing = " <> policy))+        acceptedClearPolicy `shouldNotContain` [CatalogCheckpointPolicyReplayUnsafe]+      unsafeLiveOnly <- mutationCodes (T.replace "  replay = explicit\n}" "  replay = live-only \"external side effect\"\n}")+      unsafeLiveOnly `shouldContain` [CatalogClearTargetLiveOnly]+      duplicateOrder <- mutationCodes (T.replace "  order = 20\n" "  order = 10\n")+      duplicateOrder `shouldContain` [CatalogDuplicateHandlerOrder]+      badGroupOrder <- mutationCodes (T.replace "  order = [ order_summary order_totals audit_log ]" "  order = [ order_summary order_summary audit_log ]")+      badGroupOrder `shouldContain` [CatalogGroupOrderMismatch]+      missingOwner <- mutationCodes (T.replace "  targets = [ order_summary order_totals ]\n" "  targets = [ order_summary ]\n")+      missingOwner `shouldContain` [CatalogTargetUnowned]+      unknownDependency <- mutationCodes (T.replace "  depends-on = [ order_summary ]\n" "  depends-on = [ missing_target ]\n")+      unknownDependency `shouldContain` [CatalogTargetDependencyUnknown]+      dependencyCycle <- mutationCodes (T.replace "  reset = clear\n}\n\ntarget audit_log" "  reset = clear\n  depends-on = [ order_totals ]\n}\n\ntarget audit_log")+      dependencyCycle `shouldContain` [CatalogTargetDependencyCycle]+      overlappingSource <- mutationCodes (T.replace "  source = aggregate Orders\n" "  source = aggregate Orders\n  source = category \"orders\"\n")+      overlappingSource `shouldContain` [CatalogSourceOverlap]+      ambiguousSourceOrdering <- mutationCodes (T.replace "  source = category \"audit\"\n" "  source = all\n")+      ambiguousSourceOrdering `shouldContain` [CatalogAmbiguousSourceOrdering]+      missingQueryBinding <- mutationCodes (T.replace "  targets = [ audit_log ]\n}\n\nprojection-owner audit_writer" "  targets = [ order_summary ]\n}\n\nprojection-owner audit_writer")+      missingQueryBinding `shouldContain` [CatalogAsyncQueryBindingMissing]+      missingRevisionTarget <- mutationCodes (T.replace "  target audit_log {\n    schema-version = \"v2\"" "  target missing_target {\n    schema-version = \"v2\"")+      missingRevisionTarget `shouldContain` [CatalogRevisionTargetUnknown, CatalogRevisionTargetSetMismatch]+      incompleteRevision <- mutationCodes (T.replace revisionV2AuditBlock "")+      incompleteRevision `shouldContain` [CatalogRevisionTargetSetMismatch]+      invalidRevisionIdentity <- mutationCodes (T.replace "provisioner-version = 1" "provisioner-version = 0")+      invalidRevisionIdentity `shouldContain` [CatalogRevisionIdentityInvalid]+      invalidContractVersion <- mutationCodes (T.replace "external-read order_totals_reader {\n  version = 1" "external-read order_totals_reader {\n  version = 0")+      invalidContractVersion `shouldContain` [CatalogExternalReadVersionInvalid]+      missingExternalQuery <- mutationCodes (T.replace "query = order_totals_lookup" "query = missing_query")+      missingExternalQuery `shouldContain` [CatalogExternalReadQueryUnknown]+      multiTargetExternalQuery <- mutationCodes (T.replace "  targets = [ order_totals ]\n}\n\nexternal-read" "  targets = [ order_summary order_totals ]\n  backing = order_totals\n}\n\nexternal-read")+      multiTargetExternalQuery `shouldContain` [CatalogExternalReadTargetCardinalityInvalid]+      emptyCompatibility <- mutationCodes (T.replace "compatible-revisions = [ reporting_v1 reporting_v2 ]" "compatible-revisions = [ ]")+      emptyCompatibility `shouldContain` [CatalogExternalReadCompatibilityInvalid]+      unknownCompatibleRevision <- mutationCodes (T.replace "compatible-revisions = [ reporting_v1 reporting_v2 ]" "compatible-revisions = [ missing_revision ]")+      unknownCompatibleRevision `shouldContain` [CatalogExternalReadRevisionUnknown]+      wrongRevisionGroup <- mutationCodes (T.replace "query = order_totals_lookup" "query = shipmentLookup")+      wrongRevisionGroup `shouldContain` [CatalogExternalReadRevisionGroupMismatch]+      invalidResultIdentity <- mutationCodes (T.replace "result-schema = \"app_contract\"" "result-schema = \"app-contract\"")+      invalidResultIdentity `shouldContain` [CatalogExternalReadIdentityInvalid]+      invalidSurfaceGeneration <- mutationCodes (T.replace "surface-generation = 1" "surface-generation = 0")+      invalidSurfaceGeneration `shouldContain` [CatalogExternalReadSurfaceGenerationInvalid]++    it "generates one facade, one create-once behavior surface, and durable ledger facts" $ do+      source <- readTestText "test/fixtures/projection-catalog.keiro"+      service <- checkedServiceFromText "projection-catalog.keiro" source+      let spec = checkedSpec service+          modules = scaffoldServiceModules (defaultContext (specContext spec)) service+          facade = generatedTextEndingIn "Generated/CatalogDemo/ProjectionCatalog.hs" modules+          holes = case [moduleText m | m <- modules, kind m == HoleStub, "ProjectionCatalog/ProjectionCatalogHoles.hs" `T.isSuffixOf` T.pack (modulePath m)] of+            [value] -> value+            values -> error ("expected one projection catalog hole module, got " <> show (length values))+          facts = projectionCatalogFactsForService service+      facade `shouldSatisfy` T.isInfixOf "Catalog.validateProjectionCatalog projectionCatalog"+      facade `shouldSatisfy` T.isInfixOf "Catalog.ClearBeforeReplay"+      facade `shouldSatisfy` T.isInfixOf "Catalog.PreserveAndReconcile"+      facade `shouldSatisfy` T.isInfixOf "KirokuSubscription.FromCurrentHead"+      facade `shouldSatisfy` T.isInfixOf "Catalog.ProjectionRevision (must (Catalog.mkProjectionRevisionId \"reporting_v1\"))"+      facade `shouldSatisfy` T.isInfixOf "Catalog.TargetSchemaVersion \"v2\""+      facade `shouldSatisfy` T.isInfixOf "Catalog.AllRowsExternalRead (must (Catalog.mkExternalReadContractId \"order_totals_reader\"))"+      facade `shouldSatisfy` T.isInfixOf "Catalog.QualifiedSqlType \"app_contract\" \"order_totals_row_v1\""+      facade `shouldSatisfy` T.isInfixOf "\"fnv1a:768a23d719dcb4d4\""+      facade `shouldSatisfy` T.isInfixOf "projectionCatalogQuerySupplies = Catalog.resolvedQuerySupplies validatedProjectionCatalog"+      facade `shouldSatisfy` T.isInfixOf "ordersInlineProjections = concat [orderSummaryWriterInlineProjections]"+      facade+        `shouldSatisfy` ( \text ->+                            let (_, fromFirst) = T.breakOn "orderSummaryWriterProjectionSet" text+                             in not (T.null fromFirst) && T.isInfixOf "auditWriterProjectionSet" (T.drop 1 fromFirst)+                        )+      holes `shouldSatisfy` T.isInfixOf "fill order_summary_writer live apply"+      holes `shouldSatisfy` T.isInfixOf "fill order_summary_writer replay apply"+      holes `shouldSatisfy` T.isInfixOf "provisionReportingV2OrderSummary :: Catalog.TargetProvisioningContext"+      holes `shouldSatisfy` T.isInfixOf "applyReportingV2OrderSummaryWriterLive :: Catalog.PhysicalTargets"+      holes `shouldSatisfy` T.isInfixOf "applyReportingV2AuditWriterLive :: Catalog.PhysicalTargets"+      holes `shouldSatisfy` T.isInfixOf "orderTotalsReaderV1KeyedExternalRead :: [Catalog.SqlFunctionArgument]"+      holes `shouldSatisfy` T.isInfixOf "application-owned private SQL function"+      facts `shouldBe` sort facts+      facts `shouldSatisfy` any (T.isPrefixOf "target|order_summary|")+      facts `shouldSatisfy` any (T.isPrefixOf "owner|audit_writer|")+      facts `shouldSatisfy` any (T.isPrefixOf "delivery|audit_writer|subscription|")+      facts `shouldSatisfy` any (T.isPrefixOf "revision|reporting_v1|reporting|")+      facts `shouldSatisfy` any (T.isPrefixOf "external-read|order_totals_reader|1|order_totals_lookup|app_contract.order_totals_row_v1|fnv1a:768a23d719dcb4d4|reporting_v1,reporting_v2|1|")+      facts `shouldSatisfy` any (T.isInfixOf "order_summary,v2,reporting-v2-order-summary")+      facts `shouldSatisfy` any (T.isPrefixOf "freshness|catalogAudit|immediate|")+      facts `shouldSatisfy` any (T.isPrefixOf "cursor|catalogAudit|catalog-demo-audit|")+      facts `shouldSatisfy` any (T.isPrefixOf "query|order_totals_lookup|reporting|order_totals|order_totals|")+      facts `shouldSatisfy` any (T.isPrefixOf "supply|order_inline|order_summary_writer|reporting|order_summary|")+      facts `shouldSatisfy` any (T.isPrefixOf "supply|order_totals_lookup|order_summary_writer|reporting|order_totals|")+      facts `shouldSatisfy` any (T.isInfixOf "|from-current-head|explicit|")++    it "distinguishes external-read versioning, retirement, compatibility, and derived result-shape changes" $ do+      source <- readTestText "test/fixtures/projection-catalog.keiro"+      baseline <- checkedServiceFromText "projection-catalog-external-read.keiro" source+      let externalReadBlock version resultType =+            T.unlines+              [ "external-read order_totals_reader {",+                "  version = " <> T.pack (show version),+                "  query = order_totals_lookup",+                "  result-schema = \"app_contract\"",+                "  result-type = \"" <> resultType <> "\"",+                "  compatible-revisions = [ reporting_v1 reporting_v2 ]",+                "  surface-generation = 1",+                "}",+                ""+              ]+          v1Block = externalReadBlock (1 :: Int) "order_totals_row_v1"+          codes candidate = map (ckCode . kindOfChange) (diffServices baseline candidate)+      versionAdded <-+        checkedServiceFromText+          "projection-catalog-external-read-v2.keiro"+          (T.replace v1Block (v1Block <> externalReadBlock (2 :: Int) "order_totals_row_v2") source)+      retired <- checkedServiceFromText "projection-catalog-external-read-retired.keiro" (T.replace v1Block "" source)+      compatibilityChanged <-+        checkedServiceFromText+          "projection-catalog-external-read-compatible.keiro"+          (T.replace "compatible-revisions = [ reporting_v1 reporting_v2 ]" "compatible-revisions = [ reporting_v1 ]" source)+      shapeChanged <-+        checkedServiceFromText+          "projection-catalog-external-read-shape.keiro"+          (T.replace "shape = \"fnv1a:768a23d719dcb4d4\"" "shape = \"fnv1a:0000000000000000\"" source)+      validateService versionAdded `shouldBe` []+      codes versionAdded `shouldContain` [CatalogExternalReadVersionAdded]+      codes retired `shouldContain` [CatalogExternalReadRetired]+      codes compatibilityChanged `shouldContain` [CatalogExternalReadCompatibilityChanged]+      codes shapeChanged `shouldContain` [CatalogExternalReadResultShapeChanged]++      reordered <-+        checkedServiceFromText+          "projection-catalog-external-read-reordered.keiro"+          (T.replace "compatible-revisions = [ reporting_v1 reporting_v2 ]" "compatible-revisions = [ reporting_v2 reporting_v1 ]" source)+      projectionCatalogFactsForService reordered `shouldBe` projectionCatalogFactsForService baseline+      codes reordered `shouldNotContain` [CatalogExternalReadCompatibilityChanged]++    it "preserves edited catalog behavior holes on regeneration" $+      withTempDirectory "keiro-dsl-projection-catalog-create-once" $ \out -> do+        parsed <- parsedSourceOf "test/fixtures/projection-catalog.keiro"+        let service = checkedSource parsed+            spec = checkedSpec service+            ctx = defaultContext (specContext spec)+            holeSuffix = "ProjectionCatalog/ProjectionCatalogHoles.hs"+        modules <- case planTestServiceScaffold ctx service of+          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"+          Right planned -> pure planned+        first <- executeServiceScaffold out False "projection-catalog.keiro" (parsedSourceLanguage parsed) ctx service modules+        first `shouldSatisfy` isSuccessfulScaffold+        let holePath = out </> onlyPathEndingIn holeSuffix modules+            reviewedBody = "module CatalogDemo.ProjectionCatalog.ProjectionCatalogHoles where\nreviewed = True\n"+        TIO.writeFile holePath reviewedBody+        second <- executeServiceScaffold out False "projection-catalog.keiro" (parsedSourceLanguage parsed) ctx service modules+        second `shouldSatisfy` isSuccessfulScaffold+        TIO.readFile holePath `shouldReturn` reviewedBody+        case second of+          Left _ -> fail "unreachable"+          Right report ->+            do+              reportDispositions report+                `shouldSatisfy` any (\(moduleValue, disposition) -> holeSuffix `isSuffixOfPath` moduleValue && disposition == Skipped)+              renderScaffoldReport report+                `shouldContain` ["      inherited event roots: Orders event OrderRecorded .orderPayload : OrderPayload"]+              renderScaffoldReport report+                `shouldContain` ["      operation: group=shipping; targets=shipment_summary; read-models=shipmentLookup; replayable=no; source-fingerprint=aggregate:Shipments/generated-codec/v1/mapped-9456a95e380c74b5"]+              renderScaffoldReport report `shouldContain` ["    catalog-category:audit_writer:audit"]++    it "classifies every catalog evolution dimension and reports machine-readable replay impact" $ do+      source <- readTestText "test/fixtures/projection-catalog.keiro"+      oldService <- checkedServiceFromText "projection-catalog-old.keiro" source+      let targetBlock = T.unlines ["target audit_log {", "  schema = \"sales\"", "  table = \"audit_log\"", "  reset = preserve", "}", ""]+          ownerBlock =+            T.unlines+              [ "projection-owner audit_writer {",+                "  source = category \"audit\"",+                "  delivery = subscription",+                "  group = reporting",+                "  targets = [ audit_log ]",+                "  order = 20",+                "  subscription = \"catalog-demo-audit\"",+                "  dedup = \"catalog-demo-audit-v1\"",+                "  checkpoint-on-missing = from-current-head",+                "  replay = explicit",+                "}",+                ""+              ]+          mutations =+            [ ("target-added", CatalogTargetAdded, T.replace "rebuild-group reporting" "target archive_log {\n  schema = \"sales\"\n  table = \"archive_log\"\n  reset = preserve\n}\n\nrebuild-group reporting"),+              ("target-removed", CatalogTargetRemoved, T.replace targetBlock ""),+              ("target-location", CatalogTargetLocationChanged, T.replace "table = \"order_summary\"" "table = \"order_summary_v2\""),+              ("target-reset", CatalogTargetResetPolicyChanged, T.replace "reset = preserve" "reset = clear"),+              ("target-dependency", CatalogTargetDependencyChanged, T.replace "depends-on = [ order_summary ]" "depends-on = [ audit_log ]"),+              ("group-membership-order", CatalogGroupChanged, T.replace "order = [ order_summary order_totals audit_log ]" "order = [ audit_log order_summary order_totals ]"),+              ("revision-schema", CatalogTargetSchemaChanged, T.replace "schema-version = \"v2\"" "schema-version = \"v2.1\""),+              ("revision-provider", CatalogProjectionRevisionChanged, T.replace "provisioner = \"reporting-v2-order-summary\"" "provisioner = \"reporting-v2-order-summary-new\""),+              ("owner-binding", CatalogOwnerChanged, T.replace "targets = [ order_summary order_totals ]" "targets = [ order_summary ]"),+              ("owner-removed", CatalogOwnerRemoved, T.replace ownerBlock ""),+              ("handler-order", CatalogHandlerOrderChanged, T.replace "order = 20" "order = 30"),+              ("source", CatalogSourceChanged, T.replace "source = aggregate Orders" "source = category \"archived-orders\""),+              ("delivery", ProjectionDeliveryChanged, T.replace "delivery = subscription" "delivery = inline"),+              ("subscription", CatalogFeedIdentityChanged, T.replace "subscription = \"catalog-demo-audit\"" "subscription = \"catalog-demo-audit-v2\""),+              ("dedup", CatalogFeedIdentityChanged, T.replace "dedup = \"catalog-demo-audit-v1\"" "dedup = \"catalog-demo-audit-v2\""),+              ("checkpoint-policy", CatalogCheckpointPolicyChanged, T.replace "checkpoint-on-missing = from-current-head" "checkpoint-on-missing = fail"),+              ("replay-policy", CatalogReplayPolicyChanged, T.replace "replay = live-only \"carrier events cannot be replayed\"" "replay = explicit"),+              ("query-binding", CatalogQueryBindingChanged, T.replace "targets = [ audit_log ]\n}\n\nprojection-owner audit_writer" "targets = [ order_summary ]\n}\n\nprojection-owner audit_writer")+            ]+      changedServices <-+        forM mutations $ \(caseName, expectedCode, mutate) -> do+          changed <- checkedServiceFromText ("projection-catalog-" <> caseName <> ".keiro") (mutate source)+          map (ckCode . kindOfChange) (diffServices oldService changed) `shouldContain` [expectedCode]+          pure (caseName, changed)+      supplierChanged <-+        checkedServiceFromText+          "projection-catalog-supplier-changed.keiro"+          ( T.replace+              "projection-owner audit_writer"+              ( T.unlines+                  [ "projection-owner order_totals_writer {",+                    "  source = category \"orderTotals\"",+                    "  delivery = inline",+                    "  group = reporting",+                    "  targets = [ order_totals ]",+                    "  order = 15",+                    "  replay = explicit",+                    "}",+                    "",+                    "projection-owner audit_writer"+                  ]+              )+              (T.replace "targets = [ order_summary order_totals ]" "targets = [ order_summary ]" source)+          )+      validateService supplierChanged `shouldBe` []+      map (ckCode . kindOfChange) (diffServices oldService supplierChanged)+        `shouldContain` [CatalogQueryBindingChanged]+      sourceChanged <- case lookup "source" changedServices of+        Just changed -> pure changed+        Nothing -> expectationFailure "source mutation was not exercised" >> fail "unreachable"+      policyChanged <- case lookup "checkpoint-policy" changedServices of+        Just changed -> pure changed+        Nothing -> expectationFailure "checkpoint policy mutation was not exercised" >> fail "unreachable"+      let policyChanges = [change | change <- diffServices oldService policyChanged, ckCode (kindOfChange change) == CatalogCheckpointPolicyChanged]+      case policyChanges of+        [change] -> do+          let finding = kindOfChange change+              rendered = renderFinding change+              encoded = LazyText.toStrict (LazyTextEncoding.decodeUtf8 (Aeson.encode (diffReport defaultGate [change])))+          cvPersistedIdentity (ckVector finding) `shouldBe` VCompatible+          cvConsumerBuild (ckVector finding) `shouldBe` VBreaking+          cvRollout (ckVector finding) `shouldBe` Set.singleton RolloutStopTheWorld+          ckDetail finding `shouldSatisfy` T.isInfixOf "existing checkpoint rows remain unchanged"+          rendered `shouldSatisfy` T.isInfixOf "from-current-head -> fail"+          rendered `shouldSatisfy` T.isInfixOf "rollout=stop-the-world"+          encoded `shouldSatisfy` T.isInfixOf "CatalogCheckpointPolicyChanged"+          encoded `shouldSatisfy` T.isInfixOf "from-current-head -> fail"+          encoded `shouldSatisfy` T.isInfixOf "\"persisted-identity\":\"compatible\""+          encoded `shouldSatisfy` T.isInfixOf "\"rollout\":[\"stop-the-world\"]"+        changes -> expectationFailure ("expected one checkpoint-policy finding, got " <> show (length changes))+      case ReplayImpact.catalogReplayImpactServices oldService policyChanged of+        CatalogReplayAffected groups targets sources adapters invalidates -> do+          groups `shouldBe` Set.singleton "reporting"+          targets `shouldBe` Set.singleton "audit_log"+          sources `shouldBe` Set.singleton "category:audit"+          adapters `shouldBe` Set.singleton "audit_writer"+          invalidates `shouldBe` True+        CatalogReplayNeutral -> expectationFailure "checkpoint-policy change was replay-neutral"+      case ReplayImpact.catalogReplayImpactServices oldService sourceChanged of+        CatalogReplayAffected groups targets sources adapters invalidates -> do+          groups `shouldBe` Set.singleton "reporting"+          targets `shouldBe` Set.fromList ["order_summary", "order_totals"]+          sources `shouldBe` Set.fromList ["aggregate:Orders", "category:archived-orders"]+          adapters `shouldBe` Set.singleton "order_summary_writer"+          invalidates `shouldBe` True+        CatalogReplayNeutral -> expectationFailure "catalog source change was replay-neutral"++  describe "ID domain" $ do+    let parseRight name source = case parseSource name source of+          Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+          Right value -> pure value++    it "registers language 3 as the first enforced runtime contract" $ do+      parsed <- case parseSource "id-domain-v3.keiro" "language keiro-dsl 3\ncontext id-domain\n" of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      let contract = checkedLanguageContract (checkedSource parsed)+      effectiveRuntimeSemantics contract `shouldBe` "keiro-dsl/runtime-semantics/2"+      effectiveContractLanguageVersion contract `shouldBe` maybe (error "missing v3") id (languageVersion 3)+      idDomainContractFor contract "req" `shouldSatisfy` (/= Nothing)++    it "registers language 4 as contract admission semantics without changing aggregate ID admission" $ do+      v3 <- parseRight "id-domain-v3.keiro" "language keiro-dsl 3\ncontext id-domain\n"+      v4 <- parseRight "id-domain-v4.keiro" "language keiro-dsl 4\ncontext id-domain\n"+      let v3Contract = checkedLanguageContract (checkedSource v3)+          v4Contract = checkedLanguageContract (checkedSource v4)+      effectiveRuntimeSemantics v4Contract `shouldBe` "keiro-dsl/runtime-semantics/3"+      effectiveContractLanguageVersion v4Contract `shouldBe` maybe (error "missing v4") id (languageVersion 4)+      idDomainContractFor v4Contract "req" `shouldBe` idDomainContractFor v3Contract "req"+      contractIdDomainContractFor v3Contract "req" `shouldBe` Nothing+      contractIdDomainContractFor v4Contract "req" `shouldBe` Just (typeIdV7Domain "req")++    it "constructs typed KindIDs only after the frozen four-way admission policy" $ do+      let valid = "req_01h455vb4pex5vsknk084sn02q"+          uppercase = "req_01H455VB4PEX5VSKNK084SN02Q"+          nonV7 = "req_00041061050r3gg28a1c60t3gf"+      (KindID.toText @"req" <$> parseKindIdV7Text @"req" valid) `shouldBe` Right valid+      parseKindIdV7Text @"req" "req-1" `shouldSatisfy` \case+        Left IdDomainMalformed {} -> True+        _ -> False+      parseKindIdV7Text @"req" "other_01h455vb4pex5vsknk084sn02q" `shouldSatisfy` \case+        Left (IdDomainWrongPrefix "req" "other") -> True+        _ -> False+      parseKindIdV7Text @"req" uppercase `shouldBe` Left IdDomainNonCanonical+      parseKindIdV7Text @"req" nonV7 `shouldSatisfy` \case+        Left IdDomainNotUuidV7 {} -> True+        _ -> False+      parseEither (parseKindIdV7Value @"req") (Aeson.String uppercase)+        `shouldSatisfy` \case+          Left problem -> "not canonical lowercase" `T.isInfixOf` T.pack problem+          Right _ -> False++    it "validates contract TypeID prefixes only at the language-4 boundary" $ do+      let source versionNumber =+            T.unlines+              [ "language keiro-dsl " <> T.pack (show versionNumber),+                "context invalid-contract-prefix",+                "contract emergency {",+                "  schemaVersion 1",+                "  discriminator messageType",+                "  topic incidentEvents \"emergency.incident.events\"",+                "  event IncidentDeclared on incidentEvents {",+                "    incidentId: typeid \"Bad\"",+                "  }",+                "}"+              ]+      v3 <- parseRight "contract-prefix-v3.keiro" (source (3 :: Int))+      v4 <- parseRight "contract-prefix-v4.keiro" (source (4 :: Int))+      validateService (checkedSource v3) `shouldBe` []+      case validateService (checkedSource v4) of+        [diagnostic] -> do+          code diagnostic `shouldBe` ContractInvalidTypeIdPrefix+          line diagnostic `shouldBe` 8+          message diagnostic `shouldSatisfy` T.isInfixOf "contract 'emergency' event 'IncidentDeclared' field 'incidentId'"+          message diagnostic `shouldSatisfy` T.isInfixOf "invalid TypeID prefix 'Bad'"+        diagnostics -> expectationFailure ("expected one invalid contract prefix diagnostic, got " <> show diagnostics)++    it "keeps version-3 and version-4 aggregate fold and replay semantics equal" $ do+      v3Text <- readTestText "test/fixtures/id-domain-migration-v3.keiro"+      v3 <- parseRight "fold-v3.keiro" v3Text+      v4 <- parseRight "fold-v4.keiro" (T.replace "language keiro-dsl 3" "language keiro-dsl 4" v3Text)+      let v3Service = checkedSource v3+          v4Service = checkedSource v4+          fingerprints service =+            [ aggregateFoldFingerprintForService service aggregate+            | NAggregate aggregate <- specNodes (checkedSpec service)+            ]+      fingerprints v4Service `shouldBe` fingerprints v3Service+      diffServices v3Service v4Service `shouldBe` []+      resolvedFold (ReplayImpact.replayImpactServices v3Service v4Service) `shouldBe` ReplayNeutral++    it "keeps runtime validation and the exact Keiki text image in agreement" $ do+      let contract = typeIdV7Domain "req"+          sampleText = idDomainSampleText contract+          suffix = T.drop (T.length "req_") sampleText+          replaceAt position replacement value =+            T.take position value <> T.singleton replacement <> T.drop (position + 1) value+          accepted =+            [ sampleText,+              replaceAt (T.length "req_" + 10) 'f' sampleText,+              replaceAt (T.length "req_" + 13) 'v' sampleText+            ]+          rejected =+            [ "",+              "req_",+              "other_" <> suffix,+              "req__" <> suffix,+              T.dropEnd 1 sampleText,+              sampleText <> "0",+              T.toUpper sampleText,+              replaceAt (T.length "req_" + 0) '8' sampleText,+              replaceAt (T.length "req_" + 10) 'd' sampleText,+              replaceAt (T.length "req_" + 13) 'c' sampleText+            ]+          patternValue = either (error . show) id (idDomainTextPattern contract)+      idDomainVersion contract `shouldBe` "keiro-dsl/id-domain/typeid-v7/1"+      idDomainSeparator contract `shouldBe` '_'+      idDomainSuffixLength contract `shouldBe` 26+      idDomainMaxLength contract `shouldBe` T.length sampleText+      forM_ accepted $ \value -> do+        validateIdDomainText contract value `shouldBe` Right ()+        matchesTextPattern patternValue value `shouldBe` True+      forM_ rejected $ \value -> do+        validateIdDomainText contract value `shouldSatisfy` isLeft+        matchesTextPattern patternValue value `shouldBe` False++    it "agrees for generated canonical and malformed domain values" $ property $ do+      let crockford = "0123456789abcdefghjkmnpqrstvwxyz"+          segment count = vectorOf count (elements crockford)+      leading <- elements "01234567"+      beforeVersion <- segment 9+      version <- elements "ef"+      beforeVariant <- segment 2+      variantDigit <- elements "89abrstv"+      afterVariant <- segment 12+      let value = T.pack ("req_" <> [leading] <> beforeVersion <> [version] <> beforeVariant <> [variantDigit] <> afterVariant)+          contract = typeIdV7Domain "req"+          patternValue = either (error . show) id (idDomainTextPattern contract)+          invalidValues = [T.toUpper value, "other_" <> T.drop 4 value, T.dropEnd 1 value, value <> "0"]+      pure $+        conjoin+          ( counterexample (T.unpack value) (validateIdDomainText contract value == Right () && matchesTextPattern patternValue value)+              : [counterexample (T.unpack invalid) (isLeft (validateIdDomainText contract invalid) && not (matchesTextPattern patternValue invalid)) | invalid <- invalidValues]+          )++    it "enforces the same contract before consumer binding conversion and explains its version" $ do+      v2Source <- readTestText "test/fixtures/nominal-scalars.keiro"+      let v3Text = T.replace "language keiro-dsl 2" "language keiro-dsl 3" v2Source+      parsed <- case parseSource "nominal-scalars-v3.keiro" v3Text of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      let service = checkedSource parsed+          spec = checkedSpec service+          modules = scaffoldServiceModules (defaultContext (specContext spec)) service+          generatedText suffix = case [moduleText value | value <- modules, T.pack suffix `T.isSuffixOf` T.pack (modulePath value)] of+            [value] -> value+            values -> error ("expected one generated module ending in " <> suffix <> ", got " <> show (length values))+          codecModule = generatedText "NominalLedger/Codec.hs"+          projectionModule = generatedText "NominalProjections.hs"+          harnessModule = generatedText "NominalLedger/Harness.hs"+      validateService service `shouldBe` []+      codecModule `shouldSatisfy` T.isInfixOf "case validateIdDomainText (typeIdV7Domain \"ord\") input of"+      codecModule `shouldSatisfy` T.isInfixOf "Right () -> case KindID.parseText @\"ord\" input of"+      projectionModule `shouldSatisfy` T.isInfixOf "idDomainTextPattern (typeIdV7Domain \"ord\")"+      projectionModule `shouldSatisfy` T.isInfixOf "validateIdDomainText (typeIdV7Domain \"ord\") value"+      harnessModule `shouldSatisfy` T.isInfixOf "nominal ID binding preserves canonical representations: OrderId"+      harnessModule `shouldSatisfy` T.isInfixOf "nominal ID boundary rejects wrong-prefix and normalized text: OrderId"+      obligations <- either (\errors -> expectationFailure (show errors) >> pure []) pure (bindingObligationsForService service)+      let orderIdBindings = [obligation | obligation <- obligations, obligationMappedName obligation == "OrderId", obligationKind obligation == BindingValue]+      map obligationIdDomainContract orderIdBindings `shouldBe` [Just "keiro-dsl/id-domain/typeid-v7/1"]+      renderBindingObligations (specContext spec) obligations+        `shouldSatisfy` T.isInfixOf "id-domain-contract: \"keiro-dsl/id-domain/typeid-v7/1\""++    it "reports adoption by boundary, invalidates snapshots, and preserves replay compatibility" $ do+      v2Text <- readTestText "test/fixtures/id-domain-migration-v3.keiro"+      let oldText = T.replace "language keiro-dsl 3" "language keiro-dsl 2" v2Text+      oldSource <- case parseSource "id-domain-migration-v2.keiro" oldText of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      newSource <- case parseSource "id-domain-migration-v3.keiro" v2Text of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      let oldService = checkedSource oldSource+          newService = checkedSource newSource+          changes = diffSources oldSource newSource+          findings = [kindOfChange change | change <- changes, changeCode change == IdDomainContractChanged]+      length findings `shouldBe` 1+      forM_ findings $ \finding -> do+        verdictFor PrivateHistoryRead (ckVector finding) `shouldBe` VCompatible+        verdictFor OldBinaryReadNewEvents (ckVector finding) `shouldBe` VCompatible+        verdictFor SnapshotHydration (ckVector finding) `shouldBe` VAdvisory+        verdictFor PublicConsumer (ckVector finding) `shouldBe` VBreaking+        verdictFor PersistedIdentity (ckVector finding) `shouldBe` VCompatible+        verdictFor ConsumerBuild (ckVector finding) `shouldBe` VAdvisory+        ckDetail finding `shouldSatisfy` T.isInfixOf "historical event replay retains its legacy decoder"+        remediationFor (ckContext finding) (ckCode finding)+          `shouldBe` RemedyDeploymentOrder RolloutProducerLast :| [RemedyStateCodecBump, RemedyRecompileConsumers, RemedyRunConformance]+      [ckDetail finding | change <- changes, changeCode change == SourceLanguageDeclarationChanged, let finding = kindOfChange change]+        `shouldSatisfy` all (T.isInfixOf "effective runtime semantics changed")+      idDomainIdentitiesForService oldService `shouldBe` []+      idDomainIdentitiesForService newService+        `shouldSatisfy` any (T.isInfixOf "contract=keiro-dsl/id-domain/typeid-v7/1")+      resolvedFold (ReplayImpact.replayImpactServices oldService newService) `shouldSatisfy` \case+        ReplayImpact.ReplayAffected impacts ->+          maybe False includeSnapshotStreams (Map.lookup "OrderBook" impacts)+        ReplayImpact.ReplayNeutral -> False++    it "keeps the raw constructor outside the compiled public module surface" $+      withTempDirectory "keiro-dsl-id-domain-hidden-constructor" $ \out -> do+        sourceText <- readTestText "test/fixtures/id-domain-migration-v3.keiro"+        parsed <- case parseSource "id-domain-migration-v3.keiro" sourceText of+          Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+          Right value -> pure value+        let service = checkedSource parsed+            spec = checkedSpec service+            ctx = defaultContext (specContext spec)+            modules = scaffoldServiceModules ctx service+            attempt = out </> "Attempt.hs"+            ghcOutput = out </> ".ghc"+        result <- executeServiceScaffold out False "id-domain-migration-v3.keiro" (parsedSourceLanguage parsed) ctx service modules+        result `shouldSatisfy` isRight+        recordContents <- TIO.readFile (out </> recordFileName (specContext spec))+        record <- case parseRecord recordContents of+          Nothing -> expectationFailure "generated ID-domain scaffold record did not parse" >> fail "unreachable"+          Just value -> pure value+        recIdDomains record `shouldBe` idDomainIdentitiesForService service+        recNominalEqualities record+          `shouldSatisfy` any (T.isInfixOf "keiro-dsl/id-domain/typeid-v7/1")+        createDirectoryIfMissing True ghcOutput+        TIO.writeFile+          attempt+          ( T.unlines+              [ "module Attempt where",+                "import Generated.IdDomainMigration.Nominals (OrderId (..))",+                "bad :: OrderId",+                "bad = OrderId \"ord_LEGACY-NOT-TYPEID\""+              ]+          )+        (exitCode, standardOutput, standardError) <-+          readProcessWithExitCode+            "cabal"+            [ "exec",+              "--",+              "ghc",+              "-XGHC2024",+              "-XOverloadedStrings",+              "-fno-code",+              "-fforce-recomp",+              "-package",+              "keiro-core",+              "-outputdir",+              ghcOutput,+              "-i" <> out,+              attempt+            ]+            ""+        exitCode `shouldSatisfy` (/= ExitSuccess)+        (standardOutput <> standardError) `shouldContain` "OrderId"++    it "emits one enforced nominal owner for a version-3 workspace" $ do+      manifest <- readTestText "test/fixtures/workspace-nominals/service.keiro-workspace"+      shared <- readTestText "test/fixtures/workspace-nominals/domain/shared.keiro"+      project <- readTestText "test/fixtures/workspace-nominals/domain/project.keiro"+      artifact <- readTestText "test/fixtures/workspace-nominals/domain/project-artifact.keiro"+      let v3 = T.replace "language keiro-dsl 2" "language keiro-dsl 3"+          source =+            memoryContentSource+              ( Map.fromList+                  [ ("service.keiro-workspace", manifest),+                    ("domain/shared.keiro", v3 shared),+                    ("domain/project.keiro", v3 project),+                    ("domain/project-artifact.keiro", v3 artifact)+                  ]+              )+      loaded <- loadWorkspace source "service.keiro-workspace"+      workspace <- case loaded of+        Left failure -> expectationFailure (show failure) >> fail "unreachable"+        Right value -> pure value+      plan <- case planWorkspaceScaffold "goldens" (workspaceContext workspace) workspace of+        Left refusals -> expectationFailure (show refusals) >> fail "unreachable"+        Right value -> pure value+      let paths = map (modulePath . fst) (wpModules plan)+      length (filter (== "Generated/WorkspaceNominalProof/Nominals.hs") paths) `shouldBe` 1+      length (filter (== "Generated/WorkspaceNominalProof/Nominals/Internal.hs") paths) `shouldBe` 1+      forM_ [moduleText value | (value, _) <- wpModules plan, "/Domain.hs" `T.isSuffixOf` T.pack (modulePath value)] $ \domainText ->+        domainText `shouldSatisfy` (not . T.isInfixOf "ProjectId (..)")+      withTempDirectory "keiro-dsl-v3-workspace-record" $ \out -> do+        emitted <- executeWorkspaceScaffold out False plan+        emitted `shouldSatisfy` isRight+        recordContents <- TIO.readFile (out </> workspaceRecordFileName (wsService workspace))+        record <- case parseWorkspaceRecord recordContents of+          Nothing -> expectationFailure "version-3 workspace record did not parse" >> fail "unreachable"+          Just value -> pure value+        wrIdDomains record `shouldBe` idDomainIdentitiesForService (wpCheckedService plan)+        wrNominalEqualities record+          `shouldSatisfy` any (T.isInfixOf "keiro-dsl/id-domain/typeid-v7/1")++    it "emits an abstract public ID, an internal legacy seam, and exact equality" $ do+      v2Source <- readTestText "test/fixtures/aggregate-scalar-expressions-v2.keiro"+      let v3Source = T.replace "language keiro-dsl 2" "language keiro-dsl 3" v2Source+      parsed <- case parseSource "aggregate-scalar-expressions-v3.keiro" v3Source of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      let service = checkedSource parsed+          spec = checkedSpec service+          modules = scaffoldServiceModules (defaultContext (specContext spec)) service+          moduleAt path = case [value | value <- modules, modulePath value == path] of+            [value] -> pure value+            values -> expectationFailure ("expected one module at " <> path <> ", got " <> show (map modulePath values)) >> fail "unreachable"+      validateService service `shouldBe` []+      publicNominals <- moduleAt "Generated/AggregateScalarExpressions/Nominals.hs"+      internalNominals <- moduleAt "Generated/AggregateScalarExpressions/Nominals/Internal.hs"+      domainModule <- moduleAt "Generated/AggregateScalarExpressions/ScalarAccount/Domain.hs"+      codecModule <- moduleAt "Generated/AggregateScalarExpressions/ScalarAccount/Codec.hs"+      transducerModule <- moduleAt "Generated/AggregateScalarExpressions/ScalarAccount/Transducer.hs"+      moduleText publicNominals `shouldSatisfy` T.isInfixOf "parseRequestId"+      moduleText publicNominals `shouldSatisfy` T.isInfixOf "instance ExactFieldProjection RequestIdEqualityProjection"+      moduleText publicNominals `shouldSatisfy` T.isInfixOf "idDomainTextPattern (typeIdV7Domain \"req\")"+      moduleText publicNominals `shouldSatisfy` (not . T.isInfixOf "unsafeRequestIdFromLegacyText")+      moduleText publicNominals `shouldSatisfy` (not . T.isInfixOf "newtype RequestId")+      moduleText internalNominals `shouldSatisfy` T.isInfixOf "newtype RequestId = RequestId Text"+      moduleText internalNominals `shouldSatisfy` T.isInfixOf "unsafeRequestIdFromLegacyText"+      moduleText domainModule `shouldSatisfy` (not . T.isInfixOf "RequestId (..)")+      moduleText codecModule `shouldSatisfy` T.isInfixOf "unsafeRequestIdFromLegacyText <$>"+      moduleText transducerModule `shouldSatisfy` T.isInfixOf "case parseRequestId"+      firewallBreaches modules `shouldBe` []++  describe "scalar expressions" $ do+    it "parses, validates, and round-trips the authoritative stable scalar fixture" $ do+      source <- readTestText "test/fixtures/aggregate-scalar-expressions-v2.keiro"+      parsed <- case parseSource "aggregate-scalar-expressions-v2.keiro" source of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      validateSpec (parsedSpec parsed) `shouldBe` []+      parseSource "round-trip.keiro" (renderSource parsed) `shouldBe` Right parsed+      case [aggregate | NAggregate aggregate <- specNodes (parsedSpec parsed)] of+        [aggregate] -> case aggTransitions aggregate of+          transition : holeTransition : [] -> do+            tImplementation transition `shouldBe` GeneratedImplementation+            tImplementation holeTransition `shouldBe` HoleImplementation+            let environment = expressionEnvironment (parsedSpec parsed) aggregate transition+            case lookup "reserved" (tWrites transition) >>= either (const Nothing) Just . resolveWriteExpr environment "reserved" of+              Just resolved -> do+                typedScalarType resolved `shouldBe` AggregateNatural+                show (typedScalarNode resolved) `shouldContain` "TotalNaturalArithmetic"+              Nothing -> expectationFailure "reserved write did not resolve"+            let service = checkedSource parsed+                modules = scaffoldServiceModules (defaultContext (specContext (parsedSpec parsed))) service+                transducer = generatedTextEndingIn "Transducer.hs" modules+                holes = holeTextEndingIn "Holes.hs" modules+                surface = aggregateFoldSurfaceForService service aggregate+                manifest = renderManifestForService "aggregate-scalar-expressions-v2.keiro" modules service+                readableTransducer = T.unwords (T.words transducer)+            aggregateFoldFingerprintForService service aggregate `shouldBe` "60f4f059f718b2ee2bca06360ea20221"+            T.lines surface+              `shouldBe` [ "semantic-contract:keiro-dsl/runtime-semantics/2",+                           "state:Open|terminal=false",+                           "state:Reviewed|terminal=false",+                           "state:Closed|terminal=true",+                           "reg:balance:Integer=0",+                           "reg:reserved:Natural=0",+                           "reg:capacity:Natural=5",+                           "reg:machine:Int=0",+                           "reg:label:Text=\"\"",+                           "reg:active:Bool=False",+                           "reg:mode:AccountMode=Normal",+                           "reg:requestId:RequestId=placeholder",+                           "reg:openedAt:Time=(UTCTime (fromGregorian 2026 1 1) (picosecondsToDiffTime 0))",+                           "reg:limits:Limits=initial",+                           "mapped-register:Limits|wire=4463db782a5b9924|canonical=scalar-expressions.Limits.v1|binding=ScalarExpressions.Bindings.limitsBinding|binding-version=1|initial=ScalarExpressions.Bindings.initialLimits",+                           "nominal-equality-use:nominal-equality|name=AccountMode|contract=keiro-dsl/nominal-equality/1|key=Text|domain=finite-text:normal,restricted|owner=generated",+                           "nominal-equality-use:nominal-equality|name=RequestId|contract=keiro-dsl/nominal-equality/2|key=Text|domain=typeid-v7-text:req:keiro-dsl/id-domain/typeid-v7/1|owner=generated",+                           "transition:live|Open|Adjust|implementation=generated|guard=cmd.balance + reg.balance >= -100 && reg.reserved + cmd.requested <= reg.capacity && cmd.observedAt >= reg.openedAt && cmd.limits.minimum >= reg.limits.minimum && cmd.active == false && cmd.mode == reg.mode && cmd.requestId == reg.requestId|writes=balance:=reg.balance + cmd.balance * 2;reserved:=reg.reserved + (cmd.requested - reg.capacity);machine:=-7;label:=\"adjusted\";active:=true;mode:=AccountMode.Restricted;requestId:=RequestId(\"req_01h455vb4pex5vsknk084sn02q\");openedAt:=\"2026-02-03T04:05:06Z\";limits:=cmd.limits|emits=Adjusted|outputs=Adjusted=generated-command-identity:Adjust[balance=balance:Integer,requested=requested:Natural,machine=machine:Int,label=label:Text,active=active:Bool,mode=mode:AccountMode,requestId=requestId:RequestId,observedAt=observedAt:Time,limits=limits:Limits]|goto=Reviewed",+                           "transition:live|Reviewed|Close|implementation=hole|guard=|writes=|emits=ClosedEvent|outputs=ClosedEvent=generated-command-identity:Close[balance=balance:Integer]|goto=Closed"+                         ]+            diffServices service service `shouldBe` []+            resolvedFold (ReplayImpact.replayImpactServices service service) `shouldBe` ReplayNeutral+            manifest `shouldSatisfy` (not . T.isInfixOf "Generated.AggregateScalarExpressions.ScalarAccount.Expressions")+            map modulePath modules `shouldSatisfy` all (not . T.isSuffixOf "Expressions.hs" . T.pack)+            map modulePath modules `shouldSatisfy` any (T.isSuffixOf "Transducer.hs" . T.pack)+            transducer `shouldSatisfy` T.isInfixOf "let commandLimitsMinimum = K.inpProj"+            transducer `shouldSatisfy` T.isInfixOf "registerLimitsMinimum = K.regProj"+            readableTransducer `shouldSatisfy` T.isInfixOf "B.requireGuard $ (((((d.balance .+ B.reg @\"balance\" .>= K.lit (-100 :: Integer) .&& B.reg @\"reserved\" .+ d.requested .<= B.reg @\"capacity\") .&& d.observedAt .>= B.reg @\"openedAt\") .&& commandLimitsMinimum .>= registerLimitsMinimum) .&& d.active .== K.lit False) .&& commandMode .== registerMode) .&& commandRequestId .== registerRequestId"+            transducer `shouldSatisfy` T.isInfixOf "B.slot @\"balance\" =: (B.reg @\"balance\" .+ d.balance .* K.lit (2 :: Integer))"+            transducer `shouldSatisfy` T.isInfixOf "B.slot @\"reserved\" =: (B.reg @\"reserved\" .+ (d.requested .- B.reg @\"capacity\"))"+            transducer `shouldSatisfy` (not . T.isInfixOf "K.PAnd")+            transducer `shouldSatisfy` (not . T.isInfixOf "K.tadd")+            transducer `shouldSatisfy` T.isInfixOf "scalarAccountPredicateVerifications"+            transducer `shouldSatisfy` T.isInfixOf "S.verifyPredicate predicate"+            transducer `shouldSatisfy` T.isInfixOf "B.emit wireAdjusted (AdjustedTermFields"+            transducer `shouldSatisfy` T.isInfixOf "balance = d.balance"+            transducer `shouldSatisfy` (not . T.isInfixOf "transition1OpenAdjustOutput1Adjusted")+            holes `shouldSatisfy` (not . T.isInfixOf "transition1OpenAdjustOutput1Adjusted")+            holes `shouldSatisfy` (not . T.isInfixOf "transition2ReviewedCloseOutput1ClosedEvent")+            holes `shouldSatisfy` T.isInfixOf "transition2ReviewedCloseHoleFoldVersion"+            holes `shouldSatisfy` (not . T.isInfixOf "scalarAccountTransducer")+            firewallBreaches modules `shouldBe` []+          _ -> expectationFailure "expected one generated and one Hole scalar transition"+        _ -> expectationFailure "expected one scalar aggregate"++    it "pins every readable operator, equal-precedence child position, and bare Boolean guard" $ do+      let source =+            T.unlines+              [ "language keiro-dsl 2",+                "context readable-renderer",+                "enum RenderStatus { Ready=ready Waiting=waiting }",+                "aggregate Renderer",+                "  regs",+                "    total Integer = 0",+                "    leftNested Integer = 0",+                "    product Integer = 1",+                "    status RenderStatus = Ready",+                "  states Open Closed!",+                "  command Evaluate { left:Integer right:Integer third:Integer status:RenderStatus }",+                "  event Evaluated = fields(Evaluate)",+                "  Open -- Evaluate -->",+                "    guard ((cmd.left < cmd.right || cmd.left <= cmd.right) || (cmd.left > cmd.right || cmd.left >= cmd.right))",+                "      && (cmd.left == cmd.right && cmd.left != cmd.third)",+                "      && cmd.status == RenderStatus.Waiting",+                "    write total := reg.total + (cmd.left - cmd.right)",+                "    write leftNested := (reg.leftNested + cmd.left) - cmd.right",+                "    write product := cmd.left * (cmd.right * cmd.third)",+                "    write status := RenderStatus.Ready",+                "    emit Evaluated",+                "    goto Closed",+                "aggregate BooleanRenderer",+                "  regs",+                "    enabled Bool = False",+                "  states Open Closed!",+                "  command Enable { enabled:Bool }",+                "  event Enabled = fields(Enable)",+                "  Open -- Enable -->",+                "    guard cmd.enabled",+                "    write enabled := cmd.enabled",+                "    emit Enabled",+                "    goto Closed"+              ]+      spec <- parseInlineSpec "<readable-renderer>" source+      errorCodes spec `shouldBe` []+      let modules = scaffoldModules (defaultContext (specContext spec)) spec+          moduleAt suffix = case [moduleText value | value <- modules, T.pack suffix `T.isSuffixOf` T.pack (modulePath value)] of+            [value] -> pure value+            values -> expectationFailure ("expected one generated module ending in " <> suffix <> ", got " <> show (length values)) >> fail "unreachable"+      renderer <- moduleAt "/Renderer/Transducer.hs"+      booleanRenderer <- moduleAt "/BooleanRenderer/Transducer.hs"+      let normalizedRenderer = T.unwords (T.words renderer)+          normalizedBooleanRenderer = T.unwords (T.words booleanRenderer)+      renderer+        `shouldSatisfy` T.isInfixOf "import Keiki.Core (HsPred, SymTransducer, (.*), (.+), (.-), (.==), (./=), (.<), (.<=), (.>), (.>=), (.&&), (.||))"+      normalizedRenderer+        `shouldSatisfy` T.isInfixOf "(d.left .< d.right .|| d.left .<= d.right) .|| d.left .> d.right .|| d.left .>= d.right"+      normalizedRenderer+        `shouldSatisfy` T.isInfixOf ".&& d.left .== d.right .&& d.left ./= d.third"+      normalizedRenderer+        `shouldSatisfy` T.isInfixOf ".&& commandStatus .== K.lit (\"waiting\" :: Text)"+      renderer+        `shouldSatisfy` T.isInfixOf "B.slot @\"total\" =: (B.reg @\"total\" .+ (d.left .- d.right))"+      renderer+        `shouldSatisfy` T.isInfixOf "B.slot @\"leftNested\" =: (B.reg @\"leftNested\" .+ d.left .- d.right)"+      renderer+        `shouldSatisfy` T.isInfixOf "B.slot @\"product\" =: d.left .* (d.right .* d.third)"+      normalizedBooleanRenderer `shouldSatisfy` T.isInfixOf "B.requireGuard $ d.enabled .== K.lit True"+      firewallBreaches modules `shouldBe` []++    it "renders resolved command selectors in scalar and projected expressions" $ do+      source <- readTestText "test/fixtures/aggregate-scalar-expressions-v2.keiro"+      let aliasedSource =+            T.replace "active:Bool" "active haskell commandActive:Bool"+              . T.replace "mode:AccountMode" "mode haskell commandMode:AccountMode"+              . T.replace "requestId:RequestId" "requestId haskell commandRequestId:RequestId"+              . T.replace "limits:Limits" "limits haskell commandLimits:Limits"+              $ source+      service <- checkedServiceFromText "aggregate-scalar-expression-aliases.keiro" aliasedSource+      let spec = checkedSpec service+          transducer = generatedTextEndingIn "Transducer.hs" (scaffoldServiceModules (defaultContext (specContext spec)) service)+      validateService service `shouldBe` []+      transducer `shouldSatisfy` T.isInfixOf "d.commandActive"+      transducer `shouldSatisfy` T.isInfixOf "d.commandLimits"+      transducer `shouldSatisfy` T.isInfixOf "(#commandMode :: K.Index"+      transducer `shouldSatisfy` T.isInfixOf "(#commandRequestId :: K.Index"+      transducer `shouldSatisfy` T.isInfixOf "(#commandLimits :: K.Index"+      transducer `shouldSatisfy` (not . T.isInfixOf "d.active")+      transducer `shouldSatisfy` (not . T.isInfixOf "inCtorAdjust (#mode :: K.Index")+      transducer `shouldSatisfy` (not . T.isInfixOf "inCtorAdjust (#requestId :: K.Index")+      transducer `shouldSatisfy` (not . T.isInfixOf "inCtorAdjust (#limits :: K.Index")++    it "suffixes normalized projection-alias collisions deterministically" $ do+      let source =+            T.unlines+              [ "language keiro-dsl 2",+                "context projection-alias-collision",+                "mapped structural record AliasCollision {",+                "  haskell package=keiro-dsl module=Renderer.Domain type=AliasCollision",+                "  binding = \"Renderer.Bindings.aliasCollisionBinding\"",+                "  binding-version = \"1\"",+                "  canonical-type = \"renderer.AliasCollision.v1\"",+                "  fixtures = \"Renderer.Bindings.aliasCollisionCases\"",+                "  initial = \"Renderer.Bindings.initialAliasCollision\"",+                "  wire object constructor=AliasCollision unknown-fields=reject {",+                "    dash as \"foo-bar\" : Integer required",+                "    underscore as \"foo_bar\" : Integer required",+                "  }",+                "}",+                "aggregate AliasRenderer",+                "  regs",+                "    values AliasCollision = initial",+                "  states Open Closed!",+                "  command Compare { values:AliasCollision }",+                "  event Compared = fields(Compare)",+                "  Open -- Compare -->",+                "    guard cmd.values.dash == reg.values.dash",+                "      && cmd.values.underscore == reg.values.underscore",+                "    emit Compared",+                "    goto Closed"+              ]+      spec <- parseInlineSpec "<projection-alias-collision>" source+      errorCodes spec `shouldBe` []+      let transducer = generatedTextEndingIn "Transducer.hs" (scaffoldModules (defaultContext (specContext spec)) spec)+      transducer `shouldSatisfy` T.isInfixOf "let commandValuesFooBar = K.inpProj"+      transducer `shouldSatisfy` T.isInfixOf "registerValuesFooBar = K.regProj"+      transducer `shouldSatisfy` T.isInfixOf "commandValuesFooBar2 = K.inpProj"+      transducer `shouldSatisfy` T.isInfixOf "registerValuesFooBar2 = K.regProj"++    it "keeps evolution identity independent of module layout but sensitive to checked behavior" $ do+      source <- readTestText "test/fixtures/aggregate-scalar-expressions-v2.keiro"+      original <- case parseSource "aggregate-scalar-expressions-v2.keiro" source of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      changed <- case parseSource "aggregate-scalar-expressions-changed.keiro" (T.replace "cmd.active == false" "cmd.active == true" source) of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      case ( [aggregate | NAggregate aggregate <- specNodes (parsedSpec original)],+             [aggregate | NAggregate aggregate <- specNodes (parsedSpec changed)]+           ) of+        ([originalAggregate], [changedAggregate]) -> do+          let service = checkedSource original+              changedService = checkedSource changed+              prefixed = defaultContext (specContext (parsedSpec original))+              collocated = prefixed {moduleRoot = "Acme", placement = CollocatedLeaf}+              prefixedModules = scaffoldServiceModules prefixed service+              collocatedModules = scaffoldServiceModules collocated service+              originalSurface = aggregateFoldSurfaceForService service originalAggregate+              originalFingerprint = aggregateFoldFingerprintForService service originalAggregate+          map modulePath prefixedModules `shouldNotBe` map modulePath collocatedModules+          sum (map (T.length . moduleText) prefixedModules) `shouldSatisfy` (> 0)+          sum (map (T.length . moduleText) collocatedModules) `shouldSatisfy` (> 0)+          aggregateFoldSurfaceForService service originalAggregate `shouldBe` originalSurface+          aggregateFoldFingerprintForService service originalAggregate `shouldBe` originalFingerprint+          aggregateFoldSurfaceForService changedService changedAggregate `shouldNotBe` originalSurface+          aggregateFoldFingerprintForService changedService changedAggregate `shouldNotBe` originalFingerprint+        found -> expectationFailure ("expected one aggregate before and after behavior mutation, got " <> show (length (fst found), length (snd found)))++    it "rejects cross-command fields(Command) output before scaffolding" $ do+      let source =+            T.unlines+              [ "language keiro-dsl 2",+                "context output-command-mismatch",+                "aggregate Account",+                "  regs",+                "  states Open Closed!",+                "  command OpenAccount { accountId:Text }",+                "  command CloseAccount { accountId:Text }",+                "  event AccountOpened = fields(OpenAccount)",+                "  Open -- CloseAccount --> emit AccountOpened ; goto Closed"+              ]+      spec <- parseInlineSpec "<output-command-mismatch>" source+      errorCodes spec `shouldContain` [EventOutputCommandMismatch]+      case [aggregate | NAggregate aggregate <- specNodes spec] of+        [aggregate] -> case aggTransitions aggregate of+          [transition] ->+            eventOutputMapping spec aggregate transition 1 "AccountOpened"+              `shouldBe` Left (OutputCommandMismatch "OpenAccount" "CloseAccount" "AccountOpened")+          _ -> expectationFailure "expected one transition"+        _ -> expectationFailure "expected one aggregate"++    it "rejects Int arithmetic and mixed numeric operands before scaffolding" $ do+      let source =+            T.unlines+              [ "language keiro-dsl 2",+                "context scalar-errors",+                "aggregate Counter",+                "  regs",+                "    machine Int = 0",+                "    exact Integer = 0",+                "  states Open Closed!",+                "  command Add { machine:Int exact:Integer }",+                "  event Added = fields(Add)",+                "  Open -- Add -->",+                "    guard cmd.machine + 1 >= 0 && cmd.exact == cmd.machine",+                "    emit Added",+                "    goto Closed"+              ]+      spec <- parseInlineSpec "<scalar-errors>" source+      errorCodes spec `shouldContain` [AggregateExpressionOperatorUnsupported, AggregateExpressionOperandTypeMismatch]++    it "rejects nominal type confusion and unqualified enum values at source checking" $ do+      let source =+            T.unlines+              [ "language keiro-dsl 2",+                "context nominal-type-confusion",+                "id OrderId prefix=ord",+                "id UserId prefix=usr",+                "enum OrderStatus { Draft=draft Submitted=submitted }",+                "enum UserStatus { Active=active Disabled=disabled }",+                "aggregate Account",+                "  regs",+                "    orderId OrderId = placeholder",+                "    status OrderStatus = Draft",+                "  states Open Closed!",+                "  command Compare { orderId:OrderId userId:UserId status:OrderStatus userStatus:UserStatus label:Text }",+                "  event Compared = fields(Compare)",+                "  Open -- Compare -->",+                "    guard cmd.orderId == cmd.userId",+                "      && cmd.status == cmd.userStatus",+                "      && cmd.orderId == cmd.label",+                "      && cmd.status == Draft",+                "    emit Compared",+                "    goto Closed"+              ]+      spec <- parseInlineSpec "<nominal-type-confusion>" source+      let diagnostics = validateSpec spec+      length [() | diagnostic <- diagnostics, code diagnostic == AggregateExpressionOperandTypeMismatch]+        `shouldBe` 3+      errorCodes spec `shouldContain` [AggregateExpressionRootUnknown]+      T.unlines (map message diagnostics) `shouldSatisfy` T.isInfixOf "qualify"++    it "rejects machine-Int arithmetic at both platform bounds" $ do+      let source =+            T.unlines+              [ "language keiro-dsl 2",+                "context scalar-int-bounds",+                "aggregate Counter",+                "  regs",+                "    machine Int = 0",+                "  states Open Closed!",+                "  command Set { machine:Int }",+                "  event SetEvent = fields(Set)",+                "  Open -- Set -->",+                "    guard cmd.machine + 1 >= " <> T.pack (show (minBound :: Int)),+                "      && cmd.machine - 1 <= " <> T.pack (show (maxBound :: Int)),+                "    emit SetEvent",+                "    goto Closed"+              ]+      spec <- parseInlineSpec "<scalar-int-bounds>" source+      length [() | diagnostic <- validateSpec spec, code diagnostic == AggregateExpressionOperatorUnsupported]+        `shouldBe` 2++    it "rejects predicate-valued Bool writes that Keiki cannot represent as scalar terms" $ do+      let source =+            T.unlines+              [ "language keiro-dsl 2",+                "context scalar-bool-write",+                "aggregate Flag",+                "  regs",+                "    active Bool = False",+                "  states Open Closed!",+                "  command Set { active:Bool }",+                "  event SetEvent = fields(Set)",+                "  Open -- Set -->",+                "    write active := cmd.active == true",+                "    emit SetEvent",+                "    goto Closed"+              ]+      spec <- parseInlineSpec "<scalar-bool-write>" source+      errorCodes spec `shouldContain` [AggregateExpressionOperatorUnsupported]++    it "requires explicit roots for a same-named register and command field" $ do+      let source =+            T.unlines+              [ "language keiro-dsl 2",+                "context scalar-ambiguity",+                "aggregate Counter",+                "  regs",+                "    amount Integer = 0",+                "  states Open Closed!",+                "  command Set { amount:Integer }",+                "  event SetEvent = fields(Set)",+                "  Open -- Set -->",+                "    guard amount == 0",+                "    emit SetEvent",+                "    goto Closed"+              ]+      spec <- parseInlineSpec "<scalar-ambiguity>" source+      errorCodes spec `shouldContain` [AggregateExpressionRootAmbiguous]++    it "enforces exclusive Hole ownership and preserves its canonical spelling" $ do+      let source =+            T.unlines+              [ "language keiro-dsl 2",+                "context scalar-hole",+                "aggregate Counter",+                "  regs",+                "    amount Integer = 0",+                "  states Open Closed!",+                "  command Set { amount:Integer }",+                "  event SetEvent = fields(Set)",+                "  Open -- Set -->",+                "    implementation hole",+                "    guard cmd.amount >= 0",+                "    emit SetEvent",+                "    goto Closed"+              ]+      parsed <- case parseSource "<scalar-hole>" source of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      errorCodes (parsedSpec parsed) `shouldContain` [AggregateTransitionOwnershipConflict]+      renderSource parsed `shouldSatisfy` T.isInfixOf "implementation hole"++    it "generates a stable per-transition Hole boundary and fold token" $ do+      let source =+            T.unlines+              [ "language keiro-dsl 2",+                "context scalar-hole",+                "aggregate Counter",+                "  regs",+                "    amount Integer = 0",+                "  states Open Closed!",+                "  command Set { amount:Integer }",+                "  event SetEvent = fields(Set)",+                "  Open -- Set -->",+                "    implementation hole",+                "    emit SetEvent",+                "    goto Closed"+              ]+      spec <- parseInlineSpec "<scalar-hole-valid>" source+      aggregate <- case [value | NAggregate value <- specNodes spec] of+        [value] -> pure value+        _ -> expectationFailure "expected one Hole aggregate" >> fail "unreachable"+      let modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate+          transducer = generatedTextEndingIn "Transducer.hs" modules+          holes = holeTextEndingIn "Holes.hs" modules+      errorCodes spec `shouldBe` []+      map modulePath modules `shouldSatisfy` all (not . T.isSuffixOf "Expressions.hs" . T.pack)+      transducer `shouldSatisfy` T.isInfixOf "Holes.transition1OpenSetHole d"+      transducer `shouldSatisfy` T.isInfixOf "foldToken Holes.transition1OpenSetHoleFoldVersion"+      holes `shouldSatisfy` T.isInfixOf "transition1OpenSetHole _d = B.requireGuard K.PTop"+      holes `shouldSatisfy` T.isInfixOf "transition1OpenSetHoleFoldVersion = FoldVersion"+      holes `shouldSatisfy` (not . T.isInfixOf "counterTransducer")++    it "pins v1 and collection rejection at their stable boundaries" $ do+      v1Source <- readTestText "test/fixtures/aggregate-scalar-expressions-v1-rejects.keiro"+      case parseSource "v1.keiro" v1Source of+        Left (SourceLanguageFailure diagnostic) -> sourceLanguageErrorCode diagnostic `shouldBe` LanguageFeatureRequiresVersion+        other -> expectationFailure ("expected v1 source-language refusal, got " <> show other)+      collectionSource <- readTestText "test/fixtures/aggregate-collection-expressions-v2-rejects.keiro"+      case parseSource "collections.keiro" collectionSource of+        Left failure -> renderParseFailure failure `shouldSatisfy` T.isInfixOf "CollectionExpressionUnsupported"+        Right _ -> expectationFailure "collection syntax unexpectedly parsed"++    it "keeps arithmetic operands intact when complementing a scalar comparison" $ do+      let left = EAdd noLoc (EPath noLoc CommandRoot ["balance"]) (ELiteral noLoc (LiteralIntegral 2))+          right = ESubtract noLoc (EPath noLoc RegisterRoot ["balance"]) (ELiteral noLoc (LiteralIntegral 3))+          predicate = ECmp OpLt left right+      complementExpr predicate `shouldBe` ECmp OpGe left right+      complementExpr (complementExpr predicate) `shouldBe` predicate++    it "keeps the committed scalar-expression conformance tree fresh" $ do+      modules <- scaffoldFixture "test/fixtures/aggregate-scalar-expressions-v2.keiro"+      forM_ [generatedModule | generatedModule <- modules, kind generatedModule == Generated] $ \generatedModule -> do+        committed <- readTestText ("test/conformance-scalar-expressions/" <> modulePath generatedModule)+        normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText generatedModule)++  describe "behavior obligations" $ do+    it "joins every source-stable behavior origin to one exact source position" $ do+      source <- readTestText "test/fixtures/behavior-complete.keiro"+      document <- case parseSourceDocument "test/fixtures/behavior-complete.keiro" source of+        Left failure -> expectationFailure (show failure) >> fail "unreachable"+        Right value -> pure value+      let ParsedSourceDocument {documentParsedSource = parsedSource, documentSourceIndex = sourceIndex} = document+          spec = checkedSpec (checkedSource parsedSource)+      requirements <- either (\errors -> expectationFailure (show errors) >> fail "unreachable") pure (Behavior.deriveBehaviorRequirements spec)+      entries <- either (\errors -> expectationFailure (show errors) >> fail "unreachable") pure (BehaviorSource.planBehaviorSourceMap requirements sourceIndex)+      map BehaviorSource.behaviorSourceKey entries `shouldBe` map Behavior.requirementKey requirements+      entries `shouldSatisfy` all ((== "test/fixtures/behavior-complete.keiro") . BehaviorSource.behaviorSourceFile)+      entries `shouldSatisfy` all ((>= 1) . BehaviorSource.behaviorSourceLine)+      entries `shouldSatisfy` all ((>= 1) . BehaviorSource.behaviorSourceColumn)+      let exactJson =+            Behavior.encodeBehaviorObligationsJson+              (Behavior.BehaviorObligationsReport "test/fixtures/behavior-complete.keiro" Nothing (BehaviorSource.attachBehaviorSourceLocations entries requirements))+          exactText =+            Behavior.renderBehaviorObligationsText+              (Behavior.BehaviorObligationsReport "test/fixtures/behavior-complete.keiro" Nothing (BehaviorSource.attachBehaviorSourceLocations entries requirements))+      exactJson `shouldSatisfy` T.isInfixOf "\"quality\":\"exact\""+      exactJson `shouldSatisfy` T.isInfixOf "\"column\":"+      exactJson `shouldSatisfy` T.isInfixOf "\"file\":\"test/fixtures/behavior-complete.keiro\""+      exactText `shouldSatisfy` T.isInfixOf "test/fixtures/behavior-complete.keiro:"+      exactText `shouldSatisfy` T.isInfixOf "[location-quality=exact]"+      [Behavior.requirementOrigin requirement | requirement <- requirements, Behavior.requirementKind requirement == Behavior.RequiredRejection]+        `shouldSatisfy` all (\case Behavior.RejectionRequirementOrigin "Journey" _ -> True; _ -> False)++    it "refuses line-only, missing, and duplicate behavior source anchors before writes" $+      withTempDirectory "keiro-dsl-source-anchor-refusal" $ \out -> do+        baselineTree <- treeSnapshot out+        spec <- specOf "test/fixtures/behavior-complete.keiro"+        requirements <- either (\errors -> expectationFailure (show errors) >> fail "unreachable") pure (Behavior.deriveBehaviorRequirements spec)+        compatibility <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (compatibilitySemanticSourceIndex "behavior-complete.keiro" spec)+        let failureCodes result = case result of+              Left failures -> map BehaviorSource.failureCode failures+              Right _ -> []+        failureCodes (BehaviorSource.planBehaviorSourceMap requirements compatibility)+          `shouldSatisfy` all (== BehaviorSource.BehaviorSourceAnchorInexact)+        failureCodes (BehaviorSource.planBehaviorSourceMap requirements emptySemanticSourceIndex)+          `shouldSatisfy` all (== BehaviorSource.BehaviorSourceAnchorMissing)+        case BehaviorSource.planBehaviorSourceMap requirements emptySemanticSourceIndex of+          Left (failure : _) -> do+            let diagnostics = planningRefusalDiagnostics [BehaviorSourceRefusal [failure]]+            map code diagnostics `shouldBe` [BehaviorSourceAnchorMissing]+            map message diagnostics `shouldSatisfy` all (T.isInfixOf "behavior-v1-")+            map message diagnostics `shouldSatisfy` all (T.isInfixOf "Journey:")+            map message diagnostics `shouldSatisfy` all (T.isInfixOf "subject=Aggregate")+          result -> expectationFailure ("expected missing-anchor diagnostics, got " <> show result)+        case requirements of+          first : _ ->+            failureCodes (BehaviorSource.planBehaviorSourceMap (first : requirements) compatibility)+              `shouldContain` [BehaviorSource.BehaviorSourceAnchorCollision]+          [] -> expectationFailure "behavior fixture unexpectedly has no requirements"+        treeSnapshot out `shouldReturn` baselineTree++    it "plans one exact context source map and removes line-derived contract and witness bytes" $ do+      source <- readTestText "test/fixtures/behavior-complete.keiro"+      document <- case parseSourceDocument "test/fixtures/behavior-complete.keiro" source of+        Left failure -> expectationFailure (show failure) >> fail "unreachable"+        Right value -> pure value+      let ParsedSourceDocument {documentParsedSource = parsedSource, documentSourceIndex = sourceIndex} = document+          service = checkedSource parsedSource+          ctx = defaultContext (specContext (checkedSpec service))+      modules <- either (\refusals -> expectationFailure (show refusals) >> fail "unreachable") pure (planIndexedServiceScaffold sourceIndex ctx service)+      let sourceMaps = [moduleText value | value <- modules, T.isSuffixOf "/BehaviorSourceMap.hs" (T.pack (modulePath value))]+          contracts = [moduleText value | value <- modules, T.isSuffixOf "/BehaviorContract.hs" (T.pack (modulePath value))]+          witnesses = [moduleText value | value <- modules, T.isSuffixOf "/BehaviorHoles.hs" (T.pack (modulePath value))]+      case sourceMaps of+        [sourceMapText] -> sourceMapText `shouldSatisfy` T.isInfixOf "test/fixtures/behavior-complete.keiro"+        values -> expectationFailure ("expected one behavior source map, got " <> show (length values))+      contracts `shouldSatisfy` all (T.isInfixOf ".BehaviorSourceMap qualified as BehaviorSourceMap")+      contracts `shouldSatisfy` all (not . T.isInfixOf "requirementLine")+      contracts `shouldSatisfy` all (not . T.isInfixOf "spec line")+      witnesses `shouldSatisfy` all (not . T.isInfixOf "spec line")+      compatibility <-+        either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure $+          compatibilitySemanticSourceIndex "<semantic-only>" (checkedSpec service)+      requirements <-+        either (\errors -> expectationFailure (show errors) >> fail "unreachable") pure $+          Behavior.deriveBehaviorRequirements (checkedSpec service)+      case BehaviorSource.planBehaviorSourceMap requirements compatibility of+        Left failures ->+          failures `shouldSatisfy` all ((== BehaviorSource.BehaviorSourceAnchorInexact) . BehaviorSource.failureCode)+        Right _ -> expectationFailure "compatibility line-only provenance fabricated exact behavior columns"++    it "omits the context source map when no behavior contract can import it" $ do+      spec <- parseInlineSpec "<no-behavior>" "language keiro-dsl 4\ncontext no-behavior\n"+      modules <- either (\refusals -> expectationFailure (show refusals) >> fail "unreachable") pure (planTestScaffold (defaultContext "no-behavior") spec)+      map modulePath modules `shouldSatisfy` all (not . T.isSuffixOf "BehaviorSourceMap.hs" . T.pack)+      map modulePath modules `shouldSatisfy` all (not . T.isSuffixOf "BehaviorContract.hs" . T.pack)++    it "uses one source-wide layout and excludes replay-only initial edges from live harness probes" $ do+      spec <-+        parseInlineSpec "<transition-layout>" $+          T.unlines+            [ "language keiro-dsl 4",+              "context transition-layout",+              "aggregate Journey",+              "  regs",+              "  states Empty Active",+              "  command Start { current:Bool }",+              "  command Legacy { current:Bool }",+              "  event Started = fields(Start)",+              "  event LegacyStarted = fields(Legacy)",+              "  Empty -- Start --> guard cmd.current == true ; emit Started ; goto Active",+              "  Active -- Start --> emit Started ; goto Active",+              "  replay-only Empty -- Start --> guard cmd.current == false ; emit Started ; goto Active",+              "  Active -- Legacy --> emit LegacyStarted ; goto Active",+              "  replay-only Empty -- Legacy --> emit LegacyStarted ; goto Active"+            ]+      aggregate <- case [value | NAggregate value <- specNodes spec] of+        [value] -> pure value+        _ -> expectationFailure "expected one transition-layout aggregate" >> fail "unreachable"+      let ctx = defaultContext (specContext spec)+          modules = scaffoldAggregate ctx spec aggregate <> harnessFor ctx spec aggregate+          transducer = generatedTextEndingIn "Transducer.hs" modules+          harness = generatedTextEndingIn "Harness.hs" modules+          contract = generatedTextEndingIn "BehaviorContract.hs" modules+      T.count "B.from JourneyEmpty do" transducer `shouldBe` 1+      transducer `shouldSatisfy` T.isInfixOf "transition3EmptyStart"+      transducer `shouldSatisfy` T.isInfixOf "transition5EmptyLegacy"+      T.count "acceptStart :: Bool" harness `shouldBe` 1+      harness `shouldSatisfy` (not . T.isInfixOf "acceptLegacy")+      contract `shouldSatisfy` T.isInfixOf "K.EdgeRef JourneyEmpty 1"+      contract `shouldSatisfy` T.isInfixOf "K.EdgeRef JourneyEmpty 2"++    it "refuses duplicate live initial harness helpers with both source locations" $ do+      spec <-+        parseInlineSpec "<initial-helper-collision>" $+          T.unlines+            [ "language keiro-dsl 4",+              "context helper-collision",+              "aggregate Journey",+              "  regs",+              "  states Empty Active",+              "  command Start { current:Bool }",+              "  event Started = fields(Start)",+              "  Empty -- Start --> guard cmd.current == true ; emit Started ; goto Active",+              "  Empty -- Start --> guard cmd.current == false ; emit Started ; goto Active"+            ]+      let collisions = [diagnostic | diagnostic <- validateSpec spec, code diagnostic == GeneratedOccurrenceCollision]+      map line collisions `shouldBe` [9, 9]+      collisions `shouldSatisfy` all (elem (8, "'Start' also normalizes here") . relatedLocations)++    it "inventories generated harness sample constants before rendering" $ do+      service <-+        checkedServiceFromText+          "<sample-helper-collision>"+          ( T.unlines+              [ "language keiro-dsl 4",+                "context helper-collision",+                "id ObservedAt prefix=obs",+                "aggregate Journey",+                "  regs",+                "  states Empty",+                "  command Start {",+                "    request:ObservedAt",+                "    observedAt:Time",+                "  }"+              ]+          )+      let collisions = [diagnostic | diagnostic <- validateService service, code diagnostic == GeneratedOccurrenceCollision]+      map line collisions `shouldBe` [9]+      collisions `shouldSatisfy` all (elem (3, "'ObservedAt' also normalizes here") . relatedLocations)++    it "inventories every live-reachable cell, guarded edge, terminal rejection, and replay edge" $ do+      spec <- specOf "test/fixtures/behavior-complete.keiro"+      requirements <- either (\errors -> expectationFailure (show errors) >> pure []) pure (Behavior.deriveBehaviorRequirements spec)+      length requirements `shouldBe` 19+      length [() | requirement <- requirements, Behavior.requirementKind requirement == Behavior.LiveTransition] `shouldBe` 5+      length [() | requirement <- requirements, Behavior.requirementKind requirement == Behavior.RequiredRejection] `shouldBe` 11+      length [() | requirement <- requirements, Behavior.requirementKind requirement == Behavior.ReplayTransition] `shouldBe` 3+      [Behavior.requirementSource requirement | requirement <- requirements, Behavior.requirementKind requirement == Behavior.RequiredRejection]+        `shouldContain` ["Active", "Closed"]+      length [() | requirement <- requirements, Behavior.requirementGuardCoverage requirement == Behavior.GuardTotal] `shouldBe` 3+      length [() | requirement <- requirements, Behavior.requirementGuardCoverage requirement == Behavior.GuardUnknown] `shouldBe` 2+      let report = Behavior.BehaviorObligationsReport "behavior-complete.keiro" Nothing requirements+          encoded = Behavior.encodeBehaviorObligationsJson report+          rendered = Behavior.renderBehaviorObligationsText report+      encoded `shouldSatisfy` T.isInfixOf "\"schema\":\"keiro-dsl/behavior-obligations/1\""+      encoded `shouldSatisfy` T.isInfixOf "\"source\":\"Closed\""+      encoded `shouldSatisfy` T.isInfixOf "\"kind\":\"replay-transition\""+      encoded `shouldSatisfy` T.isInfixOf "\"quality\":\"line-only\""+      rendered `shouldSatisfy` T.isInfixOf "[location-quality=line-only]"+      encoded `shouldSatisfy` (not . T.isInfixOf "\"filled\"")+      encoded `shouldSatisfy` (not . T.isInfixOf "\"missing\"")++    it "keeps semantic keys stable across line movement and canonical pretty printing" $ do+      source <- readTestText "test/fixtures/behavior-complete.keiro"+      parsed <- case parseSource "behavior-complete.keiro" source of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      let original = parsedSpec parsed+      moved <- parseInlineSpec "behavior-complete-moved.keiro" ("# line movement must not rename witnesses\n\n" <> source)+      pretty <- parseInlineSpec "behavior-complete-pretty.keiro" (renderSource parsed)+      let keys spec = fmap (map Behavior.requirementKey) (Behavior.deriveBehaviorRequirements spec)+      keys moved `shouldBe` keys original+      keys pretty `shouldBe` keys original++    it "generates direct fields(Command) output and separate create-once pending witnesses" $ do+      service <- checkedServiceOf "test/fixtures/behavior-complete.keiro"+      let spec = checkedSpec service+      aggregate <- case [value | NAggregate value <- specNodes spec] of+        [value] -> pure value+        _ -> expectationFailure "expected one behavior-complete aggregate" >> fail "unreachable"+      let ctx = defaultContext (specContext spec)+          modules = scaffoldAggregate ctx spec aggregate+          harness = generatedTextEndingIn "Harness.hs" (harnessForService ctx service aggregate)+          transducer = generatedTextEndingIn "Transducer.hs" modules+          codec = generatedTextEndingIn "Codec.hs" modules+          contract = generatedTextEndingIn "BehaviorContract.hs" modules+          projection = generatedTextEndingIn "Projection.hs" modules+          behaviorHoles = case [moduleText value | value <- modules, T.isSuffixOf "BehaviorHoles.hs" (T.pack (modulePath value))] of+            [value] -> value+            values -> error ("expected one BehaviorHoles module, got " <> show (length values))+          ordinaryHoles = [value | value <- modules, T.isSuffixOf "/Holes.hs" (T.pack (modulePath value)), not (T.isSuffixOf "BehaviorHoles.hs" (T.pack (modulePath value)))]+      transducer `shouldSatisfy` T.isInfixOf "requestId = d.requestId"+      transducer `shouldSatisfy` T.isInfixOf "observedAt = d.observedAt"+      transducer `shouldSatisfy` T.isInfixOf "amount = d.amount"+      transducer `shouldSatisfy` T.isInfixOf "details = d.details"+      codec `shouldSatisfy` T.isInfixOf "display_label"+      codec `shouldSatisfy` T.isInfixOf "optional_note"+      transducer `shouldSatisfy` (not . T.isInfixOf "Output")+      ordinaryHoles `shouldBe` []+      obsoleteGeneratedOutputHooks spec `shouldContain` [("Journey", "transition1EmptyStartOutput1Started")]+      T.count "B.from JourneyEmpty do" transducer `shouldBe` 1+      transducer `shouldSatisfy` T.isInfixOf "verifyTransition \"transition3EmptyStart\" GeneratedOwned JourneyEmpty 1"+      transducer `shouldSatisfy` T.isInfixOf "verifyTransition \"transition5EmptyLegacyStart\" GeneratedOwned JourneyEmpty 2"+      T.count "acceptStart :: Bool" harness `shouldBe` 1+      harness `shouldSatisfy` (not . T.isInfixOf "acceptLegacyStart")+      contract `shouldSatisfy` T.isInfixOf "keiro/behavior-conformance/1"+      contract `shouldSatisfy` T.isInfixOf "commandKind command == requirementCommandName requirement"+      contract `shouldSatisfy` (not . T.isInfixOf "OPTIONS_GHC")+      contract `shouldSatisfy` T.isInfixOf "module Generated.BehaviorComplete.Journey.BehaviorContract\n  ( BehaviorKey (..)"+      contract `shouldSatisfy` T.isInfixOf "runRejection :: BehaviorRequirement"+      contract `shouldSatisfy` T.isInfixOf "failureSubject :: !Text"+      contract `shouldSatisfy` T.isInfixOf "\"subject\" .= failureSubject behaviorFailure"+      contract `shouldSatisfy` T.isInfixOf "-- JourneyEmpty x Start: live transition"+      contract `shouldSatisfy` (not . T.isInfixOf "spec line")+      contract `shouldSatisfy` T.isInfixOf "requirementKey = BehaviorKey \"behavior-v1-"+      contract `shouldSatisfy` T.isInfixOf "requirementCommandName = \"Start\""+      contract `shouldSatisfy` T.isInfixOf "requirementExpectedEdge = (Just (K.EdgeRef JourneyEmpty 1))"+      contract `shouldSatisfy` T.isInfixOf "requirementCommandName = \"LegacyStart\""+      contract `shouldSatisfy` T.isInfixOf "requirementExpectedEdge = (Just (K.EdgeRef JourneyEmpty 2))"+      contract `shouldSatisfy` T.isInfixOf "runtime event values differ from the exact witness expectation; actual="+      T.count "Pending (BehaviorKey " behaviorHoles `shouldBe` 19+      behaviorHoles `shouldSatisfy` T.isInfixOf "-- JourneyEmpty x Start: live transition"+      behaviorHoles `shouldSatisfy` (not . T.isInfixOf "spec line")+      behaviorHoles `shouldSatisfy` (not . T.isInfixOf "undefined")+      behaviorHoles `shouldSatisfy` (not . T.isInfixOf "error")+      T.count "sampleRequestId :: RequestId" harness `shouldBe` 1+      T.count "sampleObservedAt :: UTCTime" harness `shouldBe` 1+      harness `shouldSatisfy` T.isInfixOf "Left problem -> error (show problem)"+      harness `shouldSatisfy` T.isInfixOf "sampleEventStarted = Started (StartedData sampleRequestId sampleObservedAt"+      harness `shouldSatisfy` T.isInfixOf "case step journeyTransducer (JourneyEmpty, initialJourneyRegs) (Start (StartData"+      harness `shouldSatisfy` T.isInfixOf "-- clock-free: spec samples no wall clock (verified at scaffold time)"+      harness `shouldSatisfy` (not . T.isInfixOf "(\"clock-free: spec samples no wall clock\", True)")+      codec `shouldSatisfy` T.isInfixOf "parseOptionalField (pure Nothing) (\\value -> case value of Null -> pure Nothing; other -> Just <$> parseJSON other) objectValue \"optional_note\""+      T.count "parseOptionalField ::" codec `shouldBe` 1+      projection `shouldSatisfy` T.isInfixOf "-- No projection declarations are present; this module keeps the generated manifest inventory total."++    it "rejects eventless state or register changes while accepting a true no-op" $ do+      invalid <-+        parseInlineSpec "<eventless-change>" $+          T.unlines+            [ "language keiro-dsl 2",+              "context eventless-change",+              "aggregate Counter",+              "  regs",+              "    count Natural = 0",+              "  states Open Closed!",+              "  command Tick { count:Natural }",+              "  Open -- Tick --> write count := cmd.count ; goto Closed"+            ]+      errorCodes invalid `shouldContain` [AggregateEventlessStateChange]+      valid <-+        parseInlineSpec "<eventless-noop>" $+          T.unlines+            [ "language keiro-dsl 2",+              "context eventless-noop",+              "aggregate Counter",+              "  regs",+              "    count Natural = 0",+              "  states Open",+              "  command Tick { count:Natural }",+              "  event Ticked = fields(Tick)",+              "  Open -- Tick --> goto Open"+            ]+      errorCodes valid `shouldBe` []++    it "refuses duplicate semantic behavior identities before scaffolding" $ do+      duplicate <-+        parseInlineSpec "<duplicate-behavior>" $+          T.unlines+            [ "language keiro-dsl 2",+              "context duplicate-behavior",+              "aggregate Counter",+              "  regs",+              "  states Open",+              "  command Tick { amount:Natural }",+              "  event Ticked = fields(Tick)",+              "  Open -- Tick --> emit Ticked ; goto Open",+              "  Open -- Tick --> emit Ticked ; goto Open"+            ]+      let isBehaviorRefusal (BehaviorRefusal _) = True+          isBehaviorRefusal _ = False+      case planTestScaffold (defaultContext (specContext duplicate)) duplicate of+        Left refusals -> refusals `shouldSatisfy` any isBehaviorRefusal+        Right _ -> expectationFailure "duplicate behavior identity reached a scaffold write set"++    it "round-trips additive single-file and workspace behavior rows with member ownership" $ do+      spec <- specOf "test/fixtures/behavior-complete.keiro"+      requirements <- either (\errors -> expectationFailure (show errors) >> pure []) pure (Behavior.deriveBehaviorRequirements spec)+      version <- maybe (expectationFailure "language version 2 was not constructible" >> fail "unreachable") pure (languageVersion 2)+      let rows = Behavior.behaviorRecordRows requirements+          singleRecord =+            ScaffoldRecord+              { recSpecPath = "behavior-complete.keiro",+                recModuleRoot = "",+                recLayout = "prefixed",+                recSourceLanguage = DeclaredLanguage version noLoc,+                recLanguageContract = effectiveLanguageContract (DeclaredLanguage version noLoc),+                recNamingEdition = IdiomaticNamingV1,+                recModuleRoles = [],+                recFiles = [],+                recMappings = [],+                recIdDomains = [],+                recNominalEqualities = [],+                recBindingObligations = [],+                recBehaviorRequirements = rows,+                recProjectionCatalogFacts = [],+                recQueryContractBaseline = True,+                recQueryContracts = [],+                recRouterSelections = [],+                recSemanticImpact = Nothing+              }+      T.count "behavior " (renderRecord singleRecord) `shouldBe` 19+      parseRecord (renderRecord singleRecord) `shouldBe` Just singleRecord++      workspace <- shouldComposeWorkspace "test/fixtures/behavior-complete-workspace/service.keiro-workspace"+      workspaceRequirements <- either (\errors -> expectationFailure (show errors) >> pure []) pure (Behavior.deriveBehaviorRequirements (wsMergedSpec workspace))+      let ownedRequirements =+            map+              (Behavior.attributeBehaviorOwner (fmap fst . nodeOwner (wsOwnership workspace) "aggregate"))+              workspaceRequirements+          ownedRows = Behavior.behaviorRecordRows ownedRequirements+          workspaceRecord =+            WorkspaceRecord+              { wrService = wsService workspace,+                wrManifest = "service.keiro-workspace",+                wrContext = wsContext workspace,+                wrModuleRoot = "",+                wrLayout = "prefixed",+                wrMembers = map wmPath (wsMembers workspace),+                wrSourceLanguages = [WorkspaceSourceLanguageRow (wmPath member) (wmSourceLanguage member) | member <- wsMembers workspace],+                wrLanguageContract = wsLanguageContract workspace,+                wrNamingEdition = IdiomaticNamingV1,+                wrModules = [],+                wrMappings = [],+                wrIdDomains = [],+                wrNominalEqualities = [],+                wrBindingObligations = [],+                wrBehaviorRequirements = ownedRows,+                wrProjectionCatalogFacts = [],+                wrQueryContractBaseline = True,+                wrQueryContracts = [],+                wrRouterSelections = [],+                wrAdopted = [],+                wrSemanticImpact = Nothing+              }+      map Behavior.behaviorRecordOwner ownedRows `shouldSatisfy` all (== Just "journey.keiro")+      T.count "behavior " (renderWorkspaceRecord workspaceRecord) `shouldBe` 19+      parseWorkspaceRecord (renderWorkspaceRecord workspaceRecord) `shouldBe` Just workspaceRecord++    it "keeps the initial replay fixture byte-identical across single, workspace, and repeat scaffolds" $ do+      withTempDirectory "keiro-dsl-initial-replay-layout" $ \base -> do+        let singleOut = base </> "single"+            workspaceOut = base </> "workspace"+            singleSource = "test/fixtures/behavior-complete.keiro"+            workspaceSource = "test/fixtures/behavior-complete-workspace/service.keiro-workspace"+            journeyModules = filter (T.isPrefixOf "Generated/BehaviorComplete/Journey/" . T.pack . fst)+            behaviorContractPath = "Generated/BehaviorComplete/Journey/BehaviorContract.hs"+            withoutBehaviorContract = filter ((/= behaviorContractPath) . fst)+            present = maybe False (const True)+            normalizeRequirementLines =+              T.unlines+                . map+                  ( \sourceLine ->+                      if "requirementLine =" `T.isInfixOf` sourceLine+                        then fst (T.breakOn "=" sourceLine) <> "= <source-line>"+                        else case T.breakOn "(spec line " sourceLine of+                          (prefix, suffix)+                            | T.null suffix -> sourceLine+                            | otherwise -> prefix <> "(spec line <source-line>)"+                  )+                . T.lines+        (singleCode, singleStdout, singleStderr) <- runKeiroDsl ["scaffold", singleSource, "--out", singleOut]+        unless (singleCode == ExitSuccess) (expectationFailure (singleStdout <> singleStderr))+        singleTree <- treeSnapshot singleOut+        (singleRepeatCode, singleRepeatStdout, singleRepeatStderr) <- runKeiroDsl ["scaffold", singleSource, "--out", singleOut]+        unless (singleRepeatCode == ExitSuccess) (expectationFailure (singleRepeatStdout <> singleRepeatStderr))+        treeSnapshot singleOut `shouldReturn` singleTree+        (workspaceCode, workspaceStdout, workspaceStderr) <- runKeiroDsl ["scaffold", workspaceSource, "--out", workspaceOut]+        unless (workspaceCode == ExitSuccess) (expectationFailure (workspaceStdout <> workspaceStderr))+        workspaceTree <- treeSnapshot workspaceOut+        let singleJourney = journeyModules singleTree+            workspaceJourney = journeyModules workspaceTree+        withoutBehaviorContract workspaceJourney `shouldBe` withoutBehaviorContract singleJourney+        case (lookup behaviorContractPath workspaceJourney, lookup behaviorContractPath singleJourney) of+          (Just workspaceContract, Just singleContract) ->+            normalizeRequirementLines workspaceContract `shouldBe` normalizeRequirementLines singleContract+          (workspaceContract, singleContract) ->+            expectationFailure+              ( "expected both generated behavior contracts, got "+                  <> show (present workspaceContract, present singleContract)+              )+        (workspaceRepeatCode, workspaceRepeatStdout, workspaceRepeatStderr) <- runKeiroDsl ["scaffold", workspaceSource, "--out", workspaceOut]+        unless (workspaceRepeatCode == ExitSuccess) (expectationFailure (workspaceRepeatStdout <> workspaceRepeatStderr))+        treeSnapshot workspaceOut `shouldReturn` workspaceTree++  describe "nominal consumer types" $ do+    it "resolves every category through one checked registry and explains exact obligations" $ do+      spec <- specOf "test/fixtures/nominal-scalars.keiro"+      errorCodes spec `shouldBe` []+      registry <- case resolveNominalTypes spec of+        Left errors -> expectationFailure (show errors) >> fail "unreachable"+        Right value -> pure value+      Map.keys (nominalTypes registry)+        `shouldBe` ["AccountNumber", "FeatureFlag", "ObservedAt", "OrderId", "OrderStatus", "RiskScore", "SequenceNumber"]+      obligations <- either (\errors -> expectationFailure (show errors) >> pure []) pure (bindingObligations spec)+      length obligations `shouldBe` 21+      map obligationCategory obligations `shouldSatisfy` all (`elem` ["nominal-id", "nominal-enum", "nominal-scalar"])+      length [() | obligation <- obligations, obligationEqualityContract obligation /= Nothing] `shouldBe` 2+      renderBindingObligations (specContext spec) obligations `shouldSatisfy` T.isInfixOf "equality-contract:"+      let signatures = map obligationSignature obligations+      forM_+        [ "orderIdBinding :: NominalBinding NominalConformance.Domain.OrderId (KindID \"ord\")",+          "orderStatusBinding :: NominalBinding NominalConformance.Domain.OrderStatus Generated.NominalScalars.Nominal.Shape.OrderStatus.OrderStatusRepresentation",+          "accountNumberBinding :: NominalBinding NominalConformance.Domain.AccountNumber Text",+          "orderIdFixtures :: NominalFixtureCases NominalConformance.Domain.OrderId",+          "initialAccountNumber :: NominalConformance.Domain.AccountNumber"+        ]+        (`shouldSatisfy` (`elem` signatures))+      map obligationCanonicalType obligations `shouldSatisfy` all (/= Nothing)+      let rendered = renderBindingObligations (specContext spec) obligations+      rendered `shouldSatisfy` T.isInfixOf "nominal-id type OrderId"+      rendered `shouldSatisfy` T.isInfixOf "canonical-type: \"nominal.OrderId.v1\""+      case obligations of+        firstObligation : _ ->+          (Aeson.eitherDecode (Aeson.encode firstObligation) :: Either String BindingObligation)+            `shouldBe` Right firstObligation+        [] -> expectationFailure "expected nominal binding obligations"++    it "allocates distinct stable diagnostics for incomplete or incompatible nominal declarations" $ do+      missing <- errorCodesOf "test/fixtures/nominal-missing-facts.keiro"+      missing `shouldBe` replicate 5 NominalMissingIngredient+      errorCodesOf "test/fixtures/nominal-bad-qualified.keiro" `shouldReturn` [NominalInvalidQualifiedName]+      errorCodesOf "test/fixtures/nominal-invalid-prefix.keiro" `shouldReturn` replicate 2 NominalInvalidIdPrefix+      errorCodesOf "test/fixtures/nominal-unsupported-representation.keiro" `shouldReturn` [NominalUnsupportedRepresentation]+      errorCodesOf "test/fixtures/nominal-missing-initial.keiro" `shouldReturn` [NominalMissingInitialValue]+      errorCodesOf "test/fixtures/nominal-name-collision.keiro"+        `shouldReturn` [NominalNameCollision, GeneratedOccurrenceCollision, NominalNameCollision]++    it "keeps v1 rejection at the source-language boundary" $ do+      source <- readTestText "test/fixtures/nominal-v1.keiro"+      case parseSource "nominal-v1.keiro" source of+        Left (SourceLanguageFailure diagnostic) -> sourceLanguageErrorCode diagnostic `shouldBe` LanguageFeatureRequiresVersion+        other -> expectationFailure ("expected source-language refusal, got " <> show other)++    it "scaffolds consumer types, checked codecs, enum representation, projections, and deterministic manifests" $ do+      spec <- specOf "test/fixtures/nominal-scalars.keiro"+      let ctx = defaultContext (specContext spec)+          modules = scaffoldModules ctx spec+          moduleAt path = case [value | value <- modules, modulePath value == path] of+            [value] -> pure value+            values -> expectationFailure ("expected one module at " <> path <> ", got " <> show (map modulePath values)) >> fail "unreachable"+      domainModule <- moduleAt "Generated/NominalScalars/NominalLedger/Domain.hs"+      codecModule <- moduleAt "Generated/NominalScalars/NominalLedger/Codec.hs"+      enumModule <- moduleAt "Generated/NominalScalars/Nominal/Shape/OrderStatus.hs"+      projectionModule <- moduleAt "Generated/NominalScalars/NominalProjections.hs"+      bindingModule <- moduleAt "NominalConformance/Bindings.hs"+      map modulePath modules `shouldNotContain` ["NominalScalars/NominalLedger/Holes.hs"]+      moduleText domainModule `shouldSatisfy` T.isInfixOf "import NominalConformance.Domain (AccountNumber, FeatureFlag, ObservedAt, OrderId, OrderStatus, RiskScore, SequenceNumber)"+      moduleText domainModule `shouldSatisfy` T.isInfixOf "orderId :: !OrderId"+      moduleText domainModule `shouldSatisfy` (not . T.isInfixOf "NominalConformance.Domain.OrderId")+      moduleText domainModule `shouldSatisfy` (not . T.isInfixOf "newtype OrderId")+      moduleText domainModule `shouldSatisfy` (not . T.isInfixOf "data OrderStatus =")+      moduleText codecModule `shouldSatisfy` T.isInfixOf "KindID.parseText @\"ord\""+      moduleText codecModule `shouldSatisfy` T.isInfixOf "KindID.toText (nominalToRepresentation"+      moduleText codecModule `shouldSatisfy` T.isInfixOf "nominalFromRepresentation"+      forM_ ["coerce", "unsafe", "read ", "error "] $ \forbidden ->+        moduleText codecModule `shouldSatisfy` (not . T.isInfixOf forbidden)+      moduleText enumModule `shouldSatisfy` T.isInfixOf "data OrderStatusRepresentation = Draft | Submitted"+      moduleText enumModule `shouldSatisfy` (not . T.isInfixOf "NominalConformance")+      moduleText projectionModule `shouldSatisfy` T.isInfixOf "type FieldOwner AccountNumberNominalProjection = AccountNumber"+      moduleText projectionModule `shouldSatisfy` T.isInfixOf "projectFieldValue _ = nominalToRepresentation Bindings.accountNumberBinding"+      moduleText projectionModule `shouldSatisfy` T.isInfixOf "instance ExactFieldProjection OrderIdEqualityProjection"+      moduleText projectionModule `shouldSatisfy` T.isInfixOf "textProjectionDomain orderIdEqualityPattern"+      moduleText projectionModule `shouldSatisfy` T.isInfixOf "instance ExactFieldProjection OrderStatusEqualityProjection"+      moduleText projectionModule `shouldSatisfy` T.isInfixOf "finiteProjectionDomain (\"draft\" :| [\"submitted\"])"+      kind bindingModule `shouldBe` HoleStub+      moduleText bindingModule `shouldSatisfy` T.isInfixOf "import NominalConformance.Domain (AccountNumber, FeatureFlag, ObservedAt, OrderId, OrderStatus, RiskScore, SequenceNumber)"+      moduleText bindingModule `shouldSatisfy` T.isInfixOf "orderIdBinding :: NominalBinding OrderId (KindID \"ord\")"+      moduleText bindingModule `shouldSatisfy` T.isInfixOf "orderStatusBinding :: NominalBinding OrderStatus ShapeOrderStatus.OrderStatusRepresentation"+      firewallBreaches modules `shouldBe` []+      scaffoldModules ctx spec `shouldBe` modules+      manifestDependencies spec `shouldContain` ["mmzk-typeid", "nominal-conformance"]++    it "persists nominal provenance in a separate forward-compatible row kind" $ do+      spec <- specOf "test/fixtures/nominal-scalars.keiro"+      workspace <- shouldComposeWorkspace canonicalWorkspacePath+      let plan = consumerPlan spec+          record =+            ScaffoldRecord+              { recSpecPath = "nominal-scalars.keiro",+                recModuleRoot = "",+                recLayout = "prefixed",+                recSourceLanguage = LegacyUnversioned,+                recLanguageContract = effectiveLanguageContract LegacyUnversioned,+                recNamingEdition = IdiomaticNamingV1,+                recModuleRoles = [],+                recFiles = [],+                recMappings = consumerMappings plan,+                recIdDomains = [],+                recNominalEqualities = nominalEqualityIdentities spec,+                recBindingObligations = [],+                recBehaviorRequirements = [],+                recProjectionCatalogFacts = [],+                recQueryContractBaseline = True,+                recQueryContracts = [],+                recRouterSelections = [],+                recSemanticImpact = Nothing+              }+          encoded = renderRecord record+          workspaceRecord =+            (sampleWorkspaceRecord workspace)+              { wrMappings = consumerMappings plan+              }+          workspaceEncoded = renderWorkspaceRecord workspaceRecord+      consumerPackages plan `shouldBe` ["nominal-conformance"]+      length [() | NominalMapping {} <- consumerMappings plan] `shouldBe` 7+      T.count "nominal-mapping " encoded `shouldBe` 7+      T.count "nominal-equality " encoded `shouldBe` 2+      T.count "\nmapping " encoded `shouldBe` 0+      parseRecord encoded `shouldBe` Just record+      T.count "nominal-mapping " workspaceEncoded `shouldBe` 7+      T.count "nominal-equality " workspaceEncoded `shouldSatisfy` (>= 2)+      T.count "\nmapping " workspaceEncoded `shouldBe` 0+      parseWorkspaceRecord workspaceEncoded `shouldBe` Just workspaceRecord++    it "reports bound-ID decoder tightening and makes binding provenance replay-visible" $ do+      current <- specOf "test/fixtures/nominal-scalars.keiro"+      let useGeneratedIdInitial (NAggregate aggregate) =+            NAggregate+              aggregate+                { aggRegs =+                    [ if regName register == "orderId"+                        then register {regInitial = RegInitBare "placeholder"}+                        else register+                    | register <- aggRegs aggregate+                    ]+                }+          useGeneratedIdInitial node = node+          unbound =+            current+              { specIds = [declaration {idBinding = Nothing} | declaration <- specIds current],+                specNodes = map useGeneratedIdInitial (specNodes current)+              }+          adoption = diffSpecs unbound current+          decoderFindings = [kindOfChange change | change <- adoption, changeCode change == NominalIdDecoderTightened]+      map ckSubject decoderFindings `shouldContain` ["NominalLedger event NominalsRecorded .orderId"]+      decoderFindings `shouldSatisfy` all ((== VAdvisory) . verdictFor PrivateHistoryRead . ckVector)+      let bumped =+            current+              { specIds =+                  [ declaration+                      { idBinding = fmap (\binding -> binding {nominalBindingVersion = Just "2"}) (idBinding declaration)+                      }+                  | declaration <- specIds current+                  ]+              }+          bindingChanges = diffSpecs current bumped+      map changeCode bindingChanges `shouldContain` [NominalBindingChanged]+      replayImpactSpecs current bumped `shouldSatisfy` \case+        ReplayImpact.ReplayAffected impacts ->+          maybe False (\impact -> Set.member "NominalsRecorded" (ReplayImpact.eventTypes impact) && includeSnapshotStreams impact) (Map.lookup "NominalLedger" impacts)+        ReplayImpact.ReplayNeutral -> False+      case [aggregate | NAggregate aggregate <- specNodes current] of+        aggregate : _ -> do+          aggregateFoldSurface current aggregate `shouldSatisfy` T.isInfixOf "nominal-equality-use:"+          aggregateFoldSurface current aggregate `shouldNotBe` aggregateFoldSurface bumped aggregate+        [] -> expectationFailure "expected nominal aggregate"++  describe "historical codec comparison" $ do+    it "treats object-key order as RFC 8785 parity" $ do+      let historical = object ["z" .= (1 :: Int), "a" .= (2 :: Int)]+          generated = object ["a" .= (2 :: Int), "z" .= (1 :: Int)]+      classifyObservation (EncodeObservation "ordered-object" historical generated)+        `shouldBe` Right JsonParity+    it "classifies an omitted key versus explicit null as version work at that pointer" $ do+      let historical = object []+          generated = object ["description" .= Aeson.Null]+      classifyObservation (EncodeObservation "absent-description" historical generated)+        `shouldBe` Right (RequiresVersionWork (EncodedValueDifference (JsonPointer "/description") historical generated))+    it "classifies generated rejection of a historical value as version work" $+      classifyObservation+        ( DecodeObservation+            "legacy.json"+            (object ["tag" .= ("legacy" :: T.Text)])+            (DecodedShape (object ["tag" .= ("legacy" :: T.Text)]))+            (DecodeFailed "unknown tag")+        )+        `shouldBe` Right (RequiresVersionWork (GeneratedDecodeRejected "unknown tag"))+    it "treats historical-codec rejection as invalid input rather than parity" $+      classifyObservation+        ( DecodeObservation+            "corrupt.json"+            Aeson.Null+            (DecodeFailed "not historical data")+            (DecodeFailed "not generated data")+        )+        `shouldBe` Left (HistoricalCodecRejected "corrupt.json" "not historical data")+    it "reports uncovered union arms separately by corpus origin" $ do+      let canonical = DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical")+          local = DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local_file")+          report = compareReport comparisonProvenance [] [] [canonical, local] [ObservedBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local_file")]+      crCoverageGaps report+        `shouldBe` [CoverageGap HistoricalGolden (JsonPointer "/location") (UnionArm "canonical")]+      reportSucceeded report `shouldBe` False+    it "derives optional, null, and union-arm observations from a generated branch schema" $ do+      let schema =+            BranchRecord+              [ BranchField "description" True (BranchOptional BranchScalar),+                BranchField "location" False (BranchUnion "tag" "contents" [BranchArm "local" (Just BranchScalar), BranchArm "canonical" Nothing])+              ]+          historical = object ["location" .= object ["tag" .= ("canonical" :: T.Text)]]+      observedBranchesFor HistoricalGolden schema historical+        `shouldBe` [ ObservedBranch HistoricalGolden (JsonPointer "/description") OptionalMissing,+                     ObservedBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical")+                   ]+      let declared = declaredBranchesFor HistoricalGolden schema+      forM_+        [ DeclaredBranch HistoricalGolden (JsonPointer "/description") OptionalMissing,+          DeclaredBranch HistoricalGolden (JsonPointer "/description") OptionalPresent,+          DeclaredBranch HistoricalGolden (JsonPointer "/description") ExplicitNull,+          DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local"),+          DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical")+        ]+        (\branch -> declared `shouldContain` [branch])+    it "round-trips the stable machine report" $ do+      let observation = EncodeObservation "parity" (object ["a" .= (1 :: Int)]) (object ["a" .= (1 :: Int)])+          report = compareReport comparisonProvenance [] [observation] [] []+      Aeson.eitherDecode (Aeson.encode report) `shouldBe` Right report+    it "atomically writes and replaces the machine report" $+      withTempDirectory "keiro-dsl-codec-compare" $ \out -> do+        let path = out </> "report.json"+            firstReport = compareReport comparisonProvenance [] [] [] []+            secondReport = compareReport comparisonProvenance [HistoricalGoldenUnreadable "bad.json" "bad JSON"] [] [] []+        writeCompareReportAtomic path firstReport `shouldReturn` Right ()+        Aeson.eitherDecodeFileStrict path `shouldReturn` Right firstReport+        writeCompareReportAtomic path secondReport `shouldReturn` Right ()+        Aeson.eitherDecodeFileStrict path `shouldReturn` Right secondReport++  describe "historical codec comparison scaffold" $ do+    it "emits an opt-in non-production runner without entering the ordinary module registry" $ do+      spec <- specOf "test/fixtures/structural-conformance.keiro"+      let ctx = defaultContext (specContext spec)+          planned = codecComparisonModule ctx spec "ArtifactInfo"+          ordinary = scaffoldModules ctx spec+      case planned of+        Left err -> expectationFailure (T.unpack err)+        Right comparisonModule -> do+          modulePath comparisonModule+            `shouldBe` "Generated/StructuralConformance/Structural/CodecCompare/ArtifactInfo.hs"+          moduleText comparisonModule `shouldSatisfy` T.isInfixOf codecComparisonBanner+          moduleText comparisonModule `shouldSatisfy` T.isInfixOf "Generated.StructuralConformance.ArtifactCatalog.Codec qualified as GeneratedCodec"+          moduleText comparisonModule `shouldSatisfy` T.isInfixOf "branchSchema = BranchRecord"+          map modulePath ordinary `shouldNotContain` [modulePath comparisonModule]+    it "refuses opaque selections rather than upgrading their claim" $ do+      spec <- specOf "test/fixtures/structural-conformance.keiro"+      codecComparisonModule (defaultContext (specContext spec)) spec "VendorGeometry"+        `shouldSatisfy` either (T.isInfixOf "is opaque") (const False)++  describe "structural/opaque coverage reporting" $ do+    it "reports mapped private-event roots and consumer-json register boundaries without a percentage" $ do+      spec <- specOf "test/fixtures/structural-conformance.keiro"+      report <- shouldResolveCoverage "structural-conformance.keiro" spec+      Coverage.privateEventPayloads (Coverage.coverageSummary report)+        `shouldBe` Coverage.CoverageCounts 2 1 1 0+      Coverage.snapshotRegisters (Coverage.coverageSummary report)+        `shouldBe` Coverage.CoverageCounts 2 1 1 0+      map Coverage.opaqueMappedType (Coverage.coverageOpaqueBoundaries report)+        `shouldBe` ["VendorGeometry"]+      map Coverage.snapshotEncoding (Coverage.coverageSnapshotBoundaries report)+        `shouldBe` ["consumer-json-cache", "consumer-json-cache"]+      map Coverage.snapshotInvalidation (Coverage.coverageSnapshotBoundaries report)+        `shouldBe` ["tracked-by-mapped-wire-fingerprint", "tracked-by-mapped-wire-fingerprint"]+      map Coverage.findingCode (Coverage.coverageFindings report)+        `shouldBe` [CoverageOpaqueSurface]+      map Coverage.findingSeverity (Coverage.coverageFindings report)+        `shouldBe` [Warning]+      case Aeson.toJSON report of+        Aeson.Object values ->+          forM_ ["spec", "roots", "opaqueBoundaries", "snapshotBoundaries", "unsupportedSurfaces"] $+            \key -> KeyMap.member key values `shouldBe` True+        value -> expectationFailure ("coverage report was not an object: " <> show value)+    it "reports queue structural and Json boundaries as a separate persisted surface" $ do+      source <- mappedConsumerSurfaceSource+      spec <- parseInlineSpec "<mapped-queue-coverage>" source+      report <- shouldResolveCoverage "mapped-queue.keiro" spec+      Coverage.workqueuePayloads (Coverage.coverageSummary report)+        `shouldBe` Coverage.CoverageCounts 1 1 0 1+      map Coverage.rootPath [root | root <- Coverage.coverageRoots report, Coverage.rootSurface root == Coverage.WorkqueuePayload]+        `shouldBe` ["workqueue ArtifactJobs payload .jobData : ArtifactInfo [] optional"]+      map Coverage.jsonPath [boundary | boundary <- Coverage.coverageJsonBoundaries report, Coverage.jsonSurface boundary == Coverage.WorkqueuePayload]+        `shouldContain` ["workqueue ArtifactJobs payload .jobData : ArtifactInfo [] optional .extra"]+      map Coverage.unsupportedSurface (Coverage.coverageUnsupportedSurfaces report)+        `shouldNotContain` ["queue-payloads"]+    it "reports a built-in-only queue Json expression without fabricating a mapped declaration" $ do+      source <- mappedConsumerSurfaceSource+      spec <-+        parseInlineSpec+          "<explicit-queue-json-coverage>"+          (T.replace "jobData -> \"payload\" : List (Optional ArtifactInfo)" "jobData -> \"payload\" : Optional Json" source)+      report <- shouldResolveCoverage "explicit-queue-json.keiro" spec+      Coverage.workqueuePayloads (Coverage.coverageSummary report)+        `shouldBe` Coverage.CoverageCounts 0 0 0 1+      map Coverage.jsonPath [boundary | boundary <- Coverage.coverageJsonBoundaries report, Coverage.jsonSurface boundary == Coverage.WorkqueuePayload]+        `shouldBe` ["workqueue ArtifactJobs payload .jobData optional"]+    it "reports explicit Json leaves by their complete persisted path" $ do+      spec <- withMetadataJson <$> specOf "test/fixtures/structural-conformance.keiro"+      report <- shouldResolveCoverage "structural-conformance-json.keiro" spec+      Coverage.jsonBoundaries (Coverage.privateEventPayloads (Coverage.coverageSummary report))+        `shouldBe` 1+      map Coverage.jsonPath (Coverage.coverageJsonBoundaries report)+        `shouldBe` ["ArtifactCatalog event ArtifactRecorded .artifact : ArtifactInfo .metadata : ArtifactMetadata .note"]+    it "keeps a zero-opaque spec advisory-free and makes rejection explicitly opt-in" $ do+      original <- specOf "test/fixtures/structural-conformance.keiro"+      clear <- shouldResolveCoverage "structural-only.keiro" (withoutVendorGeometry original)+      Coverage.opaqueRoots (Coverage.privateEventPayloads (Coverage.coverageSummary clear)) `shouldBe` 0+      Coverage.coverageOpaqueBoundaries clear `shouldBe` []+      Coverage.coverageFindings clear `shouldBe` []+      opaque <- shouldResolveCoverage "structural-conformance.keiro" original+      Coverage.coverageSucceeded opaque `shouldBe` True+      let gated = Coverage.failOnOpaque opaque+      Coverage.coverageSucceeded gated `shouldBe` False+      map Coverage.findingCode (Coverage.coverageFindings gated)+        `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueGateExceeded]+      map Coverage.findingSeverity (Coverage.coverageFindings gated)+        `shouldBe` [Warning, Error]+    it "diffs named opaque boundaries and fails only an explicitly gated increase" $ do+      newSpec <- specOf "test/fixtures/structural-conformance.keiro"+      report <- case Coverage.coverageDiffReport "structural-conformance.keiro" "HEAD" (withoutVendorGeometry newSpec) newSpec of+        Left err -> expectationFailure (show err) >> fail "unreachable"+        Right value -> pure value+      fmap Coverage.opaqueBoundaryDelta (Coverage.coverageDelta report) `shouldBe` Just 1+      fmap (map Coverage.opaqueMappedType . Coverage.addedOpaqueBoundaries) (Coverage.coverageDelta report)+        `shouldBe` Just ["VendorGeometry"]+      map Coverage.findingCode (Coverage.coverageFindings report)+        `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueBoundaryAdded]+      Coverage.coverageSucceeded report `shouldBe` True+      let gated = Coverage.failOnOpaqueIncrease report+      Coverage.coverageSucceeded gated `shouldBe` False+      map Coverage.findingCode (Coverage.coverageFindings gated)+        `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueBoundaryAdded, CoverageOpaqueGateExceeded]+    it "appends the six stable coverage and comparison registry codes" $+      map+        show+        [ CoverageOpaqueSurface,+          CoverageOpaqueBoundaryAdded,+          CoverageOpaqueGateExceeded,+          CodecCompareDifference,+          CodecCompareCoverageGap,+          CodecCompareInvalidInput+        ]+        `shouldBe` [ "CoverageOpaqueSurface",+                     "CoverageOpaqueBoundaryAdded",+                     "CoverageOpaqueGateExceeded",+                     "CodecCompareDifference",+                     "CodecCompareCoverageGap",+                     "CodecCompareInvalidInput"+                   ]++  describe "parse . pretty round-trip" $+    do+      it "re-parses any generated spec to an equal AST (modulo source locations)" $+        checkCoverage $+          forAll genSpec $ \s ->+            let families = map nodeTag (specNodes s)+                roundTrip = parseSpec "<gen>" (renderSpec s) === Right s+             in cover 5 (not (null (specMapped s))) "mapped" $+                  foldr (\family -> cover 1 (family `elem` families) family) roundTrip allNodeTags+      it "round-trips an aggregate with no states" $+        parseSpec "<empty-states>" (renderSpec emptyStatesSpec) `shouldBe` Right emptyStatesSpec+      it "separates transition emit clauses from following nodes" $ do+        spec <- parseInlineSpec "<cross-family-boundaries>" crossFamilyBoundarySpec+        case specNodes spec of+          [NAggregate first, NEmit _, NAggregate second, NPgmqDispatch _] -> do+            concatMap tEmits (aggTransitions first) `shouldBe` ["Changed"]+            aggStates second `shouldBe` []+          nodes -> expectationFailure ("unexpected node sequence: " <> show (map nodeTag nodes))++  describe "mapped types (EP-149)" $ do+    it "round-trips the canonical structural and opaque consumer fixture" $ do+      source <- TIO.readFile "test/fixtures/consumer-types.keiro"+      spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source+      parseStableRenderedSpec "<consumer-types-round-trip>" spec `shouldBe` Right spec+      length (specMapped spec) `shouldBe` 4+    it "preserves every missing-value policy, nested type expression, and unit union arm" $ do+      source <- TIO.readFile "test/fixtures/consumer-types.keiro"+      spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source+      let fields = [field | MappedStructural {msShape = ShapeRecord _ _ recordFields} <- specMapped spec, field <- recordFields]+          arms = [arm | MappedStructural {msShape = ShapeUnion _ unionArms} <- specMapped spec, arm <- unionArms]+      [value | field <- fields, Just value <- [wfOnMissing field]]+        `shouldBe` [OmCtor "Guide", OmNull, OmInt 0, OmBool False, OmEmptyList, OmEmptyMap]+      [wfType field | field <- fields, wfHaskell field == "labels"]+        `shouldBe` [TList (TOptional TText)]+      [waCtor arm | arm <- arms, waPayload arm == Nothing]+        `shouldBe` ["Unknown"]+    it "rejects every mapped validation fixture with its stable diagnostic code" $ do+      let cases =+            [ ("mapped-unresolved.keiro", MappedUnresolvedName),+              ("mapped-ambiguous.keiro", MappedAmbiguousName),+              ("mapped-dup-fieldname.keiro", MappedDuplicateFieldName),+              ("mapped-dup-wirekey.keiro", MappedDuplicateWireKey),+              ("mapped-dup-armname.keiro", MappedDuplicateArmName),+              ("mapped-dup-tag.keiro", MappedDuplicateWireTag),+              ("mapped-recursive.keiro", MappedRecursiveType),+              ("mapped-recursive-mutual.keiro", MappedRecursiveType),+              ("mapped-bad-encoding.keiro", MappedUnsupportedEncoding),+              ("mapped-union-key-collision.keiro", MappedUnsupportedEncoding),+              ("mapped-optional-json.keiro", MappedNonInjectiveNullability),+              ("mapped-optional-optional.keiro", MappedNonInjectiveNullability),+              ("mapped-optional-opaque.keiro", MappedNonInjectiveNullability),+              ("mapped-missing-binding.keiro", MappedMissingIngredient),+              ("mapped-missing-binding-version.keiro", MappedMissingIngredient),+              ("mapped-missing-canonical.keiro", MappedMissingIngredient),+              ("mapped-missing-fixture.keiro", MappedMissingIngredient),+              ("mapped-missing-initial.keiro", MappedMissingInitialValue),+              ("mapped-bad-haskell-name.keiro", MappedInvalidHaskellName),+              ("mapped-empty-identity.keiro", MappedInvalidIdentity),+              ("mapped-import-conflict.keiro", MappedImportConflict),+              ("mapped-illtyped-default.keiro", MappedDefaultIllTyped),+              ("mapped-guard.keiro", AggregateExpressionOperatorUnsupported)+            ]+      forM_ cases $ \(fixture, expected) ->+        errorCodesOf ("test/fixtures/" <> fixture) `shouldReturn` [expected]+    it "keeps Time and Natural in Keiki's curated comparison set" $ do+      errorCodesOf "test/fixtures/mapped-guard-time.keiro" `shouldReturn` []+      errorCodesOf "test/fixtures/mapped-guard-natural.keiro" `shouldReturn` []+    it "rejects required defaults, missing optional policies, Int overflow, and negative Natural defaults" $ do+      let invalidFields =+            [ WireField "requiredDefault" "requiredDefault" TText PRequired (Just (OmText "x")) noLoc,+              WireField "missingPolicy" "missingPolicy" TText POptional Nothing noLoc,+              WireField "overflow" "overflow" TInt POptional (Just (OmInt (toInteger (maxBound :: Int) + 1))) noLoc,+              WireField "negativeNatural" "negativeNatural" TNatural POptional (Just (OmInt (-1))) noLoc+            ]+          declaration = completeStructural "Defaults" (ShapeRecord "Defaults" RejectUnknown invalidFields)+      errorCodes (mappedSpec [declaration])+        `shouldBe` [MappedDefaultIllTyped, MappedMissingIngredient, MappedDefaultIllTyped, MappedDefaultIllTyped]++  describe "aggregate type capabilities" $ do+    it "enumerates the policy for every resolved type and use site" $ do+      let resolvedTypes =+            [ AggregateText,+              AggregateInt,+              AggregateBool,+              AggregateTime,+              AggregateNatural,+              AggregateNominal (ResolvedNominalType "EntityId" (IdRepresentation "ent") GeneratedNominal noLoc),+              AggregateNominal (ResolvedNominalType "Status" (EnumRepresentation (("Active", "active") :| [])) GeneratedNominal noLoc),+              AggregateNominal (ResolvedNominalType "Amount" (ScalarRepresentation NominalInt) (consumerNominalFor "Amount") noLoc),+              AggregateNominal (ResolvedNominalType "Label" (ScalarRepresentation NominalText) (consumerNominalFor "Label") noLoc),+              AggregateVertex "EntityVertex",+              AggregateMapped (MappedKey "ConsumerValue")+            ]+          useSites = [minBound .. maxBound]+          expected useSite resolvedType = case useSite of+            OrderingGuardUse -> case resolvedType of+              AggregateInt -> SolverVisible+              AggregateTime -> SolverVisible+              AggregateNatural -> SolverVisible+              AggregateNominal nominal -> case resolvedNominalRepresentation nominal of+                ScalarRepresentation NominalInt -> SolverVisible+                ScalarRepresentation NominalNatural -> SolverVisible+                ScalarRepresentation NominalTime -> SolverVisible+                _ -> Unsupported+              _ -> Unsupported+            EqualityGuardUse -> case resolvedType of+              AggregateMapped {} -> Unsupported+              AggregateNominal {} -> SolverVisible+              AggregateVertex {} -> OpaqueOnly+              _ -> SolverVisible+            _ -> case resolvedType of+              AggregateNominal nominal -> case resolvedNominalRepresentation nominal of+                ScalarRepresentation {} -> SolverVisible+                _ -> OpaqueOnly+              AggregateVertex {} -> OpaqueOnly+              AggregateMapped {} -> OpaqueOnly+              _ -> SolverVisible+          actual =+            [ (useSite, resolvedType, aggregateCapability useSite resolvedType)+            | useSite <- useSites,+              resolvedType <- resolvedTypes+            ]+          wanted =+            [ (useSite, resolvedType, expected useSite resolvedType)+            | useSite <- useSites,+              resolvedType <- resolvedTypes+            ]+      actual `shouldBe` wanted+    it "lowers direct Time and Natural through every generated aggregate boundary" $ do+      spec <- specOf "test/fixtures/aggregate-scalars.keiro"+      errorCodes spec `shouldBe` []+      let aggregate = onlyAggregate spec+          modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate+          generated =+            [ moduleText generatedModule+            | generatedModule <- modules,+              Keiro.Dsl.Scaffold.kind generatedModule == Generated+            ]+          domain = generatedTextEndingIn "Domain.hs" modules+          codec = generatedTextEndingIn "Codec.hs" modules+      domain `shouldSatisfy` T.isInfixOf "observedAt :: !UTCTime"+      domain `shouldSatisfy` T.isInfixOf "revision :: !Natural"+      domain `shouldSatisfy` T.isInfixOf "UTCTime (fromGregorian 2026 1 2) (picosecondsToDiffTime 11045123456789012)"+      domain `shouldSatisfy` T.isInfixOf "import Data.Time.Calendar (fromGregorian)"+      domain `shouldSatisfy` T.isInfixOf "import Data.Time.Clock (UTCTime (..), picosecondsToDiffTime)"+      domain `shouldSatisfy` T.isInfixOf "import Numeric.Natural (Natural)"+      manifestDependencies spec `shouldContain` ["time"]+      manifestDependencies spec `shouldNotContain` ["keiki-codec-json"]+      codec `shouldSatisfy` T.isInfixOf "scalarLedgerEventTypes :: NonEmpty EventType"+      codec `shouldSatisfy` T.isInfixOf "eventTypes = scalarLedgerEventTypes"+      codec `shouldSatisfy` T.isInfixOf "renderExpectedEventTypes scalarLedgerEventTypes"+      codec `shouldSatisfy` (not . T.isInfixOf "; expected one of: ScalarsRecorded\"")+      generated `shouldSatisfy` all (not . T.isInfixOf "error")+      generated `shouldSatisfy` all (not . T.isInfixOf "getCurrentTime")+      generated `shouldSatisfy` all (not . T.isInfixOf "iso8601ParseM")+    it "keeps the event-list binding disjoint from the private formatter" $ do+      source <- readTestText "test/fixtures/aggregate-scalars.keiro"+      spec <- parseInlineSpec "<render-aggregate>" (T.replace "aggregate ScalarLedger" "aggregate Render" source)+      let aggregate = onlyAggregate spec+          modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate+          codec = generatedTextEndingIn "Codec.hs" modules+          codecLines = T.lines codec+      codecLines `shouldContain` ["renderEventTypes :: NonEmpty EventType"]+      codecLines `shouldContain` ["renderExpectedEventTypes :: NonEmpty EventType -> String"]+      codec `shouldSatisfy` T.isInfixOf "eventTypes = renderEventTypes"+      codec `shouldSatisfy` T.isInfixOf "renderExpectedEventTypes renderEventTypes"+    it "canonicalizes Time and UTCTime across pretty, diff, and fold identity" $ do+      source <- readTestText "test/fixtures/aggregate-scalars.keiro"+      canonical <- parseInlineSpec "<time>" source+      alias <- parseInlineSpec "<utctime>" (T.replace ":Time" ":UTCTime" (T.replace " Time =" " UTCTime =" source))+      renderSpec alias `shouldBe` renderSpec canonical+      legacyDiffSpecs canonical alias `shouldBe` []+      legacyAggregateFoldFingerprint canonical (onlyAggregate canonical)+        `shouldBe` legacyAggregateFoldFingerprint alias (onlyAggregate alias)+      legacyAggregateFoldSurface canonical (onlyAggregate canonical)+        `shouldBe` legacyAggregateFoldSurface alias (onlyAggregate alias)+    it "keeps the committed scalar conformance generated tree fresh" $ do+      modules <- scaffoldFixture "test/fixtures/aggregate-scalars.keiro"+      forM_ [generatedModule | generatedModule <- modules, Keiro.Dsl.Scaffold.kind generatedModule == Generated] $ \generatedModule -> do+        committed <- readTestText ("test/conformance-aggregate-scalars/" <> modulePath generatedModule)+        normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText generatedModule)+    it "never sends a clean scalar aggregate to a type scaffold refusal" $+      property $+        forAll (elements scalarRegisterCases) $ \(typeName, initialValue) ->+          case parseSpec "<clean-scalar>" (cleanScalarAggregateSpec typeName initialValue) of+            Left parseError -> counterexample (T.unpack parseError) False+            Right spec ->+              let diagnostics = [diagnostic | diagnostic <- validateSpec spec, severity diagnostic == Error]+                  modules = scaffoldModules (defaultContext (specContext spec)) spec+               in counterexample+                    (show diagnostics <> "\n" <> show (scaffoldRefusals spec))+                    ( null diagnostics+                        && null (scaffoldRefusals spec)+                        && all (not . T.null . moduleText) modules+                    )++  describe "aggregate scalar diagnostics" $ do+    it "reports unsupported shapes, invalid initials, and mismatched guards at stable lines" $ do+      diagnostics <- diagnosticsOf "test/fixtures/aggregate-scalars-unsupported.keiro"+      [(code diagnostic, line diagnostic) | diagnostic <- diagnostics, severity diagnostic == Error]+        `shouldBe` [ (AggregateRegisterInitialInvalid, 6),+                     (AggregateRegisterInitialInvalid, 7),+                     (AggregateTypeUnsupportedAtUse, 10),+                     (AggregateExpressionOperandTypeMismatch, 14)+                   ]+      map message diagnostics `shouldSatisfy` any (T.isInfixOf "non-negative integral literals")+      map message diagnostics `shouldSatisfy` any (T.isInfixOf "ISO-8601 UTC timestamps")+      map message diagnostics `shouldSatisfy` any (T.isInfixOf "mapped structural declaration")+    it "accepts Natural aggregate arithmetic in the stable language" $ do+      diagnostics <- diagnosticsOf "test/fixtures/aggregate-scalars-arithmetic.keiro"+      [(code diagnostic, line diagnostic) | diagnostic <- diagnostics, severity diagnostic == Error]+        `shouldBe` []+    it "covers unknown, container, fractional, out-of-range, and ordering failures" $ do+      diagnostics <- diagnosticsOf "test/fixtures/aggregate-scalars-invalid-capabilities.keiro"+      [(code diagnostic, line diagnostic) | diagnostic <- diagnostics, severity diagnostic == Error]+        `shouldBe` [ (AggregateRegisterInitialInvalid, 6),+                     (AggregateRegisterInitialInvalid, 7),+                     (AggregateTypeUnknown, 10),+                     (AggregateTypeUnsupportedAtUse, 10),+                     (AggregateTypeUnsupportedAtUse, 10),+                     (AggregateTypeUnsupportedAtUse, 10),+                     (AggregateExpressionOperatorUnsupported, 13)+                   ]+    it "keeps one-member workspace diagnostics identical to the single file" $ do+      direct <- diagnosticsOf "test/fixtures/aggregate-scalars-unsupported.keiro"+      composed <- shouldComposeWorkspace "test/fixtures/aggregate-scalars-workspace/service.keiro-workspace"+      let directErrors =+            [(code diagnostic, line diagnostic, message diagnostic) | diagnostic <- direct, severity diagnostic == Error]+          workspaceErrors =+            [ (wdCode diagnostic, wlLine (NE.head (wdLocations diagnostic)), wdMessage diagnostic)+            | diagnostic <- checkWorkspace composed,+              wdSeverity diagnostic == Error+            ]+      workspaceErrors `shouldBe` directErrors++  describe "mapped type graph (EP-149)" $ do+    it "resolves checked declarations, transitive reachability, and every aggregate root path" $ do+      source <- TIO.readFile "test/fixtures/consumer-types.keiro"+      spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source+      graph <- shouldResolveTypeGraph spec+      Map.size (tgDeclarations graph) `shouldBe` 4+      Map.lookup (MappedKey "ArtifactInfo") (tgReachability graph)+        `shouldBe` Just (Set.fromList [MappedKey "ArtifactKind", MappedKey "ArtifactLocation"])+      map renderUsePath (usePaths graph "ArtifactLocation")+        `shouldBe` [ "Catalog command ObserveArtifact .artifact : ArtifactInfo .location : ArtifactLocation",+                     "Catalog event ArtifactObserved .artifact : ArtifactInfo .location : ArtifactLocation",+                     "Catalog register currentArtifact : ArtifactInfo .location : ArtifactLocation"+                   ]+    it "resolves every builtin through the complete expression algebra" $ do+      source <- TIO.readFile "test/fixtures/consumer-types.keiro"+      spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source+      graph <- shouldResolveTypeGraph spec+      case Map.lookup (MappedKey "ArtifactInfo") (tgDeclarations graph) of+        Just (ResolvedStructural _ (RRecord _ _ fields)) ->+          Set.fromList (concatMap (foldTypeExpr expressionTags . rwfType) fields)+            `shouldBe` Set.fromList ["text", "int", "bool", "natural", "time", "json", "optional", "list", "map", "ref:ArtifactKind", "ref:ArtifactLocation"]+        declaration -> expectationFailure ("unexpected ArtifactInfo declaration: " <> show declaration)+    it "rejects direct, mutual, wrapped, and union-arm recursion" $ do+      let direct = mappedSpec [completeStructural "A" (recordShape [TRef "A"])]+          mutual = mappedSpec [completeStructural "A" (recordShape [TRef "B"]), completeStructural "B" (recordShape [TRef "A"])]+          wrapped = mappedSpec [completeStructural "A" (recordShape [TList (TOptional (TRef "A"))])]+          throughArm = mappedSpec [completeStructural "A" (ShapeUnion (TaggedObject "tag" "contents" RejectUnknown) [WireArm "Again" "again" (Just (TRef "A")) noLoc])]+      map (hasTypeGraphError isRecursive . resolveTypeGraph) [direct, mutual, wrapped, throughArm]+        `shouldBe` replicate 4 True+    it "keeps existing ids and enums outside the mapped-reference namespace" $ do+      let spec =+            (mappedSpec [completeStructural "A" (recordShape [TRef "ExistingId"])])+              { specIds = [IdDecl "ExistingId" "id" Nothing noLoc]+              }+      resolveTypeGraph spec `shouldSatisfy` hasTypeGraphError isUnresolved+    it "fingerprints wire identity while ignoring Haskell selector names" $ do+      source <- TIO.readFile "test/fixtures/consumer-types.keiro"+      base <- parseInlineSpec "test/fixtures/consumer-types.keiro" source+      baseGraph <- shouldResolveTypeGraph base+      haskellRenameGraph <- shouldResolveTypeGraph (mapArtifactField (\field -> field {wfHaskell = "renamedKey"}) base)+      wireRenameGraph <- shouldResolveTypeGraph (mapArtifactField (\field -> field {wfKey = "renamed_key"}) base)+      wireFingerprint haskellRenameGraph "ArtifactInfo" `shouldBe` wireFingerprint baseGraph "ArtifactInfo"+      wireFingerprint wireRenameGraph "ArtifactInfo" `shouldNotBe` wireFingerprint baseGraph "ArtifactInfo"++  describe "semantic impact" $ do+    it "derives local aggregate closures and a complete service inventory" $ do+      source <- readTestText "test/fixtures/semantic-impact.keiro"+      spec <- parseInlineSpec "test/fixtures/semantic-impact.keiro" source+      graph <- shouldResolveTypeGraph spec+      let impact = semanticImpact graph+      aggregateMappedClosure impact "Alpha"+        `shouldBe` map MappedKey ["CommandPayload", "EventPayload", "NestedPayload", "RegisterPayload", "SharedPayload"]+      aggregateMappedClosure impact "Beta"+        `shouldBe` [MappedKey "SharedPayload"]+      mappedDeclarationConsumers impact (MappedKey "NestedPayload")+        `shouldBe` [AggregateConsumer "Alpha"]+      mappedDeclarationConsumers impact (MappedKey "SharedPayload")+        `shouldBe` [AggregateConsumer "Alpha", AggregateConsumer "Beta"]+      mappedDeclarationConsumers impact (MappedKey "UnusedPayload")+        `shouldBe` []+      Map.lookup (MappedKey "UnusedPayload") (impactDeclarationConsumers impact)+        `shouldBe` Just Set.empty+      serviceMappedInventory impact+        `shouldBe` map MappedKey ["CommandPayload", "EventPayload", "NestedPayload", "RegisterPayload", "SharedPayload", "UnusedPayload"]+    it "folds command, private-event, and register roots explicitly" $ do+      source <- readTestText "test/fixtures/semantic-impact.keiro"+      spec <- parseInlineSpec "test/fixtures/semantic-impact.keiro" source+      impact <- semanticImpact <$> shouldResolveTypeGraph spec+      map mappedRootKind (aggregateMappedRoots impact "Alpha")+        `shouldBe` [MappedCommandFieldRoot, MappedCommandFieldRoot, MappedEventFieldRoot, MappedRegisterRoot]+      map mappedRootKind (aggregateMappedRoots impact "Beta")+        `shouldBe` [MappedRegisterRoot]+    it "is independent of declaration and aggregate traversal order" $ do+      source <- readTestText "test/fixtures/semantic-impact.keiro"+      spec <- parseInlineSpec "test/fixtures/semantic-impact.keiro" source+      baseline <- semanticImpact <$> shouldResolveTypeGraph spec+      reordered <-+        semanticImpact+          <$> shouldResolveTypeGraph+            spec+              { specMapped = reverse (specMapped spec),+                specNodes = reverse (specNodes spec)+              }+      reordered `shouldBe` baseline+    it "keeps future UseSite roots behind an exhaustive compile-time fold" $ do+      source <- readTestText "src/Keiro/Dsl/SemanticImpact.hs"+      source `shouldSatisfy` T.isInfixOf "{-# OPTIONS_GHC -Werror=incomplete-patterns #-}"+      map+        (`T.isInfixOf` source)+        [ "mappedRootFromUseSite site@(RootCommandField",+          "mappedRootFromUseSite site@(RootEventField",+          "mappedRootFromUseSite site@(RootRegister",+          "mappedRootFromUseSite site@(RootWorkqueueField",+          "mappedRootFromUseSite site@(RootReadModelQueryInput",+          "mappedRootFromUseSite site@(RootReadModelQueryResult"+        ]+        `shouldBe` replicate 6 True+      source `shouldSatisfy` (not . T.isInfixOf "mappedRootFromUseSite _")+    it "round-trips canonical snapshots and reports only checked consumer membership changes" $ do+      spec <- specOf "test/fixtures/semantic-impact.keiro"+      snapshot <- semanticImpactSnapshot . semanticImpact <$> shouldResolveTypeGraph spec+      Aeson.decode (Aeson.encode snapshot) `shouldBe` Just snapshot+      let shared = MappedKey "SharedPayload"+          changed =+            snapshot+              { snapshotMappedConsumers =+                  Map.adjust (Set.delete (AggregateConsumer "Beta")) shared (snapshotMappedConsumers snapshot)+              }+      case diffSemanticImpact snapshot changed of+        [delta] -> do+          impactDeclaration delta `shouldBe` shared+          impactPreviousConsumers delta `shouldBe` Set.fromList [AggregateConsumer "Alpha", AggregateConsumer "Beta"]+          impactCurrentConsumers delta `shouldBe` Set.singleton (AggregateConsumer "Alpha")+          impactServiceConformance delta `shouldBe` True+        deltas -> expectationFailure ("expected one semantic-impact delta, got " <> show deltas)+      case mappedImpactForDeclarations [MappedKey "NestedPayload"] snapshot snapshot of+        [delta] -> do+          impactDeclaration delta `shouldBe` MappedKey "NestedPayload"+          impactPreviousConsumers delta `shouldBe` Set.singleton (AggregateConsumer "Alpha")+          impactCurrentConsumers delta `shouldBe` Set.singleton (AggregateConsumer "Alpha")+          impactPreviousEvidence delta `shouldSatisfy` maybe False (not . Set.null)+          impactCurrentConsequences delta `shouldSatisfy` maybe False (not . Set.null)+        deltas -> expectationFailure ("expected one nested semantic-impact delta, got " <> show deltas)+    it "round-trips additive semantic impact ledger rows and rejects known-row corruption" $ do+      spec <- specOf "test/fixtures/semantic-impact.keiro"+      let snapshot = semanticImpactSnapshotForSpec spec+          singleRecord =+            ScaffoldRecord+              { recSpecPath = "semantic-impact.keiro",+                recModuleRoot = "",+                recLayout = "prefixed",+                recSourceLanguage = LegacyUnversioned,+                recLanguageContract = effectiveLanguageContract LegacyUnversioned,+                recNamingEdition = IdiomaticNamingV1,+                recModuleRoles = [],+                recFiles = [],+                recMappings = [],+                recIdDomains = [],+                recNominalEqualities = [],+                recBindingObligations = [],+                recBehaviorRequirements = [],+                recProjectionCatalogFacts = [],+                recQueryContractBaseline = True,+                recQueryContracts = either (const []) id (queryContractIdentities spec),+                recRouterSelections = [],+                recSemanticImpact = Just snapshot+              }+          encoded = renderRecord singleRecord+          semanticRows = filter ("semantic-impact " `T.isPrefixOf`) (T.lines encoded)+          legacyEncoded = T.unlines (filter (not . T.isPrefixOf "semantic-impact ") (T.lines encoded))+          futureEncoded = T.replace "semantic-impact {" "semantic-impact {\"future\":true," encoded+          emptyIdentitySnapshot =+            snapshot+              { snapshotDeclarationIdentities =+                  Map.adjust (const "") (MappedKey "CommandPayload") (snapshotDeclarationIdentities snapshot)+              }+      length semanticRows `shouldBe` 1+      parseRecord encoded `shouldBe` Just singleRecord+      recSemanticImpact <$> parseRecord legacyEncoded `shouldBe` Just Nothing+      parseRecord futureEncoded `shouldBe` Just singleRecord+      (Aeson.decode (Aeson.encode emptyIdentitySnapshot) :: Maybe SemanticImpactSnapshot) `shouldBe` Nothing+      case semanticRows of+        [row] -> do+          parseRecord (encoded <> row <> "\n") `shouldBe` Nothing+          let duplicateConsumer = T.replace "\"consumers\":[\"Alpha\",\"Beta\"]" "\"consumers\":[\"Alpha\",\"Alpha\"]" encoded+          duplicateConsumer `shouldNotBe` encoded+          parseRecord duplicateConsumer `shouldBe` Nothing+        _ -> expectationFailure "expected exactly one semantic-impact row"+      workspace <- shouldComposeWorkspace canonicalWorkspacePath+      let workspaceRecord = (sampleWorkspaceRecord workspace) {wrSemanticImpact = Just snapshot}+          workspaceEncoded = renderWorkspaceRecord workspaceRecord+      T.count "semantic-impact " workspaceEncoded `shouldBe` 1+      parseWorkspaceRecord workspaceEncoded `shouldBe` Just workspaceRecord+      parseWorkspaceRecord (workspaceEncoded <> "future-row ignored\n") `shouldBe` Just workspaceRecord++  describe "string literal integrity" $ do+    it "parses an escaped emit-map value as exactly one row" $ do+      let src =+            T.unlines+              [ "context svc",+                "",+                "emit e {",+                "  contract c",+                "  topic events",+                "  source \"svc\"",+                "  key thingId",+                "  map status {",+                "    \"a\\\" => Wat \\\"b\" => ThingAccepted",+                "    _ => skip",+                "  }",+                "  messageId derive hole",+                "  idempotencyKey derive hole",+                "}"+              ]+      case parseSpec "<escaped-map>" src of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> case [row | NEmit e <- specNodes spec, row <- emMap e] of+          [row] -> do+            emrValue row `shouldBe` "a\" => Wat \"b"+            emrEvent row `shouldBe` "ThingAccepted"+          rows -> expectationFailure ("expected one emit-map row, got " <> show (length rows))+    it "rejects a raw newline inside a quoted string" $ do+      let src = "context svc\n\ncontract c {\n  schemaVersion 1\n  discriminator kind\n  topic events \"first\nsecond\"\n}\n"+      parseSpec "<raw-newline>" src `shouldSatisfy` leftContains "unescaped newline"+    it "rejects an unknown escape sequence" $ do+      let src = "context svc\n\ncontract c {\n  schemaVersion 1\n  discriminator kind\n  topic events \"bad\\q\"\n}\n"+      parseSpec "<unknown-escape>" src `shouldSatisfy` leftContains "unknown escape"+    it "round-trips adversarial text through topics, emit maps, and quoted bindings" $+      property $+        forAll genAdversarialText $ \t ->+          let spec = escapedSpec t+              rendered = renderSpec spec+           in counterexample (T.unpack rendered) (parseSpec "<escaped-round-trip>" rendered === Right spec)++  describe "partial status maps" $ do+    it "suppresses totality only when the partial marker is present" $ do+      partial <- parseInlineSpec "<partial-status-map>" (statusMapSpec " partial")+      totalSpec <- parseInlineSpec "<total-status-map>" (statusMapSpec "")+      map code (validateSpec partial) `shouldNotContain` [StatusMapNotTotal]+      map code (validateSpec totalSpec) `shouldContain` [StatusMapNotTotal]+      parseSpec "<partial-round-trip>" (renderSpec partial) `shouldBe` Right partial++  describe "positioned parser diagnostics" $ do+    it "rejects a duplicate goto at the second clause" $ do+      err <- parseErrorOf "<duplicate-goto>" duplicateGotoSpec+      err `shouldSatisfy` T.isInfixOf "duplicate goto"+      err `shouldSatisfy` T.isInfixOf "<duplicate-goto>:10:"+    it "rejects duplicate wire and projection blocks at their second occurrences" $ do+      wireErr <- parseErrorOf "<duplicate-wire>" duplicateWireSpec+      wireErr `shouldSatisfy` T.isInfixOf "duplicate wire block"+      wireErr `shouldSatisfy` T.isInfixOf "<duplicate-wire>:8:"+      projectionErr <- parseErrorOf "<duplicate-projection>" duplicateProjectionSpec+      projectionErr `shouldSatisfy` T.isInfixOf "duplicate projection block"+      projectionErr `shouldSatisfy` T.isInfixOf "<duplicate-projection>:9:"+    it "anchors a missing goto on the transition line" $ do+      err <- parseErrorOf "<missing-goto>" missingGotoSpec+      err `shouldSatisfy` T.isInfixOf "missing a goto clause"+      err `shouldSatisfy` T.isInfixOf "<missing-goto>:8:"+    it "stops before a misplaced dispatch-id and expects schedule at its start" $ do+      let src = misplacedDispatchIdSpec+          expectedPosition =+            "<misplaced-dispatch-id>:"+              <> T.pack (show (lineNumberContaining "dispatch-id" src))+              <> ":5:"+      err <- parseErrorOf "<misplaced-dispatch-id>" src+      err `shouldSatisfy` T.isInfixOf "schedule"+      err `shouldSatisfy` T.isInfixOf expectedPosition+    it "keeps a malformed register declaration's equals error" $ do+      err <- parseErrorOf "<malformed-register>" malformedRegisterSpec+      err `shouldSatisfy` T.isInfixOf "expecting '='"++  describe "bounded decimal literals" $ do+    forM_ decimalOverflowSpecs $ \(site, src) ->+      it ("rejects overflow at " <> site) $ do+        err <- parseErrorOf ("<overflow-" <> site <> ">") src+        err `shouldSatisfy` T.isInfixOf ("decimal literal " <> decimalOverflow <> " is out of range")+    it "accepts maxBound without changing its value" $ do+      spec <- parseInlineSpec "<max-bound>" (wireDecimalSpec (T.pack (show (maxBound :: Int))))+      [wireSchemaVersion wire | NAggregate aggregate <- specNodes spec, Just wire <- [aggWire aggregate]]+        `shouldBe` [maxBound]++  describe "identifier hygiene" $ do+    it "normalizes lowercase logical type names and reports generated Haskell keywords at their owning declarations" $ do+      spec <- parseInlineSpec "<identifier-hygiene>" identifierHygieneSpec+      [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic `elem` [IdentUnsafeNormalization, GeneratedOccurrenceReserved]]+        `shouldBe` [(GeneratedOccurrenceReserved, 7)]+    it "rejects generated vertex constructors that collide with event constructors" $ do+      spec <- parseInlineSpec "<vertex-collision>" vertexCollisionSpec+      [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == VertexCtorCollision]+        `shouldBe` [(VertexCtorCollision, 3)]+    it "rejects underscore-leading names whose normalization would erase a word boundary" $ do+      spec <- parseInlineSpec "<underscore-node>" underscoreNodeSpec+      [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == IdentUnsafeNormalization]+        `shouldBe` [(IdentUnsafeNormalization, 3)]+    it "rejects normalized module collisions with both source locations" $ do+      spec <- parseInlineSpec "<normalized-collision>" normalizedCollisionSpec+      case [diagnostic | diagnostic <- validateSpec spec, code diagnostic == GeneratedOccurrenceCollision] of+        [diagnostic] -> do+          line diagnostic `shouldBe` 8+          relatedLocations diagnostic `shouldBe` [(3, "'fooBar' also normalizes here")]+          renderDiagnostic "<normalized-collision>" diagnostic `shouldSatisfy` T.isInfixOf "fooBar"+        diagnostics -> expectationFailure ("expected one normalized collision, got " <> show diagnostics)+    it "validates explicit selectors and detects selector collisions in aggregate and contract records" $ do+      service <-+        checkedServiceFromText+          "<field-selector-validation>"+          ( T.unlines+              [ "language keiro-dsl 4",+                "context aliases",+                "aggregate Order",+                "  regs",+                "  states Open",+                "  command Change {",+                "    first haskell shared:Text",+                "    second haskell shared:Text",+                "    reserved haskell type:Text",+                "    invalid haskell Bad:Text",+                "  }",+                "contract publicOrder {",+                "  schemaVersion 1",+                "  discriminator kind",+                "  topic changes \"orders.v1\"",+                "  event Changed on changes {",+                "    first haskell duplicate: text",+                "    second haskell duplicate: text",+                "  }",+                "}"+              ]+          )+      let diagnostics = validateService service+          selectorCollisions = [diagnostic | diagnostic <- diagnostics, code diagnostic == GeneratedOccurrenceCollision]+      [(code diagnostic, line diagnostic) | diagnostic <- diagnostics, code diagnostic `elem` [GeneratedOccurrenceReserved, IdentUnsafeNormalization]]+        `shouldBe` [(GeneratedOccurrenceReserved, 9), (IdentUnsafeNormalization, 10)]+      map line selectorCollisions `shouldBe` [8, 18]+      map relatedLocations selectorCollisions+        `shouldBe` [ [(7, "'first' also normalizes here")],+                     [(17, "'first' also normalizes here")]+                   ]+    it "rejects empty, duplicate, and envelope-colliding resolved wire keys with field-local evidence" $ do+      service <-+        checkedServiceFromText+          "<field-wire-validation>"+          ( T.unlines+              [ "language keiro-dsl 4",+                "context aliases",+                "aggregate Order",+                "  regs",+                "  states Open",+                "  command Change {",+                "    first as \"same\":Text",+                "    second as \"same\":Text",+                "    empty as \"\":Text",+                "  }",+                "  event Changed { value as \"kind\":Text }",+                "contract publicOrder {",+                "  schemaVersion 1",+                "  discriminator kind",+                "  topic changes \"orders.v1\"",+                "  event Published on changes { value as \"kind\": text }",+                "}"+              ]+          )+      let diagnostics = validateService service+          wireDiagnostics = [diagnostic | diagnostic <- diagnostics, code diagnostic `elem` [FieldWireKeyCollision, FieldWireKeyInvalid]]+      map (\diagnostic -> (code diagnostic, line diagnostic)) wireDiagnostics+        `shouldBe` [ (FieldWireKeyCollision, 8),+                     (FieldWireKeyInvalid, 9),+                     (FieldWireKeyCollision, 11),+                     (FieldWireKeyCollision, 16)+                   ]+      case wireDiagnostics of+        firstDiagnostic : _ -> relatedLocations firstDiagnostic `shouldBe` [(7, "wire key 'same' is first declared here")]+        [] -> expectationFailure "expected resolved wire-key diagnostics"+    -- `family` is a contextual keyword GHC accepts as a term under the+    -- advertised GHC2024 contract, and it is the field mori's project signals+    -- are keyed by. This fixture pins that scenario end to end; before ExecPlan+    -- 199 no test referenced it, so the guarantee was untested.+    it "keeps a reserved-word-adjacent contract field intact from check to codec" $+      withTempDirectory "keiro-dsl-reserved-family" $ \out -> do+        let fixture = "test/fixtures/contract-reserved-family.keiro"+        (checkCode, checkOut, checkErr) <- runKeiroDsl ["check", fixture, "--min-language", "4", "--deny-warnings"]+        unless (checkCode == ExitSuccess) (expectationFailure (checkOut <> checkErr))+        checkOut `shouldBe` "OK\n"+        checkErr `shouldNotContain` "warning["++        (scaffoldCode, scaffoldOut, scaffoldErr) <- runKeiroDsl ["scaffold", fixture, "--out", out]+        unless (scaffoldCode == ExitSuccess) (expectationFailure (scaffoldOut <> scaffoldErr))+        tree <- treeSnapshot out+        case [text | (path, text) <- tree, "Contract.hs" `T.isSuffixOf` T.pack path] of+          codec : _ -> do+            -- The DSL name is the record selector …+            codec `shouldSatisfy` T.isInfixOf "family ::"+            -- … and, unaliased, the wire key is the same bytes.+            codec `shouldSatisfy` T.isInfixOf "\"family\""+            codec `shouldNotSatisfy` T.isInfixOf "family_"+          [] -> expectationFailure ("no generated contract module in " <> show (map fst tree))++    -- An alias exists to preserve a brownfield key the current convention would+    -- reject, so its *style* is deliberately not checked (ADR 0021). What is+    -- checked is that the key can be a key: a trailing space or a control+    -- character ships a permanently mis-keyed public field. See ExecPlan 199.+    it "refuses structurally unusable wire-key aliases without opinionating on style" $ do+      let aliasSpec alias =+            T.unlines+              [ "language keiro-dsl 4",+                "context aliases",+                "aggregate Order",+                "  regs",+                "  states Open",+                "  command Change {",+                "    region as \"" <> alias <> "\":Text",+                "  }"+              ]+          keyDiagnostics source = do+            service <- checkedServiceFromText "<alias-content>" source+            pure [diagnostic | diagnostic <- validateService service, code diagnostic == FieldWireKeyInvalid]++      -- Refused: the wire key is the exact bytes on the wire. Written as the+      -- DSL spells them, so `\\n` here is the source's escape, not Haskell's.+      forM_ ["family ", " family", "family\\n", "fam\\tily", "fam\\rily"] $ \bad -> do+        refused <- keyDiagnostics (aliasSpec bad)+        map code refused `shouldBe` [FieldWireKeyInvalid]+        map line refused `shouldBe` [7]++      -- Accepted: these violate `fields=camelCase` and that is exactly the point+      -- of an alias — the brownfield key is preserved, not corrected.+      forM_ ["region_code", "Region-Code", "REGION.CODE", "r\233gion"] $ \brownfield -> do+        accepted <- keyDiagnostics (aliasSpec brownfield)+        accepted `shouldBe` []++    -- The collision planner must register the selector generation actually+    -- emits. Registering a camelized rendering of the raw name made it claim+    -- `foo_bar` "normalizes to" `fooBar`, which generation never does.+    it "plans field collisions against the emitted selector, not a camelized rendering" $ do+      let recordSpec fields =+            T.unlines+              [ "language keiro-dsl 4",+                "context aliases",+                "aggregate Order",+                "  regs",+                "  states Open",+                "  command Change { " <> fields <> " }"+              ]+          collisionsIn source = do+            service <- checkedServiceFromText "<selector-collision>" source+            pure [diagnostic | diagnostic <- validateService service, code diagnostic == GeneratedOccurrenceCollision]++      -- Distinct emitted selectors: `foo_bar` generates `foo_bar`. It is still+      -- refused, but by the generated-name audit that owns lowerCamelCase — not+      -- by a collision claim naming an unrelated sibling.+      falseCollision <- collisionsIn (recordSpec "foo_bar fooBar")+      falseCollision `shouldBe` []++      -- Two declarations that really do emit one selector still collide.+      realCollision <- collisionsIn (recordSpec "fooBar other haskell fooBar")+      map code realCollision `shouldSatisfy` \codes -> GeneratedOccurrenceCollision `elem` codes++    it "checks copied command selectors in both generated record scopes" $ do+      service <-+        checkedServiceFromText+          "<copied-selector-collision>"+          ( T.unlines+              [ "language keiro-dsl 4",+                "context aliases",+                "aggregate Order",+                "  regs",+                "  states Open",+                "  command Change { first haskell shared:Text second haskell shared:Text }",+                "  event Changed = fields(Change)"+              ]+          )+      [line diagnostic | diagnostic <- validateService service, code diagnostic == GeneratedOccurrenceCollision]+        `shouldBe` [6, 6]+    it "anchors repeated reserved contract fields at their own lines and maps them through workspaces" $ do+      service <-+        checkedServiceFromText+          "domain/member.keiro"+          ( T.unlines+              [ "language keiro-dsl 4",+                "context aliases",+                "contract publicOrder {",+                "  schemaVersion 1",+                "  discriminator kind",+                "  topic changes \"orders.v1\"",+                "  event First on changes { where: text }",+                "  event Second on changes { where: text }",+                "}"+              ]+          )+      [line diagnostic | diagnostic <- validateService service, code diagnostic == GeneratedOccurrenceReserved]+        `shouldBe` [7, 8]+      let workspaceDiagnostics =+            [ diagnostic+            | diagnostic <- checkWorkspace (oneMemberWorkspace "domain/member.keiro" (checkedSpec service)),+              wdCode diagnostic == GeneratedOccurrenceReserved+            ]+          workspaceLocations =+            [ (wlFile location, wlLine location)+            | diagnostic <- workspaceDiagnostics,+              location <- NE.toList (wdLocations diagnostic)+            ]+      workspaceLocations+        `shouldBe` [ (WorkspaceMemberFile "member.keiro", 7),+                     (WorkspaceMemberFile "member.keiro", 8)+                   ]+    it "rejects non-ASCII identifier characters in the parser" $+      parseSpec "<unicode-identifier>" unicodeIdentifierSpec `shouldSatisfy` leftContains "unexpected"++  describe "Haskell.name-audit" $ do+    it "inventories every declaration in a fresh compound-name scaffold" $ do+      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+      let service = legacyCheckedService spec+          ctx = defaultContext (specContext spec)+          modules = scaffoldServiceModules ctx service+      concatMap auditGeneratedHaskell modules `shouldBe` []+    it "rejects underscore module and declaration mutations but ignores literals and comments" $ do+      let mutated =+            ScaffoldModule+              { modulePath = "Generated/IncidentPaging/Service_oncall/Mutation.hs",+                moduleText =+                  T.unlines+                    [ "module Generated.IncidentPaging.Service_oncall.Mutation where",+                      "-- comment_value :: Text",+                      "literalValue = \"string_value\"",+                      "render_eventTypes :: Int",+                      "render_eventTypes = 1"+                    ],+                kind = Generated,+                origin = "test name-audit mutation"+              }+          violations = auditGeneratedHaskell mutated+      violations `shouldSatisfy` any (T.isInfixOf "Service_oncall")+      violations `shouldSatisfy` any (T.isInfixOf "render_eventTypes")+      violations `shouldSatisfy` all (not . T.isInfixOf "comment_value")+      violations `shouldSatisfy` all (not . T.isInfixOf "string_value")+    it "rejects repeated generated signatures before writing" $ do+      let mutated =+            ScaffoldModule+              { modulePath = "Generated/Repeated.hs",+                moduleText =+                  T.unlines+                    [ "module Generated.Repeated where",+                      "sameValue :: Bool",+                      "sameValue = True",+                      "sameValue :: Bool",+                      "sameValue = False"+                    ],+                kind = Generated,+                origin = "test repeated declaration"+              }+      auditGeneratedHaskell mutated `shouldSatisfy` any (T.isInfixOf "repeated top-level type signature 'sameValue'")++  describe "Haskell.name-migration" $ do+    it "pairs a legacy module path with its stable idiomatic artifact" $ do+      let currentModule =+            ScaffoldModule+              { modulePath = "Generated/IncidentPaging/ServiceOncall/ReadModel.hs",+                moduleText = "module Generated.IncidentPaging.ServiceOncall.ReadModel where\n",+                kind = Generated,+                origin = "readmodel service_oncall ReadModel"+              }+      planSourceMoves [(Nothing, Generated, "Generated/IncidentPaging/Service_oncall/ReadModel.hs")] [currentModule]+        `shouldBe` Right+          [ SourceMove+              { moveRole = moduleRole currentModule,+                moveKind = Generated,+                moveOldModule = "Generated.IncidentPaging.Service_oncall.ReadModel",+                moveNewModule = "Generated.IncidentPaging.ServiceOncall.ReadModel",+                moveOldPath = "Generated/IncidentPaging/Service_oncall/ReadModel.hs",+                moveNewPath = "Generated/IncidentPaging/ServiceOncall/ReadModel.hs",+                moveBackupPath = ".keiro-dsl-name-migrations/legacy-v1-to-idiomatic-v1/Generated/IncidentPaging/Service_oncall/ReadModel.hs",+                moveContentDigest = Nothing,+                moveTransformedDigest = Nothing+              }+          ]+    it "rewrites code-token module references while preserving comments and literals" $ do+      let old = "Generated.IncidentPaging.Service_oncall.ReadModel"+          new = "Generated.IncidentPaging.ServiceOncall.ReadModel"+          source =+            T.unlines+              [ "module IncidentPaging.Service_oncall.ReadModelHoles where",+                "import Generated.IncidentPaging.Service_oncall.ReadModel",+                "value = Generated.IncidentPaging.Service_oncall.ReadModel.constructor",+                "-- Generated.IncidentPaging.Service_oncall.ReadModel in a comment",+                "literal = \"Generated.IncidentPaging.Service_oncall.ReadModel\"",+                "character = 'x'",+                "{- outer {- Generated.IncidentPaging.Service_oncall.ReadModel -} comment -}"+              ]+      case rewriteHaskellModuleReferences (Map.singleton old new) source of+        Left err -> expectationFailure (show err)+        Right rewritten -> do+          rewritten `shouldSatisfy` T.isInfixOf "import Generated.IncidentPaging.ServiceOncall.ReadModel"+          rewritten `shouldSatisfy` T.isInfixOf "value = Generated.IncidentPaging.ServiceOncall.ReadModel.constructor"+          rewritten `shouldSatisfy` T.isInfixOf "-- Generated.IncidentPaging.Service_oncall.ReadModel in a comment"+          rewritten `shouldSatisfy` T.isInfixOf "literal = \"Generated.IncidentPaging.Service_oncall.ReadModel\""+          rewritten `shouldSatisfy` T.isInfixOf "{- outer {- Generated.IncidentPaging.Service_oncall.ReadModel -} comment -}"+    it "refuses without mutation, then applies recoverable generated and hole moves" $+      withTempDirectory "keiro-dsl-name-migration" $ \out -> do+        spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+        let service = legacyCheckedService spec+            ctx = defaultContext (specContext spec)+        modules <- case planTestServiceScaffold ctx service of+          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"+          Right planned -> pure planned+        let selected =+              [ scaffoldModule+              | scaffoldModule <- modules,+                any (`T.isSuffixOf` T.pack (modulePath scaffoldModule)) ["ServiceOncall/ReadModel.hs", "ServiceOncall/ReadModelHoles.hs"]+              ]+            legacyPath = T.unpack . T.replace "ServiceOncall" "Service_oncall" . T.pack+            reverseModules =+              Map.fromList+                [ (moduleNameFromPath (modulePath scaffoldModule), moduleNameFromPath (legacyPath (modulePath scaffoldModule)))+                | scaffoldModule <- selected+                ]+        forM_ selected $ \scaffoldModule -> do+          legacyText <- case rewriteHaskellModuleReferences reverseModules (moduleText scaffoldModule) of+            Left err -> expectationFailure (show err) >> fail "unreachable"+            Right source -> pure source+          let oldPath = out </> legacyPath (modulePath scaffoldModule)+              withEvidence+                | kind scaffoldModule == HoleStub =+                    legacyText+                      <> "\n-- Generated.IncidentPaging.Service_oncall.ReadModel remains in this comment\n"+                      <> "migrationLiteral = \"Generated.IncidentPaging.Service_oncall.ReadModel\"\n"+                | otherwise = legacyText+          createDirectoryIfMissing True (takeDirectory oldPath)+          TIO.writeFile oldPath withEvidence+        let legacyRecord =+              ScaffoldRecord+                { recSpecPath = "incident-paging.keiro",+                  recModuleRoot = "",+                  recLayout = "prefixed",+                  recSourceLanguage = LegacyUnversioned,+                  recLanguageContract = effectiveLanguageContract LegacyUnversioned,+                  recNamingEdition = LegacyNamingV1,+                  recModuleRoles = [],+                  recFiles = [(kind scaffoldModule, legacyPath (modulePath scaffoldModule)) | scaffoldModule <- selected],+                  recMappings = [],+                  recIdDomains = [],+                  recNominalEqualities = [],+                  recBindingObligations = [],+                  recBehaviorRequirements = [],+                  recProjectionCatalogFacts = [],+                  recQueryContractBaseline = False,+                  recQueryContracts = [],+                  recRouterSelections = [],+                  recSemanticImpact = Nothing+                }+            recordPath = out </> recordFileName (specContext spec)+        TIO.writeFile recordPath (renderRecord legacyRecord)+        beforeMigration <- treeSnapshot out+        refused <- executeServiceScaffoldWithRuntimePackageAndNameMigrations Nothing False out False "incident-paging.keiro" LegacyUnversioned ctx service modules+        refused `shouldSatisfy` \case+          Left [NameMigrationRequired moves] ->+            length moves == 2+              && all ((/= Nothing) . moveContentDigest) moves+              && all ((/= Nothing) . moveTransformedDigest) moves+          _ -> False+        treeSnapshot out `shouldReturn` beforeMigration+        applied <- executeServiceScaffoldWithRuntimePackageAndNameMigrations Nothing True out False "incident-paging.keiro" LegacyUnversioned ctx service modules+        report <- case applied of+          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"+          Right value -> pure value+        length (reportNameMoves report) `shouldBe` 2+        let newHole = out </> "IncidentPaging/ServiceOncall/ReadModelHoles.hs"+            oldHole = out </> "IncidentPaging/Service_oncall/ReadModelHoles.hs"+            backupHole = out </> ".keiro-dsl-name-migrations/legacy-v1-to-idiomatic-v1/IncidentPaging/Service_oncall/ReadModelHoles.hs"+        doesFileExist oldHole `shouldReturn` False+        doesFileExist newHole `shouldReturn` True+        doesFileExist backupHole `shouldReturn` True+        migratedHole <- TIO.readFile newHole+        migratedHole `shouldSatisfy` T.isInfixOf "module IncidentPaging.ServiceOncall.ReadModelHoles"+        migratedHole `shouldSatisfy` T.isInfixOf "-- Generated.IncidentPaging.Service_oncall.ReadModel remains in this comment"+        migratedHole `shouldSatisfy` T.isInfixOf "migrationLiteral = \"Generated.IncidentPaging.Service_oncall.ReadModel\""+        backupBefore <- TIO.readFile backupHole+        rerun <- executeServiceScaffoldWithRuntimePackageAndNameMigrations Nothing True out False "incident-paging.keiro" LegacyUnversioned ctx service modules+        case rerun of+          Left refusals -> expectationFailure (show refusals)+          Right rerunReport -> reportNameMoves rerunReport `shouldBe` []+        TIO.readFile backupHole `shouldReturn` backupBefore+        -- Recreate the exact crash state after every backup and prepared file+        -- exists but before any destination is installed. A corrupted prepared+        -- file refuses; restoring its digest lets the next run resume.+        preparedSnapshots <- forM selected $ \scaffoldModule -> do+          let newPath = out </> modulePath scaffoldModule+              preparedPath = newPath <> ".keiro-dsl-name-migration-prepared"+          bytes <- TIO.readFile newPath+          renameFile newPath preparedPath+          pure (preparedPath, bytes)+        TIO.writeFile recordPath (renderRecord legacyRecord)+        case preparedSnapshots of+          (firstPrepared, firstBytes) : _ -> TIO.writeFile firstPrepared (firstBytes <> "\ncorrupt")+          [] -> expectationFailure "expected prepared migration sources"+        conflicted <- executeServiceScaffoldWithRuntimePackageAndNameMigrations Nothing True out False "incident-paging.keiro" LegacyUnversioned ctx service modules+        conflicted `shouldSatisfy` \case Left [NameMigrationRefusal messages] -> any (T.isInfixOf "prepared source digest") messages; _ -> False+        forM_ preparedSnapshots (uncurry TIO.writeFile)+        resumed <- executeServiceScaffoldWithRuntimePackageAndNameMigrations Nothing True out False "incident-paging.keiro" LegacyUnversioned ctx service modules+        case resumed of+          Left refusals -> expectationFailure (show refusals)+          Right resumedReport -> length (reportNameMoves resumedReport) `shouldBe` 2+        doesFileExist newHole `shouldReturn` True+        TIO.readFile backupHole `shouldReturn` backupBefore+    it "applies the same move protocol to a two-member workspace without changing ownership" $+      withTempDirectory "keiro-dsl-workspace-name-migration" $ \out -> do+        workspace <- shouldComposeWorkspace canonicalWorkspacePath+        plan <- shouldPlanWorkspaceSpec workspace+        initial <- executeWorkspaceScaffold out False plan+        case initial of+          Left refusals -> expectationFailure (show refusals)+          Right _ -> pure ()+        let recordPath = out </> workspaceRecordFileName (wsService workspace)+        currentRecord <-+          TIO.readFile recordPath >>= \contents ->+            maybe (expectationFailure "fresh workspace record did not parse" >> fail "unreachable") pure (parseWorkspaceRecord contents)+        let selectedRows = [row | row <- wrModules currentRecord, "ProjectActivity" `T.isInfixOf` T.pack (wrmPath row)]+            legacyPath = T.unpack . T.replace "ProjectActivity" "Project_activity" . T.pack+            reverseModules =+              Map.fromList+                [ (moduleNameFromPath (wrmPath row), moduleNameFromPath (legacyPath (wrmPath row)))+                | row <- selectedRows+                ]+        selectedRows `shouldSatisfy` (not . null)+        forM_ selectedRows $ \row -> do+          currentSource <- TIO.readFile (out </> wrmPath row)+          legacySource <- case rewriteHaskellModuleReferences reverseModules currentSource of+            Left err -> expectationFailure (show err) >> fail "unreachable"+            Right source -> pure source+          writeFileWithParents (out </> legacyPath (wrmPath row)) legacySource+          removeFile (out </> wrmPath row)+        let legacyRecord =+              currentRecord+                { wrNamingEdition = LegacyNamingV1,+                  wrModules =+                    [ if row `elem` selectedRows then row {wrmPath = legacyPath (wrmPath row)} else row+                    | row <- wrModules currentRecord+                    ]+                }+            ownersBefore = Map.fromList [(wrmRole row, wrmOwner row) | row <- selectedRows]+        TIO.writeFile recordPath (renderWorkspaceRecord legacyRecord)+        beforeMigration <- treeSnapshot out+        refused <- executeWorkspaceScaffoldWithNameMigrations out False False plan+        refused `shouldSatisfy` \case Left [NameMigrationRequired moves] -> length moves == length selectedRows; _ -> False+        treeSnapshot out `shouldReturn` beforeMigration+        applied <- executeWorkspaceScaffoldWithNameMigrations out False True plan+        report <- case applied of+          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"+          Right value -> pure value+        length (wsrNameMoves report) `shouldBe` length selectedRows+        migratedRecord <-+          TIO.readFile recordPath >>= \contents ->+            maybe (expectationFailure "migrated workspace record did not parse" >> fail "unreachable") pure (parseWorkspaceRecord contents)+        wrNamingEdition migratedRecord `shouldBe` IdiomaticNamingV1+        let migratedRows = [row | row <- wrModules migratedRecord, wrmRole row `Map.member` ownersBefore]+        Map.fromList [(wrmRole row, wrmOwner row) | row <- migratedRows] `shouldBe` ownersBefore+        map wrmPath migratedRows `shouldSatisfy` all (not . T.isInfixOf "Project_activity" . T.pack)+        forM_ selectedRows $ \row -> do+          doesFileExist (out </> legacyPath (wrmPath row)) `shouldReturn` False+          doesFileExist (out </> wrmPath row) `shouldReturn` True+          doesFileExist (out </> ".keiro-dsl-name-migrations/legacy-v1-to-idiomatic-v1" </> legacyPath (wrmPath row)) `shouldReturn` True++  describe "sidecar migration (EP-198)" $ do+    it "refuses old context names, applies lossless moves, preserves stale history, and is idempotent" $+      withTempDirectory "keiro-dsl-sidecar-migration" $ \base -> do+        parsed <- parsedSourceOf "test/fixtures/reservation.keiro"+        let service = checkedSource parsed+            spec = checkedSpec service+            ctx = defaultContext (specContext spec)+            sourceLanguage = parsedSourceLanguage parsed+            plain = base </> "plain"+            migrated = base </> "migrated"+            runAt out apply specPath selected =+              executeServiceScaffoldWithRuntimePackageAndNameMigrations+                Nothing+                apply+                out+                False+                specPath+                sourceLanguage+                ctx+                service+                selected+        modules <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planTestServiceScaffold ctx service)+        _ <- runAt plain False "reservation.keiro" modules >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        _ <- runAt migrated False "reservation.keiro" modules >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        let reduced = drop 1 modules+            currentLedger = contextLedgerFileName (specContext spec)+            currentFragment = contextCabalFragmentFileName (specContext spec)+            oldLedger = legacyContextRecordFileName (specContext spec)+            oldFragment = legacyContextManifestFileName (specContext spec)+        renameFile (migrated </> currentLedger) (migrated </> oldLedger)+        renameFile (migrated </> currentFragment) (migrated </> oldFragment)+        treeBefore <- treeSnapshot migrated+        refused <- runAt migrated False "reservation-reduced.keiro" reduced+        refused `shouldSatisfy` \case+          Left [SidecarMigrationRequired moves] ->+            length moves == 2+              && all ((== RenameSidecar) . sidecarMoveDisposition) moves+          _ -> False+        renderRefusals (either id (const []) refused)+          `shouldSatisfy` any (T.isInfixOf "--apply-name-migrations")+        treeSnapshot migrated `shouldReturn` treeBefore++        baseline <- runAt plain False "reservation-reduced.keiro" reduced >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        applied <- runAt migrated True "reservation-reduced.keiro" reduced >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        map sidecarMoveDisposition (reportSidecarMoves applied) `shouldBe` [RenameSidecar, RenameSidecar]+        reportStale applied `shouldBe` reportStale baseline+        reportPreviousSpecPath applied `shouldBe` Just "reservation.keiro"+        doesFileExist (migrated </> oldLedger) `shouldReturn` False+        doesFileExist (migrated </> oldFragment) `shouldReturn` False+        doesFileExist (migrated </> currentLedger) `shouldReturn` True+        doesFileExist (migrated </> currentFragment) `shouldReturn` True++        rerun <- runAt migrated True "reservation-reduced.keiro" reduced >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        reportSidecarMoves rerun `shouldBe` []++        let duplicateBytes = "legacy duplicate cabal fragment\n"+            backup = migrated </> ".keiro-dsl-name-migrations/sidecar-v1" </> oldFragment+        TIO.writeFile (migrated </> oldFragment) duplicateBytes+        duplicateRefusal <- runAt migrated False "reservation-reduced.keiro" reduced+        duplicateRefusal `shouldSatisfy` \case+          Left [SidecarMigrationRequired [move]] -> sidecarMoveDisposition move == RetireLegacySidecar+          _ -> False+        retired <- runAt migrated True "reservation-reduced.keiro" reduced >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        map sidecarMoveDisposition (reportSidecarMoves retired) `shouldBe` [RetireLegacySidecar]+        doesFileExist (migrated </> oldFragment) `shouldReturn` False+        TIO.readFile backup `shouldReturn` duplicateBytes++  describe "Haskell.name-diff" $ do+    it "classifies a workqueue payload type rename only on consumer-build" $ do+      base <- specOf "test/fixtures/reservation-work.keiro"+      let renamed = mapWorkqueue (\queue -> queue {wqPayloadName = "ReservationJob"}) base+          findings = generatedHaskellNameFindings (diffSpecs base renamed)+      case findings of+        [finding] -> assertGeneratedHaskellNameFinding finding+        values -> expectationFailure ("expected one payload-name finding, got " <> show (length values))+      let workspaceFindings =+            generatedHaskellNameFindings+              (map wcChange (diffWorkspaces (oneMemberWorkspace "queue.keiro" base) (oneMemberWorkspace "queue.keiro" renamed)))+      workspaceFindings `shouldSatisfy` \case [finding] -> isAdvisory finding; _ -> False+      replayImpactSpecs base renamed `shouldBe` ReplayNeutral+    it "pairs a mapped selector rename by unchanged wire key and keeps fold identity stable" $ do+      source <- readTestText "test/fixtures/consumer-types.keiro"+      base <- parseInlineSpec "<mapped-selector-old>" source+      renamed <-+        parseInlineSpec+          "<mapped-selector-new>"+          (T.replace "key         as \"key\"" "artifactKey as \"key\"" source)+      let findings = generatedHaskellNameFindings (diffSpecs base renamed)+      case findings of+        [finding] -> do+          assertGeneratedHaskellNameFinding finding+          ckSubject (kindOfChange finding) `shouldSatisfy` T.isInfixOf "artifactKey"+        values -> expectationFailure ("expected one selector-name finding, got " <> show (length values))+      replayImpactSpecs base renamed `shouldBe` ReplayNeutral+      legacyAggregateFoldFingerprint base (onlyAggregate base)+        `shouldBe` legacyAggregateFoldFingerprint renamed (onlyAggregate renamed)+    it "pairs a workqueue module rename by unchanged explicit runtime facts" $ do+      base <- specOf "test/fixtures/reservation-work.keiro"+      let queueOnly = base {specNodes = [node | node@NWorkqueue {} <- specNodes base]}+          renamed = mapWorkqueue (\queue -> queue {wqName = "reservation_jobs"}) queueOnly+          findings = generatedHaskellNameFindings (diffSpecs queueOnly renamed)+      case findings of+        [finding] -> do+          assertGeneratedHaskellNameFinding finding+          ckFacet (kindOfChange finding) `shouldBe` "workqueue-module"+        values -> expectationFailure ("expected one module-name finding, got " <> show (length values))+      map (ckCode . kindOfChange) (diffSpecs queueOnly renamed) `shouldNotContain` [QueueIdentityChanged]+      replayImpactSpecs queueOnly renamed `shouldBe` ReplayNeutral+    it "emits no finding when edited logical spellings normalize identically" $ do+      base <- specOf "test/fixtures/reservation-work.keiro"+      let queueOnly = base {specNodes = [node | node@NWorkqueue {} <- specNodes base]}+          recased = mapWorkqueue (\queue -> queue {wqName = "reservationWork"}) queueOnly+      generatedHaskellNameFindings (diffSpecs queueOnly recased) `shouldBe` []++  describe "canonical reservation.keiro" $+    it "parses into the expected aggregate shape" $ do+      input <- readTestText "test/fixtures/reservation.keiro"+      case parseSpec "test/fixtures/reservation.keiro" input of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> do+          specContext spec `shouldBe` "hospital-capacity"+          length (specIds spec) `shouldBe` 3+          length (specEnums spec) `shouldBe` 3+          length (specRules spec) `shouldBe` 1+          case specNodes spec of+            [NAggregate a] -> do+              aggName a `shouldBe` "Reservation"+              length (aggStates a) `shouldBe` 6+              length (aggCommands a) `shouldBe` 2+              length (aggEvents a) `shouldBe` 2+              length (aggTransitions a) `shouldBe` 2+              map stTerminal (aggStates a) `shouldBe` [False, False, False, True, True, True]+            other -> expectationFailure ("expected one aggregate node, got " <> show (length other))++  describe "validator" $ do+    it "accepts the canonical reservation.keiro" $ do+      codes <- errorCodesOf "test/fixtures/reservation.keiro"+      codes `shouldBe` []+    it "keeps unrelated aggregate-only specs free of inert-surface warnings" $ do+      codes <- diagnosticCodesOf "test/fixtures/reservation.keiro"+      codes+        `shouldNotContain` [ IntakeBindFlagUnenforced,+                             RmInlineSubscriptionIgnored+                           ]+    it "reports empty aggregates at their declaration under legacy and stable contracts" $ do+      spec <- specOf "test/fixtures/reservation.keiro"+      case [aggregate | NAggregate aggregate <- specNodes spec] of+        aggregate : _ -> do+          let emptyAggregate = aggregate {aggCommands = [], aggEvents = [], aggTransitions = []}+              emptySpec = spec {specNodes = [NAggregate emptyAggregate]}+              expectedLine = unLoc (aggLoc aggregate)+              planningCodes = [GeneratedPathCollision, GeneratedImportCycle, BehaviorDerivationInvalid, ConformanceFactKeyCollision, GeneratedPlanningInvariantViolation]+              expectedMessage =+                "aggregate 'Reservation' declares no commands, no events, and no transitions; scaffold cannot lower an empty aggregate -- declare at least one command, one event, and one transition"+          forM_ [legacyCheckedService emptySpec, stableCheckedService emptySpec] $ \service -> do+            let diagnostics = checkTestServiceDiagnostics Nothing (defaultContext (specContext emptySpec)) service+            [ (severity diagnostic, line diagnostic, message diagnostic)+              | diagnostic <- diagnostics,+                code diagnostic == AggregateEmpty+              ]+              `shouldBe` [(Error, expectedLine, expectedMessage)]+            filter (`elem` planningCodes) (map code diagnostics) `shouldBe` []+          scaffoldRefusals emptySpec `shouldSatisfy` any (T.isPrefixOf "AggregateEmpty:")+        [] -> expectationFailure "reservation fixture has no aggregate"+    it "reports empty contracts at their declaration under legacy and stable contracts" $ do+      spec <- specOf "test/fixtures/contract-v4.keiro"+      case [contract | NContract contract <- specNodes spec] of+        contract : _ -> do+          let emptyContract = contract {ctrEvents = []}+              emptySpec = spec {specNodes = [NContract emptyContract]}+              expectedLine = unLoc (ctrLoc contract)+              planningCodes = [GeneratedPathCollision, GeneratedImportCycle, BehaviorDerivationInvalid, ConformanceFactKeyCollision, GeneratedPlanningInvariantViolation]+              expectedMessage =+                "contract 'emergency' declares no events; scaffold cannot lower an empty contract -- declare at least one event"+          forM_ [legacyCheckedService emptySpec, stableCheckedService emptySpec] $ \service -> do+            let diagnostics = checkTestServiceDiagnostics Nothing (defaultContext (specContext emptySpec)) service+            [ (severity diagnostic, line diagnostic, message diagnostic)+              | diagnostic <- diagnostics,+                code diagnostic == ContractEmpty+              ]+              `shouldBe` [(Error, expectedLine, expectedMessage)]+            filter (`elem` planningCodes) (map code diagnostics) `shouldBe` []+          scaffoldRefusals emptySpec `shouldSatisfy` any (T.isPrefixOf "ContractEmpty:")+        [] -> expectationFailure "contract fixture has no contract"+    it "keeps a check-time error counterpart for every sampled lowering refusal class" $ do+      emitSource <- readTestText "test/fixtures/emit.keiro"+      incompleteBackoff <- parseInlineSpec "<incomplete-backoff-parity>" (T.replace "backoff constant 2s" "backoff exponential 2s" emitSource)+      baseAggregate <- parseInlineSpec "<lowering-parity>" loweringAggregateSpec+      bareTextInitial <- parseInlineSpec "<bare-text-initial-parity>" (T.replace "\"hello world\"" "hello" loweringAggregateSpec)+      unsupportedField <- parseInlineSpec "<unsupported-field-parity>" (T.replace "count:Int" "count:Json" loweringAggregateSpec)+      mappedInitial <- specOf "test/fixtures/mapped-missing-initial.keiro"+      let candidates =+            [ ("incomplete publisher backoff", incompleteBackoff),+              ("invalid register initial", bareTextInitial),+              ("unrepresentable aggregate field", unsupportedField),+              ("missing mapped register initial", mappedInitial)+            ]+      scaffoldRefusals baseAggregate `shouldBe` []+      forM_ candidates $ \(caseLabel, candidate) ->+        unless+          (not (null (scaffoldRefusals candidate)) && any ((== Error) . severity) (validateSpec candidate))+          (expectationFailure (caseLabel <> " did not fail at both check and scaffold planning"))+    it "rejects policy words that generated Haskell cannot lower" $ do+      emitSpec <- specOf "test/fixtures/emit.keiro"+      intakeSpec <- specOf "test/fixtures/intake.keiro"+      let unknownOrdering = mapPublisher (\publisher -> publisher {pubOrdering = "banana"}) emitSpec+          unknownBackoff =+            mapPublisher+              (\publisher -> publisher {pubBackoff = (pubBackoff publisher) {boKind = "banana"}})+              emitSpec+          incompleteBackoff =+            mapPublisher+              (\publisher -> publisher {pubBackoff = BackoffSpec "exponential" "2s" Nothing Nothing})+              emitSpec+          unknownDedupe = mapIntake (\intake -> intake {inkDedupePolicy = "Banana"}) intakeSpec+      errorCodes unknownOrdering `shouldContain` [PublisherOrderingUnknown]+      errorCodes unknownBackoff `shouldContain` [PublisherBackoffInvalid]+      errorCodes incompleteBackoff `shouldContain` [PublisherBackoffInvalid]+      errorCodes unknownDedupe `shouldContain` [IntakeDedupePolicyUnknown]+    it "gates numeric floors on the published stable language-4 contract" $ do+      emitSpec <- specOf "test/fixtures/emit.keiro"+      intakeSpec <- specOf "test/fixtures/intake.keiro"+      readModelSpec <- specOf "test/fixtures/workflow.keiro"+      let zeroContract = mapContract (\contract -> contract {ctrSchemaVersion = 0}) emitSpec+          zeroAttempts = mapPublisher (\publisher -> publisher {pubMaxAttempts = 0}) emitSpec+          zeroDecode = mapIntake (\intake -> intake {inkDecode = (inkDecode intake) {decBodySchemaVersion = 0}}) intakeSpec+          zeroReadModel = modifyReadModel "transferDecision" (\readModel -> readModel {rmVersion = 0}) readModelSpec+          floors =+            [ (zeroContract, ContractSchemaVersionBelowMinimum),+              (zeroAttempts, PublisherMaxAttemptsBelowMinimum),+              (zeroDecode, IntakeDecodeSchemaVersionBelowMinimum),+              (zeroReadModel, ReadModelVersionBelowMinimum)+            ]+      forM_ floors $ \(candidate, expected) -> do+        serviceErrorCodes 3 candidate `shouldNotContain` [expected]+        serviceErrorCodes 4 candidate `shouldContain` [expected]+    it "rejects duplicate declarations whose generated behavior cannot work" $ do+      reservation <- specOf "test/fixtures/reservation.keiro"+      integration <- specOf "test/fixtures/emit.keiro"+      let duplicateCommandField =+            modifyAggregate+              "Reservation"+              (\aggregate -> aggregate {aggCommands = updateFirst (\command -> command {cmdFields = duplicateFirst (cmdFields command)}) (aggCommands aggregate)})+              reservation+          duplicateState = modifyAggregate "Reservation" (\aggregate -> aggregate {aggStates = duplicateFirst (aggStates aggregate)}) reservation+          duplicateTransition =+            modifyAggregate+              "Reservation"+              (\aggregate -> aggregate {aggTransitions = aggTransitions aggregate <> take 1 (reverse (aggTransitions aggregate))})+              reservation+          duplicateContractField =+            mapContract+              (\contract -> contract {ctrEvents = updateFirst (\event -> event {ceFields = duplicateFirst (ceFields event)}) (ctrEvents contract)})+              integration+          duplicateContractEvent = mapContract (\contract -> contract {ctrEvents = duplicateFirst (ctrEvents contract)}) integration+          duplicateTopicAlias = mapContract (\contract -> contract {ctrTopics = duplicateFirst (ctrTopics contract)}) integration+          cases =+            [ (duplicateCommandField, AggregateDuplicateFieldName),+              (duplicateState, AggregateDuplicateState),+              (duplicateTransition, TransitionDuplicateUnguarded),+              (duplicateContractField, ContractDuplicateFieldName),+              (duplicateContractEvent, ContractDuplicateEvent),+              (duplicateTopicAlias, ContractDuplicateTopicAlias)+            ]+      forM_ cases $ \(candidate, expected) -> errorCodes candidate `shouldContain` [expected]+    it "gates ambiguous and silently shadowed duplicate surfaces on language 4" $ do+      reservation <- specOf "test/fixtures/reservation.keiro"+      integration <- specOf "test/fixtures/emit.keiro"+      let duplicateRegister = modifyAggregate "Reservation" (\aggregate -> aggregate {aggRegs = duplicateFirst (aggRegs aggregate)}) reservation+          duplicateNominal = reservation {specIds = duplicateFirst (specIds reservation)}+          duplicateMap = mapEmit (\emitNode -> emitNode {emMap = duplicateFirst (emMap emitNode)}) integration+          shadowDiscriminator =+            mapContract+              ( \contract ->+                  contract+                    { ctrEvents =+                        updateFirst+                          (\event -> event {ceFields = updateFirst (\field -> field {cfName = ctrDiscriminator contract}) (ceFields event)})+                          (ctrEvents contract)+                    }+              )+              integration+          guardedSibling =+            modifyAggregate+              "Reservation"+              ( \aggregate ->+                  aggregate+                    { aggTransitions =+                        aggTransitions aggregate+                          <> [transition {tGuard = Just (EAtom (ABool True))} | transition <- take 1 (reverse (aggTransitions aggregate))]+                    }+              )+              reservation+          cases =+            [ (duplicateRegister, AggregateDuplicateRegister),+              (duplicateNominal, NominalDuplicateDeclaration),+              (duplicateMap, EmitMapDuplicateCase),+              (shadowDiscriminator, ContractFieldShadowsDiscriminator),+              (guardedSibling, TransitionUnguardedSibling)+            ]+      forM_ cases $ \(candidate, expected) -> do+        serviceErrorCodes 3 candidate `shouldNotContain` [expected]+        serviceErrorCodes 4 candidate `shouldContain` [expected]+    it "gates stable identities and external names on language 4" $ do+      workflowSpec <- specOf "test/fixtures/workflow.keiro"+      processSpec <- specOf "test/fixtures/surge-service.keiro"+      routerSpec <- specOf "test/fixtures/transfer-routing.keiro"+      integration <- specOf "test/fixtures/emit.keiro"+      let invalidIdentity = mapWorkflow (\workflow -> workflow {wfStable = ""}) workflowSpec+          duplicateIdentity =+            processSpec+              { specNodes =+                  specNodes processSpec+                    <> [NRouter (router {rtName = "surge-demo"}) | NRouter router <- specNodes routerSpec]+              }+          invalidTopic = mapContract (\contract -> contract {ctrTopics = [(alias, "bad topic") | (alias, _) <- ctrTopics contract]}) integration+          emptyTopic = mapContract (\contract -> contract {ctrTopics = [(alias, "") | (alias, _) <- ctrTopics contract]}) integration+          invalidReadModel = modifyReadModel "transferDecision" (\readModel -> readModel {rmTable = "Bad-Table"}) workflowSpec+          duplicateColumn = modifyReadModel "transferDecision" (\readModel -> readModel {rmColumns = duplicateFirst (rmColumns readModel)}) workflowSpec+          gatedCases =+            [ (invalidIdentity, RuntimeIdentityInvalid),+              (duplicateIdentity, RuntimeIdentityDuplicate),+              (invalidTopic, ContractTopicNameInvalid),+              (invalidReadModel, ReadModelIdentifierInvalid),+              (duplicateColumn, ReadModelDuplicateColumn)+            ]+      forM_ gatedCases $ \(candidate, expected) -> do+        serviceErrorCodes 3 candidate `shouldNotContain` [expected]+        serviceErrorCodes 4 candidate `shouldContain` [expected]+      serviceErrorCodes 3 emptyTopic `shouldContain` [ContractTopicNameInvalid]+      serviceErrorCodes 4 emptyTopic `shouldContain` [ContractTopicNameInvalid]+    it "gates declared integration and wire couplings on language 4" $ do+      intakeSpec <- specOf "test/fixtures/intake.keiro"+      reservation <- specOf "test/fixtures/reservation.keiro"+      let unresolvedBind =+            mapIntake+              (\intake -> intake {inkBinds = updateFirst (\binding -> binding {brField = "ghost"}) (inkBinds intake)})+              intakeSpec+          acceptedEventBind =+            mapIntake+              (\intake -> intake {inkBinds = updateFirst (\binding -> binding {brField = "region"}) (inkBinds intake)})+              intakeSpec+          unresolvedDedupe = mapIntake (\intake -> intake {inkDedupeKey = "ghost"}) intakeSpec+          unknownEnvelope = mapIntake (\intake -> intake {inkDecode = (inkDecode intake) {decEnvelope = "banana policy"}}) intakeSpec+          mismatchedSchema = mapIntake (\intake -> intake {inkDecode = (inkDecode intake) {decBodySchemaVersion = 2}}) intakeSpec+          unresolvedAlias =+            mapContract+              (\contract -> contract {ctrEvents = updateFirst (\event -> event {ceTopic = "ghost"}) (ctrEvents contract)})+              intakeSpec+          unsupportedWire =+            modifyAggregate+              "Reservation"+              (\aggregate -> aggregate {aggWire = fmap (\wire -> wire {wireKind = "banana"}) (aggWire aggregate)})+              reservation+          cases =+            [ (unresolvedBind, IntakeBindUnresolved),+              (unresolvedDedupe, IntakeDedupeKeyUnresolved),+              (unknownEnvelope, IntakeEnvelopePolicyUnknown),+              (mismatchedSchema, IntakeDecodeSchemaVersionMismatch),+              (unresolvedAlias, ContractTopicAliasUnresolved),+              (unsupportedWire, WireClauseUnsupported)+            ]+      forM_ cases $ \(candidate, expected) -> do+        serviceErrorCodes 3 candidate `shouldNotContain` [expected]+        serviceErrorCodes 4 candidate `shouldContain` [expected]+      serviceErrorCodes 4 acceptedEventBind `shouldNotContain` [IntakeBindUnresolved]+    it "gates closed workqueue vocabularies and bounded windows on language 4" $ do+      queueSpec <- specOf "test/fixtures/reservation-work.keiro"+      intakeSpec <- specOf "test/fixtures/intake.keiro"+      emitSpec <- specOf "test/fixtures/emit.keiro"+      processSpec <- specOf "test/fixtures/hospital-surge.keiro"+      let huge = "18446744073709551618s"+          unknownPayload =+            mapWorkqueue+              (\queue -> queue {wqPayload = [if wqfName field == "hospitalId" then field {wqfType = LegacyQueueScalar (QueueOther "numeric")} else field | field <- wqPayload queue]})+              queueSpec+          queueDelay = mapWorkqueue (\queue -> queue {wqDelay = huge}) queueSpec+          queueRetry = mapWorkqueue (\queue -> queue {wqDisposition = updateFirst (\row -> row {wqdAction = IRetry huge}) (wqDisposition queue)}) queueSpec+          intakeRetry = mapIntake (\intake -> intake {inkDisposition = updateFirst (\row -> row {drAction = IRetry huge}) (inkDisposition intake)}) intakeSpec+          publisherBackoff = mapPublisher (\publisher -> publisher {pubBackoff = (pubBackoff publisher) {boWindow = huge}}) emitSpec+          publisherMaximum =+            mapPublisher+              (\publisher -> publisher {pubBackoff = (pubBackoff publisher) {boKind = "exponential", boMax = Just huge, boMultiplier = Just "2"}})+              emitSpec+          processFireAt =+            modifyProcess+              "HospitalSurge"+              (\process -> process {procTimer = (procTimer process) {tmFireAt = (tmFireAt (procTimer process)) {faWindow = huge}}})+              processSpec+          cases =+            [ (unknownPayload, WqPayloadTypeUnknown),+              (queueDelay, WindowOutOfRange),+              (queueRetry, WindowOutOfRange),+              (intakeRetry, WindowOutOfRange),+              (publisherBackoff, WindowOutOfRange),+              (publisherMaximum, WindowOutOfRange),+              (processFireAt, WindowOutOfRange)+            ]+      forM_ cases $ \(candidate, expected) -> do+        serviceErrorCodes 3 candidate `shouldBe` []+        serviceErrorCodes 4 candidate `shouldContain` [expected]+    -- ExecPlan 199: spellings the grammar accepted that no runtime implements.+    -- Each pair asserts both halves of the contract — the divergent spelling+    -- warns at 3 and errors at 4, and the spelling that matches the runtime+    -- stays completely silent, so these are refusals and not blanket noise.+    it "refuses spec surfaces that contradict the runtime, and stays silent on the ones that describe it" $ do+      intakeSpec <- specOf "test/fixtures/intake.keiro"+      processSpec <- specOf "test/fixtures/hospital-surge.keiro"+      routerSpec <- specOf "test/fixtures/transfer-routing.keiro"+      let lenientBody =+            mapIntake (\intake -> intake {inkDecode = (inkDecode intake) {decBodyStrict = False}}) intakeSpec+          unknownHeader =+            mapIntake+              (\intake -> intake {inkBinds = updateFirst (\binding -> binding {brSource = SrcHeader "x-custom"}) (inkBinds intake)})+              intakeSpec+          retryOnAppended =+            modifyProcess+              "HospitalSurge"+              ( \process ->+                  process+                    { procHandle =+                        (procHandle process)+                          { hDispatch =+                              updateFirst+                                (\d -> d {dispDisposition = (dispDisposition d) {onAppended = DRetry}})+                                (hDispatch (procHandle process))+                          }+                    }+              )+              processSpec+          firedNotMine =+            modifyProcess+              "HospitalSurge"+              ( \process ->+                  let timer = procTimer process+                      fire = tmFire timer+                   in process+                        { procTimer =+                            timer {tmFire = fire {fireDisposition = (fireDisposition fire) {notMine = OFired}}}+                        }+              )+              processSpec+          routerRetryOnAppended =+            mapRouter+              (\router -> router {rtDispatch = (rtDispatch router) {rdDisposition = (rdDisposition (rtDispatch router)) {onAppended = DRetry}}})+              routerSpec+          cases =+            [ (lenientBody, DecodeBodyPostureUnsupported),+              (unknownHeader, IntakeBindHeaderUnknown),+              (retryOnAppended, DispatchOnAppendedUnsupported),+              (firedNotMine, TimerNotMineUnsupported),+              (routerRetryOnAppended, DispatchOnAppendedUnsupported)+            ]+      forM_ cases $ \(candidate, expected) -> do+        serviceErrorCodes 3 candidate `shouldNotContain` [expected]+        serviceWarningCodes 3 candidate `shouldContain` [expected]+        serviceErrorCodes 4 candidate `shouldContain` [expected]++      -- The unmutated fixtures spell every one of these the way the runtime+      -- behaves, so language 4 has nothing to say about them.+      let closedCodes =+            [ DecodeBodyPostureUnsupported,+              IntakeBindHeaderUnknown,+              DispatchOnAppendedUnsupported,+              TimerNotMineUnsupported+            ]+      forM_ [intakeSpec, processSpec, routerSpec] $ \accepted -> do+        serviceErrorCodes 4 accepted `shouldNotContain` closedCodes+        serviceWarningCodes 4 accepted `shouldNotContain` closedCodes++    -- ExecPlan 197 parked these three as "explicitly descriptive-only"; ExecPlan+    -- 199 re-adjudicated each against the path it purports to describe and found+    -- a checkable referent in every one.+    it "checks the references the formerly descriptive-only surfaces name" $ do+      processSpec <- specOf "test/fixtures/hospital-surge.keiro"+      dispatchSpec <- specOf "test/fixtures/reservation-work.keiro"+      let unknownStatus =+            modifyProcess+              "HospitalSurge"+              (\process -> process {procTimer = (procTimer process) {tmDecodeUnknown = "Abandoned"}})+              processSpec+          blankDeadLetter =+            modifyProcess+              "HospitalSurge"+              (\process -> process {procTimer = (procTimer process) {tmDeadLetter = "   "}})+              processSpec+          phantomDedupeKey =+            mapPgmqDispatch (\d -> d {pdDedupKey = "ghostKey"}) dispatchSpec+          uppercaseFanout =+            mapPgmqDispatch (\d -> d {pdFanoutBody = "ResolveTransferCandidates"}) dispatchSpec+          cases =+            [ (unknownStatus, TimerDecodeStatusUnknown),+              (blankDeadLetter, TimerDeadLetterTextInvalid),+              (phantomDedupeKey, DispatchReadModelFieldUnknown),+              (uppercaseFanout, PgmqFanoutFunctionInvalid)+            ]+      forM_ cases $ \(candidate, expected) -> do+        serviceErrorCodes 3 candidate `shouldNotContain` [expected]+        serviceWarningCodes 3 candidate `shouldContain` [expected]+        serviceErrorCodes 4 candidate `shouldContain` [expected]++      -- Every timer status the runtime actually stores is accepted.+      forM_ ["Scheduled", "Firing", "Fired", "Cancelled", "Dead"] $ \status ->+        serviceErrorCodes+          4+          (modifyProcess "HospitalSurge" (\p -> p {procTimer = (procTimer p) {tmDecodeUnknown = status}}) processSpec)+          `shouldNotContain` [TimerDecodeStatusUnknown]++      serviceErrorCodes 4 processSpec `shouldNotContain` [TimerDecodeStatusUnknown, TimerDeadLetterTextInvalid]+      serviceErrorCodes 4 dispatchSpec `shouldNotContain` [PgmqFanoutFunctionInvalid]++    it "holds a process dispatch-id line to the same strictness as a router's" $ do+      -- Both lines document a derivation the spec cannot change, but the two+      -- runtimes key on different tuples: Keiro.ProcessManager on+      -- (name, correlationId, sourceEventId, emitIndex) and Keiro.Router on+      -- (name, key, sourceEventId, targetStreamName, occurrence). Before+      -- ExecPlan 199 the process line accepted any strategy and any tuple.+      processSource <- readTestText "test/fixtures/hospital-surge.keiro"+      let processLine = "dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)"+          rejected =+            [ "dispatch-id strategy=md5 from=(name, correlationId, sourceEventId, emitIndex)",+              "dispatch-id strategy=uuidv5 from=(banana)",+              "dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId)",+              -- The router's tuple is not the process's tuple.+              "dispatch-id strategy=uuidv5 from=(name, key, sourceEventId, targetStreamName, occurrence)"+            ]+      processSource `shouldSatisfy` T.isInfixOf processLine+      parseSpec "accepted" processSource `shouldSatisfy` isRight+      forM_ rejected $ \badLine ->+        parseSpec "mutated" (T.replace processLine badLine processSource)+          `shouldSatisfy` isLeft++    it "gates the remaining locally resolvable identity and field surfaces on language 4" $ do+      reservation <- specOf "test/fixtures/reservation.keiro"+      emitSpec <- specOf "test/fixtures/emit.keiro"+      processSpec <- specOf "test/fixtures/hospital-surge.keiro"+      dispatchSpec <- specOf "test/fixtures/reservation-work.keiro"+      readModelSpec <- specOf "test/fixtures/readmodel.keiro"+      let projectionKey = modifyAggregate "Reservation" (\aggregate -> aggregate {aggProjection = fmap (\projection -> projection {projKey = "ghost"}) (aggProjection aggregate)}) reservation+          outboxField = mapPublisher (\publisher -> publisher {pubOutboxField = "ghost"}) emitSpec+          timerIds =+            modifyProcess+              "HospitalSurge"+              ( \process ->+                  let timer = procTimer process+                      fire = tmFire timer+                   in process+                        { procTimer =+                            timer+                              { tmId = (tmId timer) {ideField = "ghostTimerKey"},+                                tmFire = fire {fireFiredEventId = (fireFiredEventId fire) {ideField = "ghostEventKey"}}+                              }+                        }+              )+              processSpec+          sourceKey = mapDispatch (\dispatch -> dispatch {pdSourceKey = "ghost"}) dispatchSpec+          subscriptionIdentity = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmSupply = setLegacySubscription (Just "bad subscription") (rmSupply readModel)}) readModelSpec+          scopeIdentity = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmSupply = setLegacyScope (Just (RmCategory "bad-category")) (rmSupply readModel)}) readModelSpec+          cases =+            [ (projectionKey, AggProjectionKeyUnresolved),+              (outboxField, PublisherOutboxFieldUnresolved),+              (timerIds, TimerIdFieldNotCorrelation),+              (sourceKey, DispatchReadModelFieldUnknown),+              (subscriptionIdentity, RuntimeIdentityInvalid),+              (scopeIdentity, RuntimeIdentityInvalid)+            ]+      forM_ cases $ \(candidate, expected) -> do+        serviceErrorCodes 3 candidate `shouldBe` []+        serviceErrorCodes 4 candidate `shouldContain` [expected]+      length (filter (== TimerIdFieldNotCorrelation) (serviceErrorCodes 4 timerIds)) `shouldBe` 2+      parseStableRenderedSpec "<timer-id-fields>" timerIds `shouldBe` Right timerIds+    it "uses a router-specific code for a confirmed duplicate inversion" $ do+      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+      let changed =+            modifyRouter+              "PagingRouter"+              ( \router ->+                  let dispatch = rtDispatch router+                      disposition = rdDisposition dispatch+                   in router {rtDispatch = dispatch {rdDisposition = disposition {onDuplicate = DAckOk}}}+              )+              spec+          warningCodes = [code diagnostic | diagnostic <- validateSpec changed, severity diagnostic == Warning]+      warningCodes `shouldContain` [RouterBenignInversion]+      warningCodes `shouldNotContain` [ProcessBenignInversion]+    it "pins every emitted legacy single-spec diagnostic that lacked a direct negative test" $ do+      reservation <- specOf "test/fixtures/reservation.keiro"+      intakeSpec <- specOf "test/fixtures/intake.keiro"+      emitSpec <- specOf "test/fixtures/emit.keiro"+      processSpec <- specOf "test/fixtures/surge-service.keiro"+      queueSpec <- specOf "test/fixtures/reservation-work.keiro"+      workflowSpec <- specOf "test/fixtures/workflow.keiro"+      let updateFirstTransition update aggregate = aggregate {aggTransitions = updateFirst update (aggTransitions aggregate)}+          undeclaredEvent = modifyAggregate "Reservation" (updateFirstTransition (\transition -> transition {tEmits = ["GhostEvent"]})) reservation+          undeclaredState = modifyAggregate "Reservation" (updateFirstTransition (\transition -> transition {tGoto = "GhostState"})) reservation+          terminalOutgoing = modifyAggregate "Reservation" (updateFirstTransition (\transition -> transition {tSource = "Expired"})) reservation+          deprecatedEmitted = modifyAggregate "Reservation" (\aggregate -> aggregate {aggEvents = updateFirst (\event -> event {evDeprecated = True}) (aggEvents aggregate)}) reservation+          wireVersionMismatch = modifyAggregate "Reservation" (\aggregate -> aggregate {aggWire = fmap (\wire -> wire {wireSchemaVersion = 2}) (aggWire aggregate)}) reservation+          decodeRetry =+            mapIntake+              ( \intake ->+                  intake+                    { inkDisposition =+                        [ if drOutcome row == "decodeFailed" then row {drAction = IRetry "5s"} else row+                        | row <- inkDisposition intake+                        ]+                    }+              )+              intakeSpec+          unresolvedPublisher = mapPublisher (\publisher -> publisher {pubEmit = "ghost"}) emitSpec+          unresolvedIntake = mapIntake (\intake -> intake {inkContract = "ghost"}) intakeSpec+          unboundedQueue = mapWorkqueue (\queue -> queue {wqMaxRetries = 0}) queueSpec+          unresolvedEnqueue = mapDispatch (\dispatch -> dispatch {pdEnqueueTo = "ghost"}) queueSpec+          unresolvedWorkflow =+            mapOperation+              ( \operation -> case opShape operation of+                  RunOp _ input outcome -> operation {opShape = RunOp "GhostWorkflow" input outcome}+                  _ -> operation+              )+              workflowSpec+          cases =+            [ (undeclaredEvent, UndeclaredEvent),+              (undeclaredState, UndeclaredState),+              (terminalOutgoing, TerminalHasOutgoing),+              (deprecatedEmitted, DeprecatedEventStillEmitted),+              (wireVersionMismatch, WireSchemaVersionMismatch),+              (processSpec, ProcessBenignInversion),+              (decodeRetry, DispositionDecodeUnboundedRetry),+              (unresolvedPublisher, PublisherUnresolvedEmit),+              (unresolvedIntake, IntakeUnresolvedContract),+              (unboundedQueue, WqDlqWithoutCeiling),+              (unresolvedEnqueue, DispatchEnqueueUnresolved),+              (unresolvedWorkflow, RunWorkflowUnresolved)+            ]+      forM_ cases $ \(candidate, expected) -> diagnosticCodes candidate `shouldContain` [expected]+    it "rejects a missing status-map as StatusMapNotTotal" $ do+      codes <- diagnosticCodesOf "test/fixtures/reservation-no-statusmap.keiro"+      codes `shouldContain` [StatusMapNotTotal]+    it "rejects an undeclared command as UndeclaredCommand" $ do+      codes <- diagnosticCodesOf "test/fixtures/reservation-bad-command.keiro"+      codes `shouldContain` [UndeclaredCommand]+    it "rejects a wall-clock guard atom as ClockSampled" $ do+      codes <- diagnosticCodesOf "test/fixtures/reservation-clock.keiro"+      codes `shouldContain` [ClockSampled]+    it "accepts a v2 event with a contiguous upcaster hole" $ do+      codes <- errorCodesOf "test/fixtures/reservation-v2.keiro"+      codes `shouldBe` []+    it "rejects a v2 event with no upcaster as EvtVersionMissingUpcaster" $ do+      codes <- diagnosticCodesOf "test/fixtures/reservation-v2-noupcast.keiro"+      codes `shouldContain` [EvtVersionMissingUpcaster]+    it "accepts shared upcaster sources for different event kinds" $ do+      codes <- errorCodesOf "test/fixtures/reservation-dup-upcast-source.keiro"+      codes `shouldBe` []+    it "rejects a gap in the aggregate-global upcaster chain" $ do+      codes <- errorCodesOf "test/fixtures/reservation-chain-gap.keiro"+      codes `shouldContain` [UpcasterChainGap]+    it "warns while a retiring event keeps its live emitting transition" $ do+      diagnostics <- diagnosticsOf "test/fixtures/reservation-retiring.keiro"+      [code d | d <- diagnostics, severity d == Error] `shouldBe` []+      [code d | d <- diagnostics, severity d == Warning]+        `shouldContain` [EventRetirementInProgress]+    it "rejects a retiring event after its live emitting transition disappears" $ do+      source <- readTestText "test/fixtures/reservation-retiring.keiro"+      spec <- parseInlineSpec "<retiring-without-emitter>" (T.replace "emit TransferReservationConfirmed ; " "" source)+      [code d | d <- validateSpec spec, severity d == Error]+        `shouldContain` [EventRetirementInProgress]+    it "warns when a deprecated event has no replay-only emitting transition" $ do+      diagnostics <- diagnosticsOf "test/fixtures/reservation-deprecated.keiro"+      [code d | d <- diagnostics, severity d == Error] `shouldBe` []+      [code d | d <- diagnostics, severity d == Warning]+        `shouldContain` [DeprecatedEventReplayHazard]+    it "recognises deprecated plus replay-only as the replay-safe cutover" $ do+      diagnostics <- diagnosticsOf "test/fixtures/reservation-deprecated-replay-only.keiro"+      [code d | d <- diagnostics, severity d == Error] `shouldBe` []+      [code d | d <- diagnostics, severity d == Warning]+        `shouldContain` [EventRetirementInProgress]+      [code d | d <- diagnostics] `shouldNotContain` [DeprecatedEventReplayHazard]+    it "requires exact, unique status-map event keys" $ do+      dangling <- errorCodesOf "test/fixtures/statusmap-dangling.keiro"+      mapM_ (\expected -> dangling `shouldContain` [expected]) [StatusMapDanglingKey, StatusMapNotTotal]+      duplicate <- errorCodesOf "test/fixtures/statusmap-dup-key.keiro"+      duplicate `shouldContain` [StatusMapDuplicateKey]+    it "rejects duplicate aggregate source subjects before semantic duplicate-name validation" $ do+      source <- readTestText "test/fixtures/duplicate-names.keiro"+      surface <- case parseSurfaceSource "test/fixtures/duplicate-names.keiro" source of+        Left frontendFailure -> expectationFailure (show frontendFailure) >> fail "unreachable"+        Right value -> pure value+      case lowerSurfaceDocument surface of+        Left LoweringFailure {code = SemanticSourceIndexInvalid DuplicateSourceSubject} -> pure ()+        other -> expectationFailure ("expected duplicate source-subject lowering refusal, got " <> show other)++      let withoutDuplicateAggregate = T.unlines (reverse (drop 3 (reverse (T.lines source))))+      parsed <- case parseSource "test/fixtures/duplicate-names.keiro" withoutDuplicateAggregate of+        Left parseFailure -> expectationFailure (show parseFailure) >> fail "unreachable"+        Right value -> pure value+      let spec = parsedSpec parsed+          codes = [code diagnostic | diagnostic <- validateSpec spec, severity diagnostic == Error]+      mapM_+        (\expected -> codes `shouldContain` [expected])+        [ DuplicateEnumCtor,+          DuplicateEnumWire,+          DuplicateIdPrefix,+          DuplicateCommandName,+          DuplicateEventName+        ]+      case [node | node@NAggregate {} <- specNodes spec] of+        aggregateNode : _ ->+          [code diagnostic | diagnostic <- validateSpec spec {specNodes = specNodes spec <> [aggregateNode]}, severity diagnostic == Error]+            `shouldContain` [DuplicateNodeName]+        [] -> expectationFailure "duplicate-name fixture lost its aggregate"+    it "rejects aggregate-local references that do not resolve" $ do+      codes <- errorCodesOf "test/fixtures/aggregate-bad-refs.keiro"+      mapM_ (\expected -> codes `shouldContain` [expected]) [RegisterInitialOutOfScope, UndeclaredCommand, WriteTargetNotRegister]+    it "anchors UnreachableState on the state row" $ do+      let src =+            T.unlines+              [ "context repro",+                "",+                "aggregate Thing",+                "  regs",+                "  states",+                "    Initial",+                "    Unreachable"+              ]+      case parseSpec "<unreachable-row>" src of+        Left err -> expectationFailure (T.unpack err)+        Right spec ->+          [line d | d <- validateSpec spec, code d == UnreachableState]+            `shouldBe` [7]+    it "accepts a replay-only twin with a live sibling (plan 143)" $ do+      codes <- errorCodesOf "test/fixtures/reservation-guard-tightened-twin.keiro"+      codes `shouldBe` []+    it "rejects a replay-only transition that emits nothing" $ do+      case parseSpec "<replay-only-no-emit>" (replayOnlySpecWith ["    write reservationState := Held", "    goto  Held"]) of+        Left err -> expectationFailure (T.unpack err)+        Right spec ->+          [code d | d <- validateSpec spec, severity d == Error]+            `shouldContain` [ReplayOnlyEmitsNothing]+    it "warns when a replay-only transition has no live sibling" $ do+      case parseSpec "<replay-only-orphan>" (replayOnlySpecWith ["    emit  TransferReservationCreated", "    goto  Held"]) of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> do+          [code d | d <- validateSpec spec, severity d == Warning]+            `shouldContain` [ReplayOnlyCommandStillLive]+          [code d | d <- validateSpec spec, severity d == Error]+            `shouldNotContain` [ReplayOnlyCommandStillLive]++  describe "complementExpr (plan 143)" $ do+    it "applies De Morgan over and/or and flips comparison operators" $ do+      let a = EAtom (AName "a")+          b = EAtom (AName "b")+      complementExpr (EAnd a b)+        `shouldBe` EOr (ECmp OpEq a (EAtom (ABool False))) (ECmp OpEq b (EAtom (ABool False)))+      complementExpr (ECmp OpLt a b) `shouldBe` ECmp OpGe a b+      complementExpr (ECmp OpEq a b) `shouldBe` ECmp OpNeq a b+      complementExpr (ECmp OpLe a b) `shouldBe` ECmp OpGt a b+      complementExpr (ECmp OpGt a b) `shouldBe` ECmp OpLe a b+      complementExpr (ECmp OpGe a b) `shouldBe` ECmp OpLt a b+      complementExpr (ECmp OpNeq a b) `shouldBe` ECmp OpEq a b+    it "flips boolean literals and grounds bare names as == false" $ do+      complementExpr (EAtom (ABool True)) `shouldBe` EAtom (ABool False)+      complementExpr (EAtom (AName "open"))+        `shouldBe` ECmp OpEq (EAtom (AName "open")) (EAtom (ABool False))+    it "stays inside the grammar: the complement of any guard re-parses" $+      property $+        forAll genExpr $ \e ->+          let twin =+                replayOnlySpecWith+                  [ "    guard " <> renderExprText (complementExpr e),+                    "    emit  TransferReservationCreated",+                    "    goto  Held"+                  ]+           in case parseSpec "<complement>" twin of+                Left err -> counterexample (T.unpack err) False+                Right spec ->+                  [tGuard t | NAggregate a <- specNodes spec, t <- aggTransitions a]+                    === [Just (complementExpr e)]++  describe "evolution parsing" $ do+    it "parses event version and upcaster from reservation-v2.keiro" $ do+      input <- readTestText "test/fixtures/reservation-v2.keiro"+      case parseSpec "test/fixtures/reservation-v2.keiro" input of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> case [e | NAggregate a <- specNodes spec, e <- aggEvents a, evName e == "TransferReservationCreated"] of+          (e : _) -> do+            evVersion e `shouldBe` 2+            evUpcastFrom e `shouldBe` Just (1, Hole)+          [] -> expectationFailure "TransferReservationCreated not found"+    it "round-trips the retiring marker" $ do+      spec <- specOf "test/fixtures/reservation-retiring.keiro"+      parseStableRenderedSpec "<retiring-round-trip>" spec `shouldBe` Right spec+      [evRetiring event | NAggregate aggregate <- specNodes spec, event <- aggEvents aggregate, evName event == "TransferReservationConfirmed"]+        `shouldBe` [True]+    it "rejects an event marked both retiring and deprecated" $ do+      source <- readTestText "test/fixtures/reservation-retiring.keiro"+      let conflicting = T.replace "retiring event TransferReservationConfirmed" "retiring deprecated event TransferReservationConfirmed" source+      parseSpec "<conflicting-retirement-markers>" conflicting `shouldSatisfy` isLeft++  describe "aggregate snapshots (EP-109)" $ do+    it "parses, validates, and round-trips a snapshot policy with codec fixture" $ do+      spec <- specOf "test/fixtures/reservation-snapshot.keiro"+      errorCodesOf "test/fixtures/reservation-snapshot.keiro" `shouldReturn` []+      parseStableRenderedSpec "<snapshot-round-trip>" spec `shouldBe` Right spec+      case [aggregate | NAggregate aggregate <- specNodes spec] of+        [aggregate] -> aggSnapshot aggregate `shouldBe` Just (SnapshotSpec (SnapEvery 100) 1 "7a181ceb7d798d883d28c85201c5c1692bd314a7b489da9128bff91e0f38cd28" noLoc)+        aggregates -> expectationFailure ("expected one snapshot aggregate, got " <> show (length aggregates))+    it "rejects disabled intervals and invalid codec fixtures" $ do+      source <- readTestText "test/fixtures/reservation-snapshot.keiro"+      interval <- parseInlineSpec "<snapshot-zero>" (T.replace "snapshot every 100" "snapshot every 0" source)+      map code (validateSpec interval) `shouldContain` [SnapshotIntervalInvalid]+      version <- parseInlineSpec "<snapshot-version-zero>" (T.replace "state-codec version=1" "state-codec version=0" source)+      map code (validateSpec version) `shouldContain` [SnapshotCodecFixtureInvalid]+      emptyHash <- parseInlineSpec "<snapshot-empty-hash>" (T.replace "shape-hash=\"7a181ceb7d798d883d28c85201c5c1692bd314a7b489da9128bff91e0f38cd28\"" "shape-hash=\"\"" source)+      map code (validateSpec emptyHash) `shouldContain` [SnapshotCodecFixtureInvalid]+    it "conditionally lowers JSON instances and the live defaultStateCodec" $ do+      snapshotService <- checkedServiceOf "test/fixtures/reservation-snapshot.keiro"+      ordinaryService <- checkedServiceOf "test/fixtures/reservation.keiro"+      let snapshot = checkedSpec snapshotService+          ordinary = checkedSpec ordinaryService+      case ([aggregate | NAggregate aggregate <- specNodes snapshot], [aggregate | NAggregate aggregate <- specNodes ordinary]) of+        ([_], [_]) -> do+          let snapshotModules = scaffoldServiceModules (defaultContext (specContext snapshot)) snapshotService+              ordinaryModules = scaffoldServiceModules (defaultContext (specContext ordinary)) ordinaryService+              snapshotDomain = generatedTextEndingIn "Domain.hs" snapshotModules+              snapshotStream = generatedTextEndingIn "EventStream.hs" snapshotModules+              ordinaryDomain = generatedTextEndingIn "Domain.hs" ordinaryModules+              ordinaryStream = generatedTextEndingIn "EventStream.hs" ordinaryModules+          snapshotDomain `shouldSatisfy` T.isInfixOf "deriving anyclass (ToJSON, FromJSON)"+          snapshotStream `shouldSatisfy` T.isInfixOf "snapshotPolicy = Every 100"+          snapshotStream `shouldSatisfy` T.isInfixOf "stateCodec = Just (withFoldFingerprint"+          snapshotStream `shouldSatisfy` T.isInfixOf "Spec-visible fold changes invalidate old"+          snapshotStream `shouldSatisfy` T.isInfixOf "reservationSnapshotFixture = (1, \"7a181ceb7d798d883d28c85201c5c1692bd314a7b489da9128bff91e0f38cd28\")"+          ordinaryDomain `shouldNotSatisfy` T.isInfixOf "DeriveAnyClass"+          ordinaryStream `shouldSatisfy` T.isInfixOf "snapshotPolicy = Never"+          ordinaryStream `shouldSatisfy` T.isInfixOf "stateCodec = Nothing"+          ordinaryStream `shouldSatisfy` T.isInfixOf "reservationCategory = Stream.categoryUnsafe \"reservation\""+          firewallBreaches snapshotModules `shouldBe` []+        _ -> expectationFailure "expected one aggregate in each snapshot test spec"++  describe "aggregate fold fingerprints (plan 138)" $ do+    it "is deterministic across repeated parses and formatting-only changes" $ do+      source <- readTestText "test/fixtures/reservation.keiro"+      first <- parseInlineSpec "<first>" source+      second <- shouldParseStableRenderedSpec "<second>" first+      aggregateFoldFingerprint first (onlyAggregate first)+        `shouldBe` aggregateFoldFingerprint second (onlyAggregate second)+    it "changes for transition writes, guards, and referenced rule bodies" $ do+      base <- specOf "test/fixtures/reservation.keiro"+      writeChanged <- specOf "test/fixtures/reservation-foldchange.keiro"+      guardChanged <- specOf "test/fixtures/reservation-guard-tightened.keiro"+      source <- readTestText "test/fixtures/reservation.keiro"+      ruleChanged <- parseInlineSpec "<rule-change>" (T.replace "RedTag => true" "RedTag => false" source)+      let baseFingerprint = aggregateFoldFingerprint base (onlyAggregate base)+      aggregateFoldFingerprint writeChanged (onlyAggregate writeChanged) `shouldNotBe` baseFingerprint+      aggregateFoldFingerprint guardChanged (onlyAggregate guardChanged) `shouldNotBe` baseFingerprint+      aggregateFoldFingerprint ruleChanged (onlyAggregate ruleChanged) `shouldNotBe` baseFingerprint+    it "ignores wire and projection changes" $ do+      base <- specOf "test/fixtures/reservation.keiro"+      wireChanged <- specOf "test/fixtures/reservation-wire.keiro"+      source <- readTestText "test/fixtures/reservation.keiro"+      projectionChanged <- parseInlineSpec "<projection-change>" (T.replace "projection transfer_decisions" "projection renamed_projection" source)+      let surface = aggregateFoldSurface base (onlyAggregate base)+      aggregateFoldSurface wireChanged (onlyAggregate wireChanged) `shouldBe` surface+      aggregateFoldSurface projectionChanged (onlyAggregate projectionChanged) `shouldBe` surface+    it "invalidates mapped-register snapshots when binding or wire identity changes" $ do+      base <- specOf "test/fixtures/consumer-types.keiro"+      bindingChanged <- specOf "test/fixtures/consumer-types-binding-change.keiro"+      wireChanged <- specOf "test/fixtures/consumer-types-wirekey.keiro"+      let baseFingerprint = aggregateFoldFingerprint base (onlyAggregate base)+      aggregateFoldFingerprint bindingChanged (onlyAggregate bindingChanged) `shouldNotBe` baseFingerprint+      aggregateFoldFingerprint wireChanged (onlyAggregate wireChanged) `shouldNotBe` baseFingerprint++  describe "process/timer (EP-3)" $ do+    it "parses the hospital-surge process + nested timer" $ do+      input <- readTestText "test/fixtures/hospital-surge.keiro"+      case parseSpec "test/fixtures/hospital-surge.keiro" input of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> case [p | NProcess p <- specNodes spec] of+          (p : _) -> do+            procId p `shouldBe` "HospitalSurge"+            procName p `shouldBe` "hospital-surge"+            procRejected p `shouldBe` PolHalt+            procPoison p `shouldBe` PolHalt+            sagaCategory (procSaga p) `shouldBe` "hospitalSurge"+            tmName (procTimer p) `shouldBe` "surgeFollowUp"+            onReject (fireDisposition (tmFire (procTimer p))) `shouldBe` OFired+            onAmbiguous (fireDisposition (tmFire (procTimer p))) `shouldBe` ORetry+            tmMaxAttempts (procTimer p) `shouldBe` 5+          [] -> expectationFailure "no process node parsed"+    it "round-trips the hospital-surge spec through parse . pretty" $ do+      input <- readTestText "test/fixtures/hospital-surge.keiro"+      case parseSpec "in" input of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> parseLanguage4RenderedSpec "in" spec `shouldBe` Right spec+    it "accepts the hospital-surge spec (no errors; benign-inversion warnings only)" $ do+      codes <- errorCodesOf "test/fixtures/hospital-surge.keiro"+      codes `shouldBe` []+    it "rejects illegal saga categories and no longer parses the raw stream-prefix clause" $ do+      spec <- specOf "test/fixtures/hospital-surge.keiro"+      mapM_+        (\categoryName -> processErrorCodes (\process -> process {procSaga = (procSaga process) {sagaCategory = categoryName}}) spec `shouldContain` [SagaCategoryIllegal])+        ["", "$all", "hospital-surge", "hospital surge", "wf:surge"]+      source <- readTestText "test/fixtures/hospital-surge.keiro"+      parseSpec "<legacy-saga>" (T.replace "saga Surge category \"hospitalSurge\"" "saga Surge stream=\"hospital-surge-\" <> correlationId" source)+        `shouldSatisfy` isLeft+    it "rejects a wall-clock fireAt as ProcessFireAtNotInjected" $ do+      codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro"+      codes `shouldContain` [ProcessFireAtNotInjected]+    it "reports one ProcessFireAtNotInjected for a wholly unknown fireAt field" $ do+      codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro"+      length (filter (== ProcessFireAtNotInjected) codes) `shouldBe` 1+    it "rejects a user-supplied dispatch id as ProcessDispatchIdSupplied" $ do+      codes <- errorCodesOf "test/fixtures/hospital-surge-dispatchid.keiro"+      codes `shouldContain` [ProcessDispatchIdSupplied]+    it "rejects an unresolved saga reference as ProcessUnresolvedRef" $ do+      codes <- errorCodesOf "test/fixtures/hospital-surge-badref.keiro"+      codes `shouldContain` [ProcessUnresolvedRef]+    it "rejects unresolved process commands, projections, schedules, and advance ids" $ do+      codes <- errorCodesOf "test/fixtures/process-ghost-refs.keiro"+      length (filter (== ProcessUnresolvedRef) codes) `shouldBe` 5+      codes `shouldContain` [ProcessDispatchIdSupplied]+    it "gates process correlate, dispatch-key, and binding scopes on language 4" $ do+      spec <- specOf "test/fixtures/hospital-surge.keiro"+      let badCorrelate =+            modifyProcess+              "HospitalSurge"+              (\process -> process {procCorrelate = (procCorrelate process) {corrField = "ghost"}})+              spec+          badDispatchKey =+            modifyProcess+              "HospitalSurge"+              ( \process ->+                  let handle = procHandle process+                   in process {procHandle = handle {hDispatch = updateFirst (\dispatch -> dispatch {dispKey = "input.ghost"}) (hDispatch handle)}}+              )+              spec+          badBinding =+            modifyProcess+              "HospitalSurge"+              ( \process ->+                  let handle = procHandle process+                      advance = hAdvance handle+                   in process {procHandle = handle {hAdvance = advance {advFields = updateFirst (\binding -> binding {fbValue = Just "ghost.value"}) (advFields advance)}}}+              )+              spec+          cases =+            [ (badCorrelate, ProcessKeyFieldUnknown),+              (badDispatchKey, ProcessDispatchKeyUnresolved),+              (badBinding, ProcessBindingUnscoped)+            ]+      forM_ cases $ \(candidate, expected) -> do+        serviceErrorCodes 3 candidate `shouldNotContain` [expected]+        serviceErrorCodes 4 candidate `shouldContain` [expected]+      serviceErrorCodes 4 spec+        `shouldNotContain` [ProcessKeyFieldUnknown, ProcessDispatchKeyUnresolved, ProcessBindingUnscoped]++  describe "router (EP-108)" $ do+    it "RouterSelection parses, checks, fingerprints, and round-trips bounded declarative selection" $ do+      source <- readTestText "test/fixtures/declarative-router/valid.keiro"+      parsed <- case parseSource "declarative-router.keiro" source of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      let service = checkedSource parsed+          spec = checkedSpec service+      [code diagnostic | diagnostic <- validateService service, severity diagnostic == Error] `shouldBe` []+      parseSource "declarative-router-roundtrip.keiro" (renderSource parsed) `shouldBe` Right parsed+      graph <- shouldResolveTypeGraph spec+      case [router | NRouter router <- specNodes spec] of+        [router] -> case RouterSelection.checkRouterSelection (checkedLanguageContract service) graph spec router of+          Left diagnostics -> expectationFailure (show diagnostics)+          Right selection -> do+            RouterSelection.checkedIdentity selection `shouldBe` "hospital-transfer-selection"+            RouterSelection.checkedVersion selection `shouldBe` 1+            RouterSelection.checkedLimit selection `shouldBe` 64+            RouterSelection.checkedUseSites selection `shouldSatisfy` (not . null)+            T.length (RouterSelection.checkedFingerprint selection) `shouldBe` 64+            RouterSelection.checkedFingerprint selection+              `shouldSatisfy` T.all (`elem` ("0123456789abcdef" :: String))+        routers -> expectationFailure ("expected one declarative router, got " <> show (length routers))++    it "generates the checked declarative selection without a selection-owned RouterHoles module" $ do+      service <- checkedServiceOf "test/fixtures/declarative-router/valid.keiro"+      let spec = checkedSpec service+          modules = scaffoldServiceModules (defaultContext (specContext spec)) service+          routerModule = generatedTextEndingIn "HospitalTransferRouter/Router.hs" modules+          routerHarness = generatedTextEndingIn "HospitalTransferRouter/RouterHarness.hs" modules+      [modulePath generatedModule | generatedModule <- modules, "HospitalTransferRouter/Router.hs" `T.isSuffixOf` T.pack (modulePath generatedModule)]+        `shouldBe` ["Generated/TransferRouting/HospitalTransferRouter/Router.hs"]+      [modulePath hole | hole <- modules, "HospitalTransferRouter/RouterHoles.hs" `T.isSuffixOf` T.pack (modulePath hole)]+        `shouldBe` []+      routerModule `shouldSatisfy` T.isInfixOf "DeclarativeRouter"+      routerModule `shouldSatisfy` T.isInfixOf "runQuery Nothing SelectionQuery.hospitalLoadReadModel input"+      routerModule `shouldSatisfy` T.isInfixOf "fieldWitnessGet StructuralProjections.hospitalLoadRowHospitalIdWitness row"+      routerModule `shouldSatisfy` T.isInfixOf "hospitalTransferRouterSelectionContract"+      routerModule `shouldSatisfy` T.isInfixOf "hospitalTransferRouterSelectionFingerprint"+      routerHarness `shouldSatisfy` T.isInfixOf "(\"resolverOwnership\", \"generated-declarative\")"+      routerHarness `shouldSatisfy` T.isInfixOf "(\"maxRecipients\", \"64\")"+      firewallBreaches modules `shouldBe` []++    it "classifies every declarative selection coordination transition" $ do+      source <- readTestText "test/fixtures/declarative-router/valid.keiro"+      baseline <- checkedServiceFromText "selection-baseline.keiro" source+      identityChanged <- checkedServiceFromText "selection-identity.keiro" (T.replace "identity = \"hospital-transfer-selection\"" "identity = \"hospital-transfer-selection-v2\"" source)+      versionTwo <- checkedServiceFromText "selection-version-two.keiro" (T.replace "version = 1" "version = 2" source)+      fingerprintChanged <- checkedServiceFromText "selection-fingerprint.keiro" (T.replace "max-recipients = 64" "max-recipients = 32" source)+      versionedFingerprintChanged <- checkedServiceFromText "selection-versioned-fingerprint.keiro" (T.replace "version = 1" "version = 2" (T.replace "max-recipients = 64" "max-recipients = 32" source))+      let custom =+            checkedServiceWithSpec+              ( modifyRouter+                  "HospitalTransferRouter"+                  ( \router ->+                      router+                        { rtInput = (rtInput router) {inType = Nothing, inFields = [Field "transferNeedId" Nothing, Field "region" Nothing]},+                          rtResolve = ResolveDecl ResolveHole ["hospitalId"] (rvLoc (rtResolve router))+                        }+                  )+                  (checkedSpec baseline)+              )+              baseline+          classifyCoordination old new = [(coordinationReason impact, coordinationSeverity impact) | impact <- coordinationImpact old new []]+      case routerSelectionSnapshots baseline of+        [snapshot] -> do+          selectionVerification snapshot `shouldBe` DeclarativeVerified+          selectionIdentity snapshot `shouldBe` Just "hospital-transfer-selection"+          selectionVersion snapshot `shouldBe` Just 1+          fmap T.length (selectionFingerprint snapshot) `shouldBe` Just 64+          Aeson.decode (Aeson.encode snapshot) `shouldBe` Just snapshot+        snapshots -> expectationFailure ("expected one router selection ledger snapshot, got " <> show snapshots)+      classifyCoordination baseline identityChanged `shouldBe` [(SelectionIdentityChanged, CoordinationBreaking)]+      classifyCoordination versionTwo baseline `shouldBe` [(SelectionVersionDecreased, CoordinationBreaking)]+      classifyCoordination baseline fingerprintChanged `shouldBe` [(SelectionFingerprintChangedWithoutVersionBump, CoordinationBreaking)]+      classifyCoordination baseline versionedFingerprintChanged `shouldBe` [(SelectionFingerprintChangedWithVersionBump, CoordinationAdvisory)]+      classifyCoordination baseline versionTwo `shouldBe` [(SelectionVersionMetadataOnly, CoordinationAdvisory)]+      classifyCoordination baseline custom `shouldBe` [(SelectionVerificationBoundaryChanged, CoordinationAdvisory)]+      let breakingReport = LazyText.toStrict (LazyTextEncoding.decodeUtf8 (Aeson.encode (diffReportWithImpacts defaultGate [] [] (coordinationImpact baseline fingerprintChanged []))))+      breakingReport `shouldSatisfy` T.isInfixOf "\"breaking\":true"++    it "keeps formatting out of the fingerprint and reports mapped selection dependencies in both sections" $ do+      source <- readTestText "test/fixtures/declarative-router/valid.keiro"+      baseline <- checkedServiceFromText "selection-semantic-baseline.keiro" source+      formatted <- checkedServiceFromText "selection-semantic-formatted.keiro" (T.replace "context transfer-routing\n" "context transfer-routing\n\n" source)+      coordinationImpact baseline formatted [] `shouldBe` []+      let changed = checkedServiceWithSpec (mapMappedStructural "HospitalLoadRow" changeMappedCanonical (checkedSpec baseline)) baseline+          semantic = CheckedDiff.mappedSemanticImpactForServices baseline changed+          coordination = coordinationImpact baseline changed semantic+          rowDelta = find ((== MappedKey "HospitalLoadRow") . impactDeclaration) semantic+          rendered = T.unlines (renderCoordinationImpact coordination)+          encoded = LazyText.toStrict (LazyTextEncoding.decodeUtf8 (Aeson.encode (diffReportWithImpacts defaultGate [] semantic coordination)))+          isSelectionConsumer = \case RouterSelectionConsumer {} -> True; _ -> False+      rowDelta `shouldSatisfy` maybe False (any isSelectionConsumer . Set.toList . impactCurrentConsumers)+      map coordinationReason coordination `shouldContain` [SelectionMappedDependencyChanged]+      rendered `shouldSatisfy` T.isInfixOf "selection-mapped-dependency-changed"+      encoded `shouldSatisfy` T.isInfixOf "\"coordinationImpact\""+      encoded `shouldSatisfy` T.isInfixOf "router-selection:HospitalTransferRouter:recipient"+      LazyText.toStrict (LazyTextEncoding.decodeUtf8 (Aeson.encode (diffReport defaultGate [])))+        `shouldNotSatisfy` T.isInfixOf "coordinationImpact"++    it "RouterSelection gates declarative selection at the version-5 marker" $ do+      source <- readTestText "test/fixtures/declarative-router/valid.keiro"+      let version4 = "language keiro-dsl 4\ncontext transfer-routing\n\n" <> snd (T.breakOn "router HospitalTransferRouter" source)+      case parseSurfaceSource "declarative-router-v4.keiro" version4 of+        Left FrontendFailure {code = SourceLanguageError LanguageFeatureRequiresVersion, span = SourceSpan {start = SourcePoint {offset = startOffset}, end = SourcePoint {offset = endOffset}}} ->+          T.take (endOffset - startOffset) (T.drop startOffset version4) `shouldBe` "declarative"+        Left failure -> expectationFailure (show failure)+        Right _ -> expectationFailure "language 4 unexpectedly accepted declarative selection"++    it "RouterSelection rejects unbounded selection at its declaration" $ do+      diagnostics <- diagnosticsOf "test/fixtures/declarative-router/unbounded.keiro"+      [(line diagnostic, code diagnostic) | diagnostic <- diagnostics, severity diagnostic == Error]+        `shouldBe` [(79, RouterSelectionRecipientLimitMissing)]++    it "RouterSelection assigns a dedicated diagnostic to every declarative selection rejection class" $ do+      source <- readTestText "test/fixtures/declarative-router/valid.keiro"+      let mutationCases =+            [ ("empty-identity", T.replace "identity = \"hospital-transfer-selection\"" "identity = \"\"", RouterSelectionIdentityEmpty),+              ("zero-version", T.replace "version = 1" "version = 0", RouterSelectionVersionInvalid),+              ("unknown-query", T.replace "read-model hospital_load" "read-model missing_load", RouterSelectionQueryUnknown),+              ("missing-query-contract", T.replace "  query input = TransferRouteInput\n  query result = List HospitalLoadRow\n" "", RouterSelectionQueryContractMissing),+              ("input-mismatch", T.replace "input AcceptedHospitalTransferNeed : TransferRouteInput" "input AcceptedHospitalTransferNeed : HospitalLoadRow", RouterSelectionQueryInputTypeMismatch),+              ("non-list-result", T.replace "query result = List HospitalLoadRow" "query result = HospitalLoadRow", RouterSelectionQueryResultNotList),+              ("unknown-root", T.replace "recipient = row.hospitalId" "recipient = resolved.hospitalId", RouterSelectionExpressionRootUnknown),+              ("unknown-field", T.replace "recipient = row.hospitalId" "recipient = row.missingHospitalId", RouterSelectionExpressionFieldUnknown),+              ("nullable-recipient", T.replace ": Text required\n    region" ": Optional Text required\n    region", RouterSelectionExpressionFieldOptional),+              ("predicate-type", T.replace "where = row.region == input.region && row.availableBeds > 0" "where = row.region", RouterSelectionPredicateNotBool),+              ("recipient-type", T.replace "recipient = row.hospitalId" "recipient = row.availableBeds", RouterSelectionRecipientNotText),+              ("operator", T.replace "recipient = row.hospitalId" "recipient = row.availableBeds + 1", RouterSelectionOperatorUnsupported),+              ("zero-limit", T.replace "max-recipients = 64" "max-recipients = 0", RouterSelectionRecipientLimitInvalid),+              ("order", T.replace "order = target-stream" "order = query-order", RouterSelectionOrderUnsupported),+              ("dedupe", T.replace "dedupe = target-stream" "dedupe = none", RouterSelectionDedupeUnsupported),+              ("failure-ack", T.replace "failure => retry" "failure => ack", RouterSelectionFailureAckForbidden),+              ("redelivery", T.replace "redelivery = stable-union" "redelivery = replace", RouterSelectionRedeliveryUnsupported),+              ("partial", T.replace "partial = retain-successes" "partial = rollback", RouterSelectionPartialDispatchUnsupported),+              ("target", T.replace "target Hospital\n" "target MissingHospital\n", RouterSelectionTargetAmbiguous),+              ("command", T.replace "dispatch-each RouteAcceptedTransferNeed" "dispatch-each MissingCommand", RouterSelectionCommandUnknown),+              ("duplicate-field", T.replace "    hospitalId=row.hospitalId\n" "    hospitalId=row.hospitalId\n    hospitalId=row.hospitalId\n", RouterSelectionCommandMappingDuplicate),+              ("incomplete-field", T.replace "    hospitalId=row.hospitalId\n" "", RouterSelectionCommandMappingIncomplete),+              ("field-type", T.replace "hospitalId:Text" "hospitalId:Int", RouterSelectionCommandMappingTypeMismatch)+            ]+      forM_ mutationCases $ \(caseLabel, mutate, expected) -> do+        service <- checkedServiceFromText ("declarative-router-" <> caseLabel <> ".keiro") (mutate source)+        [code diagnostic | diagnostic <- validateService service, severity diagnostic == Error]+          `shouldContain` [expected]++    it "parses the incident-paging router shape" $ do+      input <- readTestText "test/fixtures/incident-paging/incident-paging.keiro"+      case parseSpec "test/fixtures/incident-paging/incident-paging.keiro" input of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> case [router | NRouter router <- specNodes spec] of+          [router] -> do+            rtId router `shouldBe` "PagingRouter"+            rtName router `shouldBe` "jitsurei-paging"+            corrField (rtKey router) `shouldBe` "incidentId"+            rvSource (rtResolve router) `shouldBe` ResolveReadModel "service_oncall"+            rvRow (rtResolve router) `shouldBe` ["responderId"]+            rdCommand (rtDispatch router) `shouldBe` "SendPage"+            rtRejected router `shouldBe` PolDeadLetter+            rtPoison router `shouldBe` PolHalt+          routers -> expectationFailure ("expected one router, got " <> show (length routers))+    it "round-trips the incident-paging spec through parse . pretty" $ do+      input <- readTestText "test/fixtures/incident-paging/incident-paging.keiro"+      case parseSpec "in" input of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> parseLanguage4RenderedSpec "in" spec `shouldBe` Right spec+    it "accepts the incident-paging router with warnings only" $ do+      codes <- errorCodesOf "test/fixtures/incident-paging/incident-paging.keiro"+      codes `shouldBe` []+      diagnostics <- diagnosticCodesOf "test/fixtures/incident-paging/incident-paging.keiro"+      diagnostics `shouldContain` [PolicyDeadLetterUnused, AmbiguousFollowsRejectedPolicy]+    it "rejects unresolved targets, keys, commands, and binding scopes" $ do+      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+      routerErrorCodes (\router -> router {rtTarget = "Pge"}) spec `shouldContain` [RouterUnresolvedRef]+      routerErrorCodes (\router -> router {rtKey = (rtKey router) {corrField = "incidntId"}}) spec `shouldContain` [RouterKeyFieldUnknown]+      routerErrorCodes (\router -> router {rtDispatch = (rtDispatch router) {rdCommand = "SendPag"}}) spec `shouldContain` [RouterCommandUnknown]+      routerErrorCodes+        ( \router ->+            let dispatch = rtDispatch router+             in router {rtDispatch = dispatch {rdFields = [FieldBinding "responderId" (Just "resolved.responder")]}}+        )+        spec+        `shouldContain` [RouterBindingUnscoped]+    it "rejects unresolved read models and contradictory rejection policies" $ do+      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+      let withoutReadModel = removeReadModel "service_oncall" spec+      errorCodes withoutReadModel `shouldContain` [RouterUnresolvedRef]+      routerErrorCodes+        ( \router ->+            let dispatch = rtDispatch router+                disposition = rdDisposition dispatch+             in router+                  { rtRejected = PolHalt,+                    rtDispatch = dispatch {rdDisposition = disposition {onFailed = DDeadLetter "page rejected"}}+                  }+        )+        spec+        `shouldContain` [PolicyContradiction]+    it "gates resolve-row column verification on language 4" $ do+      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+      let unresolved =+            modifyRouter+              "PagingRouter"+              (\router -> router {rtResolve = (rtResolve router) {rvRow = ["ghostColumn"]}})+              spec+      serviceErrorCodes 3 unresolved `shouldNotContain` [RouterReadModelUnverified]+      serviceErrorCodes 4 unresolved `shouldContain` [RouterReadModelUnverified]+      serviceErrorCodes 4 spec `shouldNotContain` [RouterReadModelUnverified]+    it "rejects on-ambiguous Fired for process timers" $ do+      spec <- specOf "test/fixtures/hospital-surge.keiro"+      let changed =+            spec+              { specNodes =+                  [ case node of+                      NProcess process ->+                        let timer = procTimer process+                            fire = tmFire timer+                            disposition = fireDisposition fire+                         in NProcess process {procTimer = timer {tmFire = fire {fireDisposition = disposition {onAmbiguous = OFired}}}}+                      _ -> node+                  | node <- specNodes spec+                  ]+              }+      errorCodes changed `shouldContain` [AmbiguousMarkedBenign]+    it "requires explicit policy and ambiguity clauses in the grammar" $ do+      source <- readTestText "test/fixtures/hospital-surge.keiro"+      parseSpec "<missing-poison>" (T.replace "  poison => halt\n" "" source) `shouldSatisfy` isLeft+      parseSpec "<missing-ambiguous>" (T.replace " ; on-ambiguous Retry" "" source) `shouldSatisfy` isLeft+    it "scaffolds firewall-clean router wiring, policies, and typed-hole guidance" $ do+      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+      case [router | NRouter router <- specNodes spec] of+        [router] -> do+          let ctx = defaultContext (specContext spec)+              modules = scaffoldRouter ctx router+              generated = [m | m <- modules, kind m == Generated]+              holes = [m | m <- modules, kind m == HoleStub]+          firewallBreaches generated `shouldBe` []+          case (generated, holes) of+            ([generatedModule], [holeModule]) -> do+              moduleText generatedModule `shouldSatisfy` T.isInfixOf "pagingRouterWorkerOptions"+              moduleText generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedDeadLetter"+              moduleText holeModule `shouldSatisfy` T.isInfixOf "UNION of resolved target identities"+              moduleText holeModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate"+            _ -> expectationFailure "expected one generated router module and one router hole module"+        routers -> expectationFailure ("expected one router, got " <> show (length routers))+    it "requires a caller callback for non-halting poison policies" $ do+      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+      case [router | NRouter router <- specNodes spec] of+        [router] -> do+          let ctx = defaultContext (specContext spec)+              generatedFor choice = [moduleText m | m <- scaffoldRouter ctx router {rtPoison = choice}, kind m == Generated]+          mapM_+            ( \(choice, constructor) -> case generatedFor choice of+                [generatedModule] -> do+                  generatedModule `shouldSatisfy` T.isInfixOf "(Envelope msg -> Eff es ()) -> WorkerOptions es msg"+                  generatedModule `shouldSatisfy` T.isInfixOf (constructor <> " poisonCallback")+                _ -> expectationFailure "expected one generated router module"+            )+            [(PolDeadLetter, "PoisonDeadLetter"), (PolSkip, "PoisonSkip")]+          case [moduleText m | m <- scaffoldRouter ctx router {rtRejected = PolSkip}, kind m == Generated] of+            [generatedModule] -> generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedSkip"+            _ -> expectationFailure "expected one generated router module"+        routers -> expectationFailure ("expected one router, got " <> show (length routers))+    it "emits router harness facts that pin policy and target-keyed identity" $ do+      spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+      case [router | NRouter router <- specNodes spec] of+        [router] -> case harnessRouter (defaultContext (specContext spec)) router of+          [facts] -> do+            moduleText facts `shouldSatisfy` T.isInfixOf "(\"rejectedPolicy\", \"deadLetter\")"+            moduleText facts `shouldSatisfy` T.isInfixOf "targetStreamName, occurrence"+          modules -> expectationFailure ("expected one router harness, got " <> show (length modules))+        routers -> expectationFailure ("expected one router, got " <> show (length routers))+    it "rejects invalid timer ceilings and target field bindings" $ do+      codes <- errorCodesOf "test/fixtures/process-bad-timer.keiro"+      mapM_+        (\expected -> codes `shouldContain` [expected])+        [ProcessTimerCeilingInvalid, ProcessFieldBindingUnresolved]+    it "accepts resolved process projection references" $ do+      codes <- errorCodesOf "test/fixtures/surge-service.keiro"+      codes `shouldBe` []+    it "scaffolds the process: Generated wiring is firewall-clean + a HoleStub" $ do+      mods <- legacyScaffoldProcessFixture "test/fixtures/hospital-surge.keiro"+      let gens = [m | m <- mods, kind m == Generated]+          holes = [m | m <- mods, kind m == HoleStub]+      length holes `shouldBe` 1+      firewallBreaches gens `shouldBe` []+      case gens of+        [generatedModule] -> do+          -- the worker uses the spec's ceiling, never the dangerous default+          moduleText generatedModule `shouldSatisfy` T.isInfixOf "max-attempts = 5"+          moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeProcessWorkerOptions"+          moduleText generatedModule `shouldSatisfy` T.isInfixOf "import Generated.HospitalCapacity.Surge.EventStream (SurgeEventStreamDef)"+          moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeCategory :: Stream.StreamCategory SurgeEventStreamDef"+          moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeCategory = Stream.categoryUnsafe \"hospitalSurge\""+          moduleText generatedModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate"+          moduleText generatedModule `shouldSatisfy` T.isInfixOf "StreamName -> EventId -> CommandError -> Eff es Bool"+          moduleText generatedModule `shouldSatisfy` T.isInfixOf "Left (CommandAmbiguous _)"+          case holes of+            [holeModule] -> moduleText holeModule `shouldSatisfy` T.isInfixOf "entityStream hospitalSurgeCategory"+            _ -> expectationFailure "expected one process hole module"+        _ -> expectationFailure "expected one generated process module"+    it "process scaffold is deterministic" $ do+      a <- legacyScaffoldProcessFixture "test/fixtures/hospital-surge.keiro"+      b <- legacyScaffoldProcessFixture "test/fixtures/hospital-surge.keiro"+      map moduleText a `shouldBe` map moduleText b+    it "separates aggregate event-stream and command-target categories and emits stable typed sums" $ do+      spec <- specOf "test/fixtures/hospital-surge.keiro"+      let ctx = defaultContext (specContext spec)+          modules = concat [scaffoldAggregate ctx spec aggregate | NAggregate aggregate <- specNodes spec]+          surgeStream = generatedTextEndingIn "Surge/EventStream.hs" modules+          surgeDomain = generatedTextEndingIn "Surge/Domain.hs" modules+      surgeStream `shouldSatisfy` T.isInfixOf "surgeCategory :: Stream.StreamCategory SurgeEventStreamDef"+      surgeStream `shouldSatisfy` T.isInfixOf "surgeCommandCategory :: Stream.StreamCategory SurgeCommand"+      surgeDomain `shouldNotSatisfy` T.isInfixOf "{-# LANGUAGE EmptyDataDecls #-}"+      surgeDomain `shouldSatisfy` T.isInfixOf "data SurgeEvent = SurgeThresholdNoted"+      surgeDomain `shouldSatisfy` (not . T.isInfixOf "data SurgeEvent = ()")++  describe "contract (EP-4)" $ do+    it "parses the emergency contract (topics + events-on-topic + typed fields)" $ do+      input <- readTestText "test/fixtures/contract.keiro"+      case parseSpec "test/fixtures/contract.keiro" input of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> case [c | NContract c <- specNodes spec] of+          (c : _) -> do+            ctrName c `shouldBe` "emergency"+            ctrDiscriminator c `shouldBe` "messageType"+            map fst (ctrTopics c) `shouldBe` ["incidentEvents", "hospitalEvents"]+            map ceName (ctrEvents c) `shouldBe` ["IncidentTransferNeedDeclared", "TransferReservationAccepted"]+          [] -> expectationFailure "no contract node parsed"++    it "branches contract scaffolding, manifests, and durable identities only for language 4" $ do+      sourceText <- readTestText "test/fixtures/contract-v4.keiro"+      parsed <- case parseSource "contract-v4.keiro" sourceText of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      let service = checkedSource parsed+          spec = checkedSpec service+          ctx = defaultContext (specContext spec)+      contract <- case [value | NContract value <- specNodes spec] of+        [value] -> pure value+        values -> expectationFailure ("expected one contract, got " <> show (length values)) >> fail "unreachable"+      legacyModule <- case scaffoldContract ctx contract of+        [value] -> pure value+        values -> expectationFailure ("expected one legacy module, got " <> show (length values)) >> fail "unreachable"+      typedModule <- case scaffoldContractForService ctx service contract of+        [value] -> pure value+        values -> expectationFailure ("expected one typed module, got " <> show (length values)) >> fail "unreachable"+      let dependencies = manifestDependenciesForService service+          identities = idDomainIdentitiesForService service+          manifestText = renderManifestForService "contract-v4.keiro" [typedModule] service+      assertGeneratedHaskellContract "contract-v4.keiro" manifestText+      committed <- readTestText "test/conformance-contract/Generated/HospitalCapacity/Emergency/Contract.hs"+      normalizeGenerated (moduleText typedModule) `shouldBe` normalizeGenerated committed+      moduleText legacyModule `shouldSatisfy` T.isInfixOf "incidentId :: !Text"+      moduleText legacyModule `shouldSatisfy` (not . T.isInfixOf "KindID")+      moduleText typedModule `shouldSatisfy` T.isInfixOf "incidentId :: !(KindID \"inc\")"+      moduleText typedModule `shouldSatisfy` T.isInfixOf "KindID.toText payload.incidentId"+      moduleText typedModule `shouldSatisfy` T.isInfixOf "explicitParseField (parseKindIdV7Value @\"inc\") o \"incidentId\""+      moduleText typedModule `shouldSatisfy` T.isInfixOf "  , incidentEventsTopic"+      moduleText typedModule `shouldSatisfy` T.isInfixOf "  , hospitalEventsTopic"+      moduleText typedModule `shouldSatisfy` (not . T.isInfixOf "Wno-unused-top-binds")+      dependencies `shouldBe` ["aeson", "base", "keiro-core", "mmzk-typeid", "text"]+      manifestDependencies spec `shouldBe` ["aeson", "base", "text"]+      forM_ dependencies $ \dependency -> manifestText `shouldSatisfy` T.isInfixOf ("    , " <> dependency)+      identities+        `shouldBe` [ "id-domain|name=contract:emergency.IncidentTransferNeedDeclared.incidentId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=inc|separator=_|json=canonical-json-text",+                     "id-domain|name=contract:emergency.TransferReservationAccepted.incidentId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=inc|separator=_|json=canonical-json-text",+                     "id-domain|name=contract:emergency.TransferReservationAccepted.reservationId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=rsv|separator=_|json=canonical-json-text",+                     "id-domain|name=contract:emergency.TransferReservationAccepted.hospitalId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=hsp|separator=_|json=canonical-json-text"+                   ]++    it "persists contract ID domains in single-file and workspace records with owner attribution" $ do+      sourceText <- readTestText "test/fixtures/contract-v4.keiro"+      parsed <- case parseSource "contract-v4.keiro" sourceText of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right value -> pure value+      let service = checkedSource parsed+          spec = checkedSpec service+          ctx = defaultContext (specContext spec)+          modules = scaffoldServiceModules ctx service+          identities = idDomainIdentitiesForService service+      duplicateIdentity <- case identities of+        value : _ -> pure value+        [] -> expectationFailure "typed contract service did not expose ID-domain identities" >> fail "unreachable"+      withTempDirectory "keiro-dsl-v4-contract-record" $ \out -> do+        result <- executeServiceScaffold out False "contract-v4.keiro" (parsedSourceLanguage parsed) ctx service modules+        result `shouldSatisfy` isRight+        contents <- TIO.readFile (out </> recordFileName (specContext spec))+        record <- maybe (expectationFailure "typed contract scaffold record did not parse" >> fail "unreachable") pure (parseRecord contents)+        recIdDomains record `shouldBe` identities+        parseRecord (contents <> "id-domain " <> duplicateIdentity <> "\n") `shouldBe` Nothing++      let manifest = "service hospital-capacity\nspec domain/contract.keiro\n"+          source = memoryContentSource (Map.fromList [("service.keiro-workspace", manifest), ("domain/contract.keiro", sourceText)])+      loaded <- loadWorkspace source "service.keiro-workspace"+      workspace <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure loaded+      workspacePlan <- either (\refusals -> expectationFailure (show refusals) >> fail "unreachable") pure (planWorkspaceScaffold "goldens" ctx workspace)+      case [provenance | (scaffoldModule, provenance) <- wpModules workspacePlan, modulePath scaffoldModule == "Generated/HospitalCapacity/Emergency/Contract.hs"] of+        [MemberOwned owner] -> owner `shouldBe` "domain/contract.keiro"+        values -> expectationFailure ("expected one member-owned contract module, got " <> show values)+      withTempDirectory "keiro-dsl-v4-contract-workspace-record" $ \out -> do+        result <- executeWorkspaceScaffold out False workspacePlan+        result `shouldSatisfy` isRight+        contents <- TIO.readFile (out </> workspaceRecordFileName (wsService workspace))+        record <- maybe (expectationFailure "typed contract workspace record did not parse" >> fail "unreachable") pure (parseWorkspaceRecord contents)+        wrIdDomains record `shouldBe` identities+        [(wrmPath row, wrmOwner row) | row <- wrModules record, wrmPath row == "Generated/HospitalCapacity/Emergency/Contract.hs"]+          `shouldBe` [("Generated/HospitalCapacity/Emergency/Contract.hs", Just "domain/contract.keiro")]+        parseWorkspaceRecord (contents <> "id-domain " <> duplicateIdentity <> "\n") `shouldBe` Nothing+    it "round-trips the contract spec through parse . pretty" $ do+      input <- readTestText "test/fixtures/contract.keiro"+      case parseSource "in" input of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure))+        Right source -> parseSource "in" (renderSource source) `shouldBe` Right source+    it "round-trips the intake (inbox) spec through parse . pretty" $ do+      input <- readTestText "test/fixtures/intake.keiro"+      case parseSpec "in" input of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec+    it "accepts the intake spec (complete disposition, no inversions)" $ do+      codes <- errorCodesOf "test/fixtures/intake.keiro"+      codes `shouldBe` []+    it "warns when intake bind flags describe unenforced generated behavior" $ do+      codes <- diagnosticCodesOf "test/fixtures/intake.keiro"+      codes `shouldContain` [IntakeBindFlagUnenforced]+    it "lowers explicit dedupe-only persistence and defaults omission to full-envelope" $ do+      spec <- specOf "test/fixtures/intake.keiro"+      ordinary <- specOf "test/fixtures/intake-decode.keiro"+      case ([intake | NIntake intake <- specNodes spec], [intake | NIntake intake <- specNodes ordinary]) of+        ([intake], [defaultIntake]) -> do+          inkPersist intake `shouldBe` InkPersistDedupeOnly+          inkPersist defaultIntake `shouldBe` InkPersistFull+          renderSpec spec `shouldSatisfy` T.isInfixOf "persist = dedupe-only"+          renderSpec ordinary `shouldNotSatisfy` T.isInfixOf "persist ="+          let inbox = generatedTextEndingIn "Inbox.hs" (scaffoldIntake (defaultContext (specContext spec)) intake)+          inbox `shouldSatisfy` T.isInfixOf "inboxPersistence = PersistDedupeOnly"+          inbox `shouldSatisfy` T.isInfixOf "data IncidentInboxOutcome"+          inbox `shouldSatisfy` T.isInfixOf "data IncidentInboxDisposition"+          inbox `shouldSatisfy` T.isInfixOf "InboxRetryAfter !RetryDelay !(Maybe InboxFailure)"+          inbox `shouldSatisfy` T.isInfixOf "InboxDeadLetter !(Maybe Text) !(Maybe InboxFailure)"+          inbox `shouldSatisfy` T.isInfixOf "InboxHandlerFailed reason attempts ->"+          inbox `shouldNotSatisfy` T.isInfixOf "Nothing -> InboxRetry"+        (intakes, defaultIntakes) ->+          expectationFailure ("expected one intake in each fixture, got " <> show (length intakes, length defaultIntakes))+    it "rejects duplicate => retry (inversion 1)" $ do+      codes <- errorCodesOf "test/fixtures/intake-dup-retry.keiro"+      codes `shouldContain` [DispositionDuplicateRetry]+    it "rejects previouslyFailed => retry (inversion 2)" $ do+      codes <- errorCodesOf "test/fixtures/intake-pf-retry.keiro"+      codes `shouldContain` [DispositionPreviouslyFailedRetry]+    it "rejects an incomplete disposition table" $ do+      codes <- errorCodesOf "test/fixtures/intake-incomplete.keiro"+      codes `shouldContain` [DispositionIncomplete]+    it "rejects a shadowing duplicate intake disposition row" $ do+      codes <- errorCodesOf "test/fixtures/intake-dup-row.keiro"+      codes `shouldContain` [DispositionDuplicateOutcome]+    it "rejects intake events declared on another topic" $ do+      codes <- errorCodesOf "test/fixtures/intake-topic-mismatch.keiro"+      codes `shouldContain` [TopicAffinityMismatch]+    it "round-trips the emit/publisher spec through parse . pretty" $ do+      input <- readTestText "test/fixtures/emit.keiro"+      case parseSpec "in" input of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec+    it "accepts the emit/publisher spec (skip present, coupling resolves)" $ do+      codes <- errorCodesOf "test/fixtures/emit.keiro"+      codes `shouldBe` []+    -- `derive … hole` is mandatory emit grammar, so a diagnostic saying it+    -- generates nothing would fire on every emit node in every spec and could+    -- never be resolved. It is the scaffold report's inert-node line (asserted+    -- immediately below) that carries the fact, once per run. See ExecPlan 199.+    it "leaves an emit-bearing spec clean enough for --deny-warnings" $ do+      (exitCode, out, err) <- runKeiroDsl ["check", "test/fixtures/emit.keiro", "--deny-warnings"]+      unless (exitCode == ExitSuccess) (expectationFailure (out <> err))+      err `shouldNotContain` "escalated to failure"+    it "reports emit nodes that contribute no generated modules" $+      withTempDirectory "keiro-dsl-inert-report" $ \out -> do+        spec <- specOf "test/fixtures/emit.keiro"+        report <- executePlannedScaffold out "test/fixtures/emit.keiro" (defaultContext (specContext spec)) spec+        reportInertNodes report `shouldBe` [("emit", "reservationResponse")]+        renderScaffoldReport report+          `shouldSatisfy` any+            ( T.isInfixOf+                "no-modules: emit reservationResponse (validated and diff-classified; no generated modules)"+            )+    it "rejects a missing _ => skip catch-all as EmitSkipMissing" $ do+      codes <- errorCodesOf "test/fixtures/emit-noskip.keiro"+      codes `shouldContain` [EmitSkipMissing]+    it "rejects mapping to an undeclared contract event as EmitUnresolvedContract" $ do+      codes <- errorCodesOf "test/fixtures/emit-badevent.keiro"+      codes `shouldContain` [EmitUnresolvedContract]+    it "rejects emit events declared on another topic" $ do+      codes <- errorCodesOf "test/fixtures/emit-topic-mismatch.keiro"+      codes `shouldContain` [TopicAffinityMismatch]++  describe "pgmq workqueue/dispatch (EP-5)" $ do+    it "round-trips the reservation-work spec through parse . pretty" $ do+      input <- readTestText "test/fixtures/reservation-work.keiro"+      case parseSpec "in" input of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec+    it "accepts the reservation-work spec (physical matches, no inversions)" $ do+      codes <- errorCodesOf "test/fixtures/reservation-work.keiro"+      codes `shouldBe` []+    it "rejects a divergent captured physical name as WqPhysicalDivergence" $ do+      codes <- errorCodesOf "test/fixtures/reservation-work-divergent.keiro"+      codes `shouldContain` [WqPhysicalDivergence]+    it "rejects storeFailure => deadLetter as WqStoreFailureNotRetry" $ do+      codes <- errorCodesOf "test/fixtures/reservation-work-sf-deadletter.keiro"+      codes `shouldContain` [WqStoreFailureNotRetry]+    it "rejects decodeFailure => retry as WqDecodeFailureNotDeadLetter" $ do+      codes <- errorCodesOf "test/fixtures/reservation-work-df-retry.keiro"+      codes `shouldContain` [WqDecodeFailureNotDeadLetter]+    it "requires complete, unique workqueue disposition rows" $ do+      incomplete <- errorCodesOf "test/fixtures/workqueue-incomplete.keiro"+      incomplete `shouldContain` [WqDispositionIncomplete]+      duplicateSpec <- specOf "test/fixtures/workqueue-dup-row.keiro"+      let duplicateDiagnostics = [d | d <- validateSpec duplicateSpec, code d == DispositionDuplicateOutcome]+      map line duplicateDiagnostics `shouldBe` [18]+    it "checks the captured queueRef dlq and table fixtures" $ do+      dlqCodes <- errorCodesOf "test/fixtures/workqueue-dlq-divergent.keiro"+      dlqCodes `shouldContain` [WqDlqDivergence]+      tableCodes <- errorCodesOf "test/fixtures/workqueue-table-divergent.keiro"+      tableCodes `shouldContain` [WqTableDivergence]+    it "matches queueRef for upper-case, punctuation, and hashed logical names" $ do+      upper <- errorCodesOf "test/fixtures/workqueue-uppercase-logical.keiro"+      upper `shouldBe` []+      hashed <- errorCodesOf "test/fixtures/workqueue-hashed-logical.keiro"+      hashed `shouldBe` []+      derivedQueueTrio "hospital_capacity.reservation_work.per_hospital_fifo_lane_assignments"+        `shouldBe` ( "hospital_capacity_reservat_757040df00976c33",+                     "hospital_capacity_reservat_757040df00976c33_dlq",+                     "pgmq.q_hospital_capacity_reservat_757040df00976c33"+                   )+    it "resolves dispatch dedup queues and payload wire fields" $ do+      ghost <- errorCodesOf "test/fixtures/dispatch-dedup-ghost-queue.keiro"+      ghost `shouldContain` [DispatchDedupQueueUnresolved]+      field <- errorCodesOf "test/fixtures/dispatch-dedup-bad-field.keiro"+      field `shouldContain` [DispatchDedupFieldUnresolved]+    it "requires a resolvable group key exactly when ordering is FIFO" $ do+      noKey <- errorCodesOf "test/fixtures/reservation-work-fifo-nokey.keiro"+      noKey `shouldContain` [WqGroupKeyMissing]+      unordered <- errorCodesOf "test/fixtures/reservation-work-key-unordered.keiro"+      unordered `shouldContain` [WqGroupKeyWithoutFifo]+      source <- readTestText "test/fixtures/reservation-work.keiro"+      unresolved <- parseInlineSpec "<unresolved-group-key>" (T.replace "group key from reservationId" "group key from missingId" source)+      map code (validateSpec unresolved) `shouldContain` [WqGroupKeyUnresolved]+    it "warns on unlogged storage and rejects empty partition settings" $ do+      warningCodes <- diagnosticCodesOf "test/fixtures/reservation-work-unlogged.keiro"+      warningCodes `shouldContain` [WqUnloggedDurability]+      partitionCodes <- errorCodesOf "test/fixtures/reservation-work-partitioned-empty.keiro"+      partitionCodes `shouldContain` [WqPartitionSpecEmpty]+    -- Every payload field is required — generated decoders use `o .:` for all of+    -- them — so the marker no longer selects anything. A source that omits it and+    -- a source that writes it describe the same queue and produce identical+    -- output. See ExecPlan 199.+    it "treats a payload field as required whether or not the marker is written" $ do+      unmarkedSource <- readTestText "test/fixtures/reservation-work-optfield.keiro"+      let bare = "    note -> \"note\" text"+          markedSource = T.replace bare (bare <> " required") unmarkedSource+      unmarkedSource `shouldSatisfy` T.isInfixOf bare+      parseSpec "unmarked" unmarkedSource `shouldBe` parseSpec "marked" markedSource+      errorCodesOf "test/fixtures/reservation-work-optfield.keiro" >>= (`shouldBe` [])+    it "lowers ordering, provisioning, and raw group-key projection" $ do+      spec <- specOf "test/fixtures/reservation-work.keiro"+      case [workqueue | NWorkqueue workqueue <- specNodes spec] of+        workqueue : _ -> do+          let modules = scaffoldWorkqueue (defaultContext (specContext spec)) workqueue+              queue = generatedTextEndingIn "Queue.hs" modules+              policy = generatedTextEndingIn "QueuePolicy.hs" modules+          queue `shouldSatisfy` T.isInfixOf "groupKeyFor payload = payload.reservationId"+          policy `shouldSatisfy` T.isInfixOf "jobOrdering = FifoThroughput"+          policy `shouldSatisfy` T.isInfixOf "withFifoIndexProvision (standardProvision)"+          policy `shouldSatisfy` T.isInfixOf "data ReservationWorkOutcome"+          policy `shouldSatisfy` T.isInfixOf "jobOutcomeFor :: ReservationWorkOutcome -> JobOutcome"+          policy `shouldNotSatisfy` T.isInfixOf "jobOutcomeFor :: Text -> JobOutcome"+          policy `shouldNotSatisfy` T.isInfixOf "  _ -> Retry"+          firewallBreaches modules `shouldBe` []+        [] -> expectationFailure "reservation-work fixture has no workqueue"++  describe "readmodel (EP-107)" $ do+    it "parses and round-trips first-class read models" $ do+      spec <- specOf "test/fixtures/readmodel.keiro"+      case [readModel | NReadModel readModel <- specNodes spec] of+        [subscriptionModel, inlineModel] -> do+          rmName subscriptionModel `shouldBe` "transfer_decisions"+          rmColumns subscriptionModel+            `shouldBe` [ RmColumn "reservation_id" "text" True,+                         RmColumn "hospital_id" "text" True,+                         RmColumn "status" "text" True,+                         RmColumn "decided_at" "timestamptz" False+                       ]+          legacyReadModelScope subscriptionModel `shouldBe` Just (RmCategory "reservation")+          legacyReadModelFeed subscriptionModel `shouldBe` Just RmSubscription+          legacyReadModelSubscription subscriptionModel `shouldBe` Just "hospital-capacity-transfer-decisions-sub"+          rmName inlineModel `shouldBe` "subscriptions"+          legacyReadModelScope inlineModel `shouldBe` Nothing+          legacyReadModelFeed inlineModel `shouldBe` Just RmInline+        nodes -> expectationFailure ("expected two readmodel nodes, got " <> show (length nodes))+      parseLanguage4RenderedSpec "in" spec `shouldBe` Right spec+    it "accepts an aggregate projection without a consistency clause" $ do+      spec <- parseInlineSpec "<projection-without-consistency>" projectionWithoutConsistencySpec+      case [projection | NAggregate aggregate <- specNodes spec, Just projection <- [aggProjection aggregate]] of+        [projection] -> projConsistency projection `shouldBe` Nothing+        projections -> expectationFailure ("expected one projection, got " <> show (length projections))+    it "pins the canonical UTF-8 shape digest and runtime identities" $ do+      spec <- specOf "test/fixtures/readmodel.keiro"+      case [readModel | NReadModel readModel <- specNodes spec] of+        (subscriptionModel : inlineModel : _) -> do+          canonicalShape subscriptionModel+            `shouldBe` "transfer_decisions|reservation_id:text:req|hospital_id:text:req|status:text:req|decided_at:timestamptz:null"+          deriveShapeHash subscriptionModel `shouldBe` "fnv1a:3717f6d9e3c44bd6"+          deriveShapeHash inlineModel `shouldBe` "fnv1a:f54d9bb2f40a6738"+          registryNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions"+          subscriptionNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions-sub"+          subscriptionNameFor "billing" inlineModel `shouldBe` "billing-subscriptions-sub"+        nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes))+    it "accepts the positive readmodel fixture with all references resolved" $ do+      spec <- specOf "test/fixtures/readmodel.keiro"+      validateSpec spec `shouldBe` []+    it "rejects shape drift and unknown SQL column types" $ do+      codes <- errorCodesOf "test/fixtures/readmodel-shape-drift.keiro"+      codes `shouldContain` [RmShapeHashDrift, RmUnknownColumnType]+    it "rejects Strong on inline and standalone projections" $ do+      inlineCodes <- errorCodesOf "test/fixtures/readmodel-strong-inline.keiro"+      inlineCodes `shouldContain` [RmStrongInlineOnly]+      standalone <- specOf "test/fixtures/readmodel-strong-standalone.keiro"+      let diagnostics = validateSpec standalone+      map code diagnostics `shouldContain` [RmStrongInlineOnly, RmProjectionWithoutNode]+      [severity diagnostic | diagnostic <- diagnostics, code diagnostic == RmProjectionWithoutNode]+        `shouldBe` [Warning]+    it "rejects scope without Strong and an unreferenced inline feed" $ do+      scopeCodes <- errorCodesOf "test/fixtures/readmodel-scope-eventual.keiro"+      scopeCodes `shouldContain` [RmScopeWithoutStrong]+      inlineCodes <- errorCodesOf "test/fixtures/readmodel-inline-unreferenced.keiro"+      inlineCodes `shouldContain` [RmInlineFeedUnreferenced]+    it "warns when an inline feed carries an ignored subscription override" $ do+      source <- readTestText "test/fixtures/readmodel.keiro"+      spec <-+        parseInlineSpec+          "<inline-subscription>"+          (T.replace "  feed = inline\n" "  feed = inline\n  subscription = \"ignored-subscription\"\n" source)+      diagnosticCodes spec `shouldContain` [RmInlineSubscriptionIgnored]+    it "rejects projection consistency conflicts" $ do+      codes <- errorCodesOf "test/fixtures/readmodel-consistency-conflict.keiro"+      codes `shouldContain` [RmConsistencyConflict]+    it "resolves query read models and validates query consistency" $ do+      codes <- errorCodesOf "test/fixtures/readmodel-query-unresolved.keiro"+      codes `shouldContain` [QueryUnresolvedReadModel, QueryConsistencyInvalid]+    it "resolves dispatch read models and declared dedup columns" $ do+      codes <- errorCodesOf "test/fixtures/readmodel-dispatch-unresolved.keiro"+      codes `shouldContain` [DispatchReadModelUnresolved, DispatchReadModelFieldUnknown]+    it "scaffolds runtime records, rebuild helpers, async wiring, and typed holes" $ do+      spec <- specOf "test/fixtures/readmodel.keiro"+      let ctx = defaultContext (specContext spec)+          readModels = [readModel | NReadModel readModel <- specNodes spec]+          modules = concatMap (scaffoldReadModel ctx) readModels+          transfer = generatedTextEndingIn "TransferDecisions/ReadModel.hs" modules+          inline = generatedTextEndingIn "Subscriptions/ReadModel.hs" modules+          transferHoles = [moduleText m | m <- modules, "TransferDecisions/ReadModelHoles.hs" `T.isSuffixOf` T.pack (modulePath m)]+      length modules `shouldBe` 6+      length [m | m <- modules, kind m == Generated] `shouldBe` 4+      length [m | m <- modules, kind m == HoleStub] `shouldBe` 2+      firewallBreaches modules `shouldBe` []+      transfer `shouldSatisfy` T.isInfixOf "registerTransferDecisions"+      transfer `shouldSatisfy` T.isInfixOf "Rebuild.startRebuild transferDecisionsReadModel [\"hospital-capacity-transfer-decisions-async\"]"+      transfer `shouldSatisfy` T.isInfixOf "strongScope = CategoryHead \"reservation\""+      transfer `shouldSatisfy` T.isInfixOf "transferDecisionsAsyncProjection"+      inline `shouldSatisfy` T.isInfixOf "Rebuild.startRebuild subscriptionsReadModel []"+      inline `shouldNotSatisfy` T.isInfixOf "AsyncProjection"+      transferHoles `shouldSatisfy` any (T.isInfixOf "RecordedEvent -> Tx.Transaction ()")+    it "threads qualified table and column guidance into aggregate projection holes" $ do+      spec <- specOf "test/fixtures/readmodel.keiro"+      case [aggregate | NAggregate aggregate <- specNodes spec] of+        [aggregate] -> do+          let modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate+              holes = [moduleText m | m <- modules, kind m == HoleStub]+              projection = generatedTextEndingIn "Projection.hs" modules+          holes `shouldSatisfy` any (T.isInfixOf "subscriptionsQualifiedTable")+          holes `shouldSatisfy` any (T.isInfixOf "Table: \"billing\".\"subscriptions\"")+          projection `shouldSatisfy` T.isInfixOf "ReadModelTable.subscriptionsQualifiedTable"+        aggregates -> expectationFailure ("expected one aggregate, got " <> show (length aggregates))+    it "emits runtime-free derivation facts for each read model" $ do+      spec <- specOf "test/fixtures/readmodel.keiro"+      case [readModel | NReadModel readModel <- specNodes spec] of+        (subscriptionModel : _) -> do+          let modules = harnessReadModel (defaultContext (specContext spec)) spec subscriptionModel+              harnessText = generatedTextEndingIn "ReadModelHarness.hs" modules+          length modules `shouldBe` 1+          firewallBreaches modules `shouldBe` []+          harnessText `shouldSatisfy` T.isInfixOf "{-# LANGUAGE OverloadedRecordDot #-}"+          harnessText `shouldSatisfy` T.isInfixOf "import Generated.HospitalCapacity.TransferDecisions.ReadModel (transferDecisionsReadModel, transferDecisionsAsyncProjection)"+          harnessText `shouldSatisfy` T.isInfixOf "(\"shapeHash\", \"fnv1a:3717f6d9e3c44bd6\", T.unpack transferDecisionsReadModel.shapeHash)"+          harnessText `shouldSatisfy` T.isInfixOf "(\"strongScope\", \"CategoryHead reservation\", renderStrongScope transferDecisionsReadModel.strongScope)"+          harnessText `shouldSatisfy` T.isInfixOf "T.unpack transferDecisionsAsyncProjection.name"+          harnessText `shouldSatisfy` T.isInfixOf "runReadModelFacts"+        nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes))++  describe "workflow/operation (EP-6)" $ do+    it "round-trips the workflow spec through parse . pretty" $ do+      input <- readTestText "test/fixtures/workflow.keiro"+      case parseSpec "in" input of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> parseLanguage4RenderedSpec "in" spec `shouldBe` Right spec+    it "accepts the workflow spec (await<->signal matches, run resolves)" $ do+      codes <- errorCodesOf "test/fixtures/workflow.keiro"+      codes `shouldBe` []+    it "rejects a signal label with no matching await as AwaitSignalMismatch" $ do+      codes <- errorCodesOf "test/fixtures/workflow-signal-mismatch.keiro"+      codes `shouldContain` [AwaitSignalMismatch]+    it "rejects duplicate workflow labels" $ do+      codes <- errorCodesOf "test/fixtures/workflow-dup-label.keiro"+      codes `shouldContain` [WorkflowDuplicateLabel]+    it "rejects unresolved workflow id and sleep fields" $ do+      codes <- errorCodesOf "test/fixtures/workflow-unresolved-fields.keiro"+      codes `shouldContain` [WorkflowIdFieldUnresolved, WorkflowSleepDelayUnresolved]+    it "validates rule domains, totality, case constructors, and bodies" $ do+      unresolved <- errorCodesOf "test/fixtures/rule-bad-domain.keiro"+      unresolved `shouldBe` [RuleDomainUnresolved]+      codes <- errorCodesOf "test/fixtures/rule-not-total.keiro"+      mapM_+        (\expected -> codes `shouldContain` [expected])+        [RuleNotTotal, RuleCaseUnknownCtor, ClockSampled, GuardAtomOutOfScope]+    it "rejects unresolved command operation references" $ do+      codes <- errorCodesOf "test/fixtures/operation-ghost-aggregate.keiro"+      codes `shouldContain` [OperationUnresolvedRef]+    it "rejects a signal value type that differs from its await" $ do+      codes <- errorCodesOf "test/fixtures/operation-signal-value.keiro"+      codes `shouldContain` [AwaitSignalValueMismatch]+    it "round-trips guarded patches and terminal continueAsNew" $ do+      input <- readTestText "test/fixtures/workflow-evolution.keiro"+      case parseSpec "workflow-evolution" input of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> do+          parseSpec "workflow-evolution" (renderSpec spec) `shouldBe` Right spec+          errorCodes spec `shouldBe` []+    it "rejects duplicate patch ids anywhere in the workflow body" $ do+      codes <- errorCodesOf "test/fixtures/workflow-patch-dup.keiro"+      codes `shouldBe` [WorkflowPatchDuplicate]+    it "rejects non-terminal and nested continueAsNew" $ do+      codes <- errorCodesOf "test/fixtures/workflow-can-mid.keiro"+      codes `shouldBe` [WorkflowContinueAsNewNotTerminal, WorkflowContinueAsNewNotTerminal]+    it "rejects a colon in a patch id with a workflow diagnostic" $ do+      codes <- errorCodesOf "test/fixtures/workflow-patch-colon.keiro"+      codes `shouldBe` [WorkflowPatchIdInvalid]+    it "lowers patch facts and live runtime declarations" $ do+      spec <- specOf "test/fixtures/workflow-evolution.keiro"+      case [workflow | NWorkflow workflow <- specNodes spec] of+        [workflow] -> do+          let modules = harnessWorkflow (defaultContext (specContext spec)) workflow+              facts = generatedTextEndingIn "WorkflowFacts.hs" modules+              runtime = generatedTextEndingIn "WorkflowRuntime.hs" modules+          facts `shouldSatisfy` T.isInfixOf "patch:fraud-check-v2(step:fraud-check)"+          facts `shouldSatisfy` T.isInfixOf "continueAsNew:RolloverSeed"+          facts `shouldSatisfy` T.isInfixOf "data WorkflowFacts = WorkflowFacts"+          facts `shouldSatisfy` T.isInfixOf "workflowFactBody = [\"step:create-transfer-hold\", \"patch:fraud-check-v2(step:fraud-check)\""+          facts `shouldSatisfy` T.isInfixOf "workflowFactAwaitLabels = [\"reservation-confirmation\"]"+          facts `shouldSatisfy` T.isInfixOf "workflowFactPatchIds = [\"fraud-check-v2\"]"+          runtime `shouldSatisfy` T.isInfixOf "data AwaitBinding = AwaitBinding StepName"+          runtime `shouldSatisfy` T.isInfixOf "reservationConfirmationAwait :: AwaitBinding"+          runtime `shouldSatisfy` T.isInfixOf "reservationConfirmationAwait = AwaitBinding (StepName \"reservation-confirmation\")"+          runtime `shouldSatisfy` T.isInfixOf "allocateDeclaredAwait (AwaitBinding label) = awakeableNamed label"+          runtime `shouldSatisfy` (not . T.isInfixOf "awaitAwakeableId")+          runtime `shouldSatisfy` (not . T.isInfixOf "generation0AwakeableId")+          runtime `shouldSatisfy` (not . T.isInfixOf "Awakeable.Compatibility")+          runtime `shouldSatisfy` T.isInfixOf "declaredPatches = Set.fromList [PatchId \"fraud-check-v2\"]"+          runtime `shouldSatisfy` T.isInfixOf "opts{activePatches = declaredPatches}"+        workflows -> expectationFailure ("expected one workflow, got " <> show (length workflows))+    it "rejects colliding await binding names, including an await nested under a patch" $ do+      spec <-+        parseInlineSpec "<workflow-await-binding-collision>" $+          T.unlines+            [ "language keiro-dsl 4",+              "context await-binding-collision",+              "workflow CollisionWorkflow",+              "  name \"collision-workflow\"",+              "  in Input",+              "  out Output",+              "  id from input via idText",+              "  body",+              "    patch nested-proof {",+              "      await foo-bar -> Text",+              "    }",+              "    await foo_bar -> Text"+            ]+      let collisions = [diagnostic | diagnostic <- validateSpec spec, code diagnostic == GeneratedOccurrenceCollision]+      length collisions `shouldBe` 1+      map message collisions `shouldSatisfy` any (T.isInfixOf "fooBarAwait")+      collisions `shouldSatisfy` all (not . null . relatedLocations)++  describe "replay impact" $ do+    it "treats new events and transitions as replay-neutral" $ do+      old <- specOf "test/fixtures/reservation.keiro"+      let aggregate = onlyAggregate old+      case (aggEvents aggregate, aggTransitions aggregate) of+        (event : _, transition : _) -> do+          let newEvent =+                event+                  { evName = "ReservationReviewed",+                    evLoc = noLoc+                  }+              newTransition =+                transition+                  { tEmits = ["ReservationReviewed"],+                    tLoc = noLoc+                  }+              new =+                modifyAggregate+                  "Reservation"+                  ( \candidate ->+                      candidate+                        { aggEvents = aggEvents candidate <> [newEvent],+                          aggTransitions = aggTransitions candidate <> [newTransition]+                        }+                  )+                  old+          replayImpactSpecs old new `shouldBe` ReplayNeutral+        _ -> expectationFailure "reservation fixture must contain an event and transition"++    it "narrows a guard edit to that transition's event types" $ do+      impact <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened.keiro"+      impact+        `shouldBe` ReplayAffected+          ( Map.singleton+              "Reservation"+              AggregateImpact+                { eventTypes = Set.singleton "TransferReservationCreated",+                  includeSnapshotStreams = True+                }+          )++    it "proves a syntactic guard loosening replay-neutral" $ do+      old <- specOf "test/fixtures/reservation.keiro"+      let loosened =+            modifyAggregate+              "Reservation"+              ( \aggregate ->+                  aggregate+                    { aggTransitions =+                        [ transition {tGuard = Nothing}+                        | transition <- aggTransitions aggregate+                        ]+                    }+              )+              old+      replayImpactSpecs old loosened `shouldBe` ReplayNeutral++    it "pairs guard-disambiguated siblings independently of both declaration orders" $ do+      base <- specOf "test/fixtures/reservation.keiro"+      let aggregate = onlyAggregate base+      case (aggTransitions aggregate, aggEvents aggregate) of+        (prototype : _, firstEvent : secondEvent : _) -> do+          let sibling guardExpression eventName =+                prototype+                  { tGuard = guardExpression,+                    tEmits = [eventName],+                    tLoc = noLoc+                  }+              commandOverride = EPath noLoc CommandRoot ["lifeCriticalOverride"]+              exact = sibling (Just (EAtom (ABool True))) (evName firstEvent)+              loosenedOld = sibling (Just commandOverride) (evName firstEvent)+              loosenedNew = sibling Nothing (evName firstEvent)+              changedOld = sibling (Just (ECmp OpEq commandOverride (ELiteral noLoc (LiteralBool False)))) (evName secondEvent)+              changedNew = sibling (Just (ECmp OpEq commandOverride (ELiteral noLoc (LiteralBool True)))) (evName firstEvent)+              oldSiblings = [exact, loosenedOld, changedOld]+              newSiblings = [exact, loosenedNew, changedNew]+              withTransitions transitions =+                modifyAggregate+                  (aggName aggregate)+                  (\candidate -> candidate {aggTransitions = transitions})+                  base+              impacts =+                [ replayImpactSpecs (withTransitions oldOrder) (withTransitions newOrder)+                | oldOrder <- permutations oldSiblings,+                  newOrder <- permutations newSiblings+                ]+          case impacts of+            firstImpact : remainingImpacts -> do+              remainingImpacts `shouldSatisfy` all (== firstImpact)+              firstImpact `shouldSatisfy` (/= ReplayNeutral)+            [] -> expectationFailure "permutations unexpectedly produced no replay comparisons"+        _ -> expectationFailure "reservation fixture must contain one transition and two events"++    it "marks every existing event when the aggregate wire convention changes" $ do+      impact <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-wire.keiro"+      case impact of+        ReplayAffected aggregates ->+          ReplayImpact.eventTypes <$> Map.lookup "Reservation" aggregates+            `shouldBe` Just (Set.fromList ["TransferReservationCreated", "TransferReservationConfirmed"])+        ReplayNeutral -> expectationFailure "expected a wire-clause replay impact"++    it "includes snapshot streams when a write expression changes" $ do+      impact <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-foldchange.keiro"+      case impact of+        ReplayAffected aggregates ->+          includeSnapshotStreams <$> Map.lookup "Reservation" aggregates+            `shouldBe` Just True+        ReplayNeutral -> expectationFailure "expected a fold replay impact"++    it "detects codec evolution and ignores formatting-only rewrites" $ do+      changed <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v2.keiro"+      changed `shouldSatisfy` (/= ReplayNeutral)+      old <- specOf "test/fixtures/reservation.keiro"+      formatted <- shouldParseStableRenderedSpec "<formatted>" old+      replayImpactSpecs old formatted `shouldBe` ReplayNeutral++    it "names mapped nested event and snapshot roots while ignoring Haskell-only changes" $ do+      nested <- replayImpactFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-nested-propagation.keiro"+      case nested of+        ReplayAffected aggregates ->+          Map.lookup "Catalog" aggregates+            `shouldBe` Just AggregateImpact {eventTypes = Set.singleton "ArtifactObserved", includeSnapshotStreams = True}+        ReplayNeutral -> expectationFailure "expected nested mapped wire change to affect replay"+      sourceOnly <- replayImpactFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-haskell-rename.keiro"+      sourceOnly `shouldBe` ReplayNeutral++    it "generates one context target for every aggregate, including the process saga" $ do+      spec <- specOf "test/fixtures/surge-service.keiro"+      case scaffoldReplayAudit (defaultContext (specContext spec)) spec of+        [assembly] -> do+          modulePath assembly `shouldBe` "Generated/SurgeDemo/ReplayAudit.hs"+          moduleText assembly `shouldSatisfy` T.isInfixOf "Hospital.hospitalEventStream"+          moduleText assembly `shouldSatisfy` T.isInfixOf "Surge.surgeEventStream"+          T.count "      AuditTarget" (moduleText assembly) `shouldBe` 2+        assemblies -> expectationFailure ("expected one replay-audit assembly, got " <> show (length assemblies))++  describe "diff (evolution classification)" $ do+    it "covers every node family exactly once and explains exclusions" $ do+      sort (map fst familyRegistry) `shouldBe` ([minBound .. maxBound] :: [NodeFamily])+      [reason | (_, OutOfDiffScope reason) <- familyRegistry, T.null reason] `shouldBe` []+    it "reports checked mapped consumers separately from compatibility findings" $ do+      old <- specOf "test/fixtures/semantic-impact.keiro"+      let new = mapMappedStructural "NestedPayload" changeMappedCanonical old+          changes = diffSpecs old new+          impact = CheckedDiff.mappedSemanticImpact old new+          rendered = T.unlines (renderSemanticImpact impact)+          encoded = LazyText.toStrict (LazyTextEncoding.decodeUtf8 (Aeson.encode (diffReportWithSemanticImpact defaultGate changes impact)))+      map impactDeclaration impact `shouldBe` [MappedKey "NestedPayload"]+      rendered `shouldSatisfy` T.isInfixOf "previous aggregate consumers: Alpha"+      rendered `shouldSatisfy` T.isInfixOf "current aggregate consumers:  Alpha"+      rendered `shouldSatisfy` T.isInfixOf "service-conformance: impacted"+      rendered `shouldSatisfy` (not . T.isInfixOf "Beta")+      encoded `shouldSatisfy` T.isInfixOf "\"semanticImpact\""+      encoded `shouldSatisfy` T.isInfixOf "\"previousConsumers\":[\"Alpha\"]"+      let reordered = old {specMapped = reverse (specMapped old), specNodes = reverse (specNodes old)}+      CheckedDiff.mappedSemanticImpact old reordered `shouldBe` []+    it "reports added, removed, and unused mapped declarations without inventing aggregate consumers" $ do+      let declarationA = completeStructural "A" (recordShape [TText])+          declarationB = completeStructural "B" (recordShape [TInt])+          onlyA = mappedSpec [declarationA]+          withB = mappedSpec [declarationA, declarationB]+          added = CheckedDiff.mappedSemanticImpact onlyA withB+          removed = CheckedDiff.mappedSemanticImpact withB onlyA+          expectedB = MappedKey "B"+      map impactDeclaration added `shouldBe` [expectedB]+      map impactPreviousConsumers added `shouldBe` [Set.empty]+      map impactCurrentConsumers added `shouldBe` [Set.empty]+      map impactServiceConformance added `shouldBe` [True]+      map impactDeclaration removed `shouldBe` [expectedB]+      map impactPreviousConsumers removed `shouldBe` [Set.empty]+      map impactCurrentConsumers removed `shouldBe` [Set.empty]+      map impactServiceConformance removed `shouldBe` [True]++      old <- specOf "test/fixtures/semantic-impact.keiro"+      let changed = mapMappedStructural "UnusedPayload" changeMappedCanonical old+          unusedImpact = CheckedDiff.mappedSemanticImpact old changed+      map impactDeclaration unusedImpact `shouldBe` [MappedKey "UnusedPayload"]+      map impactPreviousConsumers unusedImpact `shouldBe` [Set.empty]+      map impactCurrentConsumers unusedImpact `shouldBe` [Set.empty]+      map impactServiceConformance unusedImpact `shouldBe` [True]+    it "derives every exercised headline from its vector under the default gate" $ do+      changes <-+        concat+          <$> mapM+            (uncurry diffFixtures)+            [ ("test/fixtures/reservation.keiro", "test/fixtures/reservation-fieldadd.keiro"),+              ("test/fixtures/reservation.keiro", "test/fixtures/reservation-v2.keiro"),+              ("test/fixtures/reservation.keiro", "test/fixtures/reservation-enumadd.keiro"),+              ("test/fixtures/contract.keiro", "test/fixtures/contract-fieldadd.keiro"),+              ("test/fixtures/reservation-work.keiro", "test/fixtures/reservation-work-rename.keiro")+            ]+      forM_ changes $ \change ->+        do+          deriveLabel defaultGate (ckVector (kindOfChange change))+            `shouldBe` labelOfChange change+          gatedBreaking defaultGate change `shouldBe` isBreaking change+    it "never removes a breaking result when the gate grows" $+      property $+        forAll genCompatibilityVector $ \compatibility ->+          forAll genSurfaceSet $ \gate ->+            forAll genSurfaceSet $ \extra ->+              deriveLabel gate compatibility+                == LabelBreaking+                  ==> deriveLabel (gate <> extra) compatibility+                == LabelBreaking+    it "renders the consumer-neutral matrix with separate private, snapshot, and public surfaces" $ do+      changes <- diffFixtures "test/fixtures/compatibility-vector-old.keiro" "test/fixtures/compatibility-vector-new.keiro"+      let rendered = T.intercalate "\n" (map renderFinding changes)+          explained = T.intercalate "\n" (map renderExplainBlock changes)+          reportJson = T.pack (show (Aeson.toJSON (diffReport defaultGate changes)))+      assertMatchesGolden "test/fixtures/compatibility-vector.diff.golden" rendered+      rendered `shouldSatisfy` T.isInfixOf "Reservation.event.TransferReservationCreated.patientAcuity"+      rendered `shouldSatisfy` T.isInfixOf "old-binary-read-new-events=breaking"+      rendered `shouldSatisfy` T.isInfixOf "snapshot-hydration=advisory"+      rendered `shouldSatisfy` T.isInfixOf "public-consumer=breaking"+      explained `shouldSatisfy` T.isInfixOf "invalidate and rebuild snapshots"+      reportJson `shouldSatisfy` T.isInfixOf "keiro-dsl/diff-report/1"+      reportJson `shouldSatisfy` T.isInfixOf "Reservation.event.TransferReservationCreated.patientAcuity"+      let eventEnumFindings =+            [ change+            | change@(Advisory kind) <- changes,+              ckCode kind == EnumCtorAdded,+              verdictFor OldBinaryReadNewEvents (ckVector kind) == VBreaking+            ]+      eventEnumFindings `shouldSatisfy` all (not . gatedBreaking defaultGate)+      eventEnumFindings `shouldSatisfy` all (gatedBreaking (gateWith [OldBinaryReadNewEvents]))+      forM_ changes $ \change ->+        remediationFor (ckContext (kindOfChange change)) (ckCode (kindOfChange change))+          `shouldSatisfy` (not . null)+    it "rejects unknown --gate values with the valid surface list" $ do+      parseSurfaceName "mystery-surface"+        `shouldSatisfy` either (T.isInfixOf "old-binary-read-new-events" . T.pack) (const False)+    it "covers the mapped evolution matrix with stable codes and non-empty remedies" $ do+      let cases =+            [ ("consumer-types-fieldadd-default.keiro", MappedFieldAddedWithDefault),+              ("consumer-types-fieldadd-nodefault.keiro", MappedFieldAddedNoDefault),+              ("consumer-types-fieldremove.keiro", MappedFieldRemoved),+              ("consumer-types-wirekey.keiro", MappedWireKeyChanged),+              ("consumer-types-haskell-rename.keiro", MappedHaskellSourceChanged),+              ("consumer-types-binding-change.keiro", MappedBindingChanged),+              ("consumer-types-fixtures-change.keiro", MappedFixturesChanged),+              ("consumer-types-initial-change.keiro", MappedInitialChanged),+              ("consumer-types-armadd.keiro", MappedArmAdded),+              ("consumer-types-tagchange.keiro", MappedArmTagChanged),+              ("consumer-types-enumadd.keiro", MappedEnumValueAdded),+              ("consumer-types-enumremove.keiro", MappedEnumValueRemoved),+              ("consumer-types-enumspelling.keiro", MappedEnumSpellingChanged),+              ("consumer-types-encoding.keiro", MappedUnionEncodingChanged),+              ("consumer-types-opaque-version.keiro", MappedOpaqueCodecChanged),+              ("consumer-types-mode-cross.keiro", MappedModeCrossed),+              ("consumer-types-nested-propagation.keiro", MappedArmTagChanged)+            ]+      forM_ cases $ \(fixture, expectedCode) -> do+        changes <- diffFixtures "test/fixtures/consumer-types.keiro" ("test/fixtures/" <> fixture)+        map (ckCode . kindOfChange) changes `shouldContain` [expectedCode]+        forM_ changes $ \change ->+          remediationFor (ckContext (kindOfChange change)) (ckCode (kindOfChange change))+            `shouldSatisfy` (not . null)+    it "separates mapped event migration, snapshot invalidation, and directional rollout" $ do+      breakingAdd <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-fieldadd-nodefault.keiro"+      let noDefault = [change | change <- breakingAdd, ckCode (kindOfChange change) == MappedFieldAddedNoDefault]+      [ckFacet kind | Breaking kind <- noDefault] `shouldContain` ["mapped-event"]+      [ckFacet kind | Advisory kind <- noDefault] `shouldContain` ["mapped-register"]+      defaulted <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-fieldadd-default.keiro"+      [change | change <- defaulted, isBreaking change] `shouldBe` []+      let eventDefaults = [kind | Advisory kind <- defaulted, ckCode kind == MappedFieldAddedWithDefault, ckFacet kind == "mapped-event"]+      eventDefaults `shouldSatisfy` any ((== VBreaking) . verdictFor OldBinaryReadNewEvents . ckVector)+      armAdded <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-armadd.keiro"+      [change | change <- armAdded, isBreaking change] `shouldBe` []+      [kind | Advisory kind <- armAdded, ckCode kind == MappedArmAdded, ckFacet kind == "mapped-event"]+        `shouldSatisfy` any ((== VBreaking) . verdictFor OldBinaryReadNewEvents . ckVector)+    it "classifies mapped queue history without borrowing event or snapshot surfaces" $ do+      source <- mappedConsumerSurfaceSource+      base <- parseInlineSpec "<mapped-queue-diff-old>" source+      let candidate = mapArtifactNamedField "key" (\field -> field {wfKey = "artifact_key_v2"}) base+          queueFindings =+            [ kind+            | change <- diffSpecs base candidate,+              let kind = kindOfChange change,+              ckFacet kind == "mapped-workqueue"+            ]+      queueFindings `shouldSatisfy` (not . null)+      forM_ queueFindings $ \kind -> do+        verdictFor PrivateHistoryRead (ckVector kind) `shouldBe` VNotApplicable+        verdictFor OldBinaryReadNewEvents (ckVector kind) `shouldBe` VNotApplicable+        verdictFor SnapshotHydration (ckVector kind) `shouldBe` VNotApplicable+        verdictFor ConsumerBuild (ckVector kind) `shouldBe` VBreaking+        cvRollout (ckVector kind) `shouldBe` Set.fromList [RolloutWorkersFirst, RolloutDrainRequired]+        ckMappedPersistedImpact kind+          `shouldBe` Just (MappedPersistedImpact (WorkqueueHistory "ArtifactJobs") VBreaking)+        ckDetail kind `shouldSatisfy` T.isInfixOf "schema-version-1 history"+        remediationFor (ckContext kind) (ckCode kind)+          `shouldSatisfy` all (`elem` [RemedyDeploymentOrder RolloutWorkersFirst, RemedyDrainWorkqueue, RemedyTransitionalQueueCodec, RemedyRecompileConsumers, RemedyRunConformance])+    it "propagates a nested mapped leaf to complete command, event, and register paths" $ do+      changes <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-nested-propagation.keiro"+      let subjects =+            [ ckSubject kind+            | change <- changes,+              let kind = kindOfChange change,+              ckCode kind == MappedArmTagChanged+            ]+      subjects+        `shouldContain` [ "Catalog command ObserveArtifact .artifact : ArtifactInfo .location : ArtifactLocation .arm RepoPath[\"repository_path\"]",+                          "Catalog event ArtifactObserved .artifact : ArtifactInfo .location : ArtifactLocation .arm RepoPath[\"repository_path\"]",+                          "Catalog register currentArtifact : ArtifactInfo .location : ArtifactLocation .arm RepoPath[\"repository_path\"]"+                        ]+    it "classifies every remaining mapped field and declaration evolution row" $ do+      base <- specOf "test/fixtures/consumer-types.keiro"+      let mutationCodes =+            [ (mapArtifactNamedField "key" (\field -> field {wfType = TInt}) base, MappedFieldTypeChanged),+              (mapArtifactNamedField "key" (\field -> field {wfPresence = POptional, wfOnMissing = Just (OmText "")}) base, MappedPresenceChanged),+              (mapArtifactNamedField "key" (\field -> field {wfType = TOptional TText}) base, MappedNullabilityChanged),+              (mapArtifactNamedField "description" (\field -> field {wfOnMissing = Nothing}) base, MappedDefaultRemoved),+              (mapArtifactNamedField "count" (\field -> field {wfOnMissing = Just (OmInt 1)}) base, MappedDefaultChanged),+              (mapMappedStructural "ArtifactInfo" renameMappedRecordConstructor base, MappedRecordConstructorChanged),+              (mapMappedStructural "ArtifactInfo" changeMappedCanonical base, MappedCanonicalTypeChanged)+            ]+      forM_ mutationCodes $ \(candidate, expectedCode) ->+        map (ckCode . kindOfChange) (diffSpecs base candidate) `shouldContain` [expectedCode]+      let declarationA = completeStructural "A" (recordShape [TText])+          declarationB = completeStructural "B" (recordShape [TInt])+          onlyA = mappedSpec [declarationA]+          withB = mappedSpec [declarationA, declarationB]+      map (ckCode . kindOfChange) (diffSpecs onlyA withB) `shouldContain` [MappedDeclAdded]+      map (ckCode . kindOfChange) (diffSpecs withB onlyA) `shouldContain` [MappedDeclRemoved]+      diffSpecs base (mapArtifactNamedField "key" (\field -> field {wfHaskell = "renamedKey"}) base)+        `shouldSatisfy` \case+          [Advisory change] -> ckCode change == GeneratedHaskellNameChanged+          _ -> False+    it "visits every mapped wire mutation and reports every complete root path" $ do+      base <- specOf "test/fixtures/consumer-types.keiro"+      let mutations = mappedWireMutations base+      mutations `shouldSatisfy` (not . null)+      visited <- fmap Set.unions . forM mutations $ \mutation -> do+        let changes =+              [ change+              | change <- diffSpecs base (mmCandidate mutation),+                ckCode (kindOfChange change) == mmCode mutation+              ]+            actualSubjects = Set.fromList (map (ckSubject . kindOfChange) changes)+        changes `shouldSatisfy` any (not . isAdditiveChange)+        actualSubjects `shouldBe` mmExpectedSubjects mutation+        pure actualSubjects+      visited `shouldBe` Set.unions (map mmExpectedSubjects mutations)+    it "reports the exact ingredient code when every required mapped fact is deleted" $ do+      base <- specOf "test/fixtures/consumer-types.keiro"+      forM_ (mappedIngredientMutations base) $ \(candidate, expectedCode) ->+        errorCodes candidate `shouldContain` [expectedCode]+    it "classifies a field added without a version bump as BREAKING" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldadd.keiro"+      any isBreaking cs `shouldBe` True+      [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldAddedWithoutBump]+    it "classifies the same field wrapped as v2 + upcaster as ADDITIVE" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v2.keiro"+      any isBreaking cs `shouldBe` False+      [ck | Additive ck <- cs] `shouldSatisfy` any ((== "TransferReservationCreated") . ckSubject)+    it "reports no breaking change when the spec is unchanged" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation.keiro"+      any isBreaking cs `shouldBe` False+    it "classifies a direct event field type change as EvtFieldTypeChanged" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldtype.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldTypeChanged]+    it "resolves fields(Command) before comparing event field types" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-cmdfieldtype.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldTypeChanged]+    it "uses EvtFieldRemovedSameVersion for an unchanged-version removal" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldremove.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldRemovedSameVersion]+    it "classifies selector aliases as build-only and wire aliases as replay-affecting" $ do+      let sourceFor field =+            T.unlines+              [ "language keiro-dsl 4",+                "context field-alias-diff",+                "aggregate AliasDiff",+                "  regs",+                "  states Open",+                "  command Observe { " <> field <> " }",+                "  event Observed = fields(Observe)",+                "  wire kind=ctorName fields=camelCase schemaVersion=1"+              ]+      base <- checkedServiceFromText "field-alias-diff-base.keiro" (sourceFor "region:Text")+      selectorAlias <- checkedServiceFromText "field-alias-diff-selector.keiro" (sourceFor "region haskell serviceRegion:Text")+      wireAlias <- checkedServiceFromText "field-alias-diff-wire.keiro" (sourceFor "region as \"region_code\":Text")+      let selectorChanges = diffServices base selectorAlias+          wireChanges = diffServices base wireAlias+          selectorFindings = [finding | Advisory finding <- selectorChanges, ckCode finding == GeneratedHaskellNameChanged]+          wireFindings = [finding | Breaking finding <- wireChanges, ckCode finding == EvtFieldWireKeyChanged]+      selectorChanges `shouldSatisfy` all (not . isBreaking)+      map ckFacet selectorFindings `shouldContain` ["command-field-selector", "event-field-selector"]+      map (verdictFor ConsumerBuild . ckVector) selectorFindings `shouldSatisfy` all (== VAdvisory)+      resolvedFold (ReplayImpact.replayImpactServices base selectorAlias) `shouldBe` ReplayNeutral+      case wireFindings of+        [finding] -> do+          ckSubject finding `shouldBe` "Observed.region"+          verdictFor PrivateHistoryRead (ckVector finding) `shouldBe` VBreaking+          verdictFor OldBinaryReadNewEvents (ckVector finding) `shouldBe` VBreaking+          ckDetail finding `shouldSatisfy` T.isInfixOf "'region' -> 'region_code'"+        findings -> expectationFailure ("expected one event wire-key finding, got " <> show findings)+      resolvedFold (ReplayImpact.replayImpactServices base wireAlias)+        `shouldSatisfy` \case+          ReplayAffected impacts ->+            maybe False ((== Set.singleton "Observed") . ReplayImpact.eventTypes) (Map.lookup "AliasDiff" impacts)+          ReplayNeutral -> False+    it "retains event selector advisories across a legal version bump" $ do+      let sourceFor eventDeclaration =+            T.unlines+              [ "language keiro-dsl 4",+                "context field-alias-version-diff",+                "aggregate AliasVersionDiff",+                "  regs",+                "  states Open",+                "  command Observe {}",+                eventDeclaration+              ]+      base <- checkedServiceFromText "field-alias-version-base.keiro" (sourceFor "  event Observed { region:Text }")+      bumped <-+        checkedServiceFromText+          "field-alias-version-bumped.keiro"+          (sourceFor "  event Observed v2 { region haskell serviceRegion:Text }\n    upcast from v1 = HOLE")+      let changes = diffServices base bumped+          selectorFindings = [finding | Advisory finding <- changes, ckCode finding == GeneratedHaskellNameChanged]+      [ckCode finding | Additive finding <- changes] `shouldContain` [VersionBumped]+      map ckFacet selectorFindings `shouldBe` ["event-field-selector"]+      map (verdictFor ConsumerBuild . ckVector) selectorFindings `shouldBe` [VAdvisory]+    it "classifies contract selector aliases separately from public wire changes" $ do+      let sourceFor field =+            T.unlines+              [ "language keiro-dsl 4",+                "context contract-field-alias-diff",+                "contract emergency {",+                "  schemaVersion 1",+                "  discriminator messageType",+                "  topic events \"emergency.events\"",+                "  event IncidentDeclared on events {",+                "    " <> field,+                "  }",+                "}"+              ]+      base <- checkedServiceFromText "contract-field-alias-base.keiro" (sourceFor "region: text")+      selectorAlias <- checkedServiceFromText "contract-field-alias-selector.keiro" (sourceFor "region haskell serviceRegion: text")+      wireAlias <- checkedServiceFromText "contract-field-alias-wire.keiro" (sourceFor "region as \"region_code\": text")+      let selectorChanges = diffServices base selectorAlias+          wireChanges = diffServices base wireAlias+      selectorChanges `shouldSatisfy` \case+        [Advisory finding] ->+          ckCode finding == GeneratedHaskellNameChanged+            && ckFacet finding == "contract-field-selector"+            && verdictFor ConsumerBuild (ckVector finding) == VAdvisory+        _ -> False+      case [finding | Breaking finding <- wireChanges, ckCode finding == ContractFieldChanged] of+        [finding] -> do+          verdictFor PublicConsumer (ckVector finding) `shouldBe` VBreaking+          cvRollout (ckVector finding) `shouldBe` Set.singleton RolloutProducerLast+          ckDetail finding `shouldSatisfy` T.isInfixOf "consumer-first rollout"+        findings -> expectationFailure ("expected one contract wire-key finding, got " <> show findings)+    it "keeps an alias-free field rename on the existing add/remove path" $ do+      let sourceFor field =+            T.unlines+              [ "language keiro-dsl 4",+                "context field-rename-diff",+                "aggregate RenameDiff",+                "  regs",+                "  states Open",+                "  event Renamed { " <> field <> ":Text }",+                "  wire kind=ctorName fields=camelCase schemaVersion=1"+              ]+      old <- checkedServiceFromText "field-rename-old.keiro" (sourceFor "region")+      new <- checkedServiceFromText "field-rename-new.keiro" (sourceFor "zone")+      let changes = diffServices old new+      [ckCode finding | Breaking finding <- changes]+        `shouldContain` [EvtFieldAddedWithoutBump, EvtFieldRemovedSameVersion]+      [finding | Advisory finding <- changes, ckCode finding == GeneratedHaskellNameChanged]+        `shouldBe` []+    it "uses EvtVersionDecreased for a version decrease" $ do+      cs <- diffFixtures "test/fixtures/reservation-v2.keiro" "test/fixtures/reservation.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [EvtVersionDecreased]+    it "rejects a v1 to v3 jump whose only upcaster starts at v2" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v3-dangling.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [EvtVersionMissingUpcaster]+    it "classifies a vanished historical upcaster rung as UpcasterChainGap" $ do+      cs <- diffFixtures "test/fixtures/reservation-v2.keiro" "test/fixtures/reservation-chain-gap.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [UpcasterChainGap]+    it "classifies an enum constructor removal as EnumCtorRemoved" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumdrop.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [EnumCtorRemoved]+    it "classifies an enum wire-spelling change as EnumWireSpellingChanged" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumwire.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [EnumWireSpellingChanged]+    it "classifies an enum constructor addition per use site as advisory" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumadd.keiro"+      any isBreaking cs `shouldBe` False+      let enumFindings = [k | Advisory k <- cs, ckCode k == EnumCtorAdded]+      [ckSubject k | k <- enumFindings] `shouldContain` ["BlackTag"]+      [verdictFor SnapshotHydration (ckVector k) | k <- enumFindings]+        `shouldContain` [VAdvisory]+    it "classifies an effective wire convention change as WireSpecChanged" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-wire.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [WireSpecChanged]+    it "advises when the aggregate fold surface changes" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-foldchange.keiro"+      any isBreaking cs `shouldBe` False+      [ckCode k | Advisory k <- cs] `shouldContain` [AggFoldSurfaceChanged]+    it "advises on hazardous deprecation and reports un-deprecation" $ do+      deprecated <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-deprecated.keiro"+      any isBreaking deprecated `shouldBe` False+      [ckCode k | Advisory k <- deprecated] `shouldContain` [DeprecatedEventReplayHazard]+      restored <- diffFixtures "test/fixtures/reservation-deprecated.keiro" "test/fixtures/reservation.keiro"+      any isAdvisory restored `shouldBe` True+      [ckCode k | Advisory k <- restored] `shouldContain` [EventUndeprecated]+    it "recognises replay-only deprecation as a replay-safe retirement cutover" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-deprecated-replay-only.keiro"+      any isBreaking cs `shouldBe` False+      [ckCode k | Advisory k <- cs] `shouldContain` [EventRetirementInProgress]+      [ckCode k | Advisory k <- cs] `shouldNotContain` [DeprecatedEventReplayHazard]+    it "advises when event retirement starts" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-retiring.keiro"+      any isBreaking cs `shouldBe` False+      [ckCode k | Advisory k <- cs] `shouldContain` [EventRetirementInProgress]+    it "does not recommend decode-only deprecation for an event removal" $ do+      old <- specOf "test/fixtures/reservation.keiro"+      let new =+            old+              { specNodes =+                  [ case node of+                      NAggregate aggregate ->+                        NAggregate+                          aggregate+                            { aggEvents =+                                [ event+                                | event <- aggEvents aggregate,+                                  evName event /= "TransferReservationConfirmed"+                                ],+                              aggTransitions =+                                [ transition {tEmits = filter (/= "TransferReservationConfirmed") (tEmits transition)}+                                | transition <- aggTransitions aggregate+                                ]+                            }+                      _ -> node+                  | node <- specNodes old+                  ]+              }+          removals = [change | change@(Breaking kind) <- diffSpecs old new, ckCode kind == EvtRemovedNotDeprecated]+      removals `shouldSatisfy` (not . null)+      [ckDetail kind | Breaking kind <- removals]+        `shouldSatisfy` all (not . T.isInfixOf "so old payloads still decode")+    it "prints a paste-ready replay-only twin when a guard tightens (plan 143)" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened.keiro"+      any isBreaking cs `shouldBe` False+      let advisories = [k | Advisory k <- cs, ckCode k == AggGuardTightened]+      map ckSubject advisories `shouldBe` ["Unrequested -- RequestTransferReservation"]+      detail <- case advisories of+        [k] -> pure (ckDetail k)+        other -> expectationFailure ("expected one advisory, got " <> show other) >> pure ""+      detail `shouldSatisfy` T.isInfixOf "replay-only Unrequested -- RequestTransferReservation"+      -- The printed twin is paste-ready: appended to the new spec it+      -- parses, validates without errors, and silences the advisory.+      tightened <- readTestText "test/fixtures/reservation-guard-tightened.keiro"+      let twinText = snd (T.breakOnEnd "\n\n" detail)+          pasted = tightened <> "\n" <> twinText <> "\n"+      case parseSpec "<pasted-twin>" pasted of+        Left err -> expectationFailure (T.unpack err)+        Right pastedSpec -> do+          [code d | d <- validateSpec pastedSpec, severity d == Error] `shouldBe` []+          base <- specOf "test/fixtures/reservation.keiro"+          [k | Advisory k <- diffSpecs base pastedSpec, ckCode k == AggGuardTightened]+            `shouldBe` []+    it "omits the twin advisory when the twin is already present (plan 143)" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened-twin.keiro"+      [k | Advisory k <- cs, ckCode k == AggGuardTightened] `shouldBe` []+    it "classifies a removed contract event as ContractEventRemoved" $ do+      cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventdrop.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [ContractEventRemoved]+    it "classifies contract field type changes and unversioned additions as ContractFieldChanged" $ do+      changed <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldtype.keiro"+      [ckCode k | Breaking k <- changed] `shouldContain` [ContractFieldChanged]+      added <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldadd.keiro"+      [ckCode k | Breaking k <- added] `shouldContain` [ContractFieldChanged]+    it "goldens language-3 to language-4 contract TypeID admission and rollout" $ do+      let source versionNumber prefix =+            T.unlines+              [ "language keiro-dsl " <> T.pack (show versionNumber),+                "context hospital-capacity",+                "contract emergency {",+                "  schemaVersion 1",+                "  discriminator messageType",+                "  topic incidentEvents \"emergency.incident.events\"",+                "  event IncidentTransferNeedDeclared on incidentEvents {",+                "    incidentId: typeid \"" <> prefix <> "\"",+                "  }",+                "}"+              ]+          checked name input = case parseSource name input of+            Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+            Right parsed -> pure (checkedSource parsed)+      v1 <- checked "contract-typeid-v1.keiro" (source (1 :: Int) "inc")+      v3 <- checked "contract-typeid-v3.keiro" (source (3 :: Int) "inc")+      v4 <- checked "contract-typeid-v4.keiro" (source (4 :: Int) "inc")+      v4Edited <- checked "contract-typeid-v4-edited.keiro" (source (4 :: Int) "rsv")+      let changes = diffServices v3 v4+          textGolden = T.intercalate "\n" (map renderFinding changes)+          jsonGolden = LazyText.toStrict (LazyTextEncoding.decodeUtf8 (Aeson.encode (diffReport defaultGate changes)))+          findings = [kind | Breaking kind <- changes, ckCode kind == ContractTypeIdDomainChanged]+      assertMatchesGolden "test/fixtures/contract-typeid-domain.diff.golden" textGolden+      assertMatchesGolden "test/fixtures/contract-typeid-domain.diff.json.golden" jsonGolden+      case findings of+        [finding] -> do+          verdictFor PublicConsumer (ckVector finding) `shouldBe` VBreaking+          verdictFor ConsumerBuild (ckVector finding) `shouldBe` VBreaking+          [verdictFor surface (ckVector finding) | surface <- [PrivateHistoryRead, OldBinaryReadNewEvents, SnapshotHydration, PersistedIdentity]]+            `shouldBe` replicate 4 VNotApplicable+          cvRollout (ckVector finding) `shouldBe` Set.fromList [RolloutDrainRequired, RolloutProducerFirst]+          deriveLabel (Set.singleton PublicConsumer) (ckVector finding) `shouldBe` LabelBreaking+          deriveLabel (Set.singleton ConsumerBuild) (ckVector finding) `shouldBe` LabelBreaking+          remediationFor (ckContext finding) (ckCode finding)+            `shouldBe` RemedyEmitContractTypeIdDomain :| [RemedyDrainLegacyInvalidContractMessages, RemedyRescaffoldContractConsumers, RemedyRunContractConformance]+        values -> expectationFailure ("expected one contract TypeID-domain finding, got " <> show (length values))+      [kind | change <- diffServices v1 v3, let { kind = kindOfChange change }, ckCode kind == ContractTypeIdDomainChanged] `shouldBe` []+      [kind | change <- diffServices v4 v4, let { kind = kindOfChange change }, ckCode kind == ContractTypeIdDomainChanged] `shouldBe` []+      let edited = diffServices v3 v4Edited+      map (ckCode . kindOfChange) edited `shouldContain` [ContractFieldChanged]+      [kind | change <- edited, let { kind = kindOfChange change }, ckCode kind == ContractTypeIdDomainChanged] `shouldBe` []+    it "reports a field addition with a contract version bump as an advisory" $ do+      cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-bump-fieldadd.keiro"+      any isBreaking cs `shouldBe` False+      [ckCode k | Advisory k <- cs] `shouldContain` [ContractSchemaVersionBumped]+    it "classifies a contract schema version decrease separately" $ do+      cs <- diffFixtures "test/fixtures/contract-bump-fieldadd.keiro" "test/fixtures/contract.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [ContractSchemaVersionDecreased]+    it "classifies contract topic and discriminator changes separately" $ do+      topic <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-topic.keiro"+      [ckCode k | Breaking k <- topic] `shouldContain` [ContractTopicChanged]+      discriminator <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-discriminator.keiro"+      [ckCode k | Breaking k <- discriminator] `shouldContain` [ContractDiscriminatorChanged]+    it "classifies a new contract event as additive" $ do+      cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventadd.keiro"+      any isBreaking cs `shouldBe` False+      [ckSubject k | Additive k <- cs] `shouldContain` ["IncidentTransferNeedCancelled"]+    it "classifies workqueue wire names, types, and required additions as WqPayloadFieldChanged" $ do+      wire <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-wirename.keiro"+      [ckCode k | Breaking k <- wire] `shouldContain` [WqPayloadFieldChanged]+      fieldTypeChange <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-fieldtype.keiro"+      [ckCode k | Breaking k <- fieldTypeChange] `shouldContain` [WqPayloadFieldChanged]+      required <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-reqfield.keiro"+      [ckCode k | Breaking k <- required] `shouldContain` [WqPayloadFieldChanged]+    -- Adding a payload field is breaking however it is spelled. Generated+    -- decoders read every field with `o .:`, so a job already queued under the+    -- old shape fails to decode against the new one — the "additive, optional+    -- field" classification this test previously asserted described a decoder+    -- that was never generated. See ExecPlan 199.+    it "classifies any new workqueue payload field as breaking for queued jobs" $ do+      cs <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-optfield.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [WqPayloadFieldChanged]+      [ckSubject k | Breaking k <- cs] `shouldContain` ["note"]+      [ckDetail k | Breaking k <- cs, ckSubject k == "note"]+        `shouldSatisfy` any (T.isInfixOf "queued jobs do not contain it")+    it "classifies workqueue ordering changes as breaking delivery-contract changes" $ do+      cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-ordering-change.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [WqOrderingChanged]+      [ckDetail k | Breaking k <- cs, ckCode k == WqOrderingChanged]+        `shouldSatisfy` any (T.isInfixOf "delivery-order contract")+    it "classifies workqueue provision changes as operational migrations" $ do+      cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-provision-change.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [WqProvisionChanged]+      [ckDetail k | Breaking k <- cs, ckCode k == WqProvisionChanged]+        `shouldSatisfy` any (T.isInfixOf "migrate the existing queue operationally")+    it "classifies workqueue group-key changes as breaking repartitioning" $ do+      cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-group-key-change.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [WqGroupKeyChanged]+      [ckDetail k | Breaking k <- cs, ckCode k == WqGroupKeyChanged]+        `shouldSatisfy` any (T.isInfixOf "re-partitioned")+    it "classifies a process input type change as ProcessInputChanged" $ do+      cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-inputtype.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [ProcessInputChanged]+    it "classifies workflow input and output changes as WorkflowShapeChanged" $ do+      input <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-inputfield.keiro"+      [ckCode k | Breaking k <- input] `shouldContain` [WorkflowShapeChanged]+      output <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-output.keiro"+      [ckCode k | Breaking k <- output] `shouldContain` [WorkflowShapeChanged]+    it "classifies workflow relabeling and appends as WorkflowBodyChanged" $ do+      relabeled <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-body.keiro"+      [ckCode k | Breaking k <- relabeled] `shouldContain` [WorkflowBodyChanged]+      appended <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-stepadd.keiro"+      [ckCode k | Breaking k <- appended] `shouldContain` [WorkflowBodyChanged]+      [ckDetail k | Breaking k <- appended, ckCode k == WorkflowBodyChanged]+        `shouldSatisfy` any (T.isInfixOf "new patch guard")+    it "classifies a body addition wholly guarded by a new patch as additive" $ do+      cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-evolution-diff.keiro"+      any isBreaking cs `shouldBe` False+      [ckSubject k | Additive k <- cs, ckFacet k == "workflow-patch"] `shouldContain` ["fraud-check-v2"]+      [ckSubject k | Additive k <- cs, ckFacet k == "workflow-continue-as-new"] `shouldContain` ["RolloverSeed"]+    it "classifies removing an existing patch as breaking" $ do+      cs <- diffFixtures "test/fixtures/workflow-evolution-diff.keiro" "test/fixtures/workflow-continue.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [WorkflowPatchRemoved]+      [ckDetail k | Breaking k <- cs, ckCode k == WorkflowPatchRemoved]+        `shouldSatisfy` any (T.isInfixOf "cannot prove")+    it "classifies terminal continueAsNew append as additive and seed drift as breaking" $ do+      appended <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-continue.keiro"+      any isBreaking appended `shouldBe` False+      [ckFacet k | Additive k <- appended] `shouldContain` ["workflow-continue-as-new"]+      changed <- diffFixtures "test/fixtures/workflow-continue.keiro" "test/fixtures/workflow-continue-seed-v2.keiro"+      [ckCode k | Breaking k <- changed] `shouldContain` [WorkflowContinueSeedChanged]+      [ckDetail k | Breaking k <- changed, ckCode k == WorkflowContinueSeedChanged]+        `shouldSatisfy` any (T.isInfixOf "restoreSeed")+    it "classifies a workflow stable-name change as WorkflowStableNameChanged" $ do+      cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-rename.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [WorkflowStableNameChanged]+    it "classifies workflow id-derivation changes as DerivedIdentityChanged" $ do+      cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-idfield.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [DerivedIdentityChanged]+    it "classifies an id prefix change as IdPrefixChanged" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-idprefix.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [IdPrefixChanged]+    it "classifies intake dedupe key and policy changes as DedupeIdentityChanged" $ do+      policy <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-dedupepolicy.keiro"+      [ckCode k | Breaking k <- policy] `shouldContain` [DedupeIdentityChanged]+      key <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-dedupekey.keiro"+      [ckCode k | Breaking k <- key] `shouldContain` [DedupeIdentityChanged]+    it "reports intake decode-posture changes as warnings" $ do+      cs <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-decode.keiro"+      any isBreaking cs `shouldBe` False+      [ckCode k | Advisory k <- cs] `shouldContain` [DecodePostureChanged]+      [ckCode k | Advisory k <- cs] `shouldContain` [IntakePersistenceChanged]+    it "classifies process and timer derivation changes as DerivedIdentityChanged" $ do+      processName <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-procname.keiro"+      [ckCode k | Breaking k <- processName] `shouldContain` [DerivedIdentityChanged]+      timerId <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-timerid.keiro"+      [ckCode k | Breaking k <- timerId] `shouldContain` [DerivedIdentityChanged]+      base <- specOf "test/fixtures/hospital-surge.keiro"+      let categoryChange = diffSpecs base (modifyProcess "HospitalSurge" (\process -> process {procSaga = (procSaga process) {sagaCategory = "hospitalSurgeV2"}}) base)+      [ckCode k | Breaking k <- categoryChange] `shouldContain` [DerivedIdentityChanged]+    it "classifies router stable names, keys, and targets as identity-bearing" $ do+      base <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+      let stableName = diffSpecs base (modifyRouter "PagingRouter" (\router -> router {rtName = "paging-v2"}) base)+          keyDerivation = diffSpecs base (modifyRouter "PagingRouter" (\router -> router {rtKey = (rtKey router) {corrVia = "otherIdText"}}) base)+          target = diffSpecs base (modifyRouter "PagingRouter" (\router -> router {rtTarget = "OtherPage"}) base)+      [ckCode k | Breaking k <- stableName] `shouldContain` [RouterStableNameChanged]+      [ckCode k | Breaking k <- keyDerivation] `shouldContain` [DerivedIdentityChanged]+      [ckCode k | Breaking k <- target] `shouldContain` [DerivedIdentityChanged]+    it "advises on router dispatch-surface changes without making them breaking" $ do+      cs <- diffFixtures "test/fixtures/incident-paging/incident-paging.keiro" "test/fixtures/incident-paging/incident-paging-dispatch.keiro"+      any isBreaking cs `shouldBe` False+      [ckCode k | Advisory k <- cs] `shouldBe` [RouterDecideSurfaceChanged]+    it "advises on process dispatch-surface changes without making them breaking" $ do+      cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-handle.keiro"+      any isBreaking cs `shouldBe` False+      [ckCode k | Advisory k <- cs] `shouldBe` [ProcessDecideSurfaceChanged]+    it "advises on unversioned timer payload changes without making them breaking" $ do+      cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-payload.keiro"+      any isBreaking cs `shouldBe` False+      [ckCode k | Advisory k <- cs] `shouldBe` [ProcessTimerPayloadChanged]+    it "ignores formatting-only process and timer surface rewrites" $ do+      original <- specOf "test/fixtures/hospital-surge.keiro"+      formatted <- shouldParseStableRenderedSpec "<formatted-process>" original+      diffSpecs original formatted `shouldBe` []+    it "reports a timer window change as a warning" $ do+      cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-window.keiro"+      any isBreaking cs `shouldBe` False+      [ckCode k | Advisory k <- cs] `shouldContain` [TimerWindowChanged]+    it "reports emit-map changes as warnings and derive changes as breaking" $ do+      mapping <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-mapchange.keiro"+      any isBreaking mapping `shouldBe` False+      [ckCode k | Advisory k <- mapping] `shouldContain` [EmitMappingChanged]+      derive <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-derive.keiro"+      [ckCode k | Breaking k <- derive] `shouldContain` [DerivedIdentityChanged]+    it "classifies publisher outbox identity and ordering independently" $ do+      outbox <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-outboxfield.keiro"+      [ckCode k | Breaking k <- outbox] `shouldContain` [DerivedIdentityChanged]+      ordering <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-ordering.keiro"+      any isBreaking ordering `shouldBe` False+      [ckCode k | Advisory k <- ordering] `shouldContain` [PublisherPolicyChanged]+    it "classifies workqueue names as QueueIdentityChanged" $ do+      cs <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-rename.keiro"+      [ckCode k | Breaking k <- cs] `shouldContain` [QueueIdentityChanged]+    it "classifies pgmq dispatch dedupe and retargeting independently" $ do+      dedupe <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-dedupkey.keiro"+      [ckCode k | Breaking k <- dedupe] `shouldContain` [DedupeIdentityChanged]+      retarget <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-retarget.keiro"+      any isBreaking retarget `shouldBe` False+      [ckCode k | Advisory k <- retarget] `shouldContain` [DispatchRetargeted]+    it "reports aggregate projection changes as warnings" $ do+      cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-projection.keiro"+      any isBreaking cs `shouldBe` False+      [ckCode k | Advisory k <- cs] `shouldContain` [ProjectionChanged]+    it "classifies read-model version and unversioned shape changes" $ do+      base <- specOf "test/fixtures/readmodel-runtime.keiro"+      let versionTwo = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmVersion = 2}) base+          changedShape = modifyReadModel "transfer_decisions" changeReadModelShape base+          bumpedShape = modifyReadModel "transfer_decisions" (\readModel -> (changeReadModelShape readModel) {rmVersion = 2}) base+          decreased = diffSpecs versionTwo base+          unversioned = diffSpecs base changedShape+          bumped = diffSpecs base bumpedShape+      [ckCode k | Breaking k <- decreased] `shouldContain` [ReadModelVersionDecreased]+      [ckCode k | Breaking k <- unversioned] `shouldContain` [ReadModelShapeChangedWithoutBump]+      any isBreaking bumped `shouldBe` False+      [ckFacet k | Additive k <- bumped] `shouldContain` ["read-model-version"]+    it "classifies query input and result changes only on the consumer-build surface" $ do+      source <- mappedConsumerSurfaceSource+      base <- parseInlineSpec "<mapped-query-diff-old>" source+      let changeQuery update =+            modifyReadModel+              "ArtifactLookup"+              ( \readModel ->+                  readModel+                    { queryTypes = fmap update (queryTypes readModel)+                    }+              )+              base+          inputChanged = changeQuery (\queryPair -> queryPair {input = TList (input queryPair)})+          resultChanged = changeQuery (\queryPair -> queryPair {result = TRef "ArtifactInfo"})+          assertBuildOnly expectedCode changes = case [kind | Advisory kind <- changes, ckCode kind == expectedCode] of+            [kind] -> do+              cvConsumerBuild (ckVector kind) `shouldBe` VBreaking+              cvPrivateHistoryRead (ckVector kind) `shouldBe` VCompatible+              cvOldBinaryReadNewEvents (ckVector kind) `shouldBe` VCompatible+              cvSnapshotHydration (ckVector kind) `shouldBe` VNotApplicable+              cvPublicConsumer (ckVector kind) `shouldBe` VNotApplicable+              cvPersistedIdentity (ckVector kind) `shouldBe` VNotApplicable+              ckMappedPersistedImpact kind `shouldBe` Nothing+              remediationFor (ckContext kind) (ckCode kind)+                `shouldBe` RemedyRecompileConsumers :| [RemedyRunConformance]+            values -> expectationFailure ("expected one query build finding, got " <> show values)+          onlyReadModel spec = case [readModel | NReadModel readModel <- specNodes spec, rmName readModel == "ArtifactLookup"] of+            [readModel] -> readModel+            values -> error ("expected one ArtifactLookup read model, got " <> show values)+      assertBuildOnly ReadModelQueryInputChanged (diffSpecs base inputChanged)+      assertBuildOnly ReadModelQueryResultChanged (diffSpecs base resultChanged)+      canonicalShape (onlyReadModel inputChanged) `shouldBe` canonicalShape (onlyReadModel base)+      deriveShapeHash (onlyReadModel resultChanged) `shouldBe` deriveShapeHash (onlyReadModel base)+      projectionCatalogFacts inputChanged `shouldBe` projectionCatalogFacts base+      registryNameFor (specContext inputChanged) (onlyReadModel inputChanged)+        `shouldBe` registryNameFor (specContext base) (onlyReadModel base)+      replayImpactSpecs base inputChanged `shouldBe` ReplayNeutral+    it "classifies read-model registry, table, subscription, and removal identities" $ do+      base <- specOf "test/fixtures/readmodel-runtime.keiro"+      let tableChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmTable = "transfer_decisions_v2"}) base+          subscriptionChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmSupply = setLegacySubscription (Just "transfer-decisions-v2") (rmSupply readModel)}) base+          renamed = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmName = "reservation_decisions"}) base+          removed = removeReadModel "transfer_decisions" base+      mapM_+        (\changes -> [ckCode k | Breaking k <- changes] `shouldContain` [DerivedIdentityChanged])+        [diffSpecs base tableChanged, diffSpecs base subscriptionChanged, diffSpecs base renamed, diffSpecs base removed]+    it "classifies read-model feed flips and consistency/scope weakening as breaking" $ do+      base <- specOf "test/fixtures/readmodel-runtime.keiro"+      let feedChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmSupply = setLegacyFeed RmInline (rmSupply readModel)}) base+          consistencyWeakened = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmSupply = setLegacyConsistency Eventual (rmSupply readModel), rmFreshness = FreshnessImmediate}) base+          entireLog = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmSupply = setLegacyScope (Just RmEntireLog) (rmSupply readModel), rmFreshness = FreshnessWaitForHead RmEntireLog}) base+      [ckCode k | Breaking k <- diffSpecs base feedChanged] `shouldContain` [ReadModelFeedChanged]+      [ckCode k | Breaking k <- diffSpecs base consistencyWeakened] `shouldContain` [ReadModelConsistencyWeakened]+      [ckCode k | Breaking k <- diffSpecs entireLog base] `shouldContain` [ReadModelConsistencyWeakened]+    it "classifies Eventual to Strong read-model consistency as additive" $ do+      strong <- specOf "test/fixtures/readmodel-runtime.keiro"+      let eventual = modifyReadModel "transfer_decisions" (\readModel -> readModel {rmSupply = setLegacyConsistency Eventual (rmSupply readModel), rmFreshness = FreshnessImmediate}) strong+          changes = diffSpecs eventual strong+      any isBreaking changes `shouldBe` False+      [ckFacet k | Additive k <- changes] `shouldContain` ["read-model-consistency"]+    it "classifies the legacy Strong to language-5 immediate freshness migration as breaking" $ do+      source <- readTestText "test/fixtures/readmodel-migration-l4.keiro"+      let legacyStrongPolicy =+            "  consistency = Strong\n  scope = category \"reservation\"\n  feed = subscription\n  subscription = \"hospital-capacity-transfer-decisions-sub\"\n"+          toLanguage5 policy =+            T.replace "language keiro-dsl 4" "language keiro-dsl 5"+              . T.replace legacyStrongPolicy policy+      legacyStrong <- checkedServiceFromText "readmodel-migration-legacy-strong.keiro" source+      immediate <- checkedServiceFromText "readmodel-migration-immediate.keiro" (toLanguage5 "  freshness = immediate\n" source)+      let changes = diffServices legacyStrong immediate+      [ckCode k | Breaking k <- changes] `shouldContain` [QueryFreshnessChanged]+      [ckFacet k | Breaking k <- changes] `shouldContain` ["query-freshness"]+      [ckFacet k | Additive k <- changes] `shouldNotContain` ["read-model-scope"]+      [ckDetail k | Breaking k <- changes, ckCode k == QueryFreshnessChanged]+        `shouldSatisfy` any (T.isInfixOf "wait-for-head category 'reservation' -> immediate")+    it "keeps equivalent and strengthened freshness migrations non-breaking" $ do+      source <- readTestText "test/fixtures/readmodel-migration-l4.keiro"+      let legacyStrongPolicy =+            "  consistency = Strong\n  scope = category \"reservation\"\n  feed = subscription\n  subscription = \"hospital-capacity-transfer-decisions-sub\"\n"+          legacyEventualPolicy =+            "  consistency = Eventual\n  feed = subscription\n  subscription = \"hospital-capacity-transfer-decisions-sub\"\n"+          toLanguage5 policy =+            T.replace "language keiro-dsl 4" "language keiro-dsl 5"+              . T.replace legacyStrongPolicy policy+          readModelFacets = filter (\facet -> facet == "query-freshness" || "read-model-" `T.isPrefixOf` facet) . map (ckFacet . kindOfChange)+          assertEquivalent changes = do+            any isBreaking changes `shouldBe` False+            readModelFacets changes `shouldBe` []+      legacyStrong <- checkedServiceFromText "readmodel-migration-equivalent-legacy-strong.keiro" source+      strongEquivalent <- checkedServiceFromText "readmodel-migration-equivalent-wait.keiro" (toLanguage5 "  freshness = wait-for-head category \"reservation\"\n" source)+      assertEquivalent (diffServices legacyStrong strongEquivalent)+      let eventualSource = T.replace legacyStrongPolicy legacyEventualPolicy source+      legacyEventual <- checkedServiceFromText "readmodel-migration-equivalent-legacy-eventual.keiro" eventualSource+      immediate <- checkedServiceFromText "readmodel-migration-equivalent-immediate.keiro" (toLanguage5 "  freshness = immediate\n" source)+      assertEquivalent (diffServices legacyEventual immediate)+      strengthened <- checkedServiceFromText "readmodel-migration-strengthened.keiro" (toLanguage5 "  freshness = wait-for-head entire-log\n" source)+      let strengthenedChanges = diffServices legacyEventual strengthened+      any isBreaking strengthenedChanges `shouldBe` False+      [ckCode k | Additive k <- strengthenedChanges] `shouldContain` [CompatibilityStrengthened]+      [ckFacet k | Additive k <- strengthenedChanges] `shouldContain` ["query-freshness"]+    it "classifies scope changes and reverse downgrades in the freshness migration by the normalized pair" $ do+      source <- readTestText "test/fixtures/readmodel-migration-l4.keiro"+      let legacyStrongPolicy =+            "  consistency = Strong\n  scope = category \"reservation\"\n  feed = subscription\n  subscription = \"hospital-capacity-transfer-decisions-sub\"\n"+          legacyEventualPolicy =+            "  consistency = Eventual\n  feed = subscription\n  subscription = \"hospital-capacity-transfer-decisions-sub\"\n"+          toLanguage5 policy =+            T.replace "language keiro-dsl 4" "language keiro-dsl 5"+              . T.replace legacyStrongPolicy policy+      legacyStrong <- checkedServiceFromText "readmodel-migration-scope-legacy-strong.keiro" source+      widened <- checkedServiceFromText "readmodel-migration-scope-widened.keiro" (toLanguage5 "  freshness = wait-for-head entire-log\n" source)+      let widenedChanges = diffServices legacyStrong widened+      any isBreaking widenedChanges `shouldBe` False+      [ckCode k | Additive k <- widenedChanges] `shouldContain` [CompatibilityStrengthened]+      [ckFacet k | Additive k <- widenedChanges] `shouldContain` ["query-freshness"]+      categoryChanged <- checkedServiceFromText "readmodel-migration-scope-category-changed.keiro" (toLanguage5 "  freshness = wait-for-head category \"other\"\n" source)+      [ckCode k | Breaking k <- diffServices legacyStrong categoryChanged] `shouldContain` [QueryFreshnessChanged]+      immediate <- checkedServiceFromText "readmodel-migration-reverse-immediate.keiro" (toLanguage5 "  freshness = immediate\n" source)+      let reverseStrengthened = diffServices immediate legacyStrong+      any isBreaking reverseStrengthened `shouldBe` False+      [ckCode k | Additive k <- reverseStrengthened] `shouldContain` [CompatibilityStrengthened]+      legacyEventual <- checkedServiceFromText "readmodel-migration-reverse-legacy-eventual.keiro" (T.replace legacyStrongPolicy legacyEventualPolicy source)+      waitCategory <- checkedServiceFromText "readmodel-migration-reverse-wait.keiro" (toLanguage5 "  freshness = wait-for-head category \"reservation\"\n" source)+      [ckCode k | Breaking k <- diffServices waitCategory legacyEventual] `shouldContain` [QueryFreshnessChanged]+    it "keeps identical same-language freshness migration pairs free of policy findings" $ do+      source <- readTestText "test/fixtures/readmodel-migration-l4.keiro"+      let legacyStrongPolicy =+            "  consistency = Strong\n  scope = category \"reservation\"\n  feed = subscription\n  subscription = \"hospital-capacity-transfer-decisions-sub\"\n"+          language5Source =+            T.replace "language keiro-dsl 4" "language keiro-dsl 5"+              . T.replace legacyStrongPolicy "  freshness = immediate\n"+              $ source+          policyFacets = filter (\facet -> facet == "query-freshness" || "read-model-" `T.isPrefixOf` facet) . map (ckFacet . kindOfChange)+      language4 <- checkedServiceFromText "readmodel-migration-identical-language-4.keiro" source+      language5 <- checkedServiceFromText "readmodel-migration-identical-language-5.keiro" language5Source+      policyFacets (diffServices language4 language4) `shouldBe` []+      policyFacets (diffServices language5 language5) `shouldBe` []++  describe "module placement (M1)" $ do+    it "GeneratedPrefix is today's namespace (Generated.<Ctx>.<Node>, holes at <Ctx>.<Node>)" $ do+      let ctx = defaultContext "hospital-capacity"+      genPrefixFor ctx "Reservation" `shouldBe` "Generated.HospitalCapacity.Reservation"+      holePrefixFor ctx "Reservation" `shouldBe` "HospitalCapacity.Reservation"+    it "module-root prefixes both layers" $ do+      let ctx = (defaultContext "hospital-capacity") {moduleRoot = "Acme"}+      genPrefixFor ctx "Reservation" `shouldBe` "Acme.Generated.HospitalCapacity.Reservation"+      holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation"+    it "CollocatedLeaf places the generated layer under the domain leaf" $ do+      let ctx = (defaultContext "hospital-capacity") {moduleRoot = "Acme", placement = CollocatedLeaf}+      genPrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation.Generated"+      holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation"+    it "parses and preserves the module/layout clauses through parse . pretty" $ do+      let src = "context hospital-capacity\nmodule Acme.Services\nlayout collocated\n\naggregate Reservation\n  regs\n  states Open\n"+      case parseSpec "<m1>" src of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> do+          specModuleRoot spec `shouldBe` Just "Acme.Services"+          specLayout spec `shouldBe` Just CollocatedLeaf+          parseSpec "<m1>" (renderSpec spec) `shouldBe` Right spec+    it "a spec without the clauses leaves placement at the default" $ do+      input <- readTestText "test/fixtures/reservation.keiro"+      case parseSpec "test/fixtures/reservation.keiro" input of+        Left err -> expectationFailure (T.unpack err)+        Right spec -> do+          specModuleRoot spec `shouldBe` Nothing+          specLayout spec `shouldBe` Nothing++  describe "structural scaffold" $ do+    it "emits one private shape module per structural declaration and one context facade" $ do+      spec <- specOf "test/fixtures/consumer-types.keiro"+      let modules = scaffoldModules (defaultContext (specContext spec)) spec+          paths = map modulePath modules+      paths+        `shouldContain` [ "Generated/ConsumerDemo/Structural/Shape/ArtifactInfo.hs",+                          "Generated/ConsumerDemo/Structural/Shape/ArtifactKind.hs",+                          "Generated/ConsumerDemo/Structural/Shape/ArtifactLocation.hs",+                          "Generated/ConsumerDemo/StructuralProjections.hs"+                        ]+      paths `shouldNotContain` ["Generated/ConsumerDemo/Structural/Shape/VendorGeometry.hs"]+      firewallBreaches modules `shouldBe` []+    it "emits one create-once binding skeleton per owning module and derives Generic for private shapes" $ do+      spec <- specOf "test/fixtures/consumer-types.keiro"+      let modules = scaffoldModules (defaultContext (specContext spec)) spec+          skeletons = [moduleValue | moduleValue <- modules, kind moduleValue == HoleStub, modulePath moduleValue == "Example/Artifact/KeiroBindings.hs"]+          shape = generatedTextEndingIn "Structural/Shape/ArtifactInfo.hs" modules+      case skeletons of+        [skeleton] -> do+          moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactInfoBinding :: StructuralBinding"+          moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactKindBinding :: StructuralBinding"+          moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactLocationBinding :: StructuralBinding"+          moduleText skeleton `shouldSatisfy` T.isInfixOf "HOLE: fill ArtifactInfo bindingToShape.key"+        _ -> expectationFailure ("expected exactly one shared binding skeleton, got " <> show (map modulePath skeletons))+      shape `shouldSatisfy` T.isInfixOf "deriving stock (Eq, Generic, Show)"+      shape `shouldSatisfy` T.isInfixOf "import GHC.Generics (Generic)"+    it "never overwrites an existing binding skeleton" $+      withTempDirectory "keiro-dsl-binding-create-once" $ \out -> do+        spec <- specOf "test/fixtures/consumer-types.keiro"+        let ctx = defaultContext (specContext spec)+            bindingPath = out </> "Example/Artifact/KeiroBindings.hs"+        _ <- executePlannedScaffold out "consumer-types.keiro" ctx spec+        TIO.writeFile bindingPath "hand-owned binding\n"+        second <- executePlannedScaffold out "consumer-types.keiro" ctx spec+        TIO.readFile bindingPath `shouldReturn` "hand-owned binding\n"+        reportDispositions second+          `shouldSatisfy` any (\(moduleValue, disposition) -> modulePath moduleValue == "Example/Artifact/KeiroBindings.hs" && disposition == Skipped)+    it "fresh binding skeletons compile at the application boundary" $+      withTempDirectory "keiro-dsl-binding-compiles" $ \out -> do+        spec <- specOf "test/fixtures/structural-conformance.keiro"+        let ctx = defaultContext (specContext spec)+            bindingSource = out </> "Conformance/Structural/Bindings.hs"+            ghcOutput = out </> ".ghc"+        _ <- executePlannedScaffold out "structural-conformance.keiro" ctx spec+        createDirectoryIfMissing True ghcOutput+        (exitCode, standardOutput, standardError) <-+          readProcessWithExitCode+            "cabal"+            [ "exec",+              "--",+              "ghc",+              "-XGHC2024",+              "-XOverloadedStrings",+              "-fno-code",+              "-fforce-recomp",+              "-outputdir",+              ghcOutput,+              "-i" <> out,+              "-itest/conformance-structural",+              "-i../keiro-core/src",+              bindingSource+            ]+            ""+        unless (exitCode == ExitSuccess) $+          expectationFailure (standardOutput <> standardError)+    it "keeps consumer types in Domain while the generated Codec owns keys, tags, and defaults" $ do+      spec <- specOf "test/fixtures/consumer-types.keiro"+      let modules = scaffoldModules (defaultContext (specContext spec)) spec+          domain = generatedTextEndingIn "Catalog/Domain.hs" modules+          codec = generatedTextEndingIn "Catalog/Codec.hs" modules+      domain `shouldSatisfy` T.isInfixOf "import Example.Artifact.Domain (ArtifactInfo)"+      domain `shouldSatisfy` T.isInfixOf "import Vendor.Geometry (Geometry)"+      domain `shouldSatisfy` T.isInfixOf "artifact :: !ArtifactInfo"+      domain `shouldSatisfy` T.isInfixOf "RCons (Proxy @\"currentArtifact\") ArtifactKeiroBindings.emptyArtifactInfo"+      domain `shouldSatisfy` (not . T.isInfixOf "Example.Artifact.Domain.ArtifactInfo")+      codec `shouldSatisfy` T.isInfixOf "\"location\" .= encodeArtifactLocationShape"+      codec `shouldSatisfy` T.isInfixOf "\"local_file\""+      codec `shouldSatisfy` T.isInfixOf "parseOptionalField (pure ShapeArtifactKind.Guide)"+      codec `shouldSatisfy` T.isInfixOf "rejectUnknownFields \"ArtifactInfo\""+      codec `shouldSatisfy` T.isInfixOf "toJSON payload.geometry"+      codec `shouldSatisfy` (not . T.isInfixOf "vendor.geometry.json")+    it "generates shape-only nested types and schema-derived Keiki witnesses" $ do+      spec <- specOf "test/fixtures/consumer-types.keiro"+      let modules = scaffoldModules (defaultContext (specContext spec)) spec+          shape = generatedTextEndingIn "Structural/Shape/ArtifactInfo.hs" modules+          facade = generatedTextEndingIn "StructuralProjections.hs" modules+      shape `shouldSatisfy` T.isInfixOf "data ArtifactInfoShape = ArtifactInfo"+      shape `shouldSatisfy` T.isInfixOf "ArtifactKind.ArtifactKindShape"+      mapM_+        (shape `shouldSatisfy`)+        [ T.isInfixOf "description :: !(Maybe Text)",+          T.isInfixOf "tags :: ![Text]",+          T.isInfixOf "labels :: ![Maybe Text]",+          T.isInfixOf "attributes :: !(Map Text Text)"+        ]+      mapM_+        (shape `shouldNotSatisfy`)+        [ T.isInfixOf "description :: !(Maybe (Text))",+          T.isInfixOf "tags :: !([Text])",+          T.isInfixOf "labels :: !([(Maybe (Text))])",+          T.isInfixOf "attributes :: !(Map Text (Text))"+        ]+      shape `shouldSatisfy` (not . T.isInfixOf "KeiroBindings")+      facade `shouldSatisfy` T.isInfixOf "type FieldName"+      facade `shouldSatisfy` T.isInfixOf "= \"/key\""+      facade `shouldSatisfy` T.isInfixOf "fieldShapeId _ = \"example.artifact.ArtifactInfo.v1\""+      facade `shouldSatisfy` T.isInfixOf "type FieldOwner ArtifactInfoKeyProjection = ArtifactInfo"+      facade `shouldSatisfy` T.isInfixOf "bindingToShape KeiroBindings.artifactInfoBinding owner"+      facade `shouldSatisfy` (not . T.isInfixOf "Example.Artifact.Domain.ArtifactInfo")+      facade `shouldSatisfy` T.isInfixOf "artifactInfoKeyWitness"+      facade `shouldNotSatisfy` T.isInfixOf "structuralProjectionC"+    it "suffixes only structural witness names that collide after normalization" $ do+      source <- readTestText "test/fixtures/consumer-types.keiro"+      collisionSpec <-+        parseInlineSpec+          "<projection-name-collision>"+          ( T.replace+              "    key         as \"key\"         : Text                 required"+              ( T.unlines+                  [ "    key         as \"key\"         : Text                 required",+                    "    fooDash     as \"foo-bar\"     : Text                 required",+                    "    fooUnder    as \"foo_bar\"     : Text                 required"+                  ]+              )+              source+          )+      graph <- shouldResolveTypeGraph collisionSpec+      let specs = projectionSpecs graph+          keyWitnesses = [spWitness spec | spec <- specs, spPointer spec == "/key"]+          collidedWitnesses = [spWitness spec | spec <- specs, spPointer spec `elem` ["/foo-bar", "/foo_bar"]]+      keyWitnesses `shouldBe` ["artifactInfoKeyWitness"]+      length collidedWitnesses `shouldBe` 2+      Set.size (Set.fromList collidedWitnesses) `shouldBe` 2+      collidedWitnesses `shouldSatisfy` all (T.isPrefixOf "artifactInfoFooBar")+      collidedWitnesses `shouldSatisfy` all (T.isSuffixOf "Witness")+      collidedWitnesses `shouldSatisfy` all ((== 8) . T.length . T.dropEnd (T.length ("Witness" :: T.Text)) . T.drop (T.length ("artifactInfoFooBar" :: T.Text)))+    it "uses only precedence-required parentheses in nested record field types" $ do+      let spec =+            mappedSpec+              [ completeStructural+                  "Nested"+                  ( recordShape+                      [ TMap (TOptional TText),+                        TOptional (TList TText),+                        TOptional (TMap TText)+                      ]+                  )+              ]+          shape = generatedTextEndingIn "Structural/Shape/Nested.hs" (scaffoldStructural (defaultContext (specContext spec)) spec)+      mapM_+        (shape `shouldSatisfy`)+        [ T.isInfixOf "field1 :: !(Map Text (Maybe Text))",+          T.isInfixOf "field2 :: !(Maybe [Text])",+          T.isInfixOf "field3 :: !(Maybe (Map Text Text))"+        ]+    it "uses the same precedence rules for strict union payloads" $ do+      let spec =+            mappedSpec+              [ completeStructural+                  "Payload"+                  ( ShapeUnion+                      (TaggedObject "tag" "contents" RejectUnknown)+                      [ WireArm "OptionalPayload" "optional" (Just (TOptional TText)) noLoc,+                        WireArm "ListPayload" "list" (Just (TList (TOptional TText))) noLoc,+                        WireArm "MapPayload" "map" (Just (TMap (TOptional TText))) noLoc+                      ]+                  )+              ]+          shape = generatedTextEndingIn "Structural/Shape/Payload.hs" (scaffoldStructural (defaultContext (specContext spec)) spec)+      mapM_+        (shape `shouldSatisfy`)+        [ T.isInfixOf "OptionalPayload !(Maybe Text)",+          T.isInfixOf "ListPayload ![Maybe Text]",+          T.isInfixOf "MapPayload !(Map Text (Maybe Text))"+        ]++  describe "structural manifest" $ do+    it "lists consumer packages and every domain, binding, fixture, and initial module" $ do+      spec <- specOf "test/fixtures/consumer-types.keiro"+      let modules = scaffoldModules (defaultContext (specContext spec)) spec+          manifest = renderManifest "consumer-types.keiro" modules spec+      assertGeneratedHaskellContract "consumer-types.keiro" manifest+      mapM_ (\packageName -> manifestDependencies spec `shouldContain` [packageName]) ["artifact-domain", "vendor-geometry"]+      manifest `shouldSatisfy` T.isInfixOf "consumer-packages:\n    artifact-domain\n    vendor-geometry"+      mapM_+        (\moduleName -> manifest `shouldSatisfy` T.isInfixOf moduleName)+        [ "Example.Artifact.Domain",+          "Example.Artifact.KeiroBindings",+          "Vendor.Geometry",+          "Vendor.Geometry.KeiroBindings"+        ]++  describe "structural scaffold record" $ do+    it "round-trips canonical mapping rows and reports binding drift on the next run" $+      withTempDirectory "keiro-dsl-mapping-record" $ \out -> do+        spec <- specOf "test/fixtures/consumer-types.keiro"+        let ctx = defaultContext (specContext spec)+        first <- executePlannedScaffold out "consumer-types.keiro" ctx spec+        length (consumerMappings (reportConsumerPlan first)) `shouldBe` 4+        recordText <- TIO.readFile (out </> recordFileName (specContext spec))+        let mappingRows = filter (T.isPrefixOf "mapping ") (T.lines recordText)+            bindingRows = filter (T.isPrefixOf "binding ") (T.lines recordText)+        length mappingRows `shouldBe` 4+        bindingRows `shouldSatisfy` (not . null)+        fmap recMappings (parseRecord recordText) `shouldSatisfy` maybe False ((== 4) . length)+        fmap recBindingObligations (parseRecord recordText) `shouldSatisfy` maybe False ((== length bindingRows) . length)+        let bumped = spec {specMapped = map bumpArtifactBindingVersion (specMapped spec)}+        second <- executePlannedScaffold out "consumer-types.keiro" ctx bumped+        reportMappingDrift second+          `shouldSatisfy` any (\drift -> driftSpecName drift == "ArtifactInfo" && driftPrevious drift /= driftCurrent drift)+        renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "mapping drift:")+        case mappingRows of+          row : _ -> parseRecord (recordText <> row <> "\n") `shouldBe` Nothing+          [] -> expectationFailure "expected mapping rows"+        case bindingRows of+          row : _ -> parseRecord (recordText <> row <> "\n") `shouldBe` Nothing+          [] -> expectationFailure "expected binding rows"+    it "reports exactly the newly added binding field without rewriting the shared skeleton" $+      withTempDirectory "keiro-dsl-binding-drift" $ \out -> do+        spec <- specOf "test/fixtures/consumer-types.keiro"+        let ctx = defaultContext (specContext spec)+        _ <- executePlannedScaffold out "consumer-types.keiro" ctx spec+        let extended = spec {specMapped = map addArtifactSummaryField (specMapped spec)}+        second <- executePlannedScaffold out "consumer-types.keiro" ctx extended+        reportNewHoles second+          `shouldBe` [ BindingHole+                         { holeMappedName = "ArtifactInfo",+                           holeModule = "Example.Artifact.KeiroBindings",+                           holeSymbol = "artifactInfoBinding",+                           holeKind = BindingValue,+                           holePath = Just "summary",+                           holeSignature = "artifactInfoBinding.summary :: Text"+                         }+                     ]+        renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "artifactInfoBinding.summary :: Text")+    it "rejects malformed known mapping JSON while ignoring unrelated future rows" $ do+      spec <- specOf "test/fixtures/consumer-types.keiro"+      withTempDirectory "keiro-dsl-mapping-malformed" $ \out -> do+        report <- executePlannedScaffold out "consumer-types.keiro" (defaultContext (specContext spec)) spec+        recordText <- TIO.readFile (reportRecordPath report)+        parseRecord (recordText <> "mapping {not-json}\n") `shouldBe` Nothing+        parseRecord (recordText <> "future-row retained\n") `shouldBe` parseRecord recordText+    it "reports current and legacy semantic impact without globalizing aggregate artifacts" $+      withTempDirectory "keiro-dsl-semantic-impact-report" $ \root -> do+        old <- specOf "test/fixtures/structural-locality.keiro"+        let new = addAlphaPayloadOptionalField old+            legacyNew = mapMappedStructural "AlphaPayload" changeMappedCanonical old+            ctx = defaultContext (specContext old)+            currentOut = root </> "current"+            legacyOut = root </> "legacy"+            assertAlphaOnly report = do+              map impactDeclaration (semanticReportDeltas (reportSemanticImpact report))+                `shouldBe` [MappedKey "AlphaPayload"]+              map impactPreviousConsumers (semanticReportDeltas (reportSemanticImpact report))+                `shouldBe` [Set.singleton (AggregateConsumer "Alpha")]+              map impactCurrentConsumers (semanticReportDeltas (reportSemanticImpact report))+                `shouldBe` [Set.singleton (AggregateConsumer "Alpha")]+              let semanticLines = renderSemanticImpactReport (reportSemanticImpact report)+              semanticLines `shouldSatisfy` any (T.isInfixOf "current aggregate consumers:  Alpha")+              semanticLines `shouldSatisfy` all (not . T.isInfixOf "Beta")+              map artifactCategory (reportGeneratedArtifactImpact report)+                `shouldContain` [ServiceStructuralConformanceArtifact]+              map artifactPath (reportGeneratedArtifactImpact report)+                `shouldSatisfy` all (not . T.isInfixOf "/Beta/" . T.pack)+        _ <- executePlannedScaffold currentOut "semantic-impact.keiro" ctx old+        current <- executePlannedScaffold currentOut "semantic-impact.keiro" ctx new+        assertAlphaOnly current++        firstLegacy <- executePlannedScaffold legacyOut "semantic-impact.keiro" ctx old+        legacyText <- TIO.readFile (reportRecordPath firstLegacy)+        TIO.writeFile+          (reportRecordPath firstLegacy)+          (T.unlines (filter (not . T.isPrefixOf "semantic-impact ") (T.lines legacyText)))+        legacy <- executePlannedScaffold legacyOut "semantic-impact.keiro" ctx legacyNew+        let legacyLines = renderSemanticImpactReport (reportSemanticImpact legacy)+        legacyLines `shouldSatisfy` any (T.isInfixOf "baseline: unavailable (legacy ledger)")+        legacyLines `shouldSatisfy` any (T.isInfixOf "current aggregate consumers: Alpha")+        legacyLines `shouldSatisfy` all (not . T.isInfixOf "Beta")+        currentLedger <- TIO.readFile (reportRecordPath legacy)+        (parseRecord currentLedger >>= recSemanticImpact) `shouldSatisfy` maybe False (const True)+        third <- executePlannedScaffold legacyOut "semantic-impact.keiro" ctx legacyNew+        semanticReportDeclarations (reportSemanticImpact third) `shouldBe` []++  describe "structural import plan" $ do+    it "reports the successful dependency plan in the scaffold report" $+      withTempDirectory "keiro-dsl-dependency-plan" $ \out -> do+        spec <- specOf "test/fixtures/consumer-types.keiro"+        report <- executePlannedScaffold out "consumer-types.keiro" (defaultContext (specContext spec)) spec+        renderScaffoldReport report+          `shouldSatisfy` any (T.isInfixOf "dependency plan: consumer packages [artifact-domain, vendor-geometry]")+    it "refuses a binding module inside the generated namespace with the exact cycle" $ do+      spec <- specOf "test/fixtures/consumer-types.keiro"+      let cyclic = spec {specMapped = map moveArtifactBindingIntoGenerated (specMapped spec)}+      case planTestScaffold (defaultContext (specContext cyclic)) cyclic of+        Left refusals -> do+          refusals `shouldSatisfy` any isImportCycle+          renderRefusals refusals `shouldSatisfy` any (T.isInfixOf "Generated.ConsumerDemo.Bindings")+        Right _ -> expectationFailure "expected an import-cycle refusal"+    it "refuses missing mapped register initials but permits command/event-only use" $ do+      missing <- specOf "test/fixtures/mapped-missing-initial.keiro"+      planTestScaffold (defaultContext (specContext missing)) missing `shouldSatisfy` isFoldSurfaceRefusal+      spec <- specOf "test/fixtures/consumer-types.keiro"+      let commandOnly = removeMappedRegisterRequirements spec+      planTestScaffold (defaultContext (specContext commandOnly)) commandOnly `shouldSatisfy` isRight++  describe "binding explanations" $ do+    it "lists binding, fixture, and use-site-scoped initial obligations deterministically" $ do+      spec <- specOf "test/fixtures/consumer-types.keiro"+      obligations <- either (\errors -> expectationFailure (show errors) >> pure []) pure (bindingObligations spec)+      length obligations `shouldBe` 7+      obligations+        `shouldSatisfy` any+          ( \obligation ->+              obligationKind obligation == BindingValue+                && obligationSymbol obligation == "artifactInfoBinding"+                && obligationBindingVersion obligation == Just "1"+          )+      obligations+        `shouldSatisfy` any+          ( \obligation ->+              obligationKind obligation == InitialValue+                && obligationSymbol obligation == "emptyArtifactInfo"+                && any (T.isInfixOf "Catalog register currentArtifact") (obligationUseSites obligation)+          )+      let rendered = renderBindingObligations (specContext spec) obligations+      rendered `shouldSatisfy` T.isInfixOf "binding obligations for context consumer-demo"+      rendered `shouldSatisfy` T.isInfixOf "artifactInfoBinding :: StructuralBinding Example.Artifact.Domain.ArtifactInfo ArtifactInfoShape"+      rendered `shouldSatisfy` T.isInfixOf "provenance: binding-version \"1\""+    it "states explicitly when a spec has no structural obligations" $ do+      spec <- specOf "test/fixtures/reservation.keiro"+      obligations <- either (\errors -> expectationFailure (show errors) >> pure []) pure (bindingObligations spec)+      renderBindingObligations (specContext spec) obligations+        `shouldBe` "no binding obligations for context hospital-capacity"++  describe "exact generic structural bindings" $ do+    forM_+      [ ("renamed-field", "selector mismatch"),+        ("reordered-field", "selector mismatch"),+        ("arity-mismatch", "no exact nominal correspondence"),+        ("incompatible-type", "no exact nominal correspondence")+      ]+      $ \(fixture, diagnostic) ->+        it ("rejects " <> fixture <> " and directs the author to the scaffolded module") $+          expectGenericCompileFailure fixture diagnostic++  describe "structural conformance ownership" $ do+    it "emits declaration laws once at context scope and keeps aggregate-use evidence local" $ do+      service <- checkedServiceOf "test/fixtures/consumer-types.keiro"+      let spec = checkedSpec service+          ctx = defaultContext (specContext spec)+          modules = scaffoldServiceModules ctx service+          structural = generatedTextEndingIn "StructuralConformance.hs" modules+          harness = generatedTextEndingIn "Harness.hs" modules+      mapM_+        (\needle -> structural `shouldSatisfy` T.isInfixOf needle)+        [ "binding domain round-trip: example.artifact.ArtifactInfo.v1/",+          "binding shape round-trip: example.artifact.ArtifactInfo.v1/",+          "fixture coverage: example.artifact.ArtifactLocation.v1",+          "canonical identity: example.artifact.ArtifactInfo.v1",+          "projection witness agreement: example.artifact.ArtifactInfo.v1/key",+          "opaque codec round-trip: vendor.geometry.json@3/"+        ]+      mapM_+        (\needle -> harness `shouldSatisfy` T.isInfixOf needle)+        [ "mapped codec round-trip: ArtifactObserved/artifact/",+          "wire policy missing default: example.artifact.ArtifactInfo.v1/description",+          "wire policy explicit null: example.artifact.ArtifactInfo.v1/description",+          "wire policy unknown fields: example.artifact.ArtifactInfo.v1",+          "wire union arm: example.artifact.ArtifactLocation.v1/local_file",+          "forward/replay equality: ObserveArtifact from CatalogEmpty -- ",+          "register currentArtifact"+        ]+      harness `shouldNotSatisfy` T.isInfixOf "binding domain round-trip:"+      harness `shouldNotSatisfy` T.isInfixOf "fixture coverage:"+      harness `shouldNotSatisfy` T.isInfixOf "projection witness agreement:"+      structural `shouldNotSatisfy` T.isInfixOf "mapped codec round-trip:"+      structural `shouldNotSatisfy` T.isInfixOf "wire policy missing default:"+    it "keeps opaque declaration checks at service scope without inventing structural wire policy" $ do+      service <- checkedServiceOf "test/fixtures/consumer-types.keiro"+      let spec = checkedSpec service+          modules = scaffoldServiceModules (defaultContext (specContext spec)) service+          structural = generatedTextEndingIn "StructuralConformance.hs" modules+          harness = generatedTextEndingIn "Harness.hs" modules+          codec = generatedTextEndingIn "Codec.hs" modules+      structural `shouldSatisfy` T.isInfixOf "opaque codec round-trip: vendor.geometry.json@3/"+      harness `shouldNotSatisfy` T.isInfixOf "opaque codec round-trip: vendor.geometry.json@3/"+      structural `shouldNotSatisfy` T.isInfixOf "wire policy unknown fields: vendor.geometry.json"+      structural `shouldNotSatisfy` T.isInfixOf "fixture coverage: vendor.geometry"+      codec `shouldNotSatisfy` T.isInfixOf "encodeVendorGeometryShape"+    it "keeps an opaque-only context self-contained" $ do+      service <- checkedServiceOf "test/fixtures/consumer-types.keiro"+      let spec = checkedSpec service+          opaqueOnly =+            checkedServiceWithSpec+              ( spec+                  { specMapped = [declaration | declaration@MappedOpaque {} <- specMapped spec],+                    specNodes = []+                  }+              )+              service+          structural = generatedTextEndingIn "StructuralConformance.hs" (scaffoldServiceModules (defaultContext (specContext spec)) opaqueOnly)+      structural `shouldSatisfy` T.isInfixOf "import Keiro.Codec.Structural (FixtureCases (..))"+      structural `shouldSatisfy` T.isInfixOf "opaque codec round-trip: vendor.geometry.json@3/"+      structural `shouldNotSatisfy` T.isInfixOf "bindingDomainRoundTrip"+    it "imports the context structural gate once through the service facade" $ do+      service <- checkedServiceOf "test/fixtures/consumer-types.keiro"+      let ctx = defaultContext (specContext (checkedSpec service))+      case serviceHarnessModule ctx service of+        Left duplicates -> expectationFailure ("unexpected duplicate fact keys: " <> show duplicates)+        Right facade -> do+          T.count "import Generated.ConsumerDemo.StructuralConformance qualified as StructuralConformance" (moduleText facade) `shouldBe` 1+          T.count "StructuralConformance.structuralConformanceAssertions" (moduleText facade) `shouldBe` 1+          moduleText facade `shouldSatisfy` T.isInfixOf "\"structural/\" <> fact"+          moduleText facade `shouldNotSatisfy` T.isInfixOf "structuralConformanceAssertions] |"+    it "keeps every Beta artifact byte-identical when an Alpha-only mapped declaration changes" $ do+      workspace <- shouldComposeWorkspace "test/fixtures/structural-locality.keiro-workspace"+      let changedSpec = addAlphaPayloadOptionalField (wsMergedSpec workspace)+          changedMember member = member {wmSpec = addAlphaPayloadOptionalField (wmSpec member)}+          changedWorkspace = workspace {wsMembers = map changedMember (wsMembers workspace), wsMergedSpec = changedSpec}+          ctx = workspaceContext workspace+          plan value = planWorkspaceScaffold "goldens" ctx value+          moduleBytes owner planValue =+            Map.fromList+              [ (modulePath moduleValue, (moduleText moduleValue, kind moduleValue, provenance))+              | (moduleValue, provenance) <- wpModules planValue,+                ("/" <> owner <> "/") `T.isInfixOf` T.pack (modulePath moduleValue)+              ]+          moduleWith suffix planValue = generatedTextEndingIn suffix (map fst (wpModules planValue))+      baseline <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (plan workspace)+      changed <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (plan changedWorkspace)+      moduleBytes "Beta" changed `shouldBe` moduleBytes "Beta" baseline+      moduleWith "Alpha/Harness.hs" changed `shouldNotBe` moduleWith "Alpha/Harness.hs" baseline+      moduleWith "StructuralConformance.hs" changed `shouldNotBe` moduleWith "StructuralConformance.hs" baseline+      let alphaHarness = moduleWith "Alpha/Harness.hs" changed+          betaHarness = moduleWith "Beta/Harness.hs" changed+          structural = moduleWith "StructuralConformance.hs" changed+      alphaHarness `shouldSatisfy` T.isInfixOf "mapped codec round-trip: AlphaSubmitted/item/"+      betaHarness `shouldNotSatisfy` T.isInfixOf "AlphaPayload"+      T.count "binding domain round-trip: example.locality.AlphaPayload.v1/" structural `shouldBe` 1+      alphaHarness `shouldNotSatisfy` T.isInfixOf "binding domain round-trip: example.locality.AlphaPayload.v1/"+      betaHarness `shouldNotSatisfy` T.isInfixOf "binding domain round-trip: example.locality.AlphaPayload.v1/"+      structural `shouldSatisfy` T.isInfixOf "fixture coverage: example.locality.UnusedPayload.v1"+    it "refuses a missing fixture before the CLI writes any scaffold output" $+      withTempDirectory "keiro-dsl-structural-no-write" $ \out -> do+        baselineTree <- treeSnapshot out+        (exitCode, _, standardError) <- runKeiroDsl ["scaffold", "test/fixtures/mapped-missing-fixture.keiro", "--out", out]+        exitCode `shouldSatisfy` (/= ExitSuccess)+        standardError `shouldContain` "missing fixtures ingredient"+        treeSnapshot out `shouldReturn` baselineTree++  describe "semantic locality qualification" $ do+    it "pins the exact A-only generated delta and semantic report" $+      withSemanticLocalityFixture "keiro-dsl-locality-a-only" id 0 $ \_ out workspace -> do+        baselinePlan <- shouldPlanWorkspaceSpec workspace+        let changedWorkspace = mapWorkspaceSpec addAlphaPayloadOptionalField workspace+        changedPlan <- shouldPlanWorkspaceSpec changedWorkspace+        let baselineModules = map fst (wpModules baselinePlan)+            changedModules = map fst (wpModules changedPlan)+            delta = generatedTreeDelta baselineModules changedModules+            expectedPaths =+              Set.fromList+                [ "Generated/SemanticLocality/Alpha/Codec.hs",+                  "Generated/SemanticLocality/Alpha/Harness.hs",+                  "Generated/SemanticLocality/Structural/Shape/AlphaPayload.hs",+                  "Generated/SemanticLocality/StructuralConformance.hs"+                ]+            allowedRoles =+              Set.fromList+                [ moduleRole generatedModule+                | generatedModule <- changedModules,+                  modulePath generatedModule `Set.member` expectedPaths+                ]+            impact = CheckedDiff.mappedSemanticImpact (wsMergedSpec workspace) (wsMergedSpec changedWorkspace)+            renderedImpact = T.unlines (renderSemanticImpact impact)+            encodedReport = LazyText.toStrict (LazyTextEncoding.decodeUtf8 (Aeson.encode (diffReportWithSemanticImpact defaultGate (diffSpecs (wsMergedSpec workspace) (wsMergedSpec changedWorkspace)) impact)))+        changedPaths delta `shouldBe` expectedPaths+        addedPaths delta `shouldBe` Set.empty+        removedPaths delta `shouldBe` Set.empty+        assertAllowedGeneratedDelta allowedRoles baselineModules changedModules delta+        map impactDeclaration impact `shouldBe` [MappedKey "AlphaPayload"]+        map impactPreviousConsumers impact `shouldBe` [Set.singleton (AggregateConsumer "Alpha")]+        map impactCurrentConsumers impact `shouldBe` [Set.singleton (AggregateConsumer "Alpha")]+        renderedImpact `shouldSatisfy` T.isInfixOf "previous aggregate consumers: Alpha"+        renderedImpact `shouldSatisfy` T.isInfixOf "service-conformance: impacted"+        renderedImpact `shouldSatisfy` (not . T.isInfixOf "Beta")+        encodedReport `shouldSatisfy` T.isInfixOf "\"semanticImpact\""+        encodedReport `shouldSatisfy` T.isInfixOf "\"currentConsumers\":[\"Alpha\"]"+        encodedReport `shouldSatisfy` (not . T.isInfixOf "Beta")++        _ <- executePlannedWorkspaceScaffold out workspace+        report <- executePlannedWorkspaceScaffold out changedWorkspace+        semanticReportDeclarations (wsrSemanticImpact report) `shouldBe` [MappedKey "AlphaPayload"]+        map artifactPath (wsrGeneratedArtifactImpact report) `shouldBe` Set.toAscList expectedPaths+        map artifactCategory (wsrGeneratedArtifactImpact report)+          `shouldSatisfy` \categories ->+            AggregateGeneratedArtifact `elem` categories+              && ServiceStructuralConformanceArtifact `elem` categories+        map artifactCategory (wsrGeneratedArtifactImpact report)+          `shouldNotContain` [BehaviorSourceMapArtifact]+        ledger <- TIO.readFile (wsrRecordPath report)+        case parseWorkspaceRecord ledger of+          Just record -> wrSemanticImpact record `shouldSatisfy` (/= Nothing)+          Nothing -> expectationFailure "semantic-locality workspace ledger did not parse"++    it "keeps the A-only delta constant with ten unrelated aggregates" $ do+      let deltaFor count =+            withSemanticLocalityFixture ("keiro-dsl-locality-scale-" <> show count) id count $ \_ _ workspace -> do+              baseline <- shouldPlanWorkspaceSpec workspace+              changed <- shouldPlanWorkspaceSpec (mapWorkspaceSpec addAlphaPayloadOptionalField workspace)+              pure (generatedTreeDelta (map fst (wpModules baseline)) (map fst (wpModules changed)))+      twoAggregateDelta <- deltaFor 0+      twelveAggregateDelta <- deltaFor 10+      twelveAggregateDelta `shouldBe` twoAggregateDelta++    it "keeps nested and fixture-symbol changes local while shared and unused laws remain service-owned" $+      withSemanticLocalityFixture "keiro-dsl-locality-closure" id 0 $ \_ _ workspace -> do+        baseline <- shouldPlanWorkspaceSpec workspace+        nested <- shouldPlanWorkspaceSpec (mapWorkspaceSpec addNestedPayloadOptionalField workspace)+        fixtureChanged <- shouldPlanWorkspaceSpec (mapWorkspaceSpec changeAlphaPayloadFixtureSymbol workspace)+        let baselineModules = map fst (wpModules baseline)+            nestedModules = map fst (wpModules nested)+            fixtureModules = map fst (wpModules fixtureChanged)+            nestedDelta = generatedTreeDelta baselineModules nestedModules+            fixtureDelta = generatedTreeDelta baselineModules fixtureModules+            betaPaths = Set.fromList [modulePath value | value <- baselineModules, "/Beta/" `T.isInfixOf` T.pack (modulePath value)]+            structural = generatedTextEndingIn "StructuralConformance.hs" baselineModules+            alphaHarness = generatedTextEndingIn "Alpha/Harness.hs" baselineModules+            betaHarness = generatedTextEndingIn "Beta/Harness.hs" baselineModules+            snapshot = semanticImpactSnapshotForSpec (wsMergedSpec workspace)+        changedPaths nestedDelta `shouldSatisfy` Set.null . Set.intersection betaPaths+        changedPaths fixtureDelta `shouldSatisfy` Set.null . Set.intersection betaPaths+        map impactDeclaration (CheckedDiff.mappedSemanticImpact (wsMergedSpec workspace) (addNestedPayloadOptionalField (wsMergedSpec workspace)))+          `shouldBe` [MappedKey "AlphaPayload", MappedKey "NestedPayload"]+        mappedDeclarationConsumers (semanticImpactForSpec (wsMergedSpec workspace)) (MappedKey "SharedPayload")+          `shouldBe` [AggregateConsumer "Alpha", AggregateConsumer "Beta"]+        mappedDeclarationConsumers (semanticImpactForSpec (wsMergedSpec workspace)) (MappedKey "UnusedPayload")+          `shouldBe` []+        snapshotServiceInventory snapshot `shouldSatisfy` Set.member (MappedKey "UnusedPayload")+        T.count "fixture coverage: example.semantic-locality.SharedPayload.v1" structural `shouldBe` 1+        T.count "fixture coverage: example.semantic-locality.UnusedPayload.v1" structural `shouldBe` 1+        alphaHarness `shouldSatisfy` T.isInfixOf "SharedPayload"+        betaHarness `shouldSatisfy` T.isInfixOf "SharedPayload"+        alphaHarness `shouldNotSatisfy` T.isInfixOf "fixture coverage:"+        betaHarness `shouldNotSatisfy` T.isInfixOf "fixture coverage:"++    it "isolates comments, blank lines, and an unrelated rule to BehaviorSourceMap" $ do+      let mutations =+            [ ("comment", ("# source-only movement\n" <>)),+              ("blank-line", ("\n" <>)),+              ( "unrelated-rule",+                T.replace+                  "aggregate Alpha\n"+                  "rule unusedIsUnused : UnusedPayload -> Bool\n  ex Unused => true\n\naggregate Alpha\n"+              )+            ]+      forM_ mutations $ \(variantName, mutateSource) ->+        withSemanticLocalityFixture ("keiro-dsl-locality-source-" <> variantName) id 0 $ \root out workspace -> do+          _ <- executePlannedWorkspaceScaffold out workspace+          treeBefore <- treeSnapshot out+          let memberPath = root </> "domain/alpha.keiro"+          original <- TIO.readFile memberPath+          TIO.writeFile memberPath (mutateSource original)+          moved <- loadTempWorkspace root+          report <- executePlannedWorkspaceScaffold out moved+          let overwritten = [modulePath value | (value, _, Overwritten) <- wsrDispositions report]+              sourceMapPath path = T.isSuffixOf "/BehaviorSourceMap.hs" (T.pack path)+          overwritten `shouldSatisfy` \case+            [path] -> sourceMapPath path+            _ -> False+          semanticReportDeclarations (wsrSemanticImpact report) `shouldBe` []+          map artifactCategory (wsrGeneratedArtifactImpact report) `shouldBe` [BehaviorSourceMapArtifact]+          treeAfter <- treeSnapshot out+          let treeDelta = generatedTreeDeltaFromSnapshot treeBefore treeAfter+              ledgerPath path = T.isPrefixOf "keiro-dsl-ledger.workspace." (T.pack path)+          changedPaths treeDelta `shouldSatisfy` \paths ->+            Set.size paths == 2+              && any sourceMapPath paths+              && any ledgerPath paths+          filter (\(path, _) -> not (sourceMapPath path || ledgerPath path)) treeAfter+            `shouldBe` filter (\(path, _) -> not (sourceMapPath path || ledgerPath path)) treeBefore++    it "keeps complete scaffold bytes deterministic under member reordering" $+      withSemanticLocalityFixture "keiro-dsl-locality-order-a" id 0 $ \_ outA workspaceA ->+        withSemanticLocalityFixture "keiro-dsl-locality-order-b" reverse 0 $ \_ outB workspaceB -> do+          _ <- executePlannedWorkspaceScaffold outA workspaceA+          _ <- executePlannedWorkspaceScaffold outB workspaceB+          expected <- treeSnapshot outA+          treeSnapshot outB `shouldReturn` expected++  describe "generated Haskell language contract" $ do+    it "limits every representative generated module to the closed local extension set" $ do+      let allowed =+            Set.fromList+              [ "BlockArguments",+                "DeriveAnyClass",+                "DuplicateRecordFields",+                "OverloadedLabels",+                "OverloadedRecordDot",+                "QualifiedDo",+                "TemplateHaskell",+                "TypeFamilies"+              ]+          fixtures =+            [ "test/fixtures/aggregate-scalar-expressions-v2.keiro",+              "test/fixtures/nominal-scalars.keiro",+              "test/fixtures/structural-conformance.keiro",+              "test/fixtures/reservation.keiro",+              "test/fixtures/contract-v4.keiro",+              "test/fixtures/intake.keiro",+              "test/fixtures/reservation-work.keiro",+              "test/fixtures/readmodel-runtime.keiro"+            ]+      forM_ fixtures $ \fixture -> do+        modules <- scaffoldFixture fixture+        forM_ [generatedModule | generatedModule <- modules, kind generatedModule == Generated] $ \generatedModule -> do+          let actual = Set.fromList (generatedLocalExtensions generatedModule)+          unless (actual `Set.isSubsetOf` allowed) $+            expectationFailure (fixture <> ":" <> modulePath generatedModule <> ": disallowed local extensions " <> show (Set.toList (actual `Set.difference` allowed)))++    it "retains specialized syntax extensions and removes GHC2024-covered pragmas" $ do+      scalar <- scaffoldFixture "test/fixtures/aggregate-scalar-expressions-v2.keiro"+      structural <- scaffoldFixture "test/fixtures/structural-conformance.keiro"+      reservation <- scaffoldFixture "test/fixtures/reservation.keiro"+      contract <- scaffoldFixture "test/fixtures/contract-v4.keiro"+      intake <- scaffoldFixture "test/fixtures/intake.keiro"+      queue <- scaffoldFixture "test/fixtures/reservation-work.keiro"+      readModel <- scaffoldFixture "test/fixtures/readmodel-runtime.keiro"+      generatedExtensionsEndingIn "ScalarAccount/Domain.hs" scalar+        `shouldBe` ["DeriveAnyClass", "DuplicateRecordFields", "TemplateHaskell"]+      generatedExtensionsEndingIn "ScalarAccount/Transducer.hs" scalar+        `shouldBe` ["BlockArguments", "OverloadedLabels", "OverloadedRecordDot", "QualifiedDo"]+      generatedExtensionsEndingIn "Nominals.hs" scalar `shouldContain` ["DeriveAnyClass", "TypeFamilies"]+      generatedExtensionsEndingIn "Nominals/Internal.hs" scalar `shouldBe` []+      generatedExtensionsEndingIn "StructuralProjections.hs" structural `shouldBe` ["TypeFamilies"]+      let structuralShapeExtensions =+            [ generatedLocalExtensions generatedModule+            | generatedModule <- structural,+              "/Structural/Shape/" `T.isInfixOf` T.pack (modulePath generatedModule)+            ]+      structuralShapeExtensions `shouldSatisfy` all null+      generatedExtensionsEndingIn "Projection.hs" reservation `shouldBe` []+      generatedExtensionsEndingIn "ReplayAudit.hs" reservation `shouldBe` []+      generatedExtensionsEndingIn "Contract.hs" contract `shouldBe` ["DuplicateRecordFields", "OverloadedRecordDot"]+      generatedExtensionsEndingIn "Inbox.hs" intake `shouldBe` []+      generatedExtensionsEndingIn "Queue.hs" queue `shouldBe` ["OverloadedRecordDot"]+      generatedExtensionsEndingIn "ReadModel.hs" readModel `shouldBe` ["OverloadedRecordDot"]++    it "conditions record, label, derivation, and duplicate-selector extensions on emitted syntax" $ do+      mappedGuardSource <- readTestText "test/fixtures/mapped-guard.keiro"+      mappedGuardParsed <- case parseSource "mapped-guard-no-expression.keiro" (T.replace "guard current == current ; " "" mappedGuardSource) of+        Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+        Right parsed -> pure parsed+      let mappedGuardService = checkedSource mappedGuardParsed+          mappedGuard = scaffoldServiceModules (defaultContext (specContext (checkedSpec mappedGuardService))) mappedGuardService+      registerFree <- scaffoldFixture "test/fixtures/order.keiro"+      readModels <- scaffoldFixture "test/fixtures/readmodel.keiro"+      snapshot <- scaffoldFixture "test/fixtures/reservation-snapshot.keiro"+      ordinary <- scaffoldFixture "test/fixtures/reservation.keiro"+      generatedExtensionsEndingIn "Holder/Domain.hs" mappedGuard `shouldBe` ["TemplateHaskell"]+      generatedExtensionsEndingIn "Holder/Codec.hs" mappedGuard `shouldBe` []+      generatedExtensionsEndingIn "Holder/Transducer.hs" mappedGuard+        `shouldBe` ["BlockArguments", "QualifiedDo"]+      generatedExtensionsEndingIn "Holder/Harness.hs" mappedGuard `shouldBe` ["OverloadedLabels"]+      generatedExtensionsEndingIn "Order/Harness.hs" registerFree `shouldBe` []+      generatedExtensionsEndingIn "TransferDecisions/ReadModel.hs" readModels `shouldBe` ["OverloadedRecordDot"]+      generatedExtensionsEndingIn "Subscriptions/ReadModel.hs" readModels `shouldBe` []+      generatedExtensionsEndingIn "Reservation/Domain.hs" snapshot `shouldContain` ["DeriveAnyClass"]+      generatedExtensionsEndingIn "Reservation/Domain.hs" ordinary `shouldNotContain` ["DeriveAnyClass"]++      disjoint <-+        parseInlineSpec "<disjoint-contract>" $+          T.unlines+            [ "language keiro-dsl 4",+              "context language-contract",+              "contract disjoint {",+              "  schemaVersion 1",+              "  discriminator kind",+              "  topic events \"events\"",+              "  event First on events { first: text }",+              "  event Second on events { second: text }",+              "}"+            ]+      emptyPayload <-+        parseInlineSpec "<empty-contract>" $+          T.unlines+            [ "language keiro-dsl 4",+              "context language-contract",+              "contract empty {",+              "  schemaVersion 1",+              "  discriminator kind",+              "  topic events \"events\"",+              "  event Empty on events { }",+              "}"+            ]+      let contractExtensions spec =+            generatedExtensionsEndingIn+              "Contract.hs"+              [ generatedModule+              | contractNode <- [contractNode | NContract contractNode <- specNodes spec],+                generatedModule <- scaffoldContract (defaultContext (specContext spec)) contractNode+              ]+      contractExtensions disjoint `shouldBe` ["OverloadedRecordDot"]+      contractExtensions emptyPayload `shouldBe` []++  describe "manifest (M2)" $ do+    it "lists exactly the modules the scaffolder produced" $ do+      mods <- scaffoldFixture "test/fixtures/reservation.keiro"+      service <- checkedServiceOf "test/fixtures/reservation.keiro"+      let manifest = renderManifestForService "reservation.keiro" mods service+          expectedNames = sort (map (moduleNameOf . modulePath) mods)+      assertGeneratedHaskellContract "reservation.keiro" manifest+      -- every produced module name appears in the manifest…+      mapM_ (\m -> (m `T.isInfixOf` manifest) `shouldBe` True) expectedNames+      -- …and the module list is exactly the scaffolder's output set.+      expectedNames+        `shouldBe` sort+          [ "Generated.HospitalCapacity.Reservation.Codec",+            "Generated.HospitalCapacity.Reservation.BehaviorContract",+            "Generated.HospitalCapacity.Reservation.Domain",+            "Generated.HospitalCapacity.Reservation.EventStream",+            "Generated.HospitalCapacity.Reservation.Harness",+            "Generated.HospitalCapacity.Reservation.Projection",+            "Generated.HospitalCapacity.Reservation.Transducer",+            "Generated.HospitalCapacity.Nominals",+            "Generated.HospitalCapacity.Nominals.Internal",+            "Generated.HospitalCapacity.ReplayAudit",+            "HospitalCapacity.Reservation.BehaviorHoles",+            "HospitalCapacity.Reservation.Holes"+          ]+    it "derives the dependency set from the node kinds present (aggregate)" $ do+      service <- checkedServiceOf "test/fixtures/reservation.keiro"+      manifestDependenciesForService service `shouldBe` ["aeson", "base", "keiki", "keiro", "text"]+    it "derives the process dependency set, including worker-policy runtime imports" $ do+      service <- checkedServiceOf "test/fixtures/hospital-surge.keiro"+      let dependencies = manifestDependenciesForService service+      mapM_ (\dependency -> dependencies `shouldContain` [dependency]) ["time", "uuid", "shibuya-core", "keiki", "keiro"]+    it "uses the registered shibuya-core package name for router scaffolds" $ do+      service <- checkedServiceOf "test/fixtures/incident-paging/incident-paging.keiro"+      let dependencies = manifestDependenciesForService service+      mapM_ (\dependency -> dependencies `shouldContain` [dependency]) ["effectful-core", "keiro", "shibuya-core"]+      dependencies `shouldNotContain` ["shibuya"]++  describe "service conformance facade (plan 188 M2)" $ do+    it "normalizes aggregate and read-model checks behind one base-only API" $ do+      service <- checkedServiceOf "test/fixtures/transfer-routing.keiro"+      let ctx = defaultContext (specContext (checkedSpec service))+      case serviceHarnessModule ctx service of+        Left duplicates -> expectationFailure ("unexpected duplicate fact keys: " <> show duplicates)+        Right facade -> do+          committed <- readTestText ("test/conformance-newsurface/" <> modulePath facade)+          normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText facade)+          moduleNameOf (modulePath facade) `shouldBe` "Generated.TransferRouting.Conformance"+          moduleText facade `shouldSatisfy` T.isInfixOf ".harnessAssertions"+          moduleText facade `shouldSatisfy` T.isInfixOf ".readModelFactResults"+          moduleText facade `shouldSatisfy` T.isInfixOf "aggregate/Hospital/"+          moduleText facade `shouldSatisfy` T.isInfixOf "readmodel/hospital_load/"+          moduleText facade `shouldSatisfy` T.isInfixOf "qualified as Hospital"+          moduleText facade `shouldSatisfy` T.isInfixOf "qualified as HospitalLoad"+          moduleText facade `shouldNotSatisfy` T.isInfixOf "qualified as Harness"+          moduleText facade `shouldNotSatisfy` T.isInfixOf "TransferRouting.Hospital.Holes"+    it "projects process, router, and workflow facts with qualified stable keys" $ do+      processService <- checkedServiceOf "test/fixtures/hospital-surge.keiro"+      routerService <- checkedServiceOf "test/fixtures/incident-paging/incident-paging.keiro"+      workflowService <- checkedServiceOf "test/fixtures/workflow-evolution.keiro"+      let select predicate = filter predicate . specNodes . checkedSpec+          factNodes =+            select (\case NProcess {} -> True; _ -> False) processService+              <> select (\case NRouter {} -> True; _ -> False) routerService+              <> select (\case NWorkflow {} -> True; _ -> False) workflowService+          baseSpec = checkedSpec processService+          service = checkedServiceWithSpec (baseSpec {specNodes = factNodes}) processService+          ctx = defaultContext (specContext baseSpec)+      forM_+        [ "process/HospitalSurge/maxAttempts",+          "router/PagingRouter/dispatchCommand",+          "workflow/HospitalTransferReservation/body"+        ]+        (\key -> serviceConformanceFactKeys service `shouldSatisfy` elem key)+      case serviceHarnessModule ctx service of+        Left duplicates -> expectationFailure ("unexpected duplicate fact keys: " <> show duplicates)+        Right facade -> do+          moduleText facade `shouldSatisfy` T.isInfixOf ".processHarnessValues"+          moduleText facade `shouldSatisfy` T.isInfixOf ".routerHarnessValues"+          moduleText facade `shouldSatisfy` T.isInfixOf ".workflowFactValues"+    it "uses the shared context-level placement policy" $ do+      service <- checkedServiceOf "test/fixtures/contract-v4.keiro"+      let ctx = Context {contextName = "modules", moduleRoot = "Mori", placement = CollocatedLeaf}+      serviceConformanceModuleName ctx `shouldBe` "Mori.Modules.Generated.Conformance"+      case serviceHarnessModule ctx service of+        Left duplicates -> expectationFailure ("unexpected duplicate fact keys: " <> show duplicates)+        Right facade -> do+          moduleText facade `shouldSatisfy` T.isInfixOf "runServiceConformanceChecks = pure []"+          moduleText facade `shouldSatisfy` T.isInfixOf "serviceConformanceFacts = []"+    it "adds one facade only to configured single-file plans and exposes only it" $ do+      service <- checkedServiceOf "test/fixtures/reservation.keiro"+      let ctx = defaultContext (specContext (checkedSpec service))+          runtimePackage = RuntimePackageName "reservation-runtime"+      unconfigured <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planTestServiceScaffold ctx service)+      configured <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planTestServiceScaffoldWithRuntimePackage (Just runtimePackage) ctx service)+      let facadeName = serviceConformanceModuleName ctx+          facades = [moduleValue | moduleValue <- configured, moduleNameOf (modulePath moduleValue) == facadeName]+          manifest = renderManifestForServiceWithFacade (Just facadeName) "reservation.keiro" configured service+      length configured `shouldBe` length unconfigured + 1+      length facades `shouldBe` 1+      manifest `shouldSatisfy` T.isInfixOf ("exposed-modules:\n    " <> facadeName)+      T.count facadeName manifest `shouldBe` 1+    it "emits one context-level facade for a multi-member workspace regardless of member order" $ do+      canonical <- shouldComposeWorkspace canonicalWorkspacePath+      reordered <- shouldComposeWorkspace "test/fixtures/workspace/service-reordered.keiro-workspace"+      let runtimePackage = Just (RuntimePackageName "demo-runtime")+          plan workspace =+            planWorkspaceScaffoldWithRuntimePackageAndGoldens [] runtimePackage "goldens" (workspaceContext workspace) workspace+          facades workspacePlan =+            [ (moduleText moduleValue, provenance)+            | (moduleValue, provenance) <- wpModules workspacePlan,+              ".Conformance" `T.isSuffixOf` moduleNameOf (modulePath moduleValue)+            ]+      canonicalPlan <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (plan canonical)+      reorderedPlan <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (plan reordered)+      facades canonicalPlan `shouldBe` facades reorderedPlan+      map snd (facades canonicalPlan) `shouldBe` [ContextLevel]+    it "refuses duplicate normalized fact keys before planning writes" $ do+      service <- checkedServiceOf "test/fixtures/hospital-surge.keiro"+      let spec = checkedSpec service+          processes = [node | node@NProcess {} <- specNodes spec]+          duplicated = checkedServiceWithSpec (spec {specNodes = processes <> processes}) service+      serviceHarnessModule (defaultContext (specContext spec)) duplicated `shouldSatisfy` isLeft++  describe "runnable service conformance package (plan 188 M3)" $ do+    it "uses readable ordinary names and collision-safe punctuation encoding" $ do+      cabaliseConformanceService "mori" `shouldBe` "mori"+      cabaliseConformanceService "mori_core" `shouldNotBe` cabaliseConformanceService "mori-core"+      cabaliseConformanceService "Mori" `shouldNotBe` cabaliseConformanceService "mori"+      conformancePackageDirectory (WorkspaceConformanceService "mori") `shouldBe` "keiro-dsl-conformance.workspace.mori"+      conformancePackageDirectory (StandaloneConformanceService "mori") `shouldBe` "keiro-dsl-conformance.mori"+    it "plans one base-only package and round-trips its complete generated record" $ do+      service <- checkedServiceOf "test/fixtures/hospital-surge.keiro"+      let runtimePackage = RuntimePackageName "hospital-runtime"+          facade = "Generated.HospitalSurge.Conformance"+      plan <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planConformancePackage (StandaloneConformanceService "hospital-surge") runtimePackage facade service)+      cppPackageName plan `shouldBe` "keiro-hospital-surge-conformance"+      length [file | file <- cppFiles plan, takeExtension (conformanceFilePath file) == ".cabal"] `shouldBe` 1+      cabalFile <- case [file | file <- cppFiles plan, takeExtension (conformanceFilePath file) == ".cabal"] of+        [file] -> pure file+        files -> expectationFailure ("expected one Cabal file, got " <> show (map conformanceFilePath files)) >> fail "unreachable"+      let cabalText = conformanceFileText cabalFile+      cabalText `shouldSatisfy` T.isInfixOf "base >=4.18 && <5"+      T.lines cabalText `shouldSatisfy` (\lines' -> case lines' of first : _ -> first == "cabal-version: 3.0"; [] -> False)+      cabalText `shouldSatisfy` T.isInfixOf "hospital-runtime"+      cabalText `shouldSatisfy` T.isInfixOf "ghc-options: -Wall"+      cabalText `shouldNotSatisfy` T.isInfixOf "    , keiro-dsl\n"+      recordFile <- case [file | file <- cppFiles plan, conformanceFilePath file == conformanceRecordFileName] of+        [file] -> pure file+        files -> expectationFailure ("expected one package record, got " <> show (map conformanceFilePath files)) >> fail "unreachable"+      let recordText = conformanceFileText recordFile+      parseConformancePackageRecord recordText+        `shouldBe` Just+          ConformancePackageRecord+            { cprSchema = 1,+              cprServiceKey = cppServiceKey plan,+              cprRuntimePackage = runtimePackage,+              cprFacadeModule = facade,+              cprFiles = [(conformanceFileKind file, conformanceFilePath file) | file <- cppFiles plan]+            }+    it "tolerates future rows and JSON keys while round-tripping awkward safe paths" $ do+      let recordText =+            T.unlines+              [ "keiro-dsl conformance ledger v1",+                "service-key standalone hospital-surge",+                "runtime-package hospital-runtime",+                "facade-module Generated.HospitalSurge.Conformance",+                "file {\"kind\":\"generated\",\"path\":\"generated/file with space.hs\",\"future-key\":true}",+                "future-row {\"value\":1}"+              ]+          expected =+            ConformancePackageRecord+              { cprSchema = 1,+                cprServiceKey = StandaloneConformanceService "hospital-surge",+                cprRuntimePackage = RuntimePackageName "hospital-runtime",+                cprFacadeModule = "Generated.HospitalSurge.Conformance",+                cprFiles = [(Generated, "generated/file with space.hs")]+              }+      parseConformancePackageRecord recordText `shouldBe` Just expected+      parseConformancePackageRecord (renderConformancePackageRecord expected) `shouldBe` Just expected+      parseConformancePackageRecord (T.replace "generated/file with space.hs" "../escape.hs" recordText)+        `shouldBe` Nothing+      parseConformancePackageRecord (T.replace "future-row {\"value\":1}" "file {\"kind\":\"generated\",\"path\":\"GENERATED/FILE WITH SPACE.HS\"}" recordText)+        `shouldBe` Nothing+    it "compares unique facts by key and distinguishes mismatch, missing, and unexpected" $ do+      compareConformanceFacts [("a", "1"), ("b", "2"), ("d", "4")] [("c", "3"), ("a", "1"), ("b", "9")]+        `shouldBe` Right+          [ ConformanceFactMatch "a" "1",+            ConformanceFactMismatch "b" "2" "9",+            ConformanceFactUnexpected "c" "3",+            ConformanceFactMissing "d" "4"+          ]+      compareConformanceFacts [("a", "1"), ("a", "2")] []+        `shouldBe` Left [DuplicateFactKey ExpectedFact "a"]+    it "creates once, reports generated files unchanged, and preserves accepted expectations" $ do+      withTempDirectory "keiro-dsl-conformance-package" $ \out -> do+        parsed <- parsedSourceOf "test/fixtures/hospital-surge.keiro"+        let service = checkedSource parsed+            spec = checkedSpec service+            ctx = defaultContext (specContext spec)+            runtimePackage = RuntimePackageName "hospital-runtime"+        modules <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planTestServiceScaffoldWithRuntimePackage (Just runtimePackage) ctx service)+        first <- executeServiceScaffoldWithRuntimePackage (Just runtimePackage) out False "hospital-surge.keiro" (parsedSourceLanguage parsed) ctx service modules+        firstReport <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure first+        firstPackage <- maybe (expectationFailure "expected conformance package report" >> fail "unreachable") pure (reportConformancePackage firstReport)+        let packageRoot = out </> conformancePackageDirectory (StandaloneConformanceService (contextName ctx))+            expectationsPath = packageRoot </> "src/KeiroConformance/Expectations.hs"+            accepted = "module KeiroConformance.Expectations where\n-- accepted by the application\n"+        map snd (conformanceReportDispositions firstPackage) `shouldContain` [ConformanceCreated]+        TIO.writeFile expectationsPath accepted+        second <- executeServiceScaffoldWithRuntimePackage (Just runtimePackage) out True "hospital-surge.keiro" (parsedSourceLanguage parsed) ctx service modules+        secondReport <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure second+        secondPackage <- maybe (expectationFailure "expected conformance package report" >> fail "unreachable") pure (reportConformancePackage secondReport)+        TIO.readFile expectationsPath `shouldReturn` accepted+        [ disposition+          | (file, disposition) <- conformanceReportDispositions secondPackage,+            conformanceFileKind file == Generated+          ]+          `shouldSatisfy` all (== ConformanceUnchanged)+        [ disposition+          | (file, disposition) <- conformanceReportDispositions secondPackage,+            conformanceFileKind file == HoleStub+          ]+          `shouldBe` [ConformanceSkipped]+    -- Migration used to be planned only when the run also planned a conformance+    -- package, so a spec that stopped generating one left its legacy record+    -- behind — and unreadable, since the current reader has no legacy parser.+    -- See ExecPlan 199.+    it "migrates an orphaned legacy conformance record even with no package planned" $+      withTempDirectory "keiro-dsl-orphan-conformance-ledger" $ \out -> do+        parsed <- parsedSourceOf "test/fixtures/hospital-surge.keiro"+        let service = checkedSource parsed+            spec = checkedSpec service+            ctx = defaultContext (specContext spec)+            orphanDirectory = out </> "keiro-dsl-conformance.standalone.retired-service"+            orphanPath = orphanDirectory </> legacyConformanceRecordFileName+            -- No --runtime-package, so this run plans no conformance package at+            -- all: the record below belongs to a package that no longer exists.+            run apply = do+              modules <-+                either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure $+                  planTestServiceScaffoldWithRuntimePackage Nothing ctx service+              executeServiceScaffoldWithRuntimePackageAndNameMigrations+                Nothing+                apply+                out+                False+                "hospital-surge.keiro"+                (parsedSourceLanguage parsed)+                ctx+                service+                modules+        -- Build the orphan from a record the current writer produced, so the+        -- test exercises the discovery change and not a hand-typed format.+        withTempDirectory "keiro-dsl-orphan-source" $ \source -> do+          let sourceRuntime = RuntimePackageName "retired-runtime"+              sourcePackageRoot = source </> conformancePackageDirectory (StandaloneConformanceService (contextName ctx))+          sourceModules <-+            either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure $+              planTestServiceScaffoldWithRuntimePackage (Just sourceRuntime) ctx service+          _ <-+            executeServiceScaffoldWithRuntimePackageAndNameMigrations+              (Just sourceRuntime)+              False+              source+              False+              "hospital-surge.keiro"+              (parsedSourceLanguage parsed)+              ctx+              service+              sourceModules+              >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+          ledger <- TIO.readFile (sourcePackageRoot </> conformanceLedgerFileName)+          record <-+            maybe (expectationFailure "conformance ledger did not parse" >> fail "unreachable") pure $+              parseConformancePackageRecord ledger+          createDirectoryIfMissing True orphanDirectory+          TIO.writeFile+            orphanPath+            ( T.unlines $+                [line | line <- T.lines ledger, isGeneratedBannerLine line]+                  <> [ "schema 1",+                       "service-key standalone " <> contextName ctx,+                       "runtime-package " <> unRuntimePackageName (cprRuntimePackage record),+                       "facade-module " <> cprFacadeModule record+                     ]+                  <> [ "file "+                         <> (case fileKind of Generated -> "generated"; HoleStub -> "create-once")+                         <> " "+                         <> T.pack path+                     | (fileKind, path) <- cprFiles record+                     ]+            )+        refused <- run False+        refused `shouldSatisfy` \case+          Left [SidecarMigrationRequired [move]] ->+            sidecarMoveDisposition move == ConvertLegacyConformanceLedger+          _ -> False++        applied <- run True >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        map sidecarMoveDisposition (reportSidecarMoves applied) `shouldBe` [ConvertLegacyConformanceLedger]+        doesFileExist orphanPath `shouldReturn` False+        doesFileExist (orphanDirectory </> conformanceLedgerFileName) `shouldReturn` True++    it "converts a legacy conformance record losslessly and keeps service-key mismatch refusal" $+      withTempDirectory "keiro-dsl-conformance-ledger-migration" $ \out -> do+        parsed <- parsedSourceOf "test/fixtures/hospital-surge.keiro"+        let service = checkedSource parsed+            spec = checkedSpec service+            ctx = defaultContext (specContext spec)+            runtimePackage = RuntimePackageName "hospital-runtime"+            packageRoot = out </> conformancePackageDirectory (StandaloneConformanceService (contextName ctx))+            currentPath = packageRoot </> conformanceLedgerFileName+            legacyPath = packageRoot </> legacyConformanceRecordFileName+            backupPath = out </> ".keiro-dsl-name-migrations/sidecar-v1" </> conformancePackageDirectory (StandaloneConformanceService (contextName ctx)) </> legacyConformanceRecordFileName+        modules <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planTestServiceScaffoldWithRuntimePackage (Just runtimePackage) ctx service)+        let run apply =+              executeServiceScaffoldWithRuntimePackageAndNameMigrations+                (Just runtimePackage)+                apply+                out+                False+                "hospital-surge.keiro"+                (parsedSourceLanguage parsed)+                ctx+                service+                modules+            renderLegacyKey (WorkspaceConformanceService value) = "workspace " <> value+            renderLegacyKey (StandaloneConformanceService value) = "standalone " <> value+            renderLegacyKind Generated = "generated"+            renderLegacyKind HoleStub = "create-once"+        _ <- run False >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        currentContents <- TIO.readFile currentPath+        record <- maybe (expectationFailure "fresh conformance ledger did not parse" >> fail "unreachable") pure (parseConformancePackageRecord currentContents)+        let legacyRecord =+              record+                { cprFiles =+                    [ (fileKind, if path == conformanceLedgerFileName then legacyConformanceRecordFileName else path)+                    | (fileKind, path) <- cprFiles record+                    ]+                }+            legacyContents =+              T.unlines $+                [line | line <- T.lines currentContents, isGeneratedBannerLine line]+                  <> [ "schema 1",+                       "service-key " <> renderLegacyKey (cprServiceKey legacyRecord),+                       "runtime-package " <> unRuntimePackageName (cprRuntimePackage legacyRecord),+                       "facade-module " <> cprFacadeModule legacyRecord+                     ]+                  <> ["file " <> renderLegacyKind fileKind <> " " <> T.pack path | (fileKind, path) <- cprFiles legacyRecord]+        renameFile currentPath legacyPath+        TIO.writeFile legacyPath legacyContents+        migrationTreeBefore <- treeSnapshot out+        refused <- run False+        refused `shouldSatisfy` \case+          Left [SidecarMigrationRequired [move]] -> sidecarMoveDisposition move == ConvertLegacyConformanceLedger+          _ -> False+        treeSnapshot out `shouldReturn` migrationTreeBefore+        applied <- run True >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        map sidecarMoveDisposition (reportSidecarMoves applied) `shouldBe` [ConvertLegacyConformanceLedger]+        doesFileExist legacyPath `shouldReturn` False+        TIO.readFile backupPath `shouldReturn` legacyContents+        migrated <- TIO.readFile currentPath+        cprServiceKey <$> parseConformancePackageRecord migrated+          `shouldBe` Just (StandaloneConformanceService (contextName ctx))++        TIO.writeFile+          currentPath+          ( T.replace+              ("service-key standalone " <> contextName ctx)+              "service-key standalone another-service"+              migrated+          )+        mismatchBefore <- treeSnapshot out+        mismatch <- run False+        mismatch `shouldSatisfy` \case+          Left [ConformancePackageRefusal ConformancePackageRecordMismatch {}] -> True+          _ -> False+        treeSnapshot out `shouldReturn` mismatchBefore+    it "refuses a bannerless package file before changing any runtime byte" $ do+      withTempDirectory "keiro-dsl-conformance-atomic" $ \out -> do+        parsed <- parsedSourceOf "test/fixtures/hospital-surge.keiro"+        let service = checkedSource parsed+            spec = checkedSpec service+            ctx = defaultContext (specContext spec)+            runtimePackage = RuntimePackageName "hospital-runtime"+        modules <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planTestServiceScaffoldWithRuntimePackage (Just runtimePackage) ctx service)+        executeServiceScaffoldWithRuntimePackage (Just runtimePackage) out False "hospital-surge.keiro" (parsedSourceLanguage parsed) ctx service modules+          >>= either (\failure -> expectationFailure (show failure)) (const (pure ()))+        facade <- case [moduleValue | moduleValue <- modules, ".Conformance" `T.isSuffixOf` moduleNameOf (modulePath moduleValue)] of+          [moduleValue] -> pure moduleValue+          values -> expectationFailure ("expected one facade, got " <> show (map modulePath values)) >> fail "unreachable"+        let facadePath = out </> modulePath facade+            serviceKey = contextName ctx+            cabalPath = out </> conformancePackageDirectory (StandaloneConformanceService serviceKey) </> T.unpack ("keiro-" <> cabaliseConformanceService serviceKey <> "-conformance.cabal")+        TIO.appendFile facadePath "-- would be overwritten if runtime execution began\n"+        TIO.writeFile cabalPath "hand-owned cabal file\n"+        packageTree <- treeSnapshot out+        refused <- executeServiceScaffoldWithRuntimePackage (Just runtimePackage) out False "hospital-surge.keiro" (parsedSourceLanguage parsed) ctx service modules+        refused `shouldSatisfy` isLeft+        treeSnapshot out `shouldReturn` packageTree+    it "keeps a two-aggregate workspace at exactly one Cabal package" $ do+      withTempDirectory "keiro-dsl-conformance-workspace" $ \out -> do+        workspace <- shouldComposeWorkspace canonicalWorkspacePath+        let runtimePackage = Just (RuntimePackageName "workspace-runtime")+        plan <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planWorkspaceScaffoldWithRuntimePackageAndGoldens [] runtimePackage "goldens" (workspaceContext workspace) workspace)+        length [() | NAggregate {} <- specNodes (checkedSpec (checkedWorkspace workspace))] `shouldBe` 2+        executeWorkspaceScaffold out False plan >>= either (\failure -> expectationFailure (show failure)) (const (pure ()))+        packageDirectories <- filter (T.isPrefixOf "keiro-dsl-conformance.workspace." . T.pack) <$> listDirectory out+        packageDirectories `shouldBe` ["keiro-dsl-conformance.workspace.demo-project"]+        case packageDirectories of+          [packageDirectory] -> do+            cabalFiles <- filter ((== ".cabal") . takeExtension) <$> listDirectory (out </> packageDirectory)+            length cabalFiles `shouldBe` 1+          _ -> expectationFailure "expected one package directory"+    it "scaffolds the multi-member proof idempotently through the public CLI" $ do+      withTempDirectory "keiro-dsl-conformance-proof-cli" $ \base -> do+        let fixture = "test/conformance-service-package"+            copied = base </> "fixture"+            out = copied </> "runtime/src"+            sourcePaths =+              [ "service.keiro-workspace",+                "domain/alpha.keiro",+                "domain/beta.keiro",+                "domain/evidence.keiro",+                "domain/shared.keiro"+              ]+        fixtureManifest <- resolveTestPath (fixture </> "service.keiro-workspace") >>= canonicalizePath+        let fixtureRoot = takeDirectory fixtureManifest+        forM_ sourcePaths $ \relative -> TIO.readFile (fixtureRoot </> relative) >>= writeFileWithParents (copied </> relative)+        (firstCode, firstOut, firstErr) <- runKeiroDsl ["scaffold", copied </> "service.keiro-workspace", "--out", out]+        unless (firstCode == ExitSuccess) (expectationFailure (firstOut <> firstErr))+        firstTree <- treeSnapshot out+        length [path | (path, _) <- firstTree, takeExtension path == ".cabal"] `shouldBe` 1+        length [path | (path, _) <- firstTree, "Generated/Conformance.hs" `T.isSuffixOf` T.pack path] `shouldBe` 1+        let recordPath = out </> conformancePackageDirectory (WorkspaceConformanceService "workspace-proof") </> conformanceRecordFileName+        record <- parseConformancePackageRecord <$> TIO.readFile recordPath+        cprServiceKey <$> record `shouldBe` Just (WorkspaceConformanceService "workspace-proof")+        (secondCode, secondOut, secondErr) <- runKeiroDsl ["scaffold", copied </> "service.keiro-workspace", "--out", out]+        unless (secondCode == ExitSuccess) (expectationFailure (secondOut <> secondErr))+        secondErr `shouldSatisfy` isInfixOfString "keiro-workspace-proof-conformance.cabal (unchanged)"+        secondErr `shouldSatisfy` isInfixOfString "Expectations.hs (skipped: already present)"+        secondErr `shouldSatisfy` isInfixOfString "Generated.Conformance"+        treeSnapshot out `shouldReturn` firstTree+    it "keeps Expectations fixed and turns the generated target red for a changed workflow fact" $ do+      withTempDirectory "keiro-dsl-conformance-proof-mutation" $ \base -> do+        fixtureManifest <- resolveTestPath "test/conformance-service-package/service.keiro-workspace" >>= canonicalizePath+        let fixtureRoot = takeDirectory fixtureManifest+        let copied = base </> "fixture"+            out = copied </> "runtime/src"+            evidencePath = copied </> "domain/evidence.keiro"+            expectationsPath = out </> "keiro-dsl-conformance.workspace.workspace-proof/src/KeiroConformance/Expectations.hs"+        copyTextTree fixtureRoot copied+        acceptedExpectations <- TIO.readFile expectationsPath+        TIO.readFile evidencePath+          >>= TIO.writeFile evidencePath . T.replace "name \"workspace-proof-workflow\"" "name \"workspace-proof-workflow-v2\""+        (scaffoldCode, scaffoldOut, scaffoldErr) <- runKeiroDsl ["scaffold", copied </> "service.keiro-workspace", "--out", out]+        unless (scaffoldCode == ExitSuccess) (expectationFailure (scaffoldOut <> scaffoldErr))+        TIO.readFile expectationsPath `shouldReturn` acceptedExpectations+        let repositoryRoot = takeDirectory (takeDirectory (takeDirectory fixtureRoot))+            projectPath = base </> "mutation.project"+            buildDirectory = base </> "dist-newstyle"+            packageRoot = out </> "keiro-dsl-conformance.workspace.workspace-proof"+        TIO.writeFile+          projectPath+          ( T.unlines+              [ "packages:",+                "  " <> T.pack (repositoryRoot </> "keiro"),+                "  " <> T.pack (repositoryRoot </> "keiro-core"),+                "  " <> T.pack (copied </> "runtime"),+                "  " <> T.pack packageRoot,+                "",+                "allow-newer:",+                "  haxl:time"+              ]+          )+        (testCode, testOut, testErr) <-+          readProcessWithExitCode+            "cabal"+            [ "test",+              "--project-file=" <> projectPath,+              "--builddir=" <> buildDirectory,+              "keiro-workspace-proof-conformance"+            ]+            ""+        testCode `shouldNotBe` ExitSuccess+        (testOut <> testErr)+          `shouldSatisfy` isInfixOfString "FAIL  workflow/WorkspaceProofWorkflow/name expected=\"workspace-proof-workflow\" actual=\"workspace-proof-workflow-v2\""++  describe "new <kind> skeletons (M5)" $ do+    forM_ skeletonKinds $ \skeletonKind ->+      it ("the " <> T.unpack skeletonKind <> " skeleton selects and preserves the active authoring language") $+        assertSkeletonUsesAuthoringLanguage skeletonKind+    it "every skeleton parses and validates with zero error diagnostics" $+      mapM_ assertSkeletonValid skeletonKinds+    it "every skeleton passes the scaffold refusal gates" $+      mapM_ assertSkeletonScaffoldable skeletonKinds+    -- `derive … hole` is mandatory emit grammar. While it carried a warning, a+    -- freshly generated emit service could never satisfy the documented CI+    -- recipe, no matter what its author did. See ExecPlan 199.+    it "every skeleton without a confirmed benign inversion satisfies the documented --deny-warnings CI gate" $+      withTempDirectory "keiro-dsl-skeleton-deny" $ \out ->+        -- router and process are deliberately absent: their idiomatic+        -- on-duplicate/on-reject spellings are confirmed benign inversions+        -- (RouterBenignInversion/ProcessBenignInversion), so those services+        -- gate CI with a selective --deny list rather than --deny-warnings.+        forM_ ["emit", "intake", "aggregate", "contract", "workqueue", "workflow"] $ \kind ->+          case skeletonFor kind of+            Left err -> expectationFailure (T.unpack err)+            Right source -> do+              let specPath = out </> T.unpack kind <> ".keiro"+              TIO.writeFile specPath source+              (exitCode, stdoutText, stderrText) <-+                runKeiroDsl ["check", specPath, "--min-language", "4", "--deny-warnings"]+              unless (exitCode == ExitSuccess) $+                expectationFailure (T.unpack kind <> " skeleton failed the gate:\n" <> stdoutText <> stderrText)+              stderrText `shouldNotContain` "escalated to failure"+    it "rejects an unknown kind with a helpful message" $+      case skeletonFor "bogus" of+        Left msg -> ("Valid kinds:" `T.isInfixOf` msg) `shouldBe` True+        Right _ -> expectationFailure "expected an error for an unknown kind"++  describe "firewall self-check (M3)" $ do+    it "flags a forbidden operator in a Generated module" $ do+      let m = ScaffoldModule {modulePath = "Gen/Foo.hs", moduleText = "x = a ./= b", kind = Generated, origin = "test"}+      firewallBreaches [m] `shouldBe` [("Gen/Foo.hs", "./=", 1)]+    it "ignores forbidden operators in a HoleStub module (holes own them)" $ do+      let m = ScaffoldModule {modulePath = "Foo/Holes.hs", moduleText = "x = lit 1 .== y", kind = HoleStub, origin = "test"}+      firewallBreaches [m] `shouldBe` []+    it "matches `lit` as a word, not a substring of quality/split" $ do+      let clean = ScaffoldModule {modulePath = "Gen/Q.hs", moduleText = "quality = split facility", kind = Generated, origin = "test"}+          dirty = ScaffoldModule {modulePath = "Gen/L.hs", moduleText = "v = lit foo", kind = Generated, origin = "test"}+      firewallBreaches [clean] `shouldBe` []+      firewallBreaches [dirty] `shouldBe` [("Gen/L.hs", "lit", 1)]+    it "skips strings and comments and maximal-munches symbolic tokens" $ do+      let clean = syntheticGenerated "Gen/Clean.hs" "wire = \"lit .== B.slot\"\n-- x =: y\nx = a .<= b"+          dirty = syntheticGenerated "Gen/Dirty.hs" "x = a .< b\ny = c =: d"+      firewallBreaches [clean] `shouldBe` [("Gen/Clean.hs", ".<=", 3)]+      firewallBreaches [dirty] `shouldBe` [("Gen/Dirty.hs", ".<", 1), ("Gen/Dirty.hs", "=:", 2)]+    it "guards keiki imports while allowing the generated Core allowlist" $ do+      let forbidden = syntheticGenerated "Gen/Builder.hs" "import Keiki.Builder"+          restricted = syntheticGenerated "Gen/CoreBad.hs" "import Keiki.Core (lit)"+          allowed = syntheticGenerated "Gen/CoreGood.hs" "import Keiki.Core (RegFile (..), HsPred, step)"+      firewallBreaches [forbidden] `shouldBe` [("Gen/Builder.hs", "import:Keiki.Builder", 1)]+      firewallBreaches [restricted] `shouldBe` [("Gen/CoreBad.hs", "import:Keiki.Core", 1)]+      firewallBreaches [allowed] `shouldBe` []+    it "exempts only the authoritative generated transducer module path" $ do+      let expressions = syntheticGenerated "Gen/Aggregate/Expressions.hs" "import Keiki.Core qualified as K\nx = K.lit 1"+          transducer = syntheticGenerated "Gen/Aggregate/Transducer.hs" "import Keiki.Builder qualified as B\nx = B.slot"+          ordinary = syntheticGenerated "Gen/Aggregate/Projection.hs" "import Keiki.Builder qualified as B"+      firewallBreaches [expressions, transducer]+        `shouldBe` [("Gen/Aggregate/Expressions.hs", "import:Keiki.Core", 1)]+      firewallBreaches [ordinary] `shouldBe` [("Gen/Aggregate/Projection.hs", "import:Keiki.Builder", 1)]+    it "finds no breach in real scaffolder output (aggregate + process fixtures)" $ do+      aggMods <- scaffoldFixture "test/fixtures/reservation.keiro"+      procMods <- legacyScaffoldProcessFixture "test/fixtures/hospital-surge.keiro"+      firewallBreaches (aggMods <> procMods) `shouldBe` []++  describe "generated provenance banners (plan 182 M4)" $ do+    it "stamps the running package version, effective language, and module origin" $ do+      service <- checkedServiceOf "test/fixtures/contract-v4.keiro"+      let ctx = defaultContext (specContext (checkedSpec service))+      case planTestServiceScaffold ctx service of+        Left refusals -> expectationFailure (show refusals)+        Right modules -> do+          let generated = [moduleValue | moduleValue <- modules, kind moduleValue == Generated]+          generated `shouldSatisfy` (not . null)+          forM_ generated $ \moduleValue -> do+            let recognized = filter isGeneratedBannerLine (T.lines (moduleText moduleValue))+                expected = generatedBannerFor (checkedLanguageContract service) (origin moduleValue)+            recognized `shouldBe` [expected]+            expected+              `shouldSatisfy` T.isInfixOf+                ( "keiro-dsl "+                    <> T.pack (showVersion Package.version)+                    <> " (language keiro-dsl 4) from contract emergency"+                )+      workspace <- shouldComposeWorkspace canonicalWorkspacePath+      workspacePlan <- shouldPlanWorkspaceSpec workspace+      forM_ [moduleValue | (moduleValue, _) <- wpModules workspacePlan, kind moduleValue == Generated] $ \moduleValue ->+        filter isGeneratedBannerLine (T.lines (moduleText moduleValue))+          `shouldBe` [generatedBannerFor (checkedLanguageContract (checkedWorkspace workspace)) (origin moduleValue)]+    it "recognizes only the historical banner and the stamped format" $ do+      let contract = effectiveLanguageContract LegacyUnversioned+      isGeneratedBannerLine generatedBanner `shouldBe` True+      isGeneratedBannerLine (generatedBannerFor contract "aggregate Counter (line 2)") `shouldBe` True+      isGeneratedBannerLine "-- @generated by another tool" `shouldBe` False+      isGeneratedBannerLine codecComparisonBanner `shouldBe` False+    it "migrates a legacy-banner file and keeps repeated scaffold bytes stable" $+      withTempDirectory "keiro-dsl-stamped-banner" $ \out -> do+        spec <- parseInlineSpec "<stamped-banner>" loweringAggregateSpec+        let ctx = defaultContext (specContext spec)+        modules <- case planTestScaffold ctx spec of+          Left refusals -> expectationFailure (show refusals) >> pure []+          Right planned -> pure planned+        case [moduleValue | moduleValue <- modules, kind moduleValue == Generated] of+          target : _ -> do+            let path = out </> modulePath target+                stamped = generatedBannerFor (effectiveLanguageContract LegacyUnversioned) (origin target)+                legacyText = T.replace stamped generatedBanner (moduleText target)+            createDirectoryIfMissing True (takeDirectory path)+            TIO.writeFile path legacyText+            first <- executeScaffold out False "counter.keiro" ctx spec modules+            first `shouldSatisfy` isSuccessfulScaffold+            firstTree <- treeSnapshot out+            second <- executeScaffold out False "counter.keiro" ctx spec modules+            second `shouldSatisfy` isSuccessfulScaffold+            treeSnapshot out `shouldReturn` firstTree+            TIO.readFile path `shouldReturn` moduleText target+          [] -> expectationFailure "counter scaffold has no Generated module"++  describe "service-aware fixture helpers" $ do+    it "retains version-4 contract TypeIDs and their durable admission identities" $ do+      service <- checkedServiceOf "test/fixtures/contract-v4.keiro"+      modules <- scaffoldFixture "test/fixtures/contract-v4.keiro"+      let contractModule = generatedTextEndingIn "Contract.hs" modules+          identities = idDomainIdentitiesForService service+      contractModule `shouldSatisfy` T.isInfixOf "incidentId :: !(KindID \"inc\")"+      contractModule `shouldSatisfy` T.isInfixOf "reservationId :: !(KindID \"rsv\")"+      identities+        `shouldContain` ["id-domain|name=contract:emergency.IncidentTransferNeedDeclared.incidentId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=inc|separator=_|json=canonical-json-text"]++  describe "scaffold gates" $ do+    it "reports case-folded generated paths through the complete check diagnostics" $ do+      spec <- specOf "test/fixtures/reservation.keiro"+      case [aggregate | NAggregate aggregate <- specNodes spec] of+        aggregate : _ -> do+          let caseVariant =+                spec+                  { specNodes =+                      [ NAggregate aggregate,+                        NAggregate aggregate {aggName = T.toUpper (aggName aggregate)}+                      ]+                  }+              diagnostics =+                checkTestServiceDiagnostics+                  Nothing+                  (defaultContext (specContext caseVariant))+                  (legacyCheckedService caseVariant)+          map code diagnostics `shouldContain` [GeneratedPathCollision]+          case [ diagnostic+               | diagnostic <- diagnostics,+                 code diagnostic == GeneratedPathCollision,+                 "Domain.hs" `T.isInfixOf` message diagnostic+               ] of+            [diagnostic] -> do+              line diagnostic `shouldBe` unLoc (aggLoc aggregate)+              relatedLocations diagnostic `shouldSatisfy` (not . null)+              message diagnostic `shouldSatisfy` T.isInfixOf "case-insensitive filesystem"+            found -> expectationFailure ("expected one generated-path diagnostic, got " <> show found)+          withTempDirectory "keiro-dsl-check-path-collision" $ \root -> do+            let sourcePath = root </> "collision.keiro"+            version <- maybe (expectationFailure "language version 4 missing" >> fail "unreachable") pure (languageVersion 4)+            TIO.writeFile sourcePath (renderSource (ParsedSource (DeclaredLanguage version noLoc) caseVariant))+            (exitCode, out, err) <- runKeiroDsl ["check", sourcePath]+            exitCode `shouldBe` ExitFailure 1+            out `shouldBe` ""+            err `shouldContain` "error[GeneratedPathCollision]"+        [] -> expectationFailure "reservation fixture has no aggregate"+    it "uses lowering before module planning in both scaffold planners" $ do+      spec <- specOf "test/fixtures/emit.keiro"+      case [contract | NContract contract <- specNodes spec] of+        contract : _ -> do+          let defective =+                mapPublisher+                  (\publisher -> publisher {pubBackoff = BackoffSpec "exponential" "2s" Nothing Nothing})+                  spec+                    { specNodes = NContract contract : specNodes spec+                    }+              ctx = defaultContext (specContext defective)+              workspace = oneMemberWorkspace "emit.keiro" defective+          case (planTestScaffold ctx defective, planWorkspaceScaffold "goldens" ctx workspace) of+            (Left (LoweringRefusal singleReasons : _), Left (LoweringRefusal workspaceReasons : _)) ->+              workspaceReasons `shouldBe` singleReasons+            results -> expectationFailure ("expected lowering first from both planners, got " <> show results)+        [] -> expectationFailure "emit fixture has no contract"+    it "maps import cycles and planner invariants into stable check codes" $ do+      planningRefusalDiagnostics [ImportCycle ["A", "B", "A"]]+        `shouldSatisfy` any ((== GeneratedImportCycle) . code)+      planningRefusalDiagnostics [BehaviorRefusal [Behavior.DuplicateBehaviorIdentity "duplicate" [Loc 9]]]+        `shouldSatisfy` any (\diagnostic -> code diagnostic == BehaviorDerivationInvalid && line diagnostic == 9)+      planningRefusalDiagnostics [DuplicateConformanceFactKeys [DuplicateServiceFactKey "duplicate"]]+        `shouldSatisfy` any ((== ConformanceFactKeyCollision) . code)+      planningRefusalDiagnostics [SemanticContractMismatch "test mismatch"]+        `shouldSatisfy` any ((== GeneratedPlanningInvariantViolation) . code)+      spec <- specOf "test/fixtures/consumer-types.keiro"+      let cyclic = spec {specMapped = map moveArtifactBindingIntoGenerated (specMapped spec)}+      checkTestServiceDiagnostics Nothing (defaultContext (specContext cyclic)) (stableCheckedService cyclic)+        `shouldSatisfy` any ((== GeneratedImportCycle) . code)+    it "refuses duplicate and case-folded module paths with both origins" $ do+      spec <- specOf "test/fixtures/reservation.keiro"+      case [aggregate | NAggregate aggregate <- specNodes spec] of+        aggregate : _ -> do+          let duplicate = spec {specNodes = [NAggregate aggregate, NAggregate aggregate]}+              caseVariant = spec {specNodes = [NAggregate aggregate, NAggregate aggregate {aggName = T.toUpper (aggName aggregate)}]}+          planTestScaffold (defaultContext (specContext spec)) duplicate `shouldSatisfy` hasPathCollisionWithTwoOrigins+          planTestScaffold (defaultContext (specContext spec)) caseVariant `shouldSatisfy` hasPathCollisionWithTwoOrigins+        [] -> expectationFailure "reservation fixture has no aggregate"+    it "refuses a bannerless Generated target without changing its bytes" $+      withTempDirectory "keiro-dsl-banner" $ \out -> do+        spec <- specOf "test/fixtures/reservation.keiro"+        let ctx = defaultContext (specContext spec)+        case planTestScaffold ctx spec of+          Left refusals -> expectationFailure ("unexpected planning refusal: " <> show refusals)+          Right modules -> case [m | m <- modules, kind m == Generated] of+            generated : _ -> do+              let target = out </> modulePath generated+              createDirectoryIfMissing True (takeDirectory target)+              TIO.writeFile target "hand owned\n"+              result <- executeScaffold out False "test/fixtures/reservation.keiro" ctx spec modules+              result `shouldSatisfy` isMissingBannerRefusal+              TIO.readFile target `shouldReturn` "hand owned\n"+              forced <- executeScaffold out True "test/fixtures/reservation.keiro" ctx spec modules+              forced `shouldSatisfy` isSuccessfulScaffold+              TIO.readFile target `shouldReturn` moduleText generated+            [] -> expectationFailure "reservation scaffold has no Generated module"+    it "reports renamed-node modules as stale without deleting them" $+      withTempDirectory "keiro-dsl-stale-rename" $ \out -> do+        spec <- parseInlineSpec "<stale-rename>" loweringAggregateSpec+        first <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext spec)) spec+        let renamed = spec {specNodes = map renameCounter (specNodes spec)}+        second <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext renamed)) renamed+        let oldDomain = onlyPathEndingIn "Counter/Domain.hs" (map fst (reportDispositions first))+            oldHoles = onlyPathEndingIn "Counter/Holes.hs" (map fst (reportDispositions first))+        reportStale second `shouldSatisfy` \stale ->+          StaleModule Generated oldDomain (Just ExactGeneratedBannerPresent) `elem` stale+            && StaleModule HoleStub oldHoles Nothing `elem` stale+        doesFileExist (out </> oldDomain) `shouldReturn` True+        doesFileExist (out </> oldHoles) `shouldReturn` True+        renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "exact generated banner present; verify unchanged bytes before deleting")+        renderScaffoldReport second `shouldSatisfy` all (not . T.isInfixOf "safe to delete")+    it "preserves a stale generated path whose exact banner is missing" $+      withTempDirectory "keiro-dsl-stale-banner" $ \out -> do+        spec <- parseInlineSpec "<stale-banner>" loweringAggregateSpec+        first <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext spec)) spec+        let oldDomain = onlyPathEndingIn "Counter/Domain.hs" (map fst (reportDispositions first))+            renamed = spec {specNodes = map renameCounter (specNodes spec)}+        TIO.writeFile (out </> oldDomain) "-- generated by something else\n"+        second <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext renamed)) renamed+        reportStale second `shouldSatisfy` elem (StaleModule Generated oldDomain (Just ExactGeneratedBannerMissing))+        renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "exact generated banner missing; preserve and review")+        TIO.readFile (out </> oldDomain) `shouldReturn` "-- generated by something else\n"+    it "reports the entire old tree across a module-root flip" $+      withTempDirectory "keiro-dsl-stale-root" $ \out -> do+        spec <- parseInlineSpec "<stale-root>" loweringAggregateSpec+        let initialCtx = defaultContext (specContext spec)+            rootedCtx = initialCtx {moduleRoot = "Acme"}+        first <- executePlannedScaffold out "counter.keiro" initialCtx spec+        second <- executePlannedScaffold out "moved-counter.keiro" rootedCtx spec+        reportStale second+          `shouldMatchList` [ StaleModule (kind m) (modulePath m) (if kind m == Generated then Just ExactGeneratedBannerPresent else Nothing)+                            | (m, _) <- reportDispositions first+                            ]+        forM_ (reportStale second) $ \stale -> doesFileExist (out </> stalePath stale) `shouldReturn` True+        renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "previous scaffold record used spec counter.keiro")+    it "reports moved generated modules across a layout flip" $+      withTempDirectory "keiro-dsl-stale-layout" $ \out -> do+        spec <- parseInlineSpec "<stale-layout>" loweringAggregateSpec+        let initialCtx = defaultContext (specContext spec)+            collocatedCtx = initialCtx {placement = CollocatedLeaf}+        first <- executePlannedScaffold out "counter.keiro" initialCtx spec+        second <- executePlannedScaffold out "counter.keiro" collocatedCtx spec+        let oldGenerated = [StaleModule Generated (modulePath m) (Just ExactGeneratedBannerPresent) | (m, _) <- reportDispositions first, kind m == Generated]+        reportStale second `shouldSatisfy` all (`elem` oldGenerated)+        length (reportStale second) `shouldBe` length oldGenerated+    it "writes a parseable record and no stale section for a fresh output" $+      withTempDirectory "keiro-dsl-record" $ \out -> do+        spec <- parseInlineSpec "<fresh-record>" loweringAggregateSpec+        let ctx = defaultContext (specContext spec)+        report <- executePlannedScaffold out "counter.keiro" ctx spec+        reportStale report `shouldBe` []+        renderScaffoldReport report `shouldSatisfy` all (not . T.isPrefixOf "stale:")+        contents <- TIO.readFile (out </> recordFileName (specContext spec))+        requirements <- either (\errors -> expectationFailure (show errors) >> pure []) pure (Behavior.deriveBehaviorRequirements spec)+        let expected =+              ScaffoldRecord+                { recSpecPath = "counter.keiro",+                  recModuleRoot = "",+                  recLayout = "prefixed",+                  recSourceLanguage = LegacyUnversioned,+                  recLanguageContract = effectiveLanguageContract LegacyUnversioned,+                  recNamingEdition = IdiomaticNamingV1,+                  recModuleRoles = [ScaffoldModuleRoleRow (moduleRole m) (kind m) (modulePath m) | (m, _) <- reportDispositions report],+                  recFiles = [(kind m, modulePath m) | (m, _) <- reportDispositions report],+                  recMappings = [],+                  recIdDomains = [],+                  recNominalEqualities = [],+                  recBindingObligations = [],+                  recBehaviorRequirements = Behavior.behaviorRecordRows requirements,+                  recProjectionCatalogFacts = [],+                  recQueryContractBaseline = False,+                  recQueryContracts = either (const []) id (queryContractIdentities spec),+                  recRouterSelections = [],+                  recSemanticImpact = Just (semanticImpactSnapshotForSpec spec)+                }+            sourceRows = filter ("source-language " `T.isPrefixOf`) (T.lines contents)+            withoutSourceRows = T.unlines (filter (not . T.isPrefixOf "source-language ") (T.lines contents))+            semanticRows = filter ("semantic-contract " `T.isPrefixOf`) (T.lines contents)+            withoutSemanticRows = T.unlines (filter (not . T.isPrefixOf "semantic-contract ") (T.lines contents))+        parseRecord contents `shouldBe` Just expected+        contents `shouldNotSatisfy` T.isInfixOf "query-contract-baseline"+        parseRecord withoutSourceRows `shouldBe` Just expected+        parseRecord withoutSemanticRows `shouldBe` Just expected+        case sourceRows of+          [sourceRow] -> do+            parseRecord (T.replace sourceRow (sourceRow <> "\n" <> sourceRow) contents) `shouldBe` Nothing+            parseRecord (T.replace sourceRow "source-language {malformed}" contents) `shouldBe` Nothing+          _ -> expectationFailure "expected exactly one source-language row"+        case semanticRows of+          [semanticRow] -> do+            parseRecord (T.replace semanticRow (semanticRow <> "\n" <> semanticRow) contents) `shouldBe` Nothing+            parseRecord (T.replace semanticRow "semantic-contract {malformed}" contents) `shouldBe` Nothing+            parseRecord (T.replace "\"languageVersion\":1" "\"languageVersion\":2" contents) `shouldBe` Nothing+          _ -> expectationFailure "expected exactly one semantic-contract row"+        parseRecord (T.replace "spec: " "future-field: retained\nspec: " contents) `shouldBe` parseRecord contents+        parseRecord (T.replace "record v1" "record v2" contents) `shouldBe` Nothing+    it "records declared provenance and reports a header-only scaffold drift" $+      withTempDirectory "keiro-dsl-language-drift" $ \out -> do+        spec <- parseInlineSpec "<language-drift>" loweringAggregateSpec+        let ctx = defaultContext (specContext spec)+        modules <- case planTestScaffold ctx spec of+          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"+          Right planned -> pure planned+        _ <- executePlannedScaffold out "counter.keiro" ctx spec+        case languageVersion 1 of+          Nothing -> expectationFailure "version 1 was not constructible"+          Just version -> do+            let declared = DeclaredLanguage version noLoc+            result <- executeScaffoldWithLanguage out False "counter.keiro" declared ctx spec modules+            case result of+              Left refusals -> expectationFailure (show refusals)+              Right report -> do+                reportSourceLanguageDrift report+                  `shouldBe` Just (SourceLanguageDrift LegacyUnversioned declared)+                contents <- TIO.readFile (reportRecordPath report)+                recSourceLanguage <$> parseRecord contents `shouldBe` Just declared++  describe "faithful scaffold lowering" $ do+    it "escapes a trailing-backslash payload literal exactly once" $ do+      spec <- specOf "test/fixtures/hospital-surge.keiro"+      case [process | NProcess process <- specNodes spec] of+        process : _ -> do+          let timer = (procTimer process) {tmPayload = [FieldBinding "kind" (Just "\"follow-up\\\"")]}+              modules = scaffoldProcess (defaultContext (specContext spec)) process {procTimer = timer}+          generatedTextEndingIn "Process.hs" modules+            `shouldSatisfy` T.isInfixOf "\"kind\" .= (\"follow-up\\\\\" :: Value)"+        [] -> expectationFailure "hospital-surge fixture has no process"+    it "preserves quoted Text register initials and refuses unsafe register shapes" $ do+      spec <- parseInlineSpec "<register-initials>" loweringAggregateSpec+      let modules = scaffoldAggregate (defaultContext (specContext spec)) spec =<< [aggregate | NAggregate aggregate <- specNodes spec]+          domain = generatedTextEndingIn "Domain.hs" modules+      domain `shouldSatisfy` T.isInfixOf "RCons (Proxy @\"note\") \"hello world\""+      scaffoldRefusals spec `shouldBe` []+      bare <- parseInlineSpec "<bare-text-initial>" (T.replace "\"hello world\"" "hello" loweringAggregateSpec)+      scaffoldRefusals bare `shouldSatisfy` any (T.isInfixOf "RegTextInitialNotQuoted")+      unsupported <- parseInlineSpec "<unsupported-field>" (T.replace "count:Int" "count:Json" loweringAggregateSpec)+      scaffoldRefusals unsupported `shouldSatisfy` any (T.isInfixOf "FieldTypeUnrepresentable")+    it "lowers seconds, minutes, hours, and both backoff constructors faithfully" $ do+      windowSeconds "90s" `shouldBe` Right 90+      windowSeconds "5m" `shouldBe` Right 300+      windowSeconds "2h" `shouldBe` Right 7200+      emitSource <- readTestText "test/fixtures/emit.keiro"+      let exponentialSource = T.replace "backoff constant 2s" "backoff exponential 2s max=60s multiplier=2.0" emitSource+      exponential <- parseInlineSpec "<exponential-backoff>" exponentialSource+      case [publisher | NPublisher publisher <- specNodes exponential] of+        publisher : _ -> do+          let generated = generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext exponential)) publisher)+          generated `shouldSatisfy` T.isInfixOf "ExponentialBackoff ExponentialBackoffOptions { initial = 2, maxDelay = 60, multiplier = 2.0 }"+          parseSpec "<exponential-round-trip>" (renderSpec exponential) `shouldBe` Right exponential+        [] -> expectationFailure "emit fixture has no publisher"+      constant <- parseInlineSpec "<constant-backoff>" (T.replace "backoff constant 2s" "backoff constant 2m" emitSource)+      case [publisher | NPublisher publisher <- specNodes constant] of+        publisher : _ -> generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext constant)) publisher) `shouldSatisfy` T.isInfixOf "ConstantBackoff 120"+        [] -> expectationFailure "emit fixture has no publisher"+    it "refuses incomplete exponential backoff and rejects unknown window units" $ do+      emitSource <- readTestText "test/fixtures/emit.keiro"+      incomplete <- parseInlineSpec "<incomplete-backoff>" (T.replace "backoff constant 2s" "backoff exponential 2s" emitSource)+      scaffoldRefusals incomplete `shouldSatisfy` any (T.isInfixOf "BackoffExponentialIncomplete")+      parseSpec "<bad-window>" (T.replace "backoff constant 2s" "backoff constant 2x" emitSource)+        `shouldSatisfy` leftContains "time unit: s, m, or h"+    it "lowers workqueue retry windows in minutes to seconds" $ do+      queueSource <- readTestText "test/fixtures/reservation-work.keiro"+      queueSpec <- parseInlineSpec "<minute-queue>" (T.replace "5s" "5m" queueSource)+      case [workqueue | NWorkqueue workqueue <- specNodes queueSpec] of+        workqueue : _ -> do+          let policy = generatedTextEndingIn "QueuePolicy.hs" (scaffoldWorkqueue (defaultContext (specContext queueSpec)) workqueue)+          policy `shouldSatisfy` T.isInfixOf "defaultRetryDelay = RetryDelay 300"+          policy `shouldSatisfy` T.isInfixOf "Retry (RetryDelay 300)"+        [] -> expectationFailure "queue fixture has no workqueue"+    it "uses exact status-map keys and emits total Int harness samples" $ do+      statusSpec <- parseInlineSpec "<exact-status>" exactStatusSpec+      case [aggregate | NAggregate aggregate <- specNodes statusSpec] of+        aggregate : _ -> do+          let ctx = defaultContext (specContext statusSpec)+              projection = generatedTextEndingIn "Projection.hs" (scaffoldAggregate ctx statusSpec aggregate)+              harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx statusSpec aggregate)+          projection `shouldSatisfy` T.isInfixOf "ReservationUnHeld {} -> Just \"available\""+          harness `shouldSatisfy` T.isInfixOf "CountBumpedData 0"+          harness `shouldNotSatisfy` T.isInfixOf "sample: unsupported"+        [] -> expectationFailure "exact-status spec has no aggregate"++  describe "scaffold" $ do+    it "keeps field DSL names, generated selectors, and wire keys independent" $ do+      source <- readTestText "test/fixtures/aggregate-field-alias.keiro"+      document <- case parseSourceDocument "aggregate-field-alias.keiro" source of+        Left failure -> expectationFailure (show failure) >> fail "unreachable"+        Right value -> pure value+      let ParsedSourceDocument {documentParsedSource = parsedSource, documentSourceIndex = sourceIndex} = document+          service = checkedSource parsedSource+          spec = checkedSpec service+          ctx = defaultContext (specContext spec)+          modules = scaffoldServiceModules ctx service+          domain = generatedTextEndingIn "Domain.hs" modules+          codec = generatedTextEndingIn "Codec.hs" modules+      workspace <-+        either+          (\failure -> expectationFailure (show failure) >> fail "unreachable")+          pure+          (oneMemberParsedDocumentWorkspace "aggregate-field-alias.keiro" document)+      validateService service `shouldBe` []+      domain `shouldSatisfy` ((== 2) . T.count "payloadType :: !Text")+      domain `shouldSatisfy` ((== 2) . T.count "serviceRegion :: !Text")+      domain `shouldSatisfy` ((== 2) . T.count "family :: !Text")+      codec `shouldSatisfy` T.isInfixOf "\"type\" .= payload.payloadType"+      codec `shouldSatisfy` T.isInfixOf "\"region_code\" .= payload.serviceRegion"+      codec `shouldSatisfy` T.isInfixOf "o .: \"region_code\""+      scaffoldServiceModules ctx service `shouldBe` modules+      fmap (map fst . wpModules) (planWorkspaceScaffold "goldens" ctx workspace)+        `shouldBe` planIndexedServiceScaffold sourceIndex ctx service++      newSpec <- parseInlineSpec "aggregate-field-alias-v2.keiro" (T.replace "event FieldsCopied =" "event FieldsCopied v2 =" source)+      case goldensForDiff spec newSpec of+        [golden] -> do+          goldenJson golden `shouldSatisfy` T.isInfixOf "\"family\":\"sample\""+          goldenJson golden `shouldSatisfy` T.isInfixOf "\"type\":\"sample\""+          goldenJson golden `shouldSatisfy` T.isInfixOf "\"region_code\":\"sample\""+          goldenJson golden `shouldSatisfy` (not . T.isInfixOf "payloadType")+          goldenJson golden `shouldSatisfy` (not . T.isInfixOf "serviceRegion")+        goldens -> expectationFailure ("expected one field-alias golden, got " <> show goldens)++    it "keeps aggregate fold identity neutral across field aliases" $ do+      let sourceFor field =+            T.unlines+              [ "language keiro-dsl 4",+                "context field-alias-neutrality",+                "aggregate AliasNeutrality",+                "  regs",+                "  states Open",+                "  command Observe { " <> field <> " }",+                "  event Observed = fields(Observe)",+                "  wire kind=ctorName fields=camelCase schemaVersion=1"+              ]+      base <- checkedServiceFromText "field-alias-base.keiro" (sourceFor "region:Text")+      selectorAlias <- checkedServiceFromText "field-alias-selector.keiro" (sourceFor "region haskell serviceRegion:Text")+      wireAlias <- checkedServiceFromText "field-alias-wire.keiro" (sourceFor "region as \"region_code\":Text")+      let fingerprint service = aggregateFoldFingerprintForService service (onlyAggregate (checkedSpec service))+          codecFor service =+            generatedTextEndingIn+              "Codec.hs"+              (scaffoldServiceModules (defaultContext (specContext (checkedSpec service))) service)+      fingerprint selectorAlias `shouldBe` fingerprint base+      fingerprint wireAlias `shouldBe` fingerprint base+      codecFor base `shouldSatisfy` T.isInfixOf "\"region\" .= payload.region"+      codecFor selectorAlias `shouldSatisfy` T.isInfixOf "\"region\" .= payload.serviceRegion"+      codecFor selectorAlias `shouldSatisfy` (not . T.isInfixOf "region_code")+      codecFor wireAlias `shouldSatisfy` T.isInfixOf "\"region_code\" .= payload.region"++    it "synthesizes the exact old wire shape and embeds it in the harness" $ do+      oldSpec <- specOf "test/fixtures/reservation.keiro"+      newSpec <- specOf "test/fixtures/reservation-v2.keiro"+      case goldensForDiff oldSpec newSpec of+        [golden] -> do+          goldenRelativePath golden+            `shouldBe` "hospital-capacity/Reservation/TransferReservationCreated.v1.json"+          goldenJson golden+            `shouldBe` "{\"commandId\":\"cmd_01hzy3v7q2e8kaw2m5x0d41n9c\",\"divertStatus\":\"open\",\"hospitalId\":\"hosp_01hzy3v7q2e8kaw2m5x0d41n9c\",\"kind\":\"TransferReservationCreated\",\"lifeCriticalOverride\":true,\"patientAcuity\":\"red\",\"reservationId\":\"rsv_01hzy3v7q2e8kaw2m5x0d41n9c\"}\n"+          goldenEvidence golden `shouldBe` SynthesizedWeakStandIn+          let aggregate = onlyAggregate newSpec+              modules =+                harnessForWithGoldens+                  [golden]+                  (defaultContext (specContext newSpec))+                  newSpec+                  aggregate+              harness = generatedTextEndingIn "Harness.hs" modules+          harness `shouldSatisfy` T.isInfixOf "golden TransferReservationCreated.v1 decodes"+          harness `shouldSatisfy` T.isInfixOf "\\\"reservationId\\\":\\\"rsv_"+          harness `shouldSatisfy` (not . T.isInfixOf "current-shape stand-in")+        goldens -> expectationFailure ("expected one synthesized golden, got " <> show goldens)+    it "synthesizes complete nested mapped old shapes deterministically and never overwrites captured evidence" $ do+      oldSpec <- specOf "test/fixtures/consumer-types.keiro"+      newSpec <- specOf "test/fixtures/consumer-types-v2.keiro"+      case goldensForDiff oldSpec newSpec of+        [golden] -> do+          goldenEvidence golden `shouldBe` SynthesizedWeakStandIn+          goldenJson golden `shouldSatisfy` T.isInfixOf "\"artifact\":{"+          goldenJson golden `shouldSatisfy` T.isInfixOf "\"location\":{\"contents\":\"sample\",\"tag\":\"local_file\"}"+          goldenJson golden `shouldSatisfy` T.isInfixOf "\"labels\":[\"sample\"]"+          goldenJson golden `shouldSatisfy` T.isInfixOf "\"revision\":1"+          goldenJson golden `shouldSatisfy` T.isInfixOf "\"observedAt\":\"2026-01-01T00:00:00Z\""+          goldensForDiff oldSpec newSpec `shouldBe` [golden]+          withTempDirectory "keiro-golden-preserve" $ \root -> do+            let target = root </> goldenRelativePath golden+            createDirectoryIfMissing True (takeDirectory target)+            TIO.writeFile target "hand captured\n"+            emitGoldenPayloads root oldSpec newSpec `shouldReturn` []+            TIO.readFile target `shouldReturn` "hand captured\n"+          withTempDirectory "keiro-golden-write" $ \root -> do+            let target = root </> goldenRelativePath golden+            emitGoldenPayloads root oldSpec newSpec `shouldReturn` [target]+            TIO.readFile target `shouldReturn` goldenJson golden+        goldens -> expectationFailure ("expected one nested synthesized golden, got " <> show goldens)+    it "dispatches shared-version upcasters by wire event type and passes foreign kinds through" $ do+      parsed <- parsedSourceOf "test/fixtures/reservation-dup-upcast-source.keiro"+      let spec = parsedSpec parsed+      case [aggregate | NAggregate aggregate <- specNodes spec] of+        [_] -> do+          let modules = scaffoldServiceModules (defaultContext (specContext spec)) (checkedSource parsed)+              codec = generatedTextEndingIn "Codec.hs" modules+              holes = case [moduleText m | m <- modules, "/Holes.hs" `T.isSuffixOf` T.pack (modulePath m)] of+                [text] -> text+                _ -> ""+          codec `shouldSatisfy` T.isInfixOf "upcasters = [(1, upcastRungV1)]"+          codec `shouldSatisfy` T.isInfixOf "upcastRungV1 (EventType \"TransferReservationCreated\") value = upcastTransferReservationCreatedV1 value"+          codec `shouldSatisfy` T.isInfixOf "upcastRungV1 (EventType \"TransferReservationConfirmed\") value = upcastTransferReservationConfirmedV1 value"+          codec `shouldSatisfy` T.isInfixOf "upcastRungV1 _ value = Right value"+          holes `shouldSatisfy` T.isInfixOf "receives ONLY TransferReservationCreated payloads"+        _ -> expectationFailure "expected exactly one aggregate"+    it "keeps foreign payloads byte-for-byte and invokes both same-rung event upcasters" $ do+      let payloadA = object ["kind" .= ("AmountScaled" :: T.Text), "amount" .= (2 :: Int)]+          payloadB = object ["kind" .= ("AmountRenamed" :: T.Text), "amount" .= (3 :: Int)]+          foreignPayload = object ["kind" .= ("AmountObserved" :: T.Text), "amount" .= (7 :: Int)]+          upcastA _ = Right (object ["kind" .= ("AmountScaled" :: T.Text), "amount" .= (200 :: Int)])+          upcastB _ = Right (object ["kind" .= ("AmountRenamed" :: T.Text), "amountInCents" .= (300 :: Int)])+          rung (EventType "AmountScaled") = upcastA+          rung (EventType "AmountRenamed") = upcastB+          rung _ = Right+          codec =+            Codec+              { eventTypes = EventType "AmountScaled" :| [EventType "AmountRenamed", EventType "AmountObserved"],+                eventType = const (EventType "AmountObserved"),+                schemaVersion = 2,+                encode = id,+                decode = \_ -> Right,+                upcasters = [(1, rung)]+              } ::+              Codec Value+      decodeRaw codec (EventType "AmountObserved") 1 foreignPayload `shouldBe` Right foreignPayload+      decodeRaw codec (EventType "AmountScaled") 1 payloadA+        `shouldBe` Right (object ["kind" .= ("AmountScaled" :: T.Text), "amount" .= (200 :: Int)])+      decodeRaw codec (EventType "AmountRenamed") 1 payloadB+        `shouldBe` Right (object ["kind" .= ("AmountRenamed" :: T.Text), "amountInCents" .= (300 :: Int)])+    it "never emits a keiki symbolic operator into a Generated module (firewall)" $ do+      mods <- scaffoldFixture "test/fixtures/reservation.keiro"+      firewallBreaches mods `shouldBe` []+    it "marks the Holes module HoleStub and the rest Generated" $ do+      mods <- scaffoldFixture "test/fixtures/reservation.keiro"+      let holes = [m | m <- mods, kind m == HoleStub]+      map (takeFileName . modulePath) holes `shouldBe` ["BehaviorHoles.hs", "Holes.hs"]+      -- Context nominals/internal/replay plus the stable aggregate surface.+      length [m | m <- mods, kind m == Generated] `shouldBe` 10+    it "is deterministic (re-scaffolding yields byte-identical text)" $ do+      a <- scaffoldFixture "test/fixtures/reservation.keiro"+      b <- scaffoldFixture "test/fixtures/reservation.keiro"+      map moduleText a `shouldBe` map moduleText b+    it "keeps retiring as validator-only metadata in generated modules" $ do+      ordinary <- scaffoldFixture "test/fixtures/reservation.keiro"+      retiring <- scaffoldFixture "test/fixtures/reservation-retiring.keiro"+      map (\m -> (modulePath m, kind m, moduleText m)) retiring+        `shouldBe` map (\m -> (modulePath m, kind m, moduleText m)) ordinary+    it "matches the committed compiling Generated conformance modules (modulo whitespace)" $ do+      mods <- scaffoldFixture "test/fixtures/reservation.keiro"+      mapM_ assertMatchesCommitted [m | m <- mods, kind m == Generated]+    it "matches every committed new-surface Generated module (modulo formatting)" $ do+      modules <- scaffoldFixture "test/fixtures/transfer-routing.keiro"+      forM_ [m | m <- modules, kind m == Generated] $ \m -> do+        committed <- readTestText ("test/conformance-newsurface/" <> modulePath m)+        normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m)+    it "scaffolds the register-free OrderStream smoke target without error" $ do+      mods <- scaffoldFixture "test/fixtures/order.keiro"+      -- Stable context and aggregate modules plus both hand-owned hole surfaces.+      length mods `shouldBe` 12+      firewallBreaches mods `shouldBe` []+      let harness = generatedTextEndingIn "Harness.hs" mods+      harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: PlaceOrder from OrderNotStarted -- \""+      harness `shouldSatisfy` T.isInfixOf "prefix <> \"final vertex\""+      harness `shouldNotSatisfy` T.isInfixOf "prefix <> \"register "+    it "emits forward/replay checks with field-distinct Text samples" $ do+      spec <- parseInlineSpec "<forward-replay-samples>" (T.replace "command Bump { count:Int }" "command Bump { count:Int noteText:Text echo:Text }" loweringAggregateSpec)+      case [aggregate | NAggregate aggregate <- specNodes spec] of+        aggregate : _ -> do+          let ctx = defaultContext (specContext spec)+              harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx spec aggregate)+          harness `shouldSatisfy` T.isInfixOf "\"sample-noteText\" \"sample-echo\""+          harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: Bump from CounterPending -- \""+          harness `shouldSatisfy` T.isInfixOf "prefix <> \"register note\""+        [] -> expectationFailure "forward/replay sample spec has no aggregate"+    it "keeps inequality-guard samples distinct from register initials" $ do+      mods <- scaffoldFixture "test/fixtures/subscription.keiro"+      let harness = generatedTextEndingIn "Harness.hs" mods+      harness `shouldSatisfy` T.isInfixOf "ActivateSubscriptionData"+      harness `shouldSatisfy` T.isInfixOf "Paid"+      harness `shouldNotSatisfy` T.isInfixOf "ActivateSubscriptionData (case parseSubscriptionId \"sub_01h455vb4pex5vsknk084sn02q\" of Right parsed -> parsed; Left _ -> error \"generated valid ID sample failed to parse\") (case parseCustomerId \"cust_01h455vb4pex5vsknk084sn02q\" of Right parsed -> parsed; Left _ -> error \"generated valid ID sample failed to parse\") Free"+    it "uses consumer-owned nominal initials for equality-guard samples" $ do+      mods <- scaffoldFixture "test/fixtures/nominal-scalars.keiro"+      let harness = generatedTextEndingIn "Harness.hs" mods+      harness `shouldSatisfy` T.isInfixOf "Bindings.initialOrderId"+      harness `shouldSatisfy` (not . T.isInfixOf "NominalConformance.Bindings.initialOrderId")+      harness `shouldNotSatisfy` T.isInfixOf "case parseOrderId"+    it "emits the canonical reservation register checks" $ do+      mods <- scaffoldFixture "test/fixtures/reservation.keiro"+      let harness = generatedTextEndingIn "Harness.hs" mods+      harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: RequestTransferReservation from ReservationUnrequested -- \""+      harness `shouldSatisfy` T.isInfixOf "prefix <> \"register reservationId\""+      harness `shouldSatisfy` T.isInfixOf "prefix <> \"register hospitalId\""+      harness `shouldSatisfy` T.isInfixOf "prefix <> \"register patientAcuity\""+      harness `shouldNotSatisfy` T.isInfixOf "prefix <> \"register reservationState\""+    it "lowers a replay-only transition to B.replayOnly in the holes skeleton (plan 143)" $ do+      twinMods <- scaffoldFixture "test/fixtures/reservation-guard-tightened-twin.keiro"+      map moduleText twinMods `shouldSatisfy` any (T.isInfixOf "B.replayOnly")+      let twinHarness = generatedTextEndingIn "Harness.hs" twinMods+      T.count "forwardReplayRequestTransferReservation ::" twinHarness `shouldBe` 1+      plainMods <- scaffoldFixture "test/fixtures/reservation.keiro"+      map moduleText plainMods `shouldSatisfy` all (not . T.isInfixOf "B.replayOnly")++  describe "service workspace (EP-153)" $ do+    describe "manifest grammar" $ do+      it "round-trips the canonical fixture manifest byte-for-byte" $ do+        source <- readTestText canonicalWorkspacePath+        manifest <- shouldParseManifest canonicalWorkspacePath source+        wmfService manifest `shouldBe` "demo-project"+        wmfRuntimePackage manifest `shouldBe` Nothing+        wmfModuleRoot manifest `shouldBe` Just "Demo.Modules.Project"+        wmfLayout manifest `shouldBe` Just CollocatedLeaf+        map wmrPath (NE.toList (wmfMembers manifest))+          `shouldBe` [ "domain/project-artifact.keiro",+                       "domain/project.keiro",+                       "domain/shared.keiro"+                     ]+        renderWorkspaceManifest manifest+          `shouldBe` T.intercalate+            "\n"+            [ "service demo-project",+              "module Demo.Modules.Project",+              "layout collocated",+              "spec domain/project-artifact.keiro",+              "spec domain/project.keiro",+              "spec domain/shared.keiro"+            ]+      it "round-trips runtime-package canonically immediately after service" $ do+        manifest <-+          shouldParseManifest "<runtime-package>" $+            T.unlines+              [ "service mori",+                "module Mori.Modules",+                "spec domain/mori.keiro",+                "runtime-package mori-core",+                "layout collocated"+              ]+        wmfRuntimePackage manifest `shouldBe` Just (RuntimePackageName "mori-core")+        effectiveRuntimePackage Nothing manifest `shouldBe` Just (RuntimePackageName "mori-core")+        effectiveRuntimePackage (Just (RuntimePackageName "mori-dev")) manifest+          `shouldBe` Just (RuntimePackageName "mori-dev")+        renderWorkspaceManifest manifest+          `shouldBe` T.intercalate+            "\n"+            [ "service mori",+              "runtime-package mori-core",+              "module Mori.Modules",+              "layout collocated",+              "spec domain/mori.keiro"+            ]+      it "validates runtime package names with the mapped-source Cabal grammar" $ do+        mkRuntimePackageName "mori-core" `shouldBe` Right (RuntimePackageName "mori-core")+        mkRuntimePackageName "mori_core" `shouldBe` Left "runtime package 'mori_core' does not follow Cabal package-name grammar"+      it "treats membership as a set: source order changes neither the AST nor the bytes" $ do+        canonical <- readTestText canonicalWorkspacePath >>= shouldParseManifest canonicalWorkspacePath+        reordered <-+          shouldParseManifest "<reordered>" $+            T.unlines+              [ "service demo-project",+                "layout collocated",+                "spec domain/shared.keiro",+                "module Demo.Modules.Project",+                "spec domain/project.keiro",+                "spec ./domain/project-artifact.keiro"+              ]+        reordered `shouldBe` canonical+        renderWorkspaceManifest reordered `shouldBe` renderWorkspaceManifest canonical+      it "satisfies parse . render == id and render . parse . render == render" $+        property $+          forAll genWorkspaceManifest $ \manifest ->+            let rendered = renderWorkspaceManifest manifest+             in case parseWorkspaceManifest "<generated>" rendered of+                  Left err -> counterexample (T.unpack err) False+                  Right reparsed ->+                    counterexample (T.unpack rendered) $+                      reparsed == manifest && renderWorkspaceManifest reparsed == rendered+      it "recognizes a workspace manifest by extension, case-insensitively" $ do+        map+          isWorkspacePath+          [ "service.keiro-workspace",+            "a/b/Service.KEIRO-Workspace",+            "service.keiro",+            ".keiro-workspace",+            "keiro-workspace"+          ]+          `shouldBe` [True, True, False, False, False]+    describe "manifest refusals" $ do+      let rejects description source expected =+            it description $ case parseWorkspaceManifest "<manifest>" source of+              Right _ -> expectationFailure ("expected a refusal, got a manifest for:\n" <> T.unpack source)+              Left err -> T.unpack err `shouldContain` expected+      rejects+        "an empty manifest"+        "# only a comment\n"+        "must begin with a 'service <name>' clause"+      rejects+        "a manifest with no service clause"+        "spec domain/a.keiro\n"+        "first clause of a workspace manifest must be 'service <name>'"+      rejects+        "a manifest whose first clause is not service"+        "module Demo\nservice demo\nspec domain/a.keiro\n"+        "first clause of a workspace manifest must be 'service <name>'"+      rejects+        "a duplicate service clause"+        "service demo\nservice demo\nspec domain/a.keiro\n"+        "duplicate 'service' clause"+      rejects+        "a duplicate module clause"+        "service demo\nmodule Demo\nmodule Demo\nspec domain/a.keiro\n"+        "duplicate 'module' clause"+      rejects+        "a duplicate runtime-package clause"+        "service demo\nruntime-package demo-core\nruntime-package demo-api\nspec domain/a.keiro\n"+        "duplicate 'runtime-package' clause"+      it "locates a malformed runtime-package at its manifest line" $ case parseWorkspaceManifest "<manifest>" "service demo\nspec domain/a.keiro\nruntime-package demo_core\n" of+        Right _ -> expectationFailure "expected a malformed runtime package refusal"+        Left err -> do+          T.unpack err `shouldContain` "<manifest>:3:1"+          T.unpack err `shouldContain` "does not follow Cabal package-name grammar"+      rejects+        "a duplicate layout clause"+        "service demo\nlayout prefixed\nlayout prefixed\nspec domain/a.keiro\n"+        "duplicate 'layout' clause"+      rejects+        "a manifest with no members"+        "service demo\nmodule Demo\n"+        "must list at least one 'spec <path>.keiro' member"+      rejects+        "the same member listed twice"+        "service demo\nspec domain/a.keiro\nspec ./domain/a.keiro\n"+        "duplicate workspace member 'domain/a.keiro'"+      rejects+        "two members that differ only by case"+        "service demo\nspec domain/a.keiro\nspec domain/A.keiro\n"+        "differ only by case"+      rejects+        "an absolute member path"+        "service demo\nspec /etc/a.keiro\n"+        "must be relative, not absolute"+      rejects+        "a member path escaping the manifest directory"+        "service demo\nspec ../escape.keiro\n"+        "must not contain '..' segments"+      rejects+        "a member that is not a .keiro spec"+        "service demo\nspec domain/a.txt\n"+        "must name a .keiro spec"+      rejects+        "a manifest listing another manifest"+        "service demo\nspec domain/other.keiro-workspace\n"+        "must name a .keiro spec"+    describe "line relocation" $ do+      it "shifts every location the AST carries, and only the locations" $ do+        spec <- specOf "test/fixtures/reservation.keiro"+        let shifted = relocateLocs (+ 1000) spec+        collectLocs spec `shouldSatisfy` (not . null)+        collectLocs shifted `shouldBe` map (+ 1000) (collectLocs spec)+        -- Loc's Eq deliberately ignores the line, so relocation cannot+        -- change any equality-based behavior anywhere downstream.+        shifted `shouldBe` spec+      it "leaves the placeholder location alone so it never lands inside a member range" $ do+        spec <- specOf "test/fixtures/reservation.keiro"+        let blanked = relocateLocs (const 0) spec+            reshifted = relocateLocs (\n -> if n <= 0 then n else n + 500) blanked+        collectLocs reshifted `shouldBe` map (const 0) (collectLocs spec)+    describe "composition" $ do+      it "resolves cross-file ids, enums, mapped types, and read-model feeds" $ do+        workspace <- shouldComposeWorkspace canonicalWorkspacePath+        wsService workspace `shouldBe` "demo-project"+        wsContext workspace `shouldBe` "demo-project"+        wsModuleRoot workspace `shouldBe` Just "Demo.Modules.Project"+        wsLayout workspace `shouldBe` Just CollocatedLeaf+        map wmPath (wsMembers workspace)+          `shouldBe` [ "domain/project-artifact.keiro",+                       "domain/project.keiro",+                       "domain/shared.keiro"+                     ]+        -- Every member is individually incomplete; together they check.+        checkWorkspace workspace `shouldBe` []+      it "records which member owns each shared declaration and node" $ do+        workspace <- shouldComposeWorkspace canonicalWorkspacePath+        let ownership = wsOwnership workspace+        fmap fst (declarationOwner ownership "id" "ProjectId")+          `shouldBe` Just "domain/shared.keiro"+        fmap fst (declarationOwner ownership "enum" "ProjectPhase")+          `shouldBe` Just "domain/shared.keiro"+        fmap fst (declarationOwner ownership "rule" "phaseIsTerminal")+          `shouldBe` Just "domain/shared.keiro"+        fmap fst (declarationOwner ownership "mapped" "ProjectSummary")+          `shouldBe` Just "domain/shared.keiro"+        fmap fst (nodeOwner ownership "aggregate" "Project")+          `shouldBe` Just "domain/project.keiro"+        fmap fst (nodeOwner ownership "aggregate" "ProjectArtifact")+          `shouldBe` Just "domain/project-artifact.keiro"+        fmap fst (nodeOwner ownership "readmodel" "project_activity")+          `shouldBe` Just "domain/project-artifact.keiro"+      it "maps every merged line back to the member that wrote it" $ do+        workspace <- shouldComposeWorkspace canonicalWorkspacePath+        let bases = [(wmPath m, wmLineBase m, wmLineCount m) | m <- wsMembers workspace]+        -- Ranges are disjoint and contiguous from zero.+        map (\(_, base, _) -> base) bases `shouldBe` scanl (+) 0 (init [c | (_, _, c) <- bases])+        sequence_+          [ resolveWorkspaceLine workspace (base + offset) `shouldBe` Just (path, offset)+          | (path, base, memberLines) <- bases,+            offset <- [1, memberLines]+          ]+        resolveWorkspaceLine workspace 0 `shouldBe` Nothing+      it "is insensitive to the order members are listed in" $ do+        canonical <- shouldComposeWorkspace canonicalWorkspacePath+        reordered <- shouldComposeWorkspace reorderedWorkspacePath+        reordered {wsManifestPath = wsManifestPath canonical} `shouldBe` canonical+      describe "workspace source provenance" $ do+        it "keeps a later member's exact points stable when an earlier member gains source lines" $ do+          let manifestText = T.unlines ["service provenance", "spec a.keiro", "spec b.keiro"]+              aSource =+                T.unlines+                  [ "context provenance",+                    "aggregate Alpha",+                    "  regs",+                    "  states Empty",+                    "  command Ping {}",+                    "  event Pinged {}",+                    "  Empty -- Ping --> emit Pinged; goto Empty"+                  ]+              bSource =+                T.unlines+                  [ "context provenance",+                    "aggregate Beta",+                    "  regs",+                    "  states Empty",+                    "  command Ping {}",+                    "  event Pinged {}",+                    "  Empty -- Ping --> emit Pinged; goto Empty"+                  ]+              sourceWith alpha =+                ContentSource+                  { csRead = \case+                      "service.keiro-workspace" -> pure (Right manifestText)+                      "a.keiro" -> pure (Right alpha)+                      "b.keiro" -> pure (Right bSource)+                      path -> pure (Left ("unexpected path " <> T.pack path))+                  }+              loadWith alpha = do+                loaded <- loadWorkspace (sourceWith alpha) "service.keiro-workspace"+                case loaded of+                  Left workspaceFailure -> expectationFailure (show workspaceFailure) >> fail "unreachable"+                  Right value -> pure value+              betaLocation workspace =+                lookupSourceSpan+                  (AggregateTransitionSubject "Beta" (TransitionOrdinal 0))+                  (wsSourceIndex workspace)+              betaBase workspace = wmLineBase <$> find ((== "b.keiro") . wmPath) (wsMembers workspace)+          originalWorkspace <- loadWith aSource+          shiftedWorkspace <- loadWith ("# inserted before Alpha\n" <> aSource)+          betaLocation shiftedWorkspace `shouldBe` betaLocation originalWorkspace+          betaBase shiftedWorkspace `shouldBe` ((+ 1) <$> betaBase originalWorkspace)+          case betaLocation originalWorkspace of+            Just (ExactSourcePosition, SourceSpan {source, start = SourcePoint {line, column}}) ->+              (source, line, column) `shouldBe` ("b.keiro", 7, 3)+            other -> expectationFailure ("expected exact Beta transition location, got " <> show other)++          document <- case parseSourceDocument "b.keiro" bSource of+            Left parseFailure -> expectationFailure (show parseFailure) >> fail "unreachable"+            Right value -> pure value+          exactOneMember <- case oneMemberParsedDocumentWorkspace "b.keiro" document of+            Left sourceIndexFailure -> expectationFailure (show sourceIndexFailure) >> fail "unreachable"+            Right value -> pure value+          betaLocation exactOneMember `shouldBe` betaLocation originalWorkspace+          let ParsedSourceDocument {documentParsedSource} = document+              compatibility = oneMemberParsedWorkspace "b.keiro" documentParsedSource+          fmap fst (betaLocation compatibility) `shouldBe` Just CompatibilityLineOnly+      it "checks a single .keiro file as a one-member workspace, diagnostic for diagnostic" $ do+        let fixtures =+              [ "test/fixtures/reservation.keiro",+                "test/fixtures/consumer-types.keiro",+                "test/fixtures/aggregate-bad-refs.keiro",+                "test/fixtures/readmodel.keiro"+              ]+        forM_ fixtures $ \path -> do+          spec <- specOf path+          let workspace = oneMemberWorkspace path spec+              viaWorkspace = map (renderWorkspaceDiagnostic path) (checkWorkspace workspace)+              direct = map (renderDiagnostic path) (validateSpec spec)+          viaWorkspace `shouldBe` direct+        -- At least one of those fixtures must actually produce errors,+        -- or the equivalence claim is vacuous.+        badRefs <- specOf "test/fixtures/aggregate-bad-refs.keiro"+        checkWorkspace (oneMemberWorkspace "test/fixtures/aggregate-bad-refs.keiro" badRefs)+          `shouldSatisfy` any ((== Error) . wdSeverity)+    describe "composition refusals" $ do+      let refusesWith path expectedCode expectedFiles = do+            diagnostics <- shouldRefuseWorkspace path+            map wdCode (NE.toList diagnostics) `shouldContain` [expectedCode]+            let cited =+                  [ wlFile location+                  | diagnostic <- NE.toList diagnostics,+                    wdCode diagnostic == expectedCode,+                    location <- NE.toList (wdLocations diagnostic)+                  ]+            sort (nubOrd cited) `shouldBe` sort expectedFiles+      it "refuses members that declare different contexts, citing every context clause" $+        refusesWith+          "test/fixtures/workspace-context-mismatch/service.keiro-workspace"+          WorkspaceContextMismatch+          [WorkspaceMemberFile "domain/a.keiro", WorkspaceMemberFile "domain/b.keiro"]+      it "refuses a member layout clause that contradicts the manifest authority" $+        refusesWith+          "test/fixtures/workspace-authority-conflict/service.keiro-workspace"+          WorkspaceAuthorityConflict+          [WorkspaceManifestFile, WorkspaceMemberFile "domain/b.keiro"]+      it "refuses a textually identical shared declaration owned by two members" $+        refusesWith+          "test/fixtures/workspace-dup-decl/service.keiro-workspace"+          WorkspaceDuplicateDeclaration+          [WorkspaceMemberFile "domain/project.keiro", WorkspaceMemberFile "domain/shared.keiro"]+      it "refuses one aggregate defined in two members" $+        refusesWith+          "test/fixtures/workspace-dup-node/service.keiro-workspace"+          WorkspaceDuplicateNodeName+          [WorkspaceMemberFile "domain/a.keiro", WorkspaceMemberFile "domain/b.keiro"]+      it "refuses generated paths that collide across members under case folding" $+        refusesWith+          "test/fixtures/workspace-path-collision/service.keiro-workspace"+          WorkspacePathCollision+          [WorkspaceMemberFile "domain/a.keiro", WorkspaceMemberFile "domain/b.keiro"]+      it "reports a listed member that is missing from disk" $+        refusesWith+          "test/fixtures/workspace-missing-member/service.keiro-workspace"+          WorkspaceMemberUnreadable+          [WorkspaceManifestFile]+      it "reports a member that does not parse" $+        refusesWith+          "test/fixtures/workspace-member-parse-failed/service.keiro-workspace"+          WorkspaceMemberParseFailed+          [WorkspaceManifestFile]+      it "surfaces a cross-file unresolved reference through the merged validator" $ do+        workspace <- shouldComposeWorkspace "test/fixtures/workspace-unresolved/service.keiro-workspace"+        let errors = [d | d <- checkWorkspace workspace, wdSeverity d == Error]+        map wdCode errors `shouldContain` [GuardAtomOutOfScope]+        [wlFile location | d <- errors, location <- NE.toList (wdLocations d)]+          `shouldContain` [WorkspaceMemberFile "domain/project.keiro"]+    describe "multi-file diagnostic rendering" $ do+      it "puts the primary location in the established shape and every other file on a note line" $ do+        diagnostics <- shouldRefuseWorkspace "test/fixtures/workspace-dup-decl/service.keiro-workspace"+        let manifest = "keiro-dsl/test/fixtures/workspace-dup-decl/service.keiro-workspace"+        map (renderWorkspaceDiagnostic manifest) (NE.toList diagnostics)+          `shouldBe` [ T.intercalate+                         "\n"+                         [ "keiro-dsl/test/fixtures/workspace-dup-decl/domain/project.keiro:4: error[WorkspaceDuplicateDeclaration]: duplicate declaration 'ProjectId': a shared declaration has exactly one owning member (identical duplicates do not merge)",+                           "  keiro-dsl/test/fixtures/workspace-dup-decl/domain/shared.keiro:4: note: also declared here, as id 'ProjectId'"+                         ]+                     ]+    describe "whole-service check through the CLI" $ do+      it "prints OK and exits zero for the composed fixture workspace" $ do+        (exitCode, out, err) <- runKeiroDsl ["check", canonicalWorkspacePath]+        unless (exitCode == ExitSuccess) (expectationFailure (out <> err))+        lines out `shouldBe` ["OK"]+      it "exits non-zero and names every involved file for a cross-file refusal" $ do+        (exitCode, _, err) <-+          runKeiroDsl ["check", "test/fixtures/workspace-dup-decl/service.keiro-workspace"]+        exitCode `shouldBe` ExitFailure 1+        err `shouldContain` "error[WorkspaceDuplicateDeclaration]"+        err `shouldContain` "workspace-dup-decl/domain/project.keiro:4"+        err `shouldContain` "workspace-dup-decl/domain/shared.keiro:4"+      it "attributes a merged-graph validation error to the member that wrote it" $ do+        (exitCode, _, err) <-+          runKeiroDsl ["check", "test/fixtures/workspace-unresolved/service.keiro-workspace"]+        exitCode `shouldBe` ExitFailure 1+        err `shouldContain` "workspace-unresolved/domain/project.keiro:12: error[GuardAtomOutOfScope]"+      it "produces byte-identical output for a manifest whose members are listed in reverse" $ do+        (canonicalCode, canonicalOut, _) <- runKeiroDsl ["check", canonicalWorkspacePath, "--emit"]+        (reorderedCode, reorderedOut, _) <- runKeiroDsl ["check", reorderedWorkspacePath, "--emit"]+        canonicalCode `shouldBe` ExitSuccess+        reorderedCode `shouldBe` ExitSuccess+        reorderedOut `shouldBe` canonicalOut+        (_, canonicalParse, _) <- runKeiroDsl ["parse", canonicalWorkspacePath]+        (_, reorderedParse, _) <- runKeiroDsl ["parse", reorderedWorkspacePath]+        reorderedParse `shouldBe` canonicalParse+      it "keeps the single-file path working, byte for byte" $ do+        (exitCode, out, err) <- runKeiroDsl ["check", "test/fixtures/reservation.keiro"]+        unless (exitCode == ExitSuccess) (expectationFailure (out <> err))+        lines out `shouldBe` ["OK"]+      it "explains bindings and reports coverage against the merged graph" $ do+        (bindingsCode, bindingsOut, _) <-+          runKeiroDsl ["check", canonicalWorkspacePath, "--explain-bindings"]+        bindingsCode `shouldBe` ExitSuccess+        bindingsOut `shouldContain` "binding obligations for context demo-project"+        -- The obligation's use sites span both aggregate members, which+        -- is only possible because the graph was resolved once, merged.+        bindingsOut `shouldContain` "Project register summary : ProjectSummary"+        bindingsOut `shouldContain` "ProjectArtifact command RecordArtifact .artifactSummary : ProjectSummary"+        withTempDirectory "keiro-dsl-workspace-coverage" $ \out -> do+          let reportPath = out </> "coverage.json"+          (coverageCode, coverageOut, _) <-+            runKeiroDsl ["check", canonicalWorkspacePath, "--coverage-report", reportPath]+          coverageCode `shouldBe` ExitSuccess+          coverageOut `shouldContain` "structural/opaque boundaries (reporting only)"+          report <- Aeson.eitherDecodeFileStrict reportPath+          case report of+            Left err -> expectationFailure err+            Right value -> coverageSpecPath value `shouldBe` Just (T.pack canonicalWorkspacePath)++  describe "workspace diff revision loading (EP-155 M1)" $ do+    it "composes added, removed, and renamed members through an in-memory content source" $ do+      project <- readTestText "test/fixtures/workspace/domain/project.keiro"+      artifact <- readTestText "test/fixtures/workspace/domain/project-artifact.keiro"+      shared <- readTestText "test/fixtures/workspace/domain/shared.keiro"+      let extra = "language keiro-dsl 4\ncontext demo-project\n\nid ExtraId prefix=extra\n"+          manifest members =+            T.unlines+              ( ["service demo-project", "module Demo.Modules.Project", "layout collocated"]+                  <> ["spec " <> T.pack member | member <- members]+              )+          baseFiles =+            Map.fromList+              [ ("domain/project.keiro", project),+                ("domain/project-artifact.keiro", artifact),+                ("domain/shared.keiro", shared)+              ]+          loadFrom members files =+            loadWorkspace+              (memoryContentSource (Map.insert "service.keiro-workspace" (manifest members) files))+              "service.keiro-workspace"+          baseMembers = ["domain/project.keiro", "domain/project-artifact.keiro", "domain/shared.keiro"]+          expectLoaded result = case result of+            Left failure -> expectationFailure (show failure) >> error "unreachable"+            Right workspace -> pure workspace++      oldAdded <- loadFrom baseMembers baseFiles >>= expectLoaded+      newAdded <-+        loadFrom+          (baseMembers <> ["domain/extra.keiro"])+          (Map.insert "domain/extra.keiro" extra baseFiles)+          >>= expectLoaded+      map changeCode (diffSpecs (wsMergedSpec oldAdded) (wsMergedSpec newAdded))+        `shouldContain` [DeclarationAdded]++      oldRemoved <- loadFrom baseMembers baseFiles >>= expectLoaded+      newRemoved <-+        loadFrom+          ["domain/project.keiro", "domain/shared.keiro"]+          (Map.delete "domain/project-artifact.keiro" baseFiles)+          >>= expectLoaded+      map changeCode (diffSpecs (wsMergedSpec oldRemoved) (wsMergedSpec newRemoved))+        `shouldContain` [EvtRemovedNotDeprecated]++      oldRenamed <- loadFrom baseMembers baseFiles >>= expectLoaded+      let renamedMembers = ["domain/project-renamed.keiro", "domain/project-artifact.keiro", "domain/shared.keiro"]+          renamedFiles = Map.insert "domain/project-renamed.keiro" project (Map.delete "domain/project.keiro" baseFiles)+      newRenamed <- loadFrom renamedMembers renamedFiles >>= expectLoaded+      diffSpecs (wsMergedSpec oldRenamed) (wsMergedSpec newRenamed) `shouldBe` []++  describe "workspace diff ownership and unified reports (EP-155 M2)" $ do+    it "classifies shared declarations at use sites across every member with owned citations" $ do+      old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace"+      new <- shouldComposeWorkspace "test/fixtures/workspace-diff-new/service.keiro-workspace"+      let changes = diffWorkspaces old new+          enumChanges = filter ((== EnumCtorAdded) . changeCode . wcChange) changes+          mappedChanges = filter ((== MappedFieldTypeChanged) . changeCode . wcChange) changes+          citedFiles workspaceChanges =+            [ osFile site+            | change <- workspaceChanges,+              (_, Just site) <- wcUseSites change+            ]+      enumChanges `shouldSatisfy` (not . null)+      mappedChanges `shouldSatisfy` (not . null)+      let enumWireChanges =+            [ change+            | workspaceChange <- enumChanges,+              let change = wcChange workspaceChange,+              OldBinaryReadNewEvents `elem` breakingSurfaces change+            ]+      enumWireChanges `shouldSatisfy` (not . null)+      enumWireChanges `shouldSatisfy` all (not . gatedBreaking defaultGate)+      enumWireChanges `shouldSatisfy` all (gatedBreaking (gateWith [OldBinaryReadNewEvents]))+      map (fmap osFile . wcDeclarationSite) (enumChanges <> mappedChanges)+        `shouldSatisfy` all (== Just "domain/shared.keiro")+      citedFiles enumChanges `shouldContain` ["domain/order.keiro", "domain/shipment.keiro"]+      citedFiles mappedChanges `shouldContain` ["domain/order.keiro", "domain/shipment.keiro"]+      let rendered = T.intercalate "\n" (map renderWorkspaceFinding (enumChanges <> mappedChanges))+      rendered `shouldSatisfy` T.isInfixOf "    declared: domain/shared.keiro:4"+      rendered `shouldSatisfy` T.isInfixOf "    use-site: Order"+      rendered `shouldSatisfy` T.isInfixOf "(domain/order.keiro:"+      rendered `shouldSatisfy` T.isInfixOf "(domain/shipment.keiro:"+      assertMatchesGolden "test/fixtures/workspace-diff-new/workspace.diff.golden" (T.unlines (map renderWorkspaceFinding changes))++    it "emits one additive version-1 report with workspace provenance" $ do+      old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace"+      new <- shouldComposeWorkspace "test/fixtures/workspace-diff-new/service.keiro-workspace"+      let changes = diffWorkspaces old new+          meta =+            WorkspaceMeta+              { wmIdentity = wsService new,+                wmManifest = "service.keiro-workspace",+                wmSince = "HEAD",+                wmMembersOld = map wmPath (wsMembers old),+                wmMembersNew = map wmPath (wsMembers new),+                wmAdoptionBaseline = False+              }+      case Aeson.toJSON (workspaceDiffReport meta defaultGate changes) of+        Aeson.Object report -> do+          KeyMap.lookup "schema" report `shouldBe` Just (Aeson.String "keiro-dsl/diff-report/1")+          case KeyMap.lookup "workspace" report of+            Just (Aeson.Object workspace) -> do+              KeyMap.lookup "identity" workspace `shouldBe` Just (Aeson.String "workspace-diff")+              KeyMap.lookup "adoptionBaseline" workspace `shouldBe` Just (Aeson.Bool False)+            other -> expectationFailure ("missing workspace report metadata: " <> show other)+          case KeyMap.lookup "findings" report of+            Just (Aeson.Array findings) -> do+              findings `shouldSatisfy` (not . null)+              let objects = [finding | Aeson.Object finding <- toList findings]+              objects `shouldSatisfy` any (KeyMap.member "declaration")+              objects `shouldSatisfy` any (KeyMap.member "useSites")+            other -> expectationFailure ("missing workspace findings: " <> show other)+        other -> expectationFailure ("workspace report was not an object: " <> show other)++    it "computes one replay-impact value over both aggregates" $ do+      old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace"+      new <- shouldComposeWorkspace "test/fixtures/workspace-diff-new/service.keiro-workspace"+      case replayImpactSpecs (wsMergedSpec old) (wsMergedSpec new) of+        ReplayAffected affected -> Map.keysSet affected `shouldBe` Set.fromList ["Order", "Shipment"]+        ReplayNeutral -> expectationFailure "shared mapped evolution unexpectedly reported replay-neutral"++  describe "workspace ownership and authority changes (EP-155 M3)" $ do+    it "reports an unchanged aggregate move once without wire evolution" $ do+      old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace"+      moved <- shouldComposeWorkspace "test/fixtures/workspace-diff-moved/service.keiro-workspace"+      let changes = diffWorkspaces old moved+      map (changeCode . wcChange) changes `shouldBe` [OwnershipMoved]+      forM_ changes $ \workspaceMove -> do+        let move = wcChange workspaceMove+        move `shouldSatisfy` isAdvisory+        move `shouldSatisfy` (not . gatedBreaking defaultGate)+        move `shouldSatisfy` (not . gatedBreaking (gateWith [minBound .. maxBound]))+        deriveLabel defaultGate (ckVector (workspaceChangeKind move)) `shouldBe` LabelAdvisory+        remediationFor (ckContext (workspaceChangeKind move)) OwnershipMoved+          `shouldBe` (RemedyRescaffoldWorkspace :| [])+        renderWorkspaceFinding workspaceMove+          `shouldSatisfy` T.isInfixOf "declaration moved domain/shipment.keiro -> domain/order.keiro"++    it "treats a member rename as the same owner-map change" $ do+      old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace"+      let ownership = wsOwnership old+          renamed =+            old+              { wsOwnership =+                  ownership+                    { oiNodes =+                        Map.adjust+                          (\(_, loc) -> ("domain/shipping.keiro", loc))+                          ("aggregate", "Shipment")+                          (oiNodes ownership)+                    }+              }+          moves = filter ((== OwnershipMoved) . changeCode . wcChange) (diffWorkspaces old renamed)+      length moves `shouldBe` 1+      forM_ moves $ \move ->+        renderWorkspaceFinding move `shouldSatisfy` T.isInfixOf "domain/shipment.keiro -> domain/shipping.keiro"++    it "reports ownership motion beside an independently classified wire edit" $ do+      old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace"+      edited <- shouldComposeWorkspace "test/fixtures/workspace-diff-new/service.keiro-workspace"+      let ownership = wsOwnership edited+          movedAndEdited =+            edited+              { wsOwnership =+                  ownership+                    { oiNodes =+                        Map.adjust+                          (\(_, loc) -> ("domain/order.keiro", loc))+                          ("aggregate", "Shipment")+                          (oiNodes ownership)+                    }+              }+          codes = map (changeCode . wcChange) (diffWorkspaces old movedAndEdited)+      codes `shouldContain` [OwnershipMoved]+      codes `shouldContain` [MappedFieldTypeChanged]++    it "reports context authority separately from derived read-model identity breaks" $ do+      old <- shouldComposeWorkspace canonicalWorkspacePath+      let newContext = "demo-project-renamed"+          renamed =+            old+              { wsContext = newContext,+                wsMergedSpec = (wsMergedSpec old) {specContext = newContext}+              }+          changes = diffWorkspaces old renamed+          codes = map (changeCode . wcChange) changes+      codes `shouldContain` [WorkspaceAuthorityChanged]+      codes `shouldContain` [DerivedIdentityChanged]+      map wcChange changes `shouldSatisfy` any (gatedBreaking defaultGate)++    it "keeps service, module-root, and layout authority advisories non-blocking" $ do+      old <- shouldComposeWorkspace canonicalWorkspacePath+      let changed =+            old+              { wsService = "demo-project-renamed",+                wsModuleRoot = Just "Demo.Modules.Renamed",+                wsLayout = Just GeneratedPrefix+              }+          authority = filter ((== WorkspaceAuthorityChanged) . changeCode . wcChange) (diffWorkspaces old changed)+      length authority `shouldBe` 3+      forM_ (map wcChange authority) $ \change -> do+        deriveLabel defaultGate (ckVector (workspaceChangeKind change)) `shouldBe` LabelAdvisory+        change `shouldSatisfy` (not . gatedBreaking (gateWith [minBound .. maxBound]))+        remediationFor (ckContext (workspaceChangeKind change)) WorkspaceAuthorityChanged+          `shouldBe` (RemedyRescaffoldWorkspace :| [RemedyRecompileConsumers])++  describe "workspace scaffold (EP-154)" $ do+    describe "workspace record" $ do+      it "round-trips modules, owners, members, mappings, obligations, and adoptions" $ do+        workspace <- shouldComposeWorkspace canonicalWorkspacePath+        let record = sampleWorkspaceRecord workspace+            rendered = renderWorkspaceRecord record+        parseWorkspaceRecord rendered `shouldBe` Just record+        -- The header pins the schema: a v1 context-keyed record and a+        -- workspace record can never be read as each other.+        T.lines rendered `shouldSatisfy` \case+          header : _ -> header == "keiro-dsl workspace scaffold record v1"+          [] -> False+        parseRecord rendered `shouldBe` Nothing+        parseWorkspaceRecord (T.replace "record v1" "record v2" rendered) `shouldBe` Nothing+      it "ignores unknown rows and unknown JSON keys, and keeps context-level rows ownerless" $ do+        workspace <- shouldComposeWorkspace canonicalWorkspacePath+        let record = sampleWorkspaceRecord workspace+            rendered = renderWorkspaceRecord record+        parseWorkspaceRecord (T.replace "service: " "future-row: retained\nservice: " rendered)+          `shouldBe` Just record+        parseWorkspaceRecord (T.replace "\"kind\":\"generated\"" "\"kind\":\"generated\",\"future\":1" rendered)+          `shouldBe` Just record+        [row | row <- wrModules record, wrmOwner row == Nothing]+          `shouldSatisfy` (not . null)+      it "rejects absent stable language rows and partial, duplicate, malformed, or inconsistent contracts" $ do+        workspace <- shouldComposeWorkspace canonicalWorkspacePath+        let record = sampleWorkspaceRecord workspace+            rendered = renderWorkspaceRecord record+            sourceRows = filter ("source-language " `T.isPrefixOf`) (T.lines rendered)+            withoutSourceRows = T.unlines (filter (not . T.isPrefixOf "source-language ") (T.lines rendered))+            semanticRows = filter ("semantic-contract " `T.isPrefixOf`) (T.lines rendered)+            withoutSemanticRows = T.unlines (filter (not . T.isPrefixOf "semantic-contract ") (T.lines rendered))+        parseWorkspaceRecord withoutSourceRows `shouldBe` Nothing+        case sourceRows of+          firstRow : secondRow : _ -> do+            parseWorkspaceRecord (T.unlines (filter (/= secondRow) (T.lines rendered))) `shouldBe` Nothing+            parseWorkspaceRecord (T.replace firstRow (firstRow <> "\n" <> firstRow) rendered) `shouldBe` Nothing+            parseWorkspaceRecord (T.replace firstRow "source-language {malformed}" rendered) `shouldBe` Nothing+          _ -> expectationFailure "expected multiple workspace source-language rows"+        parseWorkspaceRecord withoutSemanticRows `shouldBe` Just record+        case semanticRows of+          [semanticRow] -> do+            parseWorkspaceRecord (T.replace semanticRow (semanticRow <> "\n" <> semanticRow) rendered) `shouldBe` Nothing+            parseWorkspaceRecord (T.replace semanticRow "semantic-contract {malformed}" rendered) `shouldBe` Nothing+            parseWorkspaceRecord (T.replace "\"languageVersion\":4" "\"languageVersion\":3" rendered) `shouldBe` Nothing+          _ -> expectationFailure "expected one workspace semantic-contract row"+      it "rejects unsafe module, owner, member, and adoption paths" $ do+        workspace <- shouldComposeWorkspace canonicalWorkspacePath+        let rendered = renderWorkspaceRecord (sampleWorkspaceRecord workspace)+            corrupt from to = parseWorkspaceRecord (T.replace from to rendered)+        corrupt "member domain/shared.keiro" "member /etc/passwd" `shouldBe` Nothing+        corrupt "member domain/shared.keiro" "member ../escape.keiro" `shouldBe` Nothing+        corrupt "\"owner\":\"domain/shared.keiro\"" "\"owner\":\"../shared.keiro\"" `shouldBe` Nothing+        corrupt "\"path\":\"claimed/One.hs\"" "\"path\":\"/tmp/One.hs\"" `shouldBe` Nothing+      it "keys context and workspace history in structurally distinct explicit slots" $ do+        workspaceRecordFileName "demo-project"+          `shouldBe` workspaceLedgerFileName "demo-project"+        workspaceManifestFileName "demo-project"+          `shouldBe` workspaceCabalFragmentFileName "demo-project"+        workspaceRecordFileName "demo-project" `shouldNotBe` recordFileName "demo-project"+        contextLedgerFileName "workspace"+          `shouldNotBe` workspaceLedgerFileName "workspace"+        supersededByLine "demo-project"+          `shouldBe` "superseded-by: keiro-dsl-ledger.workspace.demo-project.txt"++    describe "workspace plan" $ do+      it "emits the context-level facade and replay-audit exactly once from the merged graph" $ do+        plan <- shouldPlanWorkspace canonicalWorkspacePath+        let modules = map fst (wpModules plan)+            facades = [m | m <- modules, "StructuralProjections.hs" `isSuffixOfPath` m]+            audits = [m | m <- modules, "ReplayAudit.hs" `isSuffixOfPath` m]+            sourceMaps = [m | m <- modules, "BehaviorSourceMap.hs" `isSuffixOfPath` m]+            shapes = [m | m <- modules, "Structural/Shape/ProjectSummary.hs" `isSuffixOfPath` m]+        length facades `shouldBe` 1+        length audits `shouldBe` 1+        length sourceMaps `shouldBe` 1+        length shapes `shouldBe` 1+        -- The audit assembles aggregates owned by two different member+        -- files, which is only possible from one merged graph.+        forM_ audits $ \audit -> do+          moduleText audit `shouldSatisfy` T.isInfixOf "Project.projectEventStream"+          moduleText audit `shouldSatisfy` T.isInfixOf "ProjectArtifact.projectArtifactEventStream"+      it "gives every generated ID and enum one context owner and imports only aggregate uses" $ do+        plan <- shouldPlanWorkspace canonicalWorkspacePath+        let ctx = wpContext plan+            modules = map fst (wpModules plan)+            nominalModules = [m | m <- modules, modulePath m == T.unpack (T.replace "." "/" (generatedNominalModule ctx) <> ".hs")]+            internalNominalModules = [m | m <- modules, modulePath m == T.unpack (T.replace "." "/" (generatedNominalModule ctx) <> "/Internal.hs")]+            domainFor suffix = case [m | m <- modules, suffix `isSuffixOfPath` m] of+              [m] -> pure m+              found -> expectationFailure ("expected one domain ending in " <> suffix <> ", got " <> show (map modulePath found)) >> fail "unreachable"+        ownerModule <- case nominalModules of+          [m] -> pure m+          found -> expectationFailure ("expected one generated nominal owner, got " <> show (map modulePath found)) >> fail "unreachable"+        internalOwnerModule <- case internalNominalModules of+          [m] -> pure m+          found -> expectationFailure ("expected one generated internal nominal owner, got " <> show (map modulePath found)) >> fail "unreachable"+        let nominalText = moduleText ownerModule+            internalNominalText = moduleText internalOwnerModule+        T.count "newtype ProjectId" nominalText `shouldBe` 0+        T.count "newtype ProjectId" internalNominalText `shouldBe` 1+        T.count "data ProjectPhase =" nominalText `shouldBe` 1+        T.count "data WorkspaceVisibility =" nominalText `shouldBe` 1+        projectDomain <- domainFor "Project/Generated/Domain.hs"+        artifactDomain <- domainFor "ProjectArtifact/Generated/Domain.hs"+        forM_ [projectDomain, artifactDomain] $ \domain -> do+          moduleText domain `shouldSatisfy` (not . T.isInfixOf "newtype ProjectId")+          moduleText domain `shouldSatisfy` (not . T.isInfixOf "data ProjectPhase")+          moduleText domain `shouldSatisfy` T.isInfixOf (generatedNominalModule ctx <> " (ProjectId, parseProjectId, ProjectPhase (..))")+          moduleText domain `shouldSatisfy` (not . T.isInfixOf "WorkspaceVisibility")+        -- Preserve the members' declared language contract. The active language-5+        -- candidate must not silently restamp an existing language-4 workspace.+        singleFileModules <- case planIndexedServiceScaffold (wsSourceIndex (wpWorkspace plan)) ctx (wpCheckedService plan) of+          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"+          Right values -> pure values+        let withoutOrigin m = (modulePath m, moduleText m, kind m)+        map withoutOrigin singleFileModules `shouldBe` map withoutOrigin modules+        owners <- case planNominalGeneration ctx (wsMergedSpec (wpWorkspace plan)) of+          Left errors -> expectationFailure (show errors) >> fail "unreachable"+          Right values -> pure values+        map (resolvedNominalName . nominalDeclaration) owners+          `shouldBe` ["ProjectId", "ProjectPhase", "WorkspaceVisibility"]+        case [owner | owner <- owners, resolvedNominalName (nominalDeclaration owner) == "ProjectId"] of+          [owner] -> do+            nominalModule owner `shouldBe` generatedNominalModule ctx+            Set.fromList [NominalUseSite "Project" RegisterUse, NominalUseSite "ProjectArtifact" EventFieldUse]+              `shouldSatisfy` (`Set.isSubsetOf` nominalUseSites owner)+          found -> expectationFailure ("expected one ProjectId owner, got " <> show (length found))+      it "attributes every module to its owning member and leaves shared ones context-level" $ do+        plan <- shouldPlanWorkspace canonicalWorkspacePath+        let memberPaths = map wmPath (wsMembers (wpWorkspace plan))+            ownerOf suffix =+              case [provenance | (m, provenance) <- wpModules plan, suffix `isSuffixOfPath` m] of+                [provenance] -> Just provenance+                _ -> Nothing+        ownerOf "StructuralProjections.hs" `shouldBe` Just ContextLevel+        ownerOf "Generated/Nominals.hs" `shouldBe` Just ContextLevel+        ownerOf "ReplayAudit.hs" `shouldBe` Just ContextLevel+        ownerOf "Structural/Shape/ProjectSummary.hs"+          `shouldBe` Just (MemberOwned "domain/shared.keiro")+        ownerOf "Project/Generated/Domain.hs"+          `shouldBe` Just (MemberOwned "domain/project.keiro")+        ownerOf "ProjectArtifact/Generated/Domain.hs"+          `shouldBe` Just (MemberOwned "domain/project-artifact.keiro")+        ownerOf "ProjectActivity/Generated/ReadModel.hs"+          `shouldBe` Just (MemberOwned "domain/project-artifact.keiro")+        -- No module may claim an owner that is not a member of the+        -- workspace: the record's owner column has to stay resolvable.+        map (provenanceOwner . snd) (wpModules plan)+          `shouldSatisfy` all (maybe True (`elem` memberPaths))+      it "keeps the compiled workspace nominal conformance tree byte-current" $ do+        workspace <- shouldComposeWorkspace "test/fixtures/workspace-nominals/service.keiro-workspace"+        plan <- shouldPlanWorkspaceSpec workspace+        let compiledPaths =+              [ "Generated/WorkspaceNominalProof/BehaviorSourceMap.hs",+                "Generated/WorkspaceNominalProof/Nominals.hs",+                "Generated/WorkspaceNominalProof/Project/Domain.hs",+                "Generated/WorkspaceNominalProof/Project/Codec.hs",+                "Generated/WorkspaceNominalProof/Project/Transducer.hs",+                "Generated/WorkspaceNominalProof/Project/BehaviorContract.hs",+                "Generated/WorkspaceNominalProof/Project/EventStream.hs",+                "Generated/WorkspaceNominalProof/Project/Harness.hs",+                "Generated/WorkspaceNominalProof/Project/Projection.hs",+                "Generated/WorkspaceNominalProof/ProjectArtifact/Domain.hs",+                "Generated/WorkspaceNominalProof/ProjectArtifact/Codec.hs",+                "Generated/WorkspaceNominalProof/ProjectArtifact/Transducer.hs",+                "Generated/WorkspaceNominalProof/ProjectArtifact/BehaviorContract.hs",+                "Generated/WorkspaceNominalProof/ProjectArtifact/EventStream.hs",+                "Generated/WorkspaceNominalProof/ProjectArtifact/Harness.hs",+                "Generated/WorkspaceNominalProof/ProjectArtifact/Projection.hs",+                "Generated/WorkspaceNominalProof/ReplayAudit.hs"+              ]+        map fst (wpModules plan) `shouldSatisfy` all (not . isSuffixOfPath "/Holes.hs")+        forM_ compiledPaths $ \path ->+          case [m | (m, _) <- wpModules plan, modulePath m == path] of+            [generated] -> do+              committed <- readTestText ("test/conformance-workspace-nominals/" <> path)+              normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText generated)+            found -> expectationFailure ("expected one generated module at " <> path <> ", got " <> show (map modulePath found))+      it "plans a one-member workspace byte-identically to the single-file path" $ do+        let fixtures =+              [ "test/fixtures/reservation.keiro",+                "test/fixtures/consumer-types.keiro",+                "test/fixtures/readmodel.keiro",+                "test/fixtures/hospital-surge.keiro"+              ]+        -- Modules and refusals both: hospital-surge refuses on both+        -- paths, which proves the gates agree as well as the emitters.+        forM_ fixtures $ \path -> do+          (workspace, document) <- exactOneMemberWorkspaceOf path+          let ParsedSourceDocument {documentParsedSource = parsedSource, documentSourceIndex = sourceIndex} = document+              service = checkedSource parsedSource+              spec = checkedSpec service+              ctx = defaultContext (specContext spec)+              isSourceMap moduleValue = "BehaviorSourceMap.hs" `isSuffixOfPath` moduleValue+          case (planWorkspaceScaffold "goldens" ctx workspace, planIndexedServiceScaffold sourceIndex ctx service) of+            (Left workspaceRefusals, Left singleSourceRefusals) ->+              workspaceRefusals `shouldBe` singleSourceRefusals+            (Right workspacePlan, Right singleSourceModules) -> do+              let workspaceModules = map fst (wpModules workspacePlan)+                  workspaceStable = filter (not . isSourceMap) workspaceModules+                  singleSourceStable = filter (not . isSourceMap) singleSourceModules+                  workspaceSourceMaps = filter isSourceMap workspaceModules+                  singleSourceMaps = filter isSourceMap singleSourceModules+              workspaceStable `shouldBe` singleSourceStable+              case (workspaceSourceMaps, singleSourceMaps) of+                ([workspaceSourceMap], [singleSourceMap]) -> do+                  modulePath workspaceSourceMap `shouldBe` modulePath singleSourceMap+                  moduleText workspaceSourceMap+                    `shouldBe` T.replace (T.pack path) (T.pack (takeFileName path)) (moduleText singleSourceMap)+                found -> expectationFailure ("expected one source map per planning path, got " <> show (map modulePath (fst found), map modulePath (snd found)))+            (Left _, Right _) -> expectationFailure "workspace planning refused while single-source planning succeeded"+            (Right _, Left _) -> expectationFailure "workspace planning succeeded while single-source planning refused"+        -- The equality is not vacuous: at least one fixture plans, and+        -- its per-node modules are attributed to the single member.+        (workspace, document) <- exactOneMemberWorkspaceOf "test/fixtures/reservation.keiro"+        let ParsedSourceDocument {documentParsedSource = parsedSource} = document+            spec = checkedSpec (checkedSource parsedSource)+        case planWorkspaceScaffold "goldens" (defaultContext (specContext spec)) workspace of+          Left refusals -> expectationFailure ("reservation should plan: " <> show refusals)+          Right plan -> do+            wpModules plan `shouldSatisfy` (not . null)+            map snd (wpModules plan)+              `shouldSatisfy` all (`elem` [ContextLevel, MemberOwned "reservation.keiro"])+            map snd (wpModules plan)+              `shouldSatisfy` elem (MemberOwned "reservation.keiro")+      it "computes obligations from the complete merged graph, spanning members" $ do+        workspace <- shouldComposeWorkspace canonicalWorkspacePath+        case bindingObligations (wsMergedSpec workspace) of+          Left graphErrors -> expectationFailure ("merged graph did not resolve: " <> show graphErrors)+          Right obligations ->+            case [o | o <- obligations, obligationMappedName o == "ProjectSummary", obligationKind o == BindingValue] of+              [obligation] -> do+                obligationUseSites obligation+                  `shouldSatisfy` any (T.isInfixOf "Project register summary")+                obligationUseSites obligation+                  `shouldSatisfy` any (T.isInfixOf "ProjectArtifact command RecordArtifact")+              found -> expectationFailure ("expected one ProjectSummary binding obligation, got " <> show (length found))+      it "refuses a case-folded path collision across members, naming both files" $ do+        workspace <- shouldComposeWorkspace canonicalWorkspacePath+        let collided = withCaseVariantAggregate workspace+        case planWorkspaceScaffold "goldens" (workspaceContext collided) collided of+          Right _ -> expectationFailure "expected a cross-member path collision refusal"+          Left refusals -> do+            let origins = concat [os | PathCollision _ os <- refusals]+            origins `shouldSatisfy` any (T.isInfixOf "domain/project.keiro: ")+            origins `shouldSatisfy` any (T.isInfixOf "domain/project-artifact.keiro: ")+      it "refuses golden fixtures stranded beside a member instead of under the workspace root" $+        withTempDirectory "keiro-dsl-workspace-goldens" $ \root -> do+          workspace <- writeGoldenWorkspace root+          let workspaceGoldens = root </> "golden-payloads"+              fixture = "hospital-capacity/Reservation/TransferReservationCreated.v1.json"+              beside = root </> "domain/golden-payloads" </> fixture+          goldenRootDivergence workspaceGoldens workspace `shouldReturn` []+          createDirectoryIfMissing True (takeDirectory beside)+          TIO.writeFile beside "{}\n"+          refusals <- goldenRootDivergence workspaceGoldens workspace+          refusals `shouldBe` [GoldenRootDivergence workspaceGoldens [beside]]+          renderRefusals refusals+            `shouldSatisfy` any (T.isInfixOf "one golden root per workspace")+          -- The same fixture under the workspace root is no divergence.+          let atRoot = workspaceGoldens </> fixture+          createDirectoryIfMissing True (takeDirectory atRoot)+          TIO.writeFile atRoot "{}\n"+          goldenRootDivergence workspaceGoldens workspace `shouldReturn` []++    describe "workspace scaffold" $ do+      it "writes workspace-keyed history and no context-keyed file at all" $+        withWorkspaceFixture "keiro-dsl-workspace-history" id $ \_ out workspace -> do+          report <- executePlannedWorkspaceScaffold out workspace+          wsrRecordPath report+            `shouldBe` out </> workspaceLedgerFileName "demo-project"+          wsrBuildManifestPath report+            `shouldBe` out </> workspaceCabalFragmentFileName "demo-project"+          doesFileExist (out </> recordFileName "demo-project") `shouldReturn` False+          doesFileExist (out </> contextCabalFragmentFileName "demo-project") `shouldReturn` False+          contents <- TIO.readFile (wsrRecordPath report)+          buildManifest <- TIO.readFile (wsrBuildManifestPath report)+          assertGeneratedHaskellContract "service.keiro-workspace" buildManifest+          case parseWorkspaceRecord contents of+            Nothing -> expectationFailure ("workspace record did not parse:\n" <> T.unpack contents)+            Just record -> do+              wrService record `shouldBe` "demo-project"+              wrManifest record `shouldBe` "service.keiro-workspace"+              wrQueryContractBaseline record `shouldBe` False+              contents `shouldNotSatisfy` T.isInfixOf "query-contract-baseline"+              wrMembers record+                `shouldBe` [ "domain/project-artifact.keiro",+                             "domain/project.keiro",+                             "domain/shared.keiro"+                           ]+              -- Context-level modules are ownerless; everything+              -- else names the member that produced it.+              [wrmPath row | row <- wrModules record, wrmOwner row == Nothing]+                `shouldSatisfy` \ownerless ->+                  length ownerless == 6+                    && any (T.isSuffixOf "StructuralConformance.hs" . T.pack) ownerless+                    && any (T.isSuffixOf "BehaviorSourceMap.hs" . T.pack) ownerless+                    && any (T.isSuffixOf "StructuralProjections.hs" . T.pack) ownerless+                    && any (T.isSuffixOf "Nominals.hs" . T.pack) ownerless+                    && any (T.isSuffixOf "Nominals/Internal.hs" . T.pack) ownerless+                    && any (T.isSuffixOf "ReplayAudit.hs" . T.pack) ownerless+              [ wrmOwner row+                | row <- wrModules record,+                  "Project/Generated/Domain.hs" `T.isSuffixOf` T.pack (wrmPath row)+                ]+                `shouldBe` [Just "domain/project.keiro"]+      it "refuses and then applies old workspace sidecar names before reading history" $+        withWorkspaceFixture "keiro-dsl-workspace-sidecar-migration" id $ \_ out workspace -> do+          plan <- shouldPlanWorkspaceSpec workspace+          first <- executeWorkspaceScaffold out False plan+          either (\failure -> expectationFailure (show failure)) (const (pure ())) first+          let service = wsService workspace+              currentLedger = workspaceLedgerFileName service+              currentFragment = workspaceCabalFragmentFileName service+              oldLedger = legacyWorkspaceRecordFileName service+              oldFragment = legacyWorkspaceManifestFileName service+          renameFile (out </> currentLedger) (out </> oldLedger)+          renameFile (out </> currentFragment) (out </> oldFragment)+          migrationTreeBefore <- treeSnapshot out+          refused <- executeWorkspaceScaffoldWithNameMigrations out False False plan+          refused `shouldSatisfy` \case+            Left [SidecarMigrationRequired moves] ->+              length moves == 2 && all ((== RenameSidecar) . sidecarMoveDisposition) moves+            _ -> False+          treeSnapshot out `shouldReturn` migrationTreeBefore+          applied <- executeWorkspaceScaffoldWithNameMigrations out False True plan+          report <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure applied+          map sidecarMoveDisposition (wsrSidecarMoves report) `shouldBe` [RenameSidecar, RenameSidecar]+          wsrStale report `shouldBe` []+          doesFileExist (out </> oldLedger) `shouldReturn` False+          doesFileExist (out </> oldFragment) `shouldReturn` False+          doesFileExist (out </> currentLedger) `shouldReturn` True+          doesFileExist (out </> currentFragment) `shouldReturn` True+          rerun <- executeWorkspaceScaffoldWithNameMigrations out False True plan+          either (\failure -> expectationFailure (show failure)) (\value -> wsrSidecarMoves value `shouldBe` []) rerun+      it "is idempotent: an unchanged second run rewrites nothing and reports nothing" $+        withWorkspaceFixture "keiro-dsl-workspace-idempotent" id $ \_ out workspace -> do+          first <- executePlannedWorkspaceScaffold out workspace+          treeBefore <- treeSnapshot out+          second <- executePlannedWorkspaceScaffold out workspace+          treeAfter <- treeSnapshot out+          treeAfter `shouldBe` treeBefore+          map thd3 (wsrDispositions second)+            `shouldSatisfy` all (`elem` [Unchanged, Skipped])+          wsrStale second `shouldBe` []+          wsrOwnershipMoves second `shouldBe` []+          wsrMappingDrift second `shouldBe` []+          wsrNewHoles second `shouldBe` []+          -- The first run had to write; the claim is not vacuous.+          map thd3 (wsrDispositions first) `shouldSatisfy` any (== Overwritten)+          renderWorkspaceScaffoldReport second+            `shouldSatisfy` all (not . T.isPrefixOf "stale:")+      it "isolates member-local source movement to the one context behavior source map" $+        withWorkspaceFixture "keiro-dsl-workspace-source-movement" id $ \root out workspace -> do+          _ <- executePlannedWorkspaceScaffold out workspace+          treeBefore <- treeSnapshot out+          let member = root </> "domain/project-artifact.keiro"+          original <- TIO.readFile member+          TIO.writeFile member ("# move exact positions without changing semantics\n\n" <> original)+          moved <- loadTempWorkspace root+          second <- executePlannedWorkspaceScaffold out moved+          let overwrittenPaths =+                [modulePath generatedModule | (generatedModule, _, Overwritten) <- wsrDispositions second]+          overwrittenPaths `shouldSatisfy` \case+            [path] -> T.isSuffixOf "/BehaviorSourceMap.hs" (T.pack path)+            _ -> False+          semanticReportDeclarations (wsrSemanticImpact second) `shouldBe` []+          map artifactCategory (wsrGeneratedArtifactImpact second)+            `shouldBe` [BehaviorSourceMapArtifact]+          treeAfter <- treeSnapshot out+          let isPositionBearingSidecar (path, _) =+                T.isSuffixOf "/BehaviorSourceMap.hs" (T.pack path)+                  || takeFileName path == workspaceLedgerFileName "demo-project"+          filter (not . isPositionBearingSidecar) treeAfter+            `shouldBe` filter (not . isPositionBearingSidecar) treeBefore+      it "produces byte-identical output for members listed in reverse order" $+        withWorkspaceFixture "keiro-dsl-workspace-order-a" id $ \_ outA workspaceA ->+          withWorkspaceFixture "keiro-dsl-workspace-order-b" reverse $ \_ outB workspaceB -> do+            _ <- executePlannedWorkspaceScaffold outA workspaceA+            _ <- executePlannedWorkspaceScaffold outB workspaceB+            treeB <- treeSnapshot outB+            treeA <- treeSnapshot outA+            treeB `shouldBe` treeA+            map fst treeA `shouldSatisfy` elem (workspaceLedgerFileName "demo-project")+      it "reports stale files only for the member that changed" $+        withWorkspaceFixture "keiro-dsl-workspace-stale" id $ \root out workspace -> do+          first <- executePlannedWorkspaceScaffold out workspace+          let siblingPaths =+                [ modulePath m+                | (m, provenance, _) <- wsrDispositions first,+                  provenance == MemberOwned "domain/project-artifact.keiro"+                ]+          siblingsBefore <- traverse (TIO.readFile . (out </>)) siblingPaths+          renamed <- renameMemberAggregate root "domain/project.keiro" "Project" "Ledger"+          second <- executePlannedWorkspaceScaffold out renamed+          let stalePaths = map stalePath (wsrStale second)+          stalePaths `shouldSatisfy` (not . null)+          stalePaths `shouldSatisfy` all (T.isInfixOf "/Project/" . T.pack)+          -- Nothing the sibling member owns is stale, and nothing it+          -- owns changed on disk: no cross-member false positives.+          stalePaths `shouldSatisfy` all (`notElem` siblingPaths)+          siblingsAfter <- traverse (TIO.readFile . (out </>)) siblingPaths+          siblingsAfter `shouldBe` siblingsBefore+          forM_ stalePaths $ \path -> doesFileExist (out </> path) `shouldReturn` True+          wsrStale second+            `shouldSatisfy` all+              ( \stale -> case staleKind stale of+                  Generated -> staleGeneratedEvidence stale == Just ExactGeneratedBannerPresent+                  HoleStub -> staleGeneratedEvidence stale == Nothing+              )+          renderWorkspaceScaffoldReport second+            `shouldSatisfy` any (T.isInfixOf "keiro-dsl never deletes files.")+          renderWorkspaceScaffoldReport second+            `shouldSatisfy` any (T.isInfixOf "exact generated banner present; verify unchanged bytes before deleting")+          renderWorkspaceScaffoldReport second+            `shouldSatisfy` all (not . T.isInfixOf "safe to delete")+      it "reports an aggregate moved between members as an ownership move, not stale churn" $+        withWorkspaceFixture "keiro-dsl-workspace-move" id $ \root out workspace -> do+          _ <- executePlannedWorkspaceScaffold out workspace+          treeBefore <- treeSnapshot out+          moved <- moveArtifactAggregate root+          second <- executePlannedWorkspaceScaffold out moved+          wsrStale second `shouldBe` []+          let moves = wsrOwnershipMoves second+          moves `shouldSatisfy` (not . null)+          moves+            `shouldSatisfy` all+              ( \move ->+                  omPrevious move == Just "domain/project-artifact.keiro"+                    && omCurrent move == Just "domain/project.keiro"+              )+          map omPath moves+            `shouldSatisfy` any (T.isInfixOf "ProjectArtifact" . T.pack)+          -- Behavior contracts contain only semantic identity. Moving a+          -- declaration rewrites the one context source map, while the ledger+          -- independently records module ownership moves.+          map thd3 (wsrDispositions second)+            `shouldSatisfy` all (`elem` [Unchanged, Skipped, Overwritten])+          let overwrittenPaths =+                [modulePath generatedModule | (generatedModule, _, Overwritten) <- wsrDispositions second]+          overwrittenPaths `shouldSatisfy` \case+            [path] -> T.isSuffixOf "/BehaviorSourceMap.hs" (T.pack path)+            _ -> False+          treeAfter <- treeSnapshot out+          map fst treeAfter `shouldBe` map fst treeBefore+          let unaffected (path, _) =+                path /= workspaceLedgerFileName "demo-project"+                  && path `notElem` overwrittenPaths+          filter unaffected treeAfter `shouldBe` filter unaffected treeBefore+          renderWorkspaceScaffoldReport second+            `shouldSatisfy` any (T.isInfixOf "changed owning member")+      it "leaves the tree, record, and manifest untouched when any member refuses" $+        withWorkspaceFixture "keiro-dsl-workspace-atomic" id $ \_ out workspace -> do+          _ <- executePlannedWorkspaceScaffold out workspace+          treeBefore <- treeSnapshot out+          let broken = withCaseVariantAggregate workspace+          case planWorkspaceScaffold "goldens" (workspaceContext broken) broken of+            Right _ -> expectationFailure "expected the broken workspace to refuse"+            Left refusals -> refusals `shouldSatisfy` any isPathCollision+          treeSnapshot out `shouldReturn` treeBefore+          -- A fresh output directory is never even created.+          withTempDirectory "keiro-dsl-workspace-atomic-fresh" $ \fresh -> do+            let target = fresh </> "out"+            case planWorkspaceScaffold "goldens" (workspaceContext broken) broken of+              Right _ -> expectationFailure "expected the broken workspace to refuse"+              Left _ -> doesDirectoryExist target `shouldReturn` False+      it "leaves prior workspace output byte-identical for parse, validation, and collision failures" $+        withWorkspaceFixture "keiro-dsl-workspace-atomic-cli" id $ \root out workspace -> do+          _ <- executePlannedWorkspaceScaffold out workspace+          treeBefore <- treeSnapshot out+          let member = root </> "domain/project-artifact.keiro"+              manifest = root </> "service.keiro-workspace"+          original <- TIO.readFile member+          let failures =+                [ ("parse", "context demo-project\naggregate !!!\n"),+                  ("validation", T.replace "ProjectId" "MissingProjectId" original),+                  ("collision", T.replace "aggregate ProjectArtifact" "aggregate PROJECT" original)+                ]+          forM_ failures $ \(failureKind, brokenSource) -> do+            TIO.writeFile member brokenSource+            (exitCode, stdoutText, stderrText) <-+              runKeiroDsl ["scaffold", manifest, "--out", out]+            unless (exitCode == ExitFailure 1) $+              expectationFailure+                (failureKind <> " failure unexpectedly scaffolded:\n" <> stdoutText <> stderrText)+            treeSnapshot out `shouldReturn` treeBefore+            TIO.writeFile member original+      it "refuses the whole workspace for one bannerless Generated target, changing nothing" $+        withWorkspaceFixture "keiro-dsl-workspace-banner" id $ \_ out workspace -> do+          plan <- shouldPlanWorkspaceSpec workspace+          let generated = [m | (m, _) <- wpModules plan, kind m == Generated]+          case generated of+            [] -> expectationFailure "workspace fixture has no Generated module"+            target : _ -> do+              let path = out </> modulePath target+              createDirectoryIfMissing True (takeDirectory path)+              TIO.writeFile path "hand owned\n"+              treeBefore <- treeSnapshot out+              refused <- executeWorkspaceScaffold out False plan+              refused `shouldSatisfy` isMissingBannerRefusal+              treeSnapshot out `shouldReturn` treeBefore+              forced <- executeWorkspaceScaffold out True plan+              forced `shouldSatisfy` isSuccessfulScaffold+              TIO.readFile path `shouldReturn` moduleText target+      it "scaffolds a whole workspace through the CLI" $+        withTempDirectory "keiro-dsl-workspace-cli" $ \out -> do+          (exitCode, stdoutText, stderrText) <-+            runKeiroDsl ["scaffold", canonicalWorkspacePath, "--out", out]+          unless (exitCode == ExitSuccess) (expectationFailure (stdoutText <> stderrText))+          stderrText `shouldContain` "workspace: demo-project"+          doesFileExist (out </> workspaceLedgerFileName "demo-project")+            `shouldReturn` True+          tree <- treeSnapshot out+          length [path | (path, _) <- tree, "StructuralProjections.hs" `T.isSuffixOf` T.pack path]+            `shouldBe` 1+          length [path | (path, _) <- tree, "ReplayAudit.hs" `T.isSuffixOf` T.pack path]+            `shouldBe` 1+          (secondCode, _, secondErr) <-+            runKeiroDsl ["scaffold", canonicalWorkspacePath, "--out", out]+          secondCode `shouldBe` ExitSuccess+          secondErr `shouldSatisfy` (not . isInfixOfString "(overwritten)")+          treeSnapshot out `shouldReturn` tree+      it "accepts a validated runtime-package override and generates exactly one service package" $+        withTempDirectory "keiro-dsl-workspace-runtime-package-cli" $ \out -> do+          (exitCode, stdoutText, stderrText) <-+            runKeiroDsl ["scaffold", canonicalWorkspacePath, "--out", out, "--runtime-package", "demo-runtime"]+          unless (exitCode == ExitSuccess) (expectationFailure (stdoutText <> stderrText))+          tree <- treeSnapshot out+          length [path | (path, _) <- tree, takeExtension path == ".cabal", "keiro-dsl-conformance.workspace.demo-project" `isInfixOfString` path]+            `shouldBe` 1+          stderrText `shouldSatisfy` isInfixOfString "conformance-target: cabal test keiro-demo-project-conformance"++    describe "workspace adoption" $ do+      it "replaces embedded 0.6 nominal declarations only in generated files" $+        withWorkspaceFixture "keiro-dsl-workspace-nominal-adopt" id $ \_ out workspace -> do+          plan <- shouldPlanWorkspaceSpec workspace+          let pathEndingIn suffix selectedKind =+                case [modulePath m | (m, _) <- wpModules plan, kind m == selectedKind, suffix `isSuffixOfPath` m] of+                  [path] -> pure path+                  found -> expectationFailure ("expected one path ending in " <> suffix <> ", got " <> show found) >> fail "unreachable"+          domainPath <- pathEndingIn "Project/Generated/Domain.hs" Generated+          nominalPath <- pathEndingIn "Generated/Nominals.hs" Generated+          internalNominalPath <- pathEndingIn "Generated/Nominals/Internal.hs" Generated+          holePath <- pathEndingIn "Project/Holes.hs" HoleStub+          writeFileWithParents+            (out </> domainPath)+            (generatedBanner <> "\n-- legacy 0.6 fixture\nmodule LegacyDomain where\nnewtype ProjectId = ProjectId String\ndata ProjectPhase = Draft | Active\n")+          writeFileWithParents (out </> holePath) "-- hand-owned 0.6 implementation\n"++          report <- executePlannedWorkspaceScaffold out workspace+          wsrStale report `shouldBe` []+          [disposition | (m, _, disposition) <- wsrDispositions report, modulePath m == domainPath]+            `shouldBe` [Overwritten]+          [disposition | (m, _, disposition) <- wsrDispositions report, modulePath m == nominalPath]+            `shouldBe` [Overwritten]+          newDomain <- TIO.readFile (out </> domainPath)+          newDomain `shouldSatisfy` (not . T.isInfixOf "newtype ProjectId")+          newDomain `shouldSatisfy` T.isInfixOf "Generated.Nominals (ProjectId, parseProjectId, ProjectPhase (..))"+          newNominals <- TIO.readFile (out </> nominalPath)+          T.count "newtype ProjectId" newNominals `shouldBe` 0+          T.count "data ProjectPhase =" newNominals `shouldBe` 1+          newInternalNominals <- TIO.readFile (out </> internalNominalPath)+          T.count "newtype ProjectId" newInternalNominals `shouldBe` 1+          TIO.readFile (out </> holePath) `shouldReturn` "-- hand-owned 0.6 implementation\n"+      it "adopts an overwritten same-context record pair by record and by banner" $+        withInlineWorkspace "keiro-dsl-workspace-adopt" adoptionMembers $ \_ out workspace -> do+          -- Reproduce today's defect first: two same-context specs+          -- scaffolded independently into one directory, the second+          -- replacing the first's record and calling its files stale.+          specA <- parseInlineSpec "domain/a.keiro" adoptionMemberA+          specB <- parseInlineSpec "domain/b.keiro" adoptionMemberB+          let ctx = defaultContext "adoption-demo"+          legacyA <- executePlannedScaffold out "domain/a.keiro" ctx specA+          legacyB <- executePlannedScaffold out "domain/b.keiro" ctx specB+          reportStale legacyB `shouldSatisfy` (not . null)+          legacyBefore <- TIO.readFile (out </> recordFileName "adoption-demo")++          report <- executePlannedWorkspaceScaffold out workspace+          wsrStale report `shouldBe` []+          case wsrMigration report of+            Nothing -> expectationFailure "expected the first workspace run to adopt"+            Just migration -> do+              let generatedOf run = sort [modulePath m | (m, _) <- reportDispositions run, kind m == Generated]+                  claimedBy evidence = sort [cfPath entry | entry <- mrClaimed migration, cfEvidence entry == evidence]+              -- The surviving record attributes B's files; A's+              -- files survived only as banners, which is exactly+              -- the orphan case the overwrite created.+              claimedBy ClaimedFromRecord `shouldBe` generatedOf legacyB+              claimedBy ClaimedFromBanner `shouldBe` sort (generatedOf legacyA \\ generatedOf legacyB)+              claimedBy ClaimedFromBanner `shouldSatisfy` (not . null)+              mrLikelyStale migration `shouldBe` []+              mrLegacyRecord migration+                `shouldBe` Just (recordFileName "adoption-demo", "domain/b.keiro")+              -- Provenance is persisted, not merely printed.+              recorded <- parseWorkspaceRecord <$> TIO.readFile (wsrRecordPath report)+              fmap (sort . map adPath . wrAdopted) recorded+                `shouldBe` Just (sort (map cfPath (mrClaimed migration)))+              fmap (sort . nubOrd . map adEvidence . wrAdopted) recorded+                `shouldBe` Just ["banner", "record"]+              persisted <- TIO.readFile (out </> "keiro-dsl-migration-report.workspace.adoption-demo.txt")+              persisted `shouldBe` T.unlines (renderMigrationReport migration)+              renderWorkspaceScaffoldReport report+                `shouldSatisfy` any (T.isInfixOf "adopting pre-workspace scaffold output")++          -- The legacy record gained one line and nothing else: it+          -- still parses to the same value for an old binary.+          legacyAfter <- TIO.readFile (out </> recordFileName "adoption-demo")+          T.lines legacyAfter `shouldSatisfy` elem (supersededByLine "adoption-demo")+          parseRecord legacyAfter `shouldBe` parseRecord legacyBefore+          T.lines legacyAfter+            `shouldBe` T.lines legacyBefore <> [supersededByLine "adoption-demo"]++          -- Adoption is not a content change: the generated tree is+          -- what a fresh workspace scaffold of the same members emits.+          withInlineWorkspace "keiro-dsl-workspace-adopt-fresh" adoptionMembers $ \_ fresh freshWorkspace -> do+            freshReport <- executePlannedWorkspaceScaffold fresh freshWorkspace+            wsrMigration freshReport `shouldBe` Nothing+            adoptedTree <- treeSnapshot out+            freshTree <- treeSnapshot fresh+            haskellOnly adoptedTree `shouldBe` haskellOnly freshTree+      it "adopts and marks context history under the legacy record name" $+        withInlineWorkspace "keiro-dsl-workspace-adopt-legacy-name" adoptionMembers $ \_ out workspace -> do+          specA <- parseInlineSpec "domain/a.keiro" adoptionMemberA+          _ <- executePlannedScaffold out "domain/a.keiro" (defaultContext "adoption-demo") specA+          let current = contextLedgerFileName "adoption-demo"+              legacy = legacyContextRecordFileName "adoption-demo"+          renameFile (out </> current) (out </> legacy)+          ledgerBefore <- TIO.readFile (out </> legacy)+          report <- executePlannedWorkspaceScaffold out workspace+          case wsrMigration report of+            Nothing -> expectationFailure "expected legacy-name context history to be adopted"+            Just migration -> mrLegacyRecord migration `shouldBe` Just (legacy, "domain/a.keiro")+          doesFileExist (out </> current) `shouldReturn` False+          ledgerAfter <- TIO.readFile (out </> legacy)+          T.lines ledgerAfter `shouldBe` T.lines ledgerBefore <> [supersededByLine "adoption-demo"]+          parseRecord ledgerAfter `shouldBe` parseRecord ledgerBefore+      it "lists hand-written files as unclaimed and leaves their bytes alone" $+        withInlineWorkspace "keiro-dsl-workspace-unclaimed" adoptionMembers $ \_ out workspace -> do+          plan <- shouldPlanWorkspaceSpec workspace+          case [modulePath m | (m, _) <- wpModules plan, kind m == HoleStub] of+            [] -> expectationFailure "adoption fixture emits no hole module"+            holePath : _ -> do+              writeFileWithParents (out </> holePath) "-- hand filled\n"+              writeFileWithParents (out </> "Notes.hs") "module Notes where\n"+              report <- executePlannedWorkspaceScaffold out workspace+              case wsrMigration report of+                Nothing -> expectationFailure "expected a report for a directory holding hand-written files"+                Just migration -> do+                  mrLegacyRecord migration `shouldBe` Nothing+                  mrClaimed migration `shouldBe` []+                  mrUnclaimed migration `shouldBe` sort [holePath, "Notes.hs"]+              TIO.readFile (out </> holePath) `shouldReturn` "-- hand filled\n"+              TIO.readFile (out </> "Notes.hs") `shouldReturn` "module Notes where\n"+      it "never claims a bannerless file at a planned Generated path" $+        withInlineWorkspace "keiro-dsl-workspace-unattributable" adoptionMembers $ \_ out workspace -> do+          plan <- shouldPlanWorkspaceSpec workspace+          case [modulePath m | (m, _) <- wpModules plan, kind m == Generated] of+            [] -> expectationFailure "adoption fixture emits no Generated module"+            target : _ -> do+              writeFileWithParents (out </> target) "hand owned\n"+              refused <- executeWorkspaceScaffold out False plan+              refused `shouldSatisfy` isMissingBannerRefusal+              TIO.readFile (out </> target) `shouldReturn` "hand owned\n"+              doesFileExist (out </> "keiro-dsl-migration-report.workspace.adoption-demo.txt")+                `shouldReturn` False+      it "adopts at most once, and the second run is an ordinary idempotent run" $+        withInlineWorkspace "keiro-dsl-workspace-adopt-once" adoptionMembers $ \_ out workspace -> do+          specA <- parseInlineSpec "domain/a.keiro" adoptionMemberA+          _ <- executePlannedScaffold out "domain/a.keiro" (defaultContext "adoption-demo") specA+          first <- executePlannedWorkspaceScaffold out workspace+          wsrMigration first `shouldSatisfy` \case Just _ -> True; Nothing -> False+          treeBefore <- treeSnapshot out+          reportBefore <- TIO.readFile (out </> "keiro-dsl-migration-report.workspace.adoption-demo.txt")+          legacyBefore <- TIO.readFile (out </> recordFileName "adoption-demo")++          second <- executePlannedWorkspaceScaffold out workspace+          wsrMigration second `shouldBe` Nothing+          wsrStale second `shouldBe` []+          map thd3 (wsrDispositions second) `shouldSatisfy` all (`elem` [Unchanged, Skipped])+          treeSnapshot out `shouldReturn` treeBefore+          TIO.readFile (out </> "keiro-dsl-migration-report.workspace.adoption-demo.txt")+            `shouldReturn` reportBefore+          legacyAfter <- TIO.readFile (out </> recordFileName "adoption-demo")+          legacyAfter `shouldBe` legacyBefore+          length (filter (== supersededByLine "adoption-demo") (T.lines legacyAfter))+            `shouldBe` 1++comparisonProvenance :: CompareProvenance+comparisonProvenance =+  CompareProvenance+    { cpHistoricalCodecIdentity = "example.historical",+      cpHistoricalCodecVersion = "legacy-v1",+      cpCanonicalType = CanonicalTypeId "example.Artifact.v1",+      cpBindingSymbol = QualifiedValueName "Example.Bindings.artifactBinding",+      cpBindingVersion = BindingVersion "1",+      cpWireFingerprint = "deadbeef"+    }++syntheticGenerated :: FilePath -> T.Text -> ScaffoldModule+syntheticGenerated path contents =+  ScaffoldModule {modulePath = path, moduleText = contents, kind = Generated, origin = "test"}++data GeneratedTreeDelta = GeneratedTreeDelta+  { changedPaths :: !(Set.Set FilePath),+    addedPaths :: !(Set.Set FilePath),+    removedPaths :: !(Set.Set FilePath),+    changedLineCounts :: !(Map.Map FilePath Int)+  }+  deriving stock (Eq, Show)++generatedTreeDelta :: [ScaffoldModule] -> [ScaffoldModule] -> GeneratedTreeDelta+generatedTreeDelta previous current =+  GeneratedTreeDelta+    { changedPaths = changed,+      addedPaths = added,+      removedPaths = removed,+      changedLineCounts = Map.fromSet lineCount impacted+    }+  where+    previousByPath = generatedByPath previous+    currentByPath = generatedByPath current+    previousPaths = Map.keysSet previousByPath+    currentPaths = Map.keysSet currentByPath+    added = currentPaths Set.\\ previousPaths+    removed = previousPaths Set.\\ currentPaths+    shared = previousPaths `Set.intersection` currentPaths+    changed = Set.filter (\path -> Map.lookup path previousByPath /= Map.lookup path currentByPath) shared+    impacted = changed <> added <> removed+    lineCount path = case (Map.lookup path previousByPath, Map.lookup path currentByPath) of+      (Just old, Just new) -> differingLineCount (moduleText old) (moduleText new)+      (Just old, Nothing) -> length (T.lines (moduleText old))+      (Nothing, Just new) -> length (T.lines (moduleText new))+      (Nothing, Nothing) -> 0+    generatedByPath modules = Map.fromList [(modulePath value, value) | value <- modules, kind value == Generated]++generatedTreeDeltaFromSnapshot :: [(FilePath, T.Text)] -> [(FilePath, T.Text)] -> GeneratedTreeDelta+generatedTreeDeltaFromSnapshot previous current =+  generatedTreeDelta+    [syntheticGenerated path contents | (path, contents) <- previous]+    [syntheticGenerated path contents | (path, contents) <- current]++differingLineCount :: T.Text -> T.Text -> Int+differingLineCount previous current =+  unequalShared + abs (length previousLines - length currentLines)+  where+    previousLines = T.lines previous+    currentLines = T.lines current+    unequalShared = length [() | (old, new) <- zip previousLines currentLines, old /= new]++assertAllowedGeneratedDelta :: Set.Set ModuleRole -> [ScaffoldModule] -> [ScaffoldModule] -> GeneratedTreeDelta -> Expectation+assertAllowedGeneratedDelta allowed previous current delta = do+  removedPaths delta `shouldBe` Set.empty+  actualRoles `shouldSatisfy` (`Set.isSubsetOf` allowed)+  where+    modulesByPath = Map.fromList [(modulePath value, value) | value <- previous <> current, kind value == Generated]+    impacted = changedPaths delta <> addedPaths delta <> removedPaths delta+    actualRoles = Set.fromList [moduleRole value | path <- Set.toList impacted, Just value <- [Map.lookup path modulesByPath]]++generatedTextEndingIn :: T.Text -> [ScaffoldModule] -> T.Text+generatedTextEndingIn suffix modules = case [moduleText m | m <- modules, kind m == Generated, suffix `T.isSuffixOf` T.pack (modulePath m)] of+  contents : _ -> contents+  [] -> ""++generatedExtensionsEndingIn :: T.Text -> [ScaffoldModule] -> [T.Text]+generatedExtensionsEndingIn suffix modules = case [generatedModule | generatedModule <- modules, kind generatedModule == Generated, suffix `T.isSuffixOf` T.pack (modulePath generatedModule)] of+  [generatedModule] -> generatedLocalExtensions generatedModule+  matches -> error ("expected one generated module ending in " <> T.unpack suffix <> ", got " <> show (map modulePath matches))++generatedLocalExtensions :: ScaffoldModule -> [T.Text]+generatedLocalExtensions generatedModule =+  [ extension+  | line <- takeWhile (T.isPrefixOf languagePrefix) (T.lines (moduleText generatedModule)),+    Just extensionWithSuffix <- [T.stripPrefix languagePrefix line],+    Just extension <- [T.stripSuffix languageSuffix extensionWithSuffix]+  ]+  where+    languagePrefix = "{-# LANGUAGE "+    languageSuffix = " #-}"++holeTextEndingIn :: T.Text -> [ScaffoldModule] -> T.Text+holeTextEndingIn suffix modules = case [moduleText m | m <- modules, kind m == HoleStub, suffix `T.isSuffixOf` T.pack (modulePath m), not ("BehaviorHoles.hs" `T.isSuffixOf` T.pack (modulePath m))] of+  contents : _ -> contents+  [] -> ""++onlyAggregate :: Spec -> Aggregate+onlyAggregate spec = case [aggregate | NAggregate aggregate <- specNodes spec] of+  [aggregate] -> aggregate+  aggregates -> error ("expected one aggregate, got " <> show (length aggregates))++loweringAggregateSpec :: T.Text+loweringAggregateSpec =+  T.unlines+    [ "context samples",+      "",+      "aggregate Counter",+      "  regs",+      "    note Text = \"hello world\"",+      "    count Int = 0",+      "    state CounterVertex = Pending",+      "  states Pending Done!",+      "  command Bump { count:Int }",+      "  event CountBumped { count:Int }",+      "  Pending -- Bump --> emit CountBumped ; goto Done"+    ]++scalarRegisterCases :: [(T.Text, T.Text)]+scalarRegisterCases =+  [ ("Text", "\"sample\""),+    ("Int", "0"),+    ("Bool", "False"),+    ("Time", "\"2026-01-02T03:04:05.123456789012Z\""),+    ("Natural", "0")+  ]++cleanScalarAggregateSpec :: T.Text -> T.Text -> T.Text+cleanScalarAggregateSpec typeName initialValue =+  T.unlines+    [ "context clean-scalar",+      "",+      "aggregate Scalar",+      "  regs",+      "    value " <> typeName <> " = " <> initialValue,+      "  states Empty Done!",+      "  command Set { value:" <> typeName <> " }",+      "  event SetDone { value:" <> typeName <> " }",+      "  Empty -- Set --> write value := value ; emit SetDone ; goto Done"+    ]++exactStatusSpec :: T.Text+exactStatusSpec =+  T.unlines+    [ "context samples",+      "",+      "aggregate Reservation",+      "  regs",+      "    state ReservationVertex = Open",+      "  states Open Closed!",+      "  command Bump { count:Int }",+      "  event ReservationHeld { count:Int }",+      "  event ReservationUnHeld { count:Int }",+      "  event CountBumped { count:Int }",+      "  Open -- Bump --> emit CountBumped ; goto Closed",+      "  projection reservation_status consistency=Eventual key=count",+      "    status-map { ReservationHeld=>held ReservationUnHeld=>available CountBumped=>bumped }"+    ]++hasPathCollisionWithTwoOrigins :: Either [Refusal] [ScaffoldModule] -> Bool+hasPathCollisionWithTwoOrigins = \case+  Left refusals -> any hasTwo refusals+  Right _ -> False+  where+    hasTwo (PathCollision _ origins) = length origins == 2+    hasTwo _ = False++isMissingBannerRefusal :: Either [Refusal] a -> Bool+isMissingBannerRefusal = \case+  Left [MissingGeneratedBanner paths] -> not (null paths)+  _ -> False++isSuccessfulScaffold :: Either [Refusal] a -> Bool+isSuccessfulScaffold = \case+  Right _ -> True+  Left _ -> False++-- Unit tests that construct semantic values directly still need to exercise+-- the production planner's exact-source path. Promote the compatibility spans+-- into an explicitly exact, complete index here; production code never+-- fabricates this provenance.+syntheticExactSourceIndex :: Spec -> SemanticSourceIndex+syntheticExactSourceIndex spec =+  case compatibilitySemanticSourceIndex sourceName spec of+    Left failure -> error ("failed to construct the test source index: " <> show failure)+    Right compatibilityIndex ->+      case exactSemanticSourceIndex sourceName (semanticSourceSubjects spec) entries of+        Left failure -> error ("failed to promote the test source index: " <> show failure)+        Right exactIndex -> exactIndex+      where+        entries = [(subject, sourceSpan) | (subject, _, sourceSpan) <- semanticSourceEntries compatibilityIndex]+  where+    sourceName = "<test-exact>"++planTestServiceScaffold :: Context -> CheckedService -> Either [Refusal] [ScaffoldModule]+planTestServiceScaffold ctx service =+  planIndexedServiceScaffold (syntheticExactSourceIndex (checkedSpec service)) ctx service++planTestServiceScaffoldWithRuntimePackage :: Maybe RuntimePackageName -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]+planTestServiceScaffoldWithRuntimePackage runtimePackage ctx service =+  planIndexedServiceScaffoldWithRuntimePackage runtimePackage (syntheticExactSourceIndex (checkedSpec service)) ctx service++planTestScaffold :: Context -> Spec -> Either [Refusal] [ScaffoldModule]+planTestScaffold ctx spec = planTestServiceScaffold ctx (legacyCheckedService spec)++checkTestServiceDiagnostics :: Maybe RuntimePackageName -> Context -> CheckedService -> [Diagnostic]+checkTestServiceDiagnostics runtimePackage ctx service =+  checkIndexedServiceDiagnostics runtimePackage (syntheticExactSourceIndex (checkedSpec service)) ctx service++executePlannedScaffold :: FilePath -> FilePath -> Context -> Spec -> IO ScaffoldReport+executePlannedScaffold out specPath ctx spec = case planTestScaffold ctx spec of+  Left refusals -> expectationFailure ("unexpected scaffold refusal: " <> show refusals) >> error "unreachable"+  Right modules -> do+    result <- executeScaffold out False specPath ctx spec modules+    case result of+      Left refusals -> expectationFailure ("unexpected execution refusal: " <> show refusals) >> error "unreachable"+      Right report -> pure report++renameCounter :: Node -> Node+renameCounter (NAggregate aggregate) =+  NAggregate+    aggregate+      { aggName = "Widget",+        aggRegs = [reg {regType = if regType reg == TRef "CounterVertex" then TRef "WidgetVertex" else regType reg} | reg <- aggRegs aggregate]+      }+renameCounter node = node++onlyPathEndingIn :: FilePath -> [ScaffoldModule] -> FilePath+onlyPathEndingIn suffix modules = case [modulePath m | m <- modules, T.pack suffix `T.isSuffixOf` T.pack (modulePath m)] of+  [path] -> path+  paths -> error ("expected one path ending in " <> suffix <> ", got " <> show paths)++withTempDirectory :: String -> (FilePath -> IO a) -> IO a+withTempDirectory template = bracket acquire removePathForcibly+  where+    acquire = do+      base <- getTemporaryDirectory+      (path, handle) <- openTempFile base template+      hClose handle+      removeFile path+      createDirectory path+      pure path++-- | Parse a fixture and return the validator's diagnostic codes (failing the+-- test on a parse error).+diagnosticCodesOf :: FilePath -> IO [DiagnosticCode]+diagnosticCodesOf path = do+  map code <$> diagnosticsOf path++-- | Parse a fixture and return all validator diagnostics.+diagnosticsOf :: FilePath -> IO [Diagnostic]+diagnosticsOf path = do+  service <- checkedServiceOf path+  pure (validateService service)++-- | Like 'diagnosticCodesOf' but only the Error-severity codes (warnings, e.g.+-- the benign-inversion notices, are excluded).+errorCodesOf :: FilePath -> IO [DiagnosticCode]+errorCodesOf path = do+  diagnostics <- diagnosticsOf path+  pure [code d | d <- diagnostics, severity d == Error]++-- | Parse two fixtures and diff them (old, new).+-- | Plan 143: render an Expr in concrete guard syntax by printing a dummy+-- transition through the real pretty-printer and slicing its guard clause,+-- so the test exercises the exact printer the diff advisory uses.+renderExprText :: Expr -> T.Text+renderExprText e =+  case [T.strip l | l <- T.lines rendered, "guard " `T.isPrefixOf` T.strip l] of+    [guardLine] -> T.strip (T.drop (T.length "guard ") guardLine)+    _ -> error ("renderExprText: unexpected printer output: " <> T.unpack rendered)+  where+    rendered =+      renderTransition+        Transition+          { tSource = "S",+            tCommand = "C",+            tImplementation = LegacyHoleImplementation,+            tGuard = Just e,+            tWrites = [],+            tEmits = [],+            tOutcome = Nothing,+            tOutcomeDuplicateLocs = [],+            tGoto = "S",+            tMode = TmLive,+            tLoc = noLoc+          }++-- | Plan 143: a minimal spec whose only transition is replay-only, with the+-- supplied clause lines spliced into its body.+replayOnlySpecWith :: [T.Text] -> T.Text+replayOnlySpecWith clauseLines =+  T.unlines $+    [ "context hospital-capacity",+      "",+      "id TransferReservationId prefix=rsv",+      "",+      "aggregate Reservation",+      "  regs",+      "    reservationId    TransferReservationId = placeholder",+      "    reservationState ReservationVertex     = Unrequested",+      "  states Unrequested Held",+      "",+      "  command RequestTransferReservation { reservationId }",+      "",+      "  event TransferReservationCreated = fields(RequestTransferReservation)",+      "",+      "  replay-only Unrequested -- RequestTransferReservation -->"+    ]+      ++ clauseLines++diffFixtures :: FilePath -> FilePath -> IO [Change]+diffFixtures oldP newP = do+  old <- parsedSourceOf oldP+  new <- parsedSourceOf newP+  pure (diffSources old new)++kindOfChange :: Change -> ChangeKind+kindOfChange (Additive kind) = kind+kindOfChange (Advisory kind) = kind+kindOfChange (Breaking kind) = kind++generatedHaskellNameFindings :: [Change] -> [Change]+generatedHaskellNameFindings = filter ((== GeneratedHaskellNameChanged) . ckCode . kindOfChange)++assertGeneratedHaskellNameFinding :: Change -> Expectation+assertGeneratedHaskellNameFinding change = do+  change `shouldSatisfy` isAdvisory+  let kind = kindOfChange change+      compatibility = ckVector kind+      nonBuildVerdicts =+        [ verdictFor surface compatibility+        | surface <- [PrivateHistoryRead, OldBinaryReadNewEvents, SnapshotHydration, PublicConsumer, PersistedIdentity]+        ]+  nonBuildVerdicts `shouldBe` replicate 5 VCompatible+  verdictFor ConsumerBuild compatibility `shouldBe` VAdvisory+  cvRollout compatibility `shouldBe` Set.empty+  renderFinding change `shouldSatisfy` T.isInfixOf "consumer-build=advisory"+  remediationFor (ckContext kind) (ckCode kind)+    `shouldBe` RemedyRescaffoldGenerated :| [RemedyRecompileConsumers, RemedyRunConformance]++labelOfChange :: Change -> Label+labelOfChange Additive {} = LabelAdditive+labelOfChange Advisory {} = LabelAdvisory+labelOfChange Breaking {} = LabelBreaking++genSurfaceSet :: Gen (Set.Set CompatibilitySurface)+genSurfaceSet = Set.fromList <$> listOf (elements [minBound .. maxBound])++genCompatibilityVector :: Gen CompatibilityVector+genCompatibilityVector =+  CompatibilityVector+    <$> genVerdict+    <*> genVerdict+    <*> genVerdict+    <*> genVerdict+    <*> genVerdict+    <*> genVerdict+    <*> (Set.fromList <$> listOf (elements rolloutConstraints))+  where+    genVerdict = elements [VCompatible, VAdvisory, VBreaking, VNotApplicable]+    rolloutConstraints =+      [ RolloutStopTheWorld,+        RolloutWorkersFirst,+        RolloutDrainRequired,+        RolloutProducerLast,+        RolloutProducerFirst+      ]++replayImpactFixtures :: FilePath -> FilePath -> IO ReplayImpact+replayImpactFixtures oldPath newPath = do+  old <- checkedServiceOf oldPath+  new <- checkedServiceOf newPath+  pure (resolvedFold (ReplayImpact.replayImpactServices old new))++modifyAggregate :: Name -> (Aggregate -> Aggregate) -> Spec -> Spec+modifyAggregate target update spec =+  spec+    { specNodes =+        [ case node of+            NAggregate aggregate | aggName aggregate == target -> NAggregate (update aggregate)+            _ -> node+        | node <- specNodes spec+        ]+    }++modifyReadModel :: Name -> (ReadModelNode -> ReadModelNode) -> Spec -> Spec+modifyReadModel target update spec =+  spec+    { specNodes =+        [ case node of+            NReadModel readModel | rmName readModel == target -> NReadModel (update readModel)+            _ -> node+        | node <- specNodes spec+        ]+    }++setLegacySubscription :: Maybe T.Text -> ReadModelSupply -> ReadModelSupply+setLegacySubscription subscription supply = case supply of+  legacy@LegacyReadModelSupply {} -> legacy {legacySubscription = subscription}+  OwnerDerivedSupply -> OwnerDerivedSupply++setLegacyScope :: Maybe RmScope -> ReadModelSupply -> ReadModelSupply+setLegacyScope scope supply = case supply of+  legacy@LegacyReadModelSupply {} -> legacy {legacyScope = scope}+  OwnerDerivedSupply -> OwnerDerivedSupply++setLegacyFeed :: RmFeed -> ReadModelSupply -> ReadModelSupply+setLegacyFeed feed supply = case supply of+  legacy@LegacyReadModelSupply {} -> legacy {legacyFeed = feed}+  OwnerDerivedSupply -> OwnerDerivedSupply++setLegacyConsistency :: Consistency -> ReadModelSupply -> ReadModelSupply+setLegacyConsistency consistency supply = case supply of+  legacy@LegacyReadModelSupply {} -> legacy {legacyConsistency = consistency}+  OwnerDerivedSupply -> OwnerDerivedSupply++mapContract :: (ContractNode -> ContractNode) -> Spec -> Spec+mapContract update spec =+  spec+    { specNodes =+        [ case node of+            NContract contract -> NContract (update contract)+            _ -> node+        | node <- specNodes spec+        ]+    }++mapIntake :: (IntakeNode -> IntakeNode) -> Spec -> Spec+mapIntake update spec =+  spec+    { specNodes =+        [ case node of+            NIntake intake -> NIntake (update intake)+            _ -> node+        | node <- specNodes spec+        ]+    }++mapPgmqDispatch :: (PgmqDispatchNode -> PgmqDispatchNode) -> Spec -> Spec+mapPgmqDispatch update spec =+  spec+    { specNodes =+        [ case node of+            NPgmqDispatch dispatch -> NPgmqDispatch (update dispatch)+            _ -> node+        | node <- specNodes spec+        ]+    }++mapRouter :: (RouterNode -> RouterNode) -> Spec -> Spec+mapRouter update spec =+  spec+    { specNodes =+        [ case node of+            NRouter router -> NRouter (update router)+            _ -> node+        | node <- specNodes spec+        ]+    }++mapEmit :: (EmitNode -> EmitNode) -> Spec -> Spec+mapEmit update spec =+  spec+    { specNodes =+        [ case node of+            NEmit emitNode -> NEmit (update emitNode)+            _ -> node+        | node <- specNodes spec+        ]+    }++mapWorkflow :: (WorkflowNode -> WorkflowNode) -> Spec -> Spec+mapWorkflow update spec =+  spec+    { specNodes =+        [ case node of+            NWorkflow workflow -> NWorkflow (update workflow)+            _ -> node+        | node <- specNodes spec+        ]+    }++mapWorkqueue :: (WorkqueueNode -> WorkqueueNode) -> Spec -> Spec+mapWorkqueue update spec =+  spec+    { specNodes =+        [ case node of+            NWorkqueue queue -> NWorkqueue (update queue)+            _ -> node+        | node <- specNodes spec+        ]+    }++mapDispatch :: (PgmqDispatchNode -> PgmqDispatchNode) -> Spec -> Spec+mapDispatch update spec =+  spec+    { specNodes =+        [ case node of+            NPgmqDispatch dispatch -> NPgmqDispatch (update dispatch)+            _ -> node+        | node <- specNodes spec+        ]+    }++mapOperation :: (OperationNode -> OperationNode) -> Spec -> Spec+mapOperation update spec =+  spec+    { specNodes =+        [ case node of+            NOperation operation -> NOperation (update operation)+            _ -> node+        | node <- specNodes spec+        ]+    }++mapPublisher :: (PublisherNode -> PublisherNode) -> Spec -> Spec+mapPublisher update spec =+  spec+    { specNodes =+        [ case node of+            NPublisher publisher -> NPublisher (update publisher)+            _ -> node+        | node <- specNodes spec+        ]+    }++serviceErrorCodes :: Int -> Spec -> [DiagnosticCode]+serviceErrorCodes versionNumber spec =+  [code diagnostic | diagnostic <- validateService service, severity diagnostic == Error]+  where+    service = case languageVersion (fromIntegral versionNumber) >>= effectiveLanguageContractForVersion of+      Nothing -> error ("unsupported test language version " <> show versionNumber)+      Just languageContract -> checkedServiceForContract languageContract spec++-- | Codes emitted at 'Warning' severity under the given released language.+-- Pairs with 'serviceErrorCodes' to assert a surface's warn-then-error tiering+-- from both sides, rather than only proving it is not an error.+serviceWarningCodes :: Int -> Spec -> [DiagnosticCode]+serviceWarningCodes versionNumber spec =+  [code diagnostic | diagnostic <- validateService service, severity diagnostic == Warning]+  where+    service = case languageVersion (fromIntegral versionNumber) >>= effectiveLanguageContractForVersion of+      Nothing -> error ("unsupported test language version " <> show versionNumber)+      Just languageContract -> checkedServiceForContract languageContract spec++duplicateFirst :: [a] -> [a]+duplicateFirst = \case+  [] -> []+  first : rest -> first : first : rest++updateFirst :: (a -> a) -> [a] -> [a]+updateFirst update = \case+  [] -> []+  first : rest -> update first : rest++removeReadModel :: Name -> Spec -> Spec+removeReadModel target spec =+  spec {specNodes = [node | node <- specNodes spec, not (isTarget node)]}+  where+    isTarget (NReadModel readModel) = rmName readModel == target+    isTarget _ = False++modifyRouter :: Name -> (RouterNode -> RouterNode) -> Spec -> Spec+modifyRouter target update spec =+  spec+    { specNodes =+        [ case node of+            NRouter router | rtId router == target -> NRouter (update router)+            _ -> node+        | node <- specNodes spec+        ]+    }++routerErrorCodes :: (RouterNode -> RouterNode) -> Spec -> [DiagnosticCode]+routerErrorCodes update = errorCodes . modifyRouter "PagingRouter" update++modifyProcess :: Name -> (ProcessNode -> ProcessNode) -> Spec -> Spec+modifyProcess target update spec =+  spec+    { specNodes =+        [ case node of+            NProcess process | procId process == target -> NProcess (update process)+            _ -> node+        | node <- specNodes spec+        ]+    }++processErrorCodes :: (ProcessNode -> ProcessNode) -> Spec -> [DiagnosticCode]+processErrorCodes update = errorCodes . modifyProcess "HospitalSurge" update++errorCodes :: Spec -> [DiagnosticCode]+errorCodes spec = [code diagnostic | diagnostic <- validateSpec spec, severity diagnostic == Error]++diagnosticCodes :: Spec -> [DiagnosticCode]+diagnosticCodes = map code . validateSpec++changeReadModelShape :: ReadModelNode -> ReadModelNode+changeReadModelShape readModel =+  readModel+    { rmColumns = rmColumns readModel <> [RmColumn "reviewed_by" "text" False],+      rmShape = "fnv1a:0000000000000000"+    }++-- | Assert a @new \<kind\>@ skeleton parses and validates with zero+-- error-severity diagnostics.+assertSkeletonValid :: T.Text -> IO ()+assertSkeletonValid kind = case skeletonFor kind of+  Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err))+  Right src -> case parseSpec ("new:" <> T.unpack kind) src of+    Left perr -> expectationFailure (T.unpack ("skeleton for " <> kind <> " failed to parse: " <> perr))+    Right spec ->+      [code d | d <- validateSpec spec, severity d == Error]+        `shouldBe` ([] :: [DiagnosticCode])++assertSkeletonUsesAuthoringLanguage :: T.Text -> IO ()+assertSkeletonUsesAuthoringLanguage kind = case skeletonFor kind of+  Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err))+  Right source -> case parseSource ("new:" <> T.unpack kind) source of+    Left failure -> expectationFailure (T.unpack (renderParseFailure failure))+    Right parsed -> do+      let service = checkedSource parsed+      effectiveContractLanguageVersion (checkedLanguageContract service) `shouldBe` currentAuthoringLanguageVersion+      effectiveLanguageSupport (checkedLanguageContract service) `shouldBe` Stable+      [code diagnostic | diagnostic <- validateService service, severity diagnostic == Error]+        `shouldBe` ([] :: [DiagnosticCode])+      scaffoldServiceModules (defaultContext (specContext (checkedSpec service))) service+        `shouldSatisfy` (not . null)++assertSkeletonScaffoldable :: T.Text -> IO ()+assertSkeletonScaffoldable kind = case skeletonFor kind of+  Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err))+  Right src -> case parseSpec ("new:" <> T.unpack kind) src of+    Left perr -> expectationFailure (T.unpack perr)+    Right spec -> planTestScaffold (defaultContext (specContext spec)) spec `shouldSatisfy` isSuccessfulScaffold++bumpArtifactBindingVersion :: MappedDecl -> MappedDecl+bumpArtifactBindingVersion declaration@MappedStructural {msName = "ArtifactInfo"} =+  declaration {msBindingVersion = Just "2"}+bumpArtifactBindingVersion declaration = declaration++addArtifactSummaryField :: MappedDecl -> MappedDecl+addArtifactSummaryField declaration@MappedStructural {msName = "ArtifactInfo", msShape = ShapeRecord constructor unknownFields fields} =+  declaration+    { msShape =+        ShapeRecord+          constructor+          unknownFields+          ( fields+              <> [ WireField+                     { wfHaskell = "summary",+                       wfKey = "summary",+                       wfType = TText,+                       wfPresence = PRequired,+                       wfOnMissing = Nothing,+                       wfLoc = Loc 0+                     }+                 ]+          )+    }+addArtifactSummaryField declaration = declaration++addAlphaPayloadOptionalField :: Spec -> Spec+addAlphaPayloadOptionalField = addMappedOptionalTextField "AlphaPayload" "note"++addNestedPayloadOptionalField :: Spec -> Spec+addNestedPayloadOptionalField = addMappedOptionalTextField "NestedPayload" "detail"++addMappedOptionalTextField :: Name -> Name -> Spec -> Spec+addMappedOptionalTextField target fieldName spec = spec {specMapped = map addField (specMapped spec)}+  where+    addField declaration@MappedStructural {msName = declarationName, msShape = ShapeRecord constructor unknownFields fields}+      | declarationName == target =+          declaration+            { msShape =+                ShapeRecord+                  constructor+                  unknownFields+                  ( fields+                      <> [ WireField+                             { wfHaskell = fieldName,+                               wfKey = fieldName,+                               wfType = TOptional TText,+                               wfPresence = POptional,+                               wfOnMissing = Just OmNull,+                               wfLoc = Loc 0+                             }+                         ]+                  )+            }+    addField declaration = declaration++changeAlphaPayloadFixtureSymbol :: Spec -> Spec+changeAlphaPayloadFixtureSymbol spec = spec {specMapped = map changeFixture (specMapped spec)}+  where+    changeFixture declaration@MappedStructural {msName = "AlphaPayload"} =+      declaration {msFixtures = Just "Example.SemanticLocality.Bindings.alphaPayloadV2Cases"}+    changeFixture declaration = declaration++mapWorkspaceSpec :: (Spec -> Spec) -> WorkspaceSpec -> WorkspaceSpec+mapWorkspaceSpec transform workspace =+  workspace+    { wsMembers = [member {wmSpec = transform (wmSpec member)} | member <- wsMembers workspace],+      wsMergedSpec = transform (wsMergedSpec workspace)+    }++expectGenericCompileFailure :: FilePath -> String -> Expectation+expectGenericCompileFailure fixture expectedDiagnostic = do+  let fixtureDir = "../keiro-core/test/compile-fail" </> fixture+      fixtureSource = fixtureDir </> "Fixture.hs"+  (exitCode, standardOutput, standardError) <-+    readProcessWithExitCode+      "cabal"+      [ "exec",+        "--",+        "ghc",+        "-XGHC2024",+        "-fno-code",+        "-fforce-recomp",+        "-i../keiro-core/src",+        "-i" <> fixtureDir,+        fixtureSource+      ]+      ""+  exitCode `shouldSatisfy` (/= ExitSuccess)+  let compilerOutput = standardOutput <> standardError+  compilerOutput `shouldContain` expectedDiagnostic+  compilerOutput `shouldContain` "Run keiro-dsl scaffold and fill the binding by hand at this error location in the scaffolded module."+  compilerOutput `shouldContain` fixtureSource++moveArtifactBindingIntoGenerated :: MappedDecl -> MappedDecl+moveArtifactBindingIntoGenerated declaration@MappedStructural {msName = "ArtifactInfo"} =+  declaration {msBinding = Just "Generated.ConsumerDemo.Bindings.artifactInfoBinding"}+moveArtifactBindingIntoGenerated declaration = declaration++removeMappedRegisterRequirements :: Spec -> Spec+removeMappedRegisterRequirements spec =+  spec+    { specMapped = map removeInitial (specMapped spec),+      specNodes = map removeRegisters (specNodes spec)+    }+  where+    removeInitial declaration@MappedStructural {} = declaration {msInitial = Nothing}+    removeInitial declaration@MappedOpaque {} = declaration {moInitial = Nothing}+    removeRegisters (NAggregate aggregate) =+      NAggregate+        aggregate+          { aggRegs = [],+            aggTransitions = [transition {tWrites = []} | transition <- aggTransitions aggregate]+          }+    removeRegisters node = node++isImportCycle :: Refusal -> Bool+isImportCycle ImportCycle {} = True+isImportCycle _ = False++isFoldSurfaceRefusal :: Either [Refusal] modules -> Bool+isFoldSurfaceRefusal (Left refusals) = any isFold refusals+  where+    isFold FoldSurfaceRefusal {} = True+    isFold _ = False+isFoldSurfaceRefusal (Right _) = False++-- | The canonical positive workspace fixture: three members under one context.+canonicalWorkspacePath :: FilePath+canonicalWorkspacePath = "test/fixtures/workspace/service.keiro-workspace"++-- | Deterministic workspace source used to model git blobs without invoking git.+memoryContentSource :: Map.Map FilePath T.Text -> ContentSource+memoryContentSource files =+  ContentSource+    { csRead = \path ->+        pure $ maybe (Left ("missing in-memory content: " <> T.pack path)) Right (Map.lookup path files)+    }++changeCode :: Change -> DiagnosticCode+changeCode (Additive kind) = ckCode kind+changeCode (Advisory kind) = ckCode kind+changeCode (Breaking kind) = ckCode kind++breakingSurfaces :: Change -> [CompatibilitySurface]+breakingSurfaces change =+  [ surface+  | surface <- [minBound .. maxBound],+    verdictFor surface (ckVector kind) == VBreaking+  ]+  where+    kind = case change of+      Additive value -> value+      Advisory value -> value+      Breaking value -> value++workspaceChangeKind :: Change -> ChangeKind+workspaceChangeKind (Additive kind) = kind+workspaceChangeKind (Advisory kind) = kind+workspaceChangeKind (Breaking kind) = kind++-- | The same members as 'canonicalWorkspacePath', listed in reverse order.+reorderedWorkspacePath :: FilePath+reorderedWorkspacePath = "test/fixtures/workspace/service-reordered.keiro-workspace"++-- | Load and compose a workspace fixture, failing the test on a refusal. The+-- fixture path is package-relative; the loader is rooted at the manifest's own+-- directory, exactly as the CLI roots it.+shouldComposeWorkspace :: FilePath -> IO WorkspaceSpec+shouldComposeWorkspace path = do+  resolved <- resolveTestPath path+  loaded <- loadWorkspace (fileContentSource (takeDirectory resolved)) resolved+  case loaded of+    Left failure ->+      expectationFailure (T.unpack (T.intercalate "\n" (renderWorkspaceFailure resolved failure)))+        >> error "unreachable"+    Right workspace -> pure workspace {wsManifestPath = path}++-- | The 'Context' a workspace scaffolds under, with no CLI overrides: the+-- members' unanimous context name, the manifest's module-root and layout+-- authority, and the built-in defaults where the manifest is silent.+workspaceContext :: WorkspaceSpec -> Context+workspaceContext workspace =+  Context+    { contextName = wsContext workspace,+      moduleRoot = maybe "" id (wsModuleRoot workspace),+      placement = maybe GeneratedPrefix id (wsLayout workspace)+    }++-- | Compose and plan a workspace fixture, failing the test on any refusal.+shouldPlanWorkspace :: FilePath -> IO WorkspacePlan+shouldPlanWorkspace path = do+  workspace <- shouldComposeWorkspace path+  case planWorkspaceScaffold "goldens" (workspaceContext workspace) workspace of+    Left refusals -> expectationFailure ("unexpected workspace plan refusal: " <> show refusals) >> error "unreachable"+    Right plan -> pure plan++-- | Does a scaffolded module's path end in this suffix?+isSuffixOfPath :: FilePath -> ScaffoldModule -> Bool+isSuffixOfPath suffix m = T.pack suffix `T.isSuffixOf` T.pack (modulePath m)++-- | A workspace record built from real composed data plus two synthetic+-- adoption rows, so the round-trip test exercises every row kind including the+-- JSON encodings shared with the v1 record.+sampleWorkspaceRecord :: WorkspaceSpec -> WorkspaceRecord+sampleWorkspaceRecord workspace =+  WorkspaceRecord+    { wrService = wsService workspace,+      wrManifest = "service.keiro-workspace",+      wrContext = wsContext workspace,+      wrModuleRoot = maybe "" id (wsModuleRoot workspace),+      wrLayout = "collocated",+      wrMembers = map wmPath (wsMembers workspace),+      wrSourceLanguages =+        [ WorkspaceSourceLanguageRow (wmPath member) (wmSourceLanguage member)+        | member <- wsMembers workspace+        ],+      wrLanguageContract = wsLanguageContract workspace,+      wrNamingEdition = IdiomaticNamingV1,+      wrModules =+        [ WorkspaceModuleRow Generated "Demo/Generated/StructuralProjections.hs" Nothing Nothing,+          WorkspaceModuleRow Generated "Demo/Project/Generated/Domain.hs" (Just "domain/project.keiro") Nothing,+          WorkspaceModuleRow HoleStub "Demo/Project/Holes.hs" (Just "domain/shared.keiro") Nothing+        ],+      wrMappings = consumerMappings (consumerPlan (wsMergedSpec workspace)),+      wrIdDomains = [],+      wrNominalEqualities = nominalEqualityIdentities (wsMergedSpec workspace),+      wrBindingObligations = either (const []) id (bindingHoles (wsMergedSpec workspace)),+      wrBehaviorRequirements = [],+      wrProjectionCatalogFacts = [],+      wrQueryContractBaseline = True,+      wrQueryContracts = either (const []) id (queryContractIdentities (wsMergedSpec workspace)),+      wrRouterSelections = [],+      wrAdopted =+        [ AdoptedRow "claimed/One.hs" "record" (Just "keiro-dsl-ledger.context.demo-project.txt") (Just "project.keiro"),+          AdoptedRow "claimed/Two.hs" "banner" Nothing Nothing+        ],+      wrSemanticImpact = Just (semanticImpactSnapshotForSpec (wsMergedSpec workspace))+    }++semanticImpactSnapshotForSpec :: Spec -> SemanticImpactSnapshot+semanticImpactSnapshotForSpec = semanticImpactSnapshot . semanticImpactForSpec++semanticImpactForSpec :: Spec -> SemanticImpact+semanticImpactForSpec spec = case resolveTypeGraph spec of+  Left failures -> error ("test fixture type graph did not resolve: " <> show failures)+  Right graph -> semanticImpact graph++-- | Test-facing selection from the production semantic authority. This does+-- not walk the raw 'Spec' or reconstruct dependency edges.+data MappedSurfaceQualification = MappedSurfaceQualification+  { declaration :: !MappedKey,+    evidence :: !(Set.Set MappedRootEvidence),+    consumers :: !(Set.Set MappedConsumer),+    consequences :: !(Set.Set MappedConsequence)+  }+  deriving stock (Eq, Show)++qualifyMappedSurface :: SemanticImpact -> MappedKey -> MappedSurfaceQualification+qualifyMappedSurface impact key =+  MappedSurfaceQualification+    { declaration = key,+      evidence = Map.findWithDefault Set.empty key (impactDeclarationEvidence impact),+      consumers = Map.findWithDefault Set.empty key (impactDeclarationConsumers impact),+      consequences = Map.findWithDefault Set.empty key (impactDeclarationConsequences impact)+    }++-- | The canonical workspace with a case-variant copy of one member's aggregate+-- grafted onto another member. Composition refuses this shape (EP-153 catches it+-- at the earliest boundary), so the planner's own cross-member collision gate can+-- only be exercised by constructing the graph directly — which is exactly what+-- this does, mirroring the single-file @caseVariant@ construction.+withCaseVariantAggregate :: WorkspaceSpec -> WorkspaceSpec+withCaseVariantAggregate workspace = case [aggregate | NAggregate aggregate <- specNodes merged, aggName aggregate == "Project"] of+  [] -> error "canonical workspace fixture has no Project aggregate"+  aggregate : _ ->+    let shouted = aggregate {aggName = T.toUpper (aggName aggregate)}+        ownership = wsOwnership workspace+     in workspace+          { wsMergedSpec = merged {specNodes = specNodes merged <> [NAggregate shouted]},+            wsOwnership =+              ownership+                { oiNodes =+                    Map.insert+                      ("aggregate", aggName shouted)+                      ("domain/project-artifact.keiro", Loc 1)+                      (oiNodes ownership)+                }+          }+  where+    merged = wsMergedSpec workspace++-- | Write a one-member workspace whose member declares an upcaster, so its+-- golden payload fixture has a canonical location. Returns the composed+-- workspace; the caller decides where the fixture lives.+writeGoldenWorkspace :: FilePath -> IO WorkspaceSpec+writeGoldenWorkspace root = do+  source <- readTestText "test/fixtures/reservation-v2.keiro"+  createDirectoryIfMissing True (root </> "domain")+  TIO.writeFile (root </> "domain/reservation.keiro") source+  let manifestPath = root </> "service.keiro-workspace"+  TIO.writeFile manifestPath "service gold-demo\nspec domain/reservation.keiro\n"+  loaded <- loadWorkspace (fileContentSource root) manifestPath+  case loaded of+    Left failure ->+      expectationFailure (T.unpack (T.intercalate "\n" (renderWorkspaceFailure manifestPath failure)))+        >> error "unreachable"+    Right workspace -> pure workspace++-- | Materialize the canonical fixture workspace in a fresh temporary directory+-- and hand the callback its root, a sibling output directory, and the composed+-- workspace. Working on a copy is what lets a test edit a member and re-scaffold.+--+-- The manifest's @spec@ lines are passed through the given function first, so a+-- caller can list the same members in a different order; the manifest __file+-- name__ stays the same, which is what makes two runs comparable byte for byte.+withWorkspaceFixture ::+  String ->+  ([FilePath] -> [FilePath]) ->+  (FilePath -> FilePath -> WorkspaceSpec -> IO a) ->+  IO a+withWorkspaceFixture template orderMembers act =+  withTempDirectory template $ \base -> do+    let root = base </> "workspace"+        out = base </> "out"+        members =+          [ "domain/project-artifact.keiro",+            "domain/project.keiro",+            "domain/shared.keiro"+          ]+    createDirectoryIfMissing True (root </> "domain")+    forM_ members $ \relative -> do+      source <- readTestText ("test/fixtures/workspace" </> relative)+      TIO.writeFile (root </> relative) source+    TIO.writeFile+      (root </> "service.keiro-workspace")+      ( T.unlines+          ( ["service demo-project", "module Demo.Modules.Project", "layout collocated"]+              <> ["spec " <> T.pack relative | relative <- orderMembers members]+          )+      )+    workspace <- loadTempWorkspace root+    act root out workspace++withSemanticLocalityFixture ::+  String ->+  ([FilePath] -> [FilePath]) ->+  Int ->+  (FilePath -> FilePath -> WorkspaceSpec -> IO a) ->+  IO a+withSemanticLocalityFixture template orderMembers unrelatedCount act =+  withTempDirectory template $ \base -> do+    let root = base </> "workspace"+        out = base </> "out"+        members = ["domain/alpha.keiro", "domain/beta.keiro"]+    forM_ members $ \relative -> do+      source <- readTestText ("test/fixtures/semantic-locality" </> relative)+      let withUnrelated+            | relative == "domain/beta.keiro" = source <> unrelatedAggregatesSource unrelatedCount+            | otherwise = source+      writeFileWithParents (root </> relative) withUnrelated+    TIO.writeFile+      (root </> "service.keiro-workspace")+      (T.unlines ("service semantic-locality" : ["spec " <> T.pack relative | relative <- orderMembers members]))+    workspace <- loadTempWorkspace root+    act root out workspace++unrelatedAggregatesSource :: Int -> T.Text+unrelatedAggregatesSource count =+  T.unlines+    ( concat+        [ [ "",+            "aggregate Unrelated" <> suffix,+            "  regs",+            "    marker Bool = False",+            "  states Ready Done!",+            "  command SubmitUnrelated" <> suffix <> " { accepted:Bool }",+            "  event Unrelated" <> suffix <> "Submitted = fields(SubmitUnrelated" <> suffix <> ")",+            "  Ready -- SubmitUnrelated" <> suffix <> " --> guard cmd.accepted ; write marker := true ; emit Unrelated" <> suffix <> "Submitted ; goto Done"+          ]+        | index <- [1 .. count],+          let suffix = T.pack (show index)+        ]+    )++-- | Materialize an inline workspace — a manifest plus literal member sources —+-- in a fresh temporary directory, and hand the callback its root, a sibling output+-- directory, and the composed workspace.+withInlineWorkspace ::+  String ->+  (T.Text, [(FilePath, T.Text)]) ->+  (FilePath -> FilePath -> WorkspaceSpec -> IO a) ->+  IO a+withInlineWorkspace template (service, members) act =+  withTempDirectory template $ \base -> do+    let root = base </> "workspace"+        out = base </> "out"+    forM_ members $ \(relative, source) -> writeFileWithParents (root </> relative) source+    TIO.writeFile+      (root </> "service.keiro-workspace")+      ( T.unlines+          (("service " <> service) : ["spec " <> T.pack relative | (relative, _) <- members])+      )+    workspace <- loadTempWorkspace root+    act root out workspace++-- | Two independently valid members under one context. Each is a complete spec+-- that the pre-workspace single-file scaffolder accepts, which is what lets a test+-- reproduce the overwritten-record defect before adopting.+adoptionMembers :: (T.Text, [(FilePath, T.Text)])+adoptionMembers = ("adoption-demo", [("domain/a.keiro", adoptionMemberA), ("domain/b.keiro", adoptionMemberB)])++adoptionMemberA :: T.Text+adoptionMemberA =+  T.unlines+    [ "context adoption-demo",+      "",+      "aggregate Counter",+      "  regs",+      "    count Int = 0",+      "    state CounterVertex = Pending",+      "  states Pending Done!",+      "  command Bump { count:Int }",+      "  event CountBumped { count:Int }",+      "  Pending -- Bump --> emit CountBumped ; goto Done"+    ]++adoptionMemberB :: T.Text+adoptionMemberB =+  T.unlines+    [ "context adoption-demo",+      "",+      "aggregate Widget",+      "  regs",+      "    size Int = 0",+      "    state WidgetVertex = Draft",+      "  states Draft Shipped!",+      "  command Ship { size:Int }",+      "  event WidgetShipped { size:Int }",+      "  Draft -- Ship --> emit WidgetShipped ; goto Shipped"+    ]++writeFileWithParents :: FilePath -> T.Text -> IO ()+writeFileWithParents path contents = do+  createDirectoryIfMissing True (takeDirectory path)+  TIO.writeFile path contents++-- | Only the Haskell sources of a tree snapshot, dropping bookkeeping files.+haskellOnly :: [(FilePath, T.Text)] -> [(FilePath, T.Text)]+haskellOnly entries = [entry | entry@(path, _) <- entries, ".hs" `T.isSuffixOf` T.pack path]++-- | Compose a workspace that a test just wrote to disk.+loadTempWorkspace :: FilePath -> IO WorkspaceSpec+loadTempWorkspace root = do+  let manifestPath = root </> "service.keiro-workspace"+  loaded <- loadWorkspace (fileContentSource root) manifestPath+  case loaded of+    Left failure ->+      expectationFailure (T.unpack (T.intercalate "\n" (renderWorkspaceFailure manifestPath failure)))+        >> error "unreachable"+    Right workspace -> pure workspace++-- | Plan an already-composed workspace, failing the test on a refusal.+shouldPlanWorkspaceSpec :: WorkspaceSpec -> IO WorkspacePlan+shouldPlanWorkspaceSpec workspace =+  case planWorkspaceScaffold "goldens" (workspaceContext workspace) workspace of+    Left refusals -> expectationFailure ("unexpected workspace plan refusal: " <> show refusals) >> error "unreachable"+    Right plan -> pure plan++-- | Plan then execute a whole-workspace scaffold, failing loudly on either.+executePlannedWorkspaceScaffold :: FilePath -> WorkspaceSpec -> IO WorkspaceScaffoldReport+executePlannedWorkspaceScaffold out workspace = do+  plan <- shouldPlanWorkspaceSpec workspace+  result <- executeWorkspaceScaffold out False plan+  case result of+    Left refusals -> expectationFailure ("unexpected workspace execution refusal: " <> show refusals) >> error "unreachable"+    Right report -> pure report++-- | Rename one member's aggregate in place and recompose. Only the+-- @aggregate \<Name\>@ header is rewritten, so declarations that merely share the+-- prefix (@ProjectId@, @ProjectSummary@) are untouched.+renameMemberAggregate :: FilePath -> FilePath -> T.Text -> T.Text -> IO WorkspaceSpec+renameMemberAggregate root member from to = do+  source <- TIO.readFile (root </> member)+  TIO.writeFile (root </> member) (T.replace ("aggregate " <> from <> "\n") ("aggregate " <> to <> "\n") source)+  loadTempWorkspace root++-- | Move the @ProjectArtifact@ aggregate from the artifact member into the+-- project member, and recompose.+--+-- It is prepended, so the merged spec's node order — and therefore every emitted+-- byte, including the replay-audit assembly's aggregate list — is exactly what it+-- was. That isolates the change to ownership, which is the point of the test.+moveArtifactAggregate :: FilePath -> IO WorkspaceSpec+moveArtifactAggregate root = do+  artifact <- TIO.readFile (root </> "domain/project-artifact.keiro")+  project <- TIO.readFile (root </> "domain/project.keiro")+  case T.breakOn "aggregate ProjectArtifact" artifact of+    (kept, moved) | not (T.null moved) -> do+      TIO.writeFile (root </> "domain/project-artifact.keiro") kept+      TIO.writeFile+        (root </> "domain/project.keiro")+        (T.replace "aggregate Project\n" (moved <> "\naggregate Project\n") project)+      loadTempWorkspace root+    _ -> expectationFailure "artifact member has no ProjectArtifact aggregate" >> error "unreachable"++-- | Every regular file under a directory, as @(relative path, contents)@ sorted+-- by path — the comparison unit for "byte-identical output".+treeSnapshot :: FilePath -> IO [(FilePath, T.Text)]+treeSnapshot root = do+  exists <- doesDirectoryExist root+  if not exists then pure [] else sort <$> walk ""+  where+    walk relative = do+      entries <- listDirectory (root </> relative)+      fmap concat . forM (sort entries) $ \entry -> do+        let child = if null relative then entry else relative </> entry+        isDirectory <- doesDirectoryExist (root </> child)+        if isDirectory+          then walk child+          else do+            contents <- TIO.readFile (root </> child)+            pure [(child, contents)]++copyTextTree :: FilePath -> FilePath -> IO ()+copyTextTree source destination =+  treeSnapshot source >>= mapM_ (\(relative, contents) -> writeFileWithParents (destination </> relative) contents)++thd3 :: (a, b, c) -> c+thd3 (_, _, value) = value++isPathCollision :: Refusal -> Bool+isPathCollision PathCollision {} = True+isPathCollision _ = False++isInfixOfString :: String -> String -> Bool+isInfixOfString needle haystack = T.isInfixOf (T.pack needle) (T.pack haystack)++-- | Load a workspace fixture expecting a compose refusal, and return it.+shouldRefuseWorkspace :: FilePath -> IO (NonEmpty WorkspaceDiagnostic)+shouldRefuseWorkspace path = do+  resolved <- resolveTestPath path+  loaded <- loadWorkspace (fileContentSource (takeDirectory resolved)) resolved+  case loaded of+    Left (WorkspaceRefused diagnostics) -> pure diagnostics+    Left other ->+      expectationFailure+        ("expected compose refusals, got:\n" <> T.unpack (T.intercalate "\n" (renderWorkspaceFailure resolved other)))+        >> error "unreachable"+    Right _ -> expectationFailure ("expected " <> path <> " to be refused") >> error "unreachable"++-- | Invoke the built @keiro-dsl@ executable. Fixture paths are resolved first,+-- so the test works whether it runs from the package directory or the repository+-- root.+runKeiroDsl :: [String] -> IO (ExitCode, String, String)+runKeiroDsl arguments = do+  resolved <- traverse resolveArgument arguments+  -- Cabal places build-tool dependencies on PATH for the test process. Invoke the+  -- exact packaged CLI directly so each example retains its process/stdio/exit-code+  -- boundary without paying for a fresh `cabal run` planning pass.+  readProcessWithExitCode "keiro-dsl" resolved ""+  where+    resolveArgument argument+      | "test/fixtures/" `isPrefixOfString` argument = resolveTestPath argument+      | otherwise = pure argument+    isPrefixOfString prefix value = take (length prefix) value == prefix++-- | The @spec@ field of a coverage report, i.e. what the report says it covers.+coverageSpecPath :: Value -> Maybe T.Text+coverageSpecPath value = case value of+  Aeson.Object fields -> case KeyMap.lookup "spec" fields of+    Just (Aeson.String path) -> Just path+    _ -> Nothing+  _ -> Nothing++decodeJsonValue :: FilePath -> IO Value+decodeJsonValue path = do+  decoded <- Aeson.eitherDecodeFileStrict path+  case decoded of+    Left err -> expectationFailure (path <> ": " <> err) >> fail "unreachable"+    Right value -> pure value++jsonField :: T.Text -> Value -> Maybe Value+jsonField name = \case+  Aeson.Object fields -> KeyMap.lookup (Key.fromText name) fields+  _ -> Nothing++-- | Order-preserving deduplication for comparing cited file sets.+nubOrd :: (Eq a) => [a] -> [a]+nubOrd = go []+  where+    go seen [] = reverse seen+    go seen (x : xs) = if x `elem` seen then go seen xs else go (x : seen) xs++-- | Parse a workspace manifest, failing the test on a refusal.+shouldParseManifest :: FilePath -> T.Text -> IO WorkspaceManifest+shouldParseManifest path source = case parseWorkspaceManifest path source of+  Left err -> expectationFailure (T.unpack err) >> error "unreachable"+  Right manifest -> pure manifest++-- | Generate a canonical workspace manifest. Members are drawn from a pool of+-- paths that are distinct even under case folding and are held sorted, which is+-- the invariant every parsed manifest satisfies.+genWorkspaceManifest :: Gen WorkspaceManifest+genWorkspaceManifest = do+  service <- elements ["demo-project", "mori", "kotei", "a1", "svc-2"]+  runtimePackage <- elements [Nothing, Just (RuntimePackageName "demo-core"), Just (RuntimePackageName "mori2")]+  moduleRoot <- elements [Nothing, Just "Demo", Just "Demo.Modules.Project"]+  layout <- elements [Nothing, Just GeneratedPrefix, Just CollocatedLeaf]+  chosen <-+    sublistOf+      [ "a.keiro",+        "d-e_f.keiro",+        "domain/b.keiro",+        "domain/sub/c.keiro",+        "x1.keiro"+      ]+      `suchThat` (not . null)+  pure+    WorkspaceManifest+      { wmfService = service,+        wmfServiceLoc = Loc 1,+        wmfRuntimePackage = runtimePackage,+        wmfRuntimePackageLoc = Loc 2,+        wmfModuleRoot = moduleRoot,+        wmfModuleRootLoc = Loc 2,+        wmfLayout = layout,+        wmfLayoutLoc = Loc 3,+        wmfMembers = NE.fromList [WorkspaceMemberRef path (Loc 4) | path <- sort chosen]+      }++-- | Parse a fixture while retaining its released language contract.+parsedSourceOf :: FilePath -> IO ParsedSource+parsedSourceOf path = do+  input <- readTestText path+  case parseSource path input of+    Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable"+    Right parsed -> pure parsed++checkedServiceOf :: FilePath -> IO CheckedService+checkedServiceOf = fmap checkedSource . parsedSourceOf++renderFoldBaseline :: T.Text -> CheckedService -> T.Text+renderFoldBaseline fixture service =+  T.intercalate+    "\n\n"+    [ T.unlines+        ( [ "fixture=" <> fixture,+            "aggregate=" <> aggName aggregate,+            "fingerprint=" <> aggregateFoldFingerprintForService service aggregate,+            "surface-begin"+          ]+            <> T.lines (aggregateFoldSurfaceForService service aggregate)+            <> ["surface-end"]+        )+    | NAggregate aggregate <- specNodes (checkedSpec service)+    ]++-- | Parse a fixture through the source-aware boundary and return its graph.+specOf :: FilePath -> IO Spec+specOf = fmap checkedSpec . checkedServiceOf++-- | Parse one fixture through the exact source-aware boundary and adapt it to+-- one-member workspace semantics without falling back to line-only provenance.+exactOneMemberWorkspaceOf :: FilePath -> IO (WorkspaceSpec, ParsedSourceDocument)+exactOneMemberWorkspaceOf path = do+  source <- readTestText path+  document <- case parseSourceDocument path source of+    Left failure -> expectationFailure (show failure) >> fail "unreachable"+    Right value -> pure value+  workspace <-+    either+      (\failure -> expectationFailure (show failure) >> fail "unreachable")+      pure+      (oneMemberParsedDocumentWorkspace path document)+  pure (workspace, document)++-- | Parse a fixture and scaffold its checked semantic service.+scaffoldFixture :: FilePath -> IO [ScaffoldModule]+scaffoldFixture path = do+  service <- checkedServiceOf path+  pure (scaffoldServiceModules (defaultContext (specContext (checkedSpec service))) service)++legacyScaffoldProcessFixture :: FilePath -> IO [ScaffoldModule]+legacyScaffoldProcessFixture path = do+  spec <- specOf path+  pure $ concat [scaffoldProcess (ctx spec) process | NProcess process <- specNodes spec]+  where+    ctx spec = defaultContext (specContext spec)++-- | Assert a freshly-scaffolded Generated module matches its committed copy+-- under test/conformance/ (whitespace-normalized). The committed copies are the+-- ones the keiro-dsl-conformance suite compiles, so this pins the live scaffolder+-- to known-compiling output.+assertMatchesCommitted :: ScaffoldModule -> IO ()+assertMatchesCommitted m = do+  let committedPath = "test/conformance/" <> modulePath m+  committed <- readTestText committedPath+  normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m)++normalizeGenerated :: T.Text -> (T.Text, [T.Text])+normalizeGenerated text =+  let (orderInsensitiveLines, body) = partition isOrderInsensitive (T.lines text)+   in (normalizeBody body, sort (map normalizeImport orderInsensitiveLines))+  where+    -- Compare the deterministic body exactly as before and imports/language+    -- pragmas as a sorted, whitespace-normalized list. Sorting tolerates+    -- formatter reordering while additions, removals, and renamed entries still+    -- fail the pin.+    isOrderInsensitive line = isImport line || "{-# LANGUAGE " `T.isPrefixOf` line+    normalizeBody =+      -- Fourmolu parenthesizes a single class constraint while the emitter's+      -- compact spelling remains valid Haskell.  Treat that formatter-only+      -- rewrite like the whitespace and comma placement normalized below.+      T.replace "(Show value) =>" "Show value =>"+        . T.replace "( " "("+        . T.replace " )" ")"+        . T.replace " , )" " )"+        . T.unwords+        . T.words+        . T.replace "}" " } "+        . T.replace "{" " { "+        . T.replace "]" " ] "+        . T.replace "[" " [ "+        . T.replace "," " , "+        . T.unlines+        . map normalizeBanner+    normalizeBanner line+      | isGeneratedBannerLine line = generatedBanner+      | otherwise = line+    normalizeImport line =+      let reordered = case T.words line of+            "import" : "qualified" : moduleName : rest -> T.unwords ("import" : moduleName : "qualified" : rest)+            wordsInImport -> T.unwords wordsInImport+          (prefix, explicit) = T.breakOn " (" reordered+       in if T.null explicit+            then prefix+            else+              let members =+                    sort+                      . map (T.replace " (" "(" . T.unwords . T.words)+                      . T.splitOn ","+                      . T.dropEnd 1+                      $ T.drop 2 explicit+               in prefix <> " (" <> T.intercalate "," members <> ")"+    isImport line = case T.words line of+      "import" : _ -> True+      _ -> False++-- | Locate and read a test fixture or committed conformance source regardless+-- of whether the suite was launched from the package directory or repo root.+readTestText :: FilePath -> IO T.Text+readTestText path = resolveTestPath path >>= TIO.readFile++assertMatchesGolden :: FilePath -> T.Text -> IO ()+assertMatchesGolden path actual = do+  resolved <- resolveTestPath path+  update <- lookupEnv "KEIRO_DSL_UPDATE_GOLDENS"+  if update == Just "1"+    then TIO.writeFile resolved (T.stripEnd actual <> "\n")+    else do+      golden <- TIO.readFile resolved+      T.stripEnd actual `shouldBe` T.stripEnd golden++-- | Locate a repo file regardless of the test process's current directory.+resolveTestPath :: FilePath -> IO FilePath+resolveTestPath rel = do+  override <- lookupEnv "KEIRO_DSL_TEST_ROOT"+  let candidates = [rel, "keiro-dsl" </> rel] <> maybe [] (\root -> [root </> rel]) override+  existing <- filterM doesFileExist candidates+  case existing of+    path : _ -> pure path+    [] ->+      fail $+        "unable to locate keiro-dsl test file "+          <> show rel+          <> "; tried "+          <> show candidates++leftContains :: T.Text -> Either T.Text a -> Bool+leftContains needle = \case+  Left err -> needle `T.isInfixOf` err+  Right _ -> False++mappedConsumerSurfaceSource :: IO T.Text+mappedConsumerSurfaceSource = do+  base <- readTestText "test/fixtures/consumer-types.keiro"+  pure $+    T.replace "language keiro-dsl 4" "language keiro-dsl 5" base+      <> T.unlines+        [ "",+          "workqueue ArtifactJobs {",+          "  queue logical = \"artifact-jobs\"",+          "  derive physical = \"artifact-jobs\"",+          "    dlq = \"artifact-jobs_dlq\"",+          "    table = \"q_artifact-jobs\"",+          "  payload ArtifactJob {",+          "    jobData -> \"payload\" : List (Optional ArtifactInfo)",+          "  }",+          "  retry maxRetries = 3 delay = 1s dlq = on",+          "  disposition {",+          "    storeFailure -> retry 1s",+          "    commandRejected -> ackOk",+          "    decodeFailure -> deadLetter",+          "    onCodecReject -> deadLetter",+          "  }",+          "}",+          "",+          "readmodel ArtifactLookup {",+          "  table = \"artifact_lookup\"",+          "  schema = \"public\"",+          "  columns {}",+          "  query input = ArtifactInfo",+          "  query result = Optional ArtifactLocation",+          "  version = 1",+          "  shape = \"fixture\"",+          "  freshness = immediate",+          "}"+        ]++changeProjectionMappedWire :: MappedDecl -> MappedDecl+changeProjectionMappedWire declaration@MappedOpaque {moCodecVersion = version} =+  declaration {moCodecVersion = fmap (<> "-changed") version}+changeProjectionMappedWire declaration@MappedStructural {msShape = ShapeUnion encoding arms} =+  declaration+    { msShape =+        ShapeUnion+          encoding+          ( case arms of+              [] -> []+              arm : remaining -> arm {waTag = waTag arm <> "-changed"} : remaining+          )+    }+changeProjectionMappedWire declaration = declaration++projectionEventWithoutGeometry :: Spec -> Spec+projectionEventWithoutGeometry candidate =+  candidate {specNodes = map stripGeometry (specNodes candidate)}+  where+    stripGeometry (NAggregate aggregate) =+      let artifactFields =+            [ field+            | command <- aggCommands aggregate,+              cmdName command == "ObserveArtifact",+              field <- cmdFields command,+              aggregateFieldName field == "artifact"+            ]+       in NAggregate+            aggregate+              { aggRegs = filter ((/= "currentGeometry") . regName) (aggRegs aggregate),+                aggEvents = map (explicitArtifactEvent artifactFields) (aggEvents aggregate),+                aggTransitions = map stripGeometryWrite (aggTransitions aggregate)+              }+    stripGeometry node = node+    explicitArtifactEvent artifactFields event@Event {evBody = EventFromCommand commandName}+      | commandName == "ObserveArtifact" =+          event {evBody = EventFields artifactFields}+    explicitArtifactEvent _ event = event+    stripGeometryWrite transition = transition {tWrites = filter ((/= "currentGeometry") . fst) (tWrites transition)}++parseInlineSpec :: FilePath -> T.Text -> IO Spec+parseInlineSpec sourceName src = case parseSpec sourceName src of+  Left err -> expectationFailure (T.unpack err) >> error "unreachable"+  Right spec -> pure spec++checkedServiceFromText :: FilePath -> T.Text -> IO CheckedService+checkedServiceFromText sourceName src = case parseSource sourceName src of+  Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> error "unreachable"+  Right parsed -> pure (checkedSource parsed)++parseStableRenderedSpec :: FilePath -> Spec -> Either T.Text Spec+parseStableRenderedSpec sourceName spec =+  case parseSource sourceName stableSource of+    Left failure -> Left (renderParseFailure failure)+    Right parsed -> Right (parsedSpec parsed)+  where+    stableSource =+      "language keiro-dsl "+        <> T.pack (show (languageVersionNumber currentStableLanguageVersion))+        <> "\n"+        <> renderSpec spec++parseLanguage4RenderedSpec :: FilePath -> Spec -> Either T.Text Spec+parseLanguage4RenderedSpec sourceName spec =+  case parseSource sourceName language4Source of+    Left failure -> Left (renderParseFailure failure)+    Right parsed -> Right (parsedSpec parsed)+  where+    language4Source = "language keiro-dsl 4\n" <> renderSpec spec++shouldParseStableRenderedSpec :: FilePath -> Spec -> IO Spec+shouldParseStableRenderedSpec sourceName spec =+  case parseStableRenderedSpec sourceName spec of+    Left failure -> expectationFailure (T.unpack failure) >> fail "unreachable"+    Right reparsed -> pure reparsed++shouldResolveTypeGraph :: Spec -> IO TypeGraph+shouldResolveTypeGraph spec = case resolveTypeGraph spec of+  Left errors -> expectationFailure ("type graph failed: " <> show errors) >> error "unreachable"+  Right graph -> pure graph++shouldResolveCoverage :: FilePath -> Spec -> IO Coverage.CoverageReport+shouldResolveCoverage path spec = case Coverage.coverageReport path spec of+  Left errors -> expectationFailure ("coverage graph failed: " <> show errors) >> error "unreachable"+  Right report -> pure report++withoutVendorGeometry :: Spec -> Spec+withoutVendorGeometry spec =+  spec+    { specMapped = filter (not . isVendorGeometry) (specMapped spec),+      specNodes = map stripNode (specNodes spec)+    }+  where+    isVendorGeometry MappedOpaque {moName = "VendorGeometry"} = True+    isVendorGeometry _ = False+    stripNode (NAggregate aggregate) =+      NAggregate+        aggregate+          { aggRegs = filter ((/= TRef "VendorGeometry") . regType) (aggRegs aggregate),+            aggCommands = map stripCommand (aggCommands aggregate),+            aggEvents = map stripEvent (aggEvents aggregate)+          }+    stripNode node = node+    stripCommand command = command {cmdFields = filter ((/= Just (TRef "VendorGeometry")) . aggregateFieldType) (cmdFields command)}+    stripEvent event = event {evBody = case evBody event of EventFields fields -> EventFields (filter ((/= Just (TRef "VendorGeometry")) . aggregateFieldType) fields); body -> body}++withMetadataJson :: Spec -> Spec+withMetadataJson spec = spec {specMapped = map updateDeclaration (specMapped spec)}+  where+    updateDeclaration declaration@MappedStructural {msName = "ArtifactMetadata", msShape = ShapeRecord constructor unknownFields fields} =+      declaration+        { msShape =+            ShapeRecord+              constructor+              unknownFields+              [if wfHaskell field == "note" then field {wfType = TJson} else field | field <- fields]+        }+    updateDeclaration declaration = declaration++expressionTags :: TypeExprAlgebra [T.Text]+expressionTags =+  TypeExprAlgebra+    { onText = ["text"],+      onInt = ["int"],+      onInteger = ["integer"],+      onBool = ["bool"],+      onNatural = ["natural"],+      onTime = ["time"],+      onJson = ["json"],+      onOptional = ("optional" :),+      onList = ("list" :),+      onMap = ("map" :),+      onRef = \key -> ["ref:" <> unMappedKey key]+    }++hasTypeGraphError :: (TypeGraphError -> Bool) -> Either (NonEmpty TypeGraphError) TypeGraph -> Bool+hasTypeGraphError predicate = \case+  Left errors -> any predicate errors+  Right _ -> False++isRecursive :: TypeGraphError -> Bool+isRecursive TGRecursive {} = True+isRecursive _ = False++isUnresolved :: TypeGraphError -> Bool+isUnresolved TGUnresolvedRef {} = True+isUnresolved _ = False++mappedSpec :: [MappedDecl] -> Spec+mappedSpec declarations = Spec "mapped-test" Nothing Nothing [] [] [] [] declarations []++completeStructural :: Name -> MappedShape -> MappedDecl+completeStructural name shape =+  MappedStructural+    { msName = name,+      msHaskell = Just (HaskellSource "mapped-test" "Example.Mapped" name),+      msBinding = Just ("Example.Mapped." <> T.toLower name <> "Binding"),+      msBindingVersion = Just "1",+      msCanonical = Just ("example.mapped." <> name),+      msFixtures = Just ("Example.Mapped." <> T.toLower name <> "Cases"),+      msInitial = Nothing,+      msShape = shape,+      msLoc = noLoc+    }++recordShape :: [TypeExpr] -> MappedShape+recordShape types =+  ShapeRecord+    "MappedRecord"+    RejectUnknown+    [ WireField+        { wfHaskell = "field" <> T.pack (show index),+          wfKey = "field" <> T.pack (show index),+          wfType = fieldType,+          wfPresence = PRequired,+          wfOnMissing = Nothing,+          wfLoc = noLoc+        }+    | (index, fieldType) <- zip [(1 :: Int) ..] types+    ]++mapArtifactField :: (WireField -> WireField) -> Spec -> Spec+mapArtifactField = mapArtifactNamedField "key"++mapArtifactNamedField :: Name -> (WireField -> WireField) -> Spec -> Spec+mapArtifactNamedField target transform spec = spec {specMapped = map updateDeclaration (specMapped spec)}+  where+    updateDeclaration declaration@MappedStructural {msName = "ArtifactInfo", msShape = ShapeRecord constructor unknownFields fields} =+      declaration+        { msShape =+            ShapeRecord+              constructor+              unknownFields+              [if wfHaskell field == target then transform field else field | field <- fields]+        }+    updateDeclaration declaration = declaration++mapMappedStructural :: Name -> (MappedDecl -> MappedDecl) -> Spec -> Spec+mapMappedStructural target transform spec =+  spec+    { specMapped =+        [ case declaration of+            MappedStructural {msName = name}+              | name == target -> transform declaration+            _ -> declaration+        | declaration <- specMapped spec+        ]+    }++renameRecordConstructor :: MappedShape -> MappedShape+renameRecordConstructor (ShapeRecord _ unknownFields fields) = ShapeRecord "ArtifactInfoV2" unknownFields fields+renameRecordConstructor shape = shape++renameMappedRecordConstructor :: MappedDecl -> MappedDecl+renameMappedRecordConstructor declaration@MappedStructural {msShape = shape} =+  declaration {msShape = renameRecordConstructor shape}+renameMappedRecordConstructor declaration = declaration++changeMappedCanonical :: MappedDecl -> MappedDecl+changeMappedCanonical declaration@MappedStructural {} =+  declaration {msCanonical = Just "example.artifact.ArtifactInfo.v2"}+changeMappedCanonical declaration = declaration++data MappedMutation = MappedMutation+  { mmCandidate :: !Spec,+    mmCode :: !DiagnosticCode,+    mmExpectedSubjects :: !(Set.Set T.Text)+  }+  deriving stock (Show)++mappedWireMutations :: Spec -> [MappedMutation]+mappedWireMutations spec = case resolveTypeGraph spec of+  Left _ -> []+  Right graph -> concatMap (uncurry (declarationMutations graph)) (zip [0 :: Int ..] (specMapped spec))+  where+    declarationMutations graph declarationIndex declaration = case declaration of+      MappedStructural {msName = declarationName, msShape = shape} -> case shape of+        ShapeRecord _ _ fields ->+          concat+            [ [ mutation+                  graph+                  declarationName+                  MappedWireKeyChanged+                  (fieldSubject field {wfKey = wfKey field <> "__mutated"})+                  (mutateRecordField declarationIndex fieldIndex (\value -> value {wfKey = wfKey value <> "__mutated"}) spec),+                mutation+                  graph+                  declarationName+                  MappedPresenceChanged+                  (fieldSubject field)+                  (mutateRecordField declarationIndex fieldIndex (\value -> value {wfPresence = flipPresence (wfPresence value)}) spec)+              ]+                <> [ mutation+                       graph+                       declarationName+                       defaultCode+                       (fieldSubject field)+                       (mutateRecordField declarationIndex fieldIndex (\value -> value {wfOnMissing = changedDefault}) spec)+                   | oldDefault <- maybeToListTest (wfOnMissing field),+                     let (changedDefault, defaultCode) = mutateDefault oldDefault+                   ]+            | (fieldIndex, field) <- zip [0 :: Int ..] fields+            ]+        ShapeEnum entries ->+          [ mutation+              graph+              declarationName+              MappedEnumSpellingChanged+              (enumSubject entry {weTag = weTag entry <> "__mutated"})+              (mutateEnumEntry declarationIndex entryIndex (\value -> value {weTag = weTag value <> "__mutated"}) spec)+          | (entryIndex, entry) <- zip [0 :: Int ..] entries+          ]+        ShapeUnion _ arms ->+          [ mutation+              graph+              declarationName+              MappedArmTagChanged+              (armSubject arm {waTag = waTag arm <> "__mutated"})+              (mutateUnionArm declarationIndex armIndex (\value -> value {waTag = waTag value <> "__mutated"}) spec)+          | (armIndex, arm) <- zip [0 :: Int ..] arms+          ]+      MappedOpaque {moName = declarationName, moCodecVersion = version} ->+        [ mutation+            graph+            declarationName+            MappedOpaqueCodecChanged+            "codec"+            ( updateMappedAt+                declarationIndex+                ( \case+                    value@MappedOpaque {} -> value {moCodecVersion = fmap (<> "__mutated") version}+                    value -> value+                )+                spec+            )+        ]++    mutation graph declarationName diagnosticCode leaf candidate =+      MappedMutation+        { mmCandidate = candidate,+          mmCode = diagnosticCode,+          mmExpectedSubjects =+            Set.fromList+              [ renderUsePath path <> " " <> leaf+              | path <- usePaths graph declarationName+              ]+        }++fieldSubject :: WireField -> T.Text+fieldSubject field = ".field " <> wfHaskell field <> "[\"" <> wfKey field <> "\"]"++enumSubject :: WireEnum -> T.Text+enumSubject entry = ".enum " <> weCtor entry <> "[\"" <> weTag entry <> "\"]"++armSubject :: WireArm -> T.Text+armSubject arm = ".arm " <> waCtor arm <> "[\"" <> waTag arm <> "\"]"++flipPresence :: Presence -> Presence+flipPresence PRequired = POptional+flipPresence POptional = PRequired++mutateDefault :: OnMissing -> (Maybe OnMissing, DiagnosticCode)+mutateDefault = \case+  OmNull -> (Nothing, MappedDefaultRemoved)+  OmText value -> (Just (OmText (value <> "__mutated")), MappedDefaultChanged)+  OmInt value -> (Just (OmInt (value + 1)), MappedDefaultChanged)+  OmBool value -> (Just (OmBool (not value)), MappedDefaultChanged)+  OmEmptyList -> (Nothing, MappedDefaultRemoved)+  OmEmptyMap -> (Nothing, MappedDefaultRemoved)+  OmCtor constructor -> (Just (OmCtor (constructor <> "Mutated")), MappedDefaultChanged)++mutateRecordField :: Int -> Int -> (WireField -> WireField) -> Spec -> Spec+mutateRecordField declarationIndex fieldIndex transform =+  updateMappedAt declarationIndex $ \case+    declaration@MappedStructural {msShape = ShapeRecord constructor unknownFields fields} ->+      declaration {msShape = ShapeRecord constructor unknownFields (updateAt fieldIndex transform fields)}+    declaration -> declaration++mutateEnumEntry :: Int -> Int -> (WireEnum -> WireEnum) -> Spec -> Spec+mutateEnumEntry declarationIndex entryIndex transform =+  updateMappedAt declarationIndex $ \case+    declaration@MappedStructural {msShape = ShapeEnum entries} ->+      declaration {msShape = ShapeEnum (updateAt entryIndex transform entries)}+    declaration -> declaration++mutateUnionArm :: Int -> Int -> (WireArm -> WireArm) -> Spec -> Spec+mutateUnionArm declarationIndex armIndex transform =+  updateMappedAt declarationIndex $ \case+    declaration@MappedStructural {msShape = ShapeUnion encoding arms} ->+      declaration {msShape = ShapeUnion encoding (updateAt armIndex transform arms)}+    declaration -> declaration++updateMappedAt :: Int -> (MappedDecl -> MappedDecl) -> Spec -> Spec+updateMappedAt declarationIndex transform spec =+  spec {specMapped = updateAt declarationIndex transform (specMapped spec)}++updateAt :: Int -> (a -> a) -> [a] -> [a]+updateAt target transform values =+  [if index == target then transform value else value | (index, value) <- zip [0 :: Int ..] values]++maybeToListTest :: Maybe a -> [a]+maybeToListTest = maybe [] pure++isAdditiveChange :: Change -> Bool+isAdditiveChange Additive {} = True+isAdditiveChange Advisory {} = False+isAdditiveChange Breaking {} = False++mappedIngredientMutations :: Spec -> [(Spec, DiagnosticCode)]+mappedIngredientMutations spec =+  [ (mapMappedStructural "ArtifactInfo" clearStructuralHaskell spec, MappedMissingIngredient),+    (mapMappedStructural "ArtifactInfo" clearStructuralBinding spec, MappedMissingIngredient),+    (mapMappedStructural "ArtifactInfo" clearStructuralBindingVersion spec, MappedMissingIngredient),+    (mapMappedStructural "ArtifactInfo" clearStructuralCanonical spec, MappedMissingIngredient),+    (mapMappedStructural "ArtifactInfo" clearStructuralFixtures spec, MappedMissingIngredient),+    (mapMappedStructural "ArtifactInfo" clearStructuralInitial spec, MappedMissingInitialValue),+    (mapMappedDeclaration "VendorGeometry" clearOpaqueHaskell spec, MappedMissingIngredient),+    (mapMappedDeclaration "VendorGeometry" clearOpaqueCodec spec, MappedMissingIngredient),+    (mapMappedDeclaration "VendorGeometry" clearOpaqueCodecVersion spec, MappedMissingIngredient),+    (mapMappedDeclaration "VendorGeometry" clearOpaqueFixtures spec, MappedMissingIngredient)+  ]+  where+    clearStructuralHaskell declaration@MappedStructural {} = declaration {msHaskell = Nothing}+    clearStructuralHaskell declaration = declaration+    clearStructuralBinding declaration@MappedStructural {} = declaration {msBinding = Nothing}+    clearStructuralBinding declaration = declaration+    clearStructuralBindingVersion declaration@MappedStructural {} = declaration {msBindingVersion = Nothing}+    clearStructuralBindingVersion declaration = declaration+    clearStructuralCanonical declaration@MappedStructural {} = declaration {msCanonical = Nothing}+    clearStructuralCanonical declaration = declaration+    clearStructuralFixtures declaration@MappedStructural {} = declaration {msFixtures = Nothing}+    clearStructuralFixtures declaration = declaration+    clearStructuralInitial declaration@MappedStructural {} = declaration {msInitial = Nothing}+    clearStructuralInitial declaration = declaration+    clearOpaqueHaskell declaration@MappedOpaque {} = declaration {moHaskell = Nothing}+    clearOpaqueHaskell declaration = declaration+    clearOpaqueCodec declaration@MappedOpaque {} = declaration {moCodecId = Nothing}+    clearOpaqueCodec declaration = declaration+    clearOpaqueCodecVersion declaration@MappedOpaque {} = declaration {moCodecVersion = Nothing}+    clearOpaqueCodecVersion declaration = declaration+    clearOpaqueFixtures declaration@MappedOpaque {} = declaration {moFixtures = Nothing}+    clearOpaqueFixtures declaration = declaration++mapMappedDeclaration :: Name -> (MappedDecl -> MappedDecl) -> Spec -> Spec+mapMappedDeclaration target transform spec =+  spec+    { specMapped =+        [ if mappedDeclarationName declaration == target then transform declaration else declaration+        | declaration <- specMapped spec+        ]+    }++mappedDeclarationName :: MappedDecl -> Name+mappedDeclarationName MappedStructural {msName = name} = name+mappedDeclarationName MappedOpaque {moName = name} = name++statusMapSpec :: T.Text -> T.Text+statusMapSpec marker =+  T.unlines+    [ "context svc",+      "",+      "aggregate Thing",+      "  regs",+      "  states Open",+      "",+      "  event Created { }",+      "  event Changed { }",+      "",+      "  projection things consistency=Eventual key=thingId",+      "    status-map" <> marker <> " { Created=>held }"+    ]++parseErrorOf :: FilePath -> T.Text -> IO T.Text+parseErrorOf sourceName src = case parseSpec sourceName src of+  Left err -> pure err+  Right _ -> expectationFailure ("expected parse failure for " <> sourceName) >> error "unreachable"++duplicateGotoSpec :: T.Text+duplicateGotoSpec =+  T.unlines+    [ "context svc",+      "",+      "aggregate Thing",+      "  regs",+      "  states A B C",+      "",+      "  command Go { }",+      "  A -- Go -->",+      "    goto B",+      "    goto C"+    ]++missingGotoSpec :: T.Text+missingGotoSpec =+  T.unlines+    [ "context svc",+      "",+      "aggregate Thing",+      "  regs",+      "  states A B",+      "",+      "  command Go { }",+      "  A -- Go -->",+      "    emit Changed"+    ]++duplicateWireSpec :: T.Text+duplicateWireSpec =+  T.unlines+    [ "context svc",+      "",+      "aggregate Thing",+      "  regs",+      "  states Open",+      "",+      "  wire kind=ctorName fields=camelCase schemaVersion=1",+      "  wire kind=typeName fields=snakeCase schemaVersion=2"+    ]++duplicateProjectionSpec :: T.Text+duplicateProjectionSpec =+  T.unlines+    [ "context svc",+      "",+      "aggregate Thing",+      "  regs",+      "  states Open",+      "",+      "  projection first consistency=Strong key=thingId",+      "    status-map partial { }",+      "  projection second consistency=Eventual key=thingId"+    ]++projectionWithoutConsistencySpec :: T.Text+projectionWithoutConsistencySpec =+  T.unlines+    [ "context svc",+      "",+      "aggregate Thing",+      "  regs",+      "  states Open",+      "",+      "  projection things key=thingId"+    ]++malformedRegisterSpec :: T.Text+malformedRegisterSpec =+  T.unlines+    [ "context svc",+      "",+      "aggregate Thing",+      "  regs",+      "    status Status",+      "  states Open"+    ]++misplacedDispatchIdSpec :: T.Text+misplacedDispatchIdSpec =+  T.replace+    "    schedule timer\n\n  dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)\n"+    "    dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)\n    schedule timer\n"+    (renderSpec (Spec "svc" Nothing Nothing [] [] [] [] [] [NProcess (processWithLiteral "literal")]))++lineNumberContaining :: T.Text -> T.Text -> Int+lineNumberContaining needle = go 1 . T.lines+  where+    go current = \case+      [] -> current+      lineText : rest+        | needle `T.isInfixOf` lineText -> current+        | otherwise -> go (current + 1) rest++decimalOverflow :: T.Text+decimalOverflow = "18446744073709551617"++decimalOverflowSpecs :: [(String, T.Text)]+decimalOverflowSpecs =+  [ ("event-version", eventVersionDecimalSpec decimalOverflow),+    ("wire-schema", wireDecimalSpec decimalOverflow),+    ("contract-schema", contractDecimalSpec decimalOverflow),+    ("decode-schema", decodeDecimalSpec decimalOverflow),+    ("publisher-attempts", publisherDecimalSpec decimalOverflow),+    ("workqueue-retries", workqueueDecimalSpec decimalOverflow),+    ("timer-attempts", timerDecimalSpec decimalOverflow)+  ]++eventVersionDecimalSpec :: T.Text -> T.Text+eventVersionDecimalSpec value =+  T.unlines+    [ "context svc",+      "",+      "aggregate Thing",+      "  regs",+      "  states Open",+      "",+      "  event Changed v" <> value <> " { }"+    ]++wireDecimalSpec :: T.Text -> T.Text+wireDecimalSpec value =+  T.unlines+    [ "context svc",+      "",+      "aggregate Thing",+      "  regs",+      "  states Open",+      "",+      "  wire kind=ctorName fields=camelCase schemaVersion=" <> value+    ]++contractDecimalSpec :: T.Text -> T.Text+contractDecimalSpec value =+  T.unlines+    [ "context svc",+      "",+      "contract Contract {",+      "  schemaVersion " <> value,+      "  discriminator kind",+      "}"+    ]++decodeDecimalSpec :: T.Text -> T.Text+decodeDecimalSpec value =+  T.unlines+    [ "context svc",+      "",+      "intake Inbox {",+      "  contract Contract",+      "  topic events",+      "  accept Event",+      "  dedupe key messageId policy PreferIntegrationMessageId",+      "  decode { envelope strict-required lenient-optional body strict schemaVersion == " <> value <> " }",+      "  disposition { }",+      "}"+    ]++publisherDecimalSpec :: T.Text -> T.Text+publisherDecimalSpec value =+  T.unlines+    [ "context svc",+      "",+      "publisher Publisher {",+      "  emit Emit",+      "  ordering PerKeyHeadOfLine",+      "  maxAttempts " <> value,+      "  backoff constant 2s",+      "  outboxId stable from messageId",+      "}"+    ]++workqueueDecimalSpec :: T.Text -> T.Text+workqueueDecimalSpec value =+  T.unlines+    [ "context svc",+      "",+      "workqueue Queue {",+      "  queue logical = \"queue\"",+      "  derive physical = \"queue\"",+      "    dlq = \"queue_dlq\"",+      "    table = \"pgmq.q_queue\"",+      "  payload Job { }",+      "  retry maxRetries = " <> value <> " delay = 5s dlq = on",+      "  disposition { }",+      "}"+    ]++timerDecimalSpec :: T.Text -> T.Text+timerDecimalSpec value =+  T.replace+    "max-attempts 5"+    ("max-attempts " <> value)+    (renderSpec (Spec "svc" Nothing Nothing [] [] [] [] [] [NProcess (processWithLiteral "literal")]))++identifierHygieneSpec :: T.Text+identifierHygieneSpec =+  T.unlines+    [ "context svc",+      "",+      "aggregate thing",+      "  regs",+      "  states Open",+      "",+      "  command DoIt { data }"+    ]++vertexCollisionSpec :: T.Text+vertexCollisionSpec =+  T.unlines+    [ "context svc",+      "",+      "aggregate Reservation",+      "  regs",+      "  states Created",+      "",+      "  event ReservationCreated { }"+    ]++underscoreNodeSpec :: T.Text+underscoreNodeSpec =+  T.unlines+    [ "context svc",+      "",+      "contract _contract {",+      "  schemaVersion 1",+      "  discriminator kind",+      "}"+    ]++normalizedCollisionSpec :: T.Text+normalizedCollisionSpec =+  T.unlines+    [ "context svc",+      "",+      "contract fooBar {",+      "  schemaVersion 1",+      "  discriminator kind",+      "}",+      "",+      "contract foo_bar {",+      "  schemaVersion 1",+      "  discriminator kind",+      "}"+    ]++unicodeIdentifierSpec :: T.Text+unicodeIdentifierSpec =+  T.unlines+    [ "context svc",+      "",+      "aggregate Résumé",+      "  regs",+      "  states Open"+    ]++emptyStatesSpec :: Spec+emptyStatesSpec =+  Spec+    "svc"+    Nothing+    Nothing+    []+    []+    []+    []+    []+    [NAggregate (Aggregate "Thing" [] [] [] [] [] Nothing [] Nothing Nothing Nothing noLoc)]++crossFamilyBoundarySpec :: T.Text+crossFamilyBoundarySpec =+  T.unlines+    [ "context svc",+      "",+      "aggregate First",+      "  regs",+      "  states A B",+      "  command Go { }",+      "  A -- Go -->",+      "    emit Changed",+      "    goto B",+      "",+      "emit Output {",+      "  contract Contract",+      "  topic events",+      "  source \"source\"",+      "  key thingId",+      "  map status { _ => skip }",+      "  messageId derive hole",+      "  idempotencyKey derive hole",+      "}",+      "",+      "aggregate Second",+      "  regs",+      "  states",+      "",+      "dispatch QueueDispatch {",+      "  source readModel = source key = thingId",+      "  fanout body = resolveFanout",+      "  dedup key = thingId",+      "    seenIn readModel = seen field = thingId",+      "    seenIn queue = workQueue field = thingId",+      "  enqueue to = workQueue",+      "}"+    ]++--------------------------------------------------------------------------------+-- Generators (bounded; restricted to valid, non-reserved identifiers)+--------------------------------------------------------------------------------++-- | Text that exercises every supported escape plus notation punctuation that+-- used to be able to split one emit-map row into several rows.+genAdversarialText :: Gen T.Text+genAdversarialText =+  T.concat+    <$> resize+      20+      (listOf (elements ["a", "Z", "\"", "\\", "\n", "\t", "\r", "=>", "#", "{", "}", " "]))++-- | One spec carrying the same adversarial value through three distinct+-- printer paths: a contract topic, an emit-map value, and a quote-wrapped+-- field-binding literal.+escapedSpec :: T.Text -> Spec+escapedSpec value =+  Spec+    "escape"+    Nothing+    Nothing+    []+    []+    []+    []+    []+    [ NContract+        ContractNode+          { ctrName = "Contract",+            ctrSchemaVersion = 1,+            ctrDiscriminator = "kind",+            ctrTopics = [("events", value)],+            ctrEvents = [],+            ctrLoc = noLoc+          },+      NEmit+        EmitNode+          { emName = "Emit",+            emContract = "Contract",+            emTopic = "events",+            emSource = "source",+            emKey = "key",+            emDiscriminant = "status",+            emMap = [EmitMapRow value "Event" noLoc],+            emSkip = True,+            emMessageId = DeriveSpec Nothing,+            emIdempotencyKey = DeriveSpec Nothing,+            emLoc = noLoc+          },+      NProcess (processWithLiteral value)+    ]++processWithLiteral :: T.Text -> ProcessNode+processWithLiteral value =+  ProcessNode+    { procId = "Process",+      procName = "process",+      procInput = InputDecl "Input" [] Nothing noLoc,+      procCorrelate = CorrelateDecl "key" "idText",+      procSaga = SagaRef "Saga" "saga",+      procTarget = "Target",+      procProjections = [],+      procHandle =+        HandleNode+          { hOn = "Input",+            hAdvance = AdvanceNode "Advance" [FieldBinding "literal" (Just ("\"" <> value <> "\""))],+            hDispatch = [],+            hSchedule = "timer"+          },+      procRejected = PolHalt,+      procPoison = PolHalt,+      procTimer =+        TimerNode+          { tmName = "timer",+            tmId = IdExpr UuidV5Id "timer:" "correlationId",+            tmFireAt = FireAtExpr "observedAt" "5m",+            tmPayload = [],+            tmFire =+              FireNode+                { fireTarget = "Target",+                  fireKey = "correlationId",+                  fireCommand = "Fire",+                  fireFields = [],+                  fireFiredEventId = IdExpr UuidV5Id "fired:" "correlationId",+                  fireDisposition = FireDisposition OFired OFired ORetry ORetry ORetry+                },+            tmDecodeUnknown = "Cancelled",+            tmMaxAttempts = 5,+            tmDeadLetter = "exhausted",+            tmLoc = noLoc+          },+      procLoc = noLoc+    }++genName :: Gen Name+genName =+  frequency+    [ ( 3,+        do+          base <- elements ["Aa", "Bb", "Cc", "Dd", "St", "Cmd", "Ev", "Reg", "Fld", "Foo", "Bar", "Qux"]+          n <- choose (0, 9 :: Int)+          pure (T.pack (base <> show n))+      ),+      (1, elements ["data1", "typeA", "whereX", "gotoX", "guardY", "emitZ", "_lead"])+    ]++genWire :: Gen T.Text+genWire = do+  base <- elements ["red", "blue", "green", "ctorName", "camelCase", "rsv", "hosp", "held", "partial-divert", "1st"]+  n <- choose (0, 9 :: Int)+  pure (T.pack (base <> show n))++genWireWord :: Gen T.Text+genWireWord = genWire++smallList :: Gen a -> Gen [a]+smallList g = choose (0, 3 :: Int) >>= \n -> vectorOf n g++nonEmptyList :: Gen a -> Gen [a]+nonEmptyList g = choose (1, 3 :: Int) >>= \n -> vectorOf n g++genMaybe :: Gen a -> Gen (Maybe a)+genMaybe g = oneof [pure Nothing, Just <$> g]++genCmp :: Gen CmpOp+genCmp = elements [OpEq, OpNeq, OpLt, OpLe, OpGt, OpGe]++genAtom :: Gen Expr+genAtom = EAtom <$> oneof [AName <$> genName, ABool <$> arbitrary]++genExpr :: Gen Expr+genExpr = go (3 :: Int)+  where+    go 0 = genAtom+    go d =+      oneof+        [ genAtom,+          EOr <$> go (d - 1) <*> go (d - 1),+          EAnd <$> go (d - 1) <*> go (d - 1),+          ECmp <$> genCmp <*> go (d - 1) <*> go (d - 1)+        ]++genField :: Gen Field+genField = Field <$> genName <*> oneof [pure Nothing, Just <$> genName]++genAggregateField :: Gen AggregateField+genAggregateField = AggregateField <$> genName <*> pure Nothing <*> pure Nothing <*> genMaybe (genTypeExpr []) <*> pure noLoc++genReg :: Gen RegDecl+genReg = RegDecl <$> genName <*> genTypeExpr [] <*> genRegInitial <*> pure noLoc++genRegInitial :: Gen RegInitial+genRegInitial = oneof [RegInitBare <$> genName, RegInitText <$> genAdversarialText]++genState :: Gen StateDecl+genState = StateDecl <$> genName <*> arbitrary <*> pure noLoc++genCommand :: Gen Command+genCommand = Command <$> genName <*> smallList genAggregateField <*> pure noLoc++genEvent :: Gen Event+genEvent = do+  name <- genName+  eventBody <- body+  version <- choose (1, 3)+  upcast <- genMaybe ((,) <$> choose (0, 3) <*> pure Hole)+  (retiring, deprecated) <- elements [(False, False), (True, False), (False, True)]+  pure+    Event+      { evName = name,+        evBody = eventBody,+        evVersion = version,+        evUpcastFrom = upcast,+        evRetiring = retiring,+        evDeprecated = deprecated,+        evLoc = noLoc+      }+  where+    body = oneof [EventFromCommand <$> genName, EventFields <$> smallList genAggregateField]++genTransition :: Gen Transition+genTransition =+  Transition+    <$> genName+    <*> genName+    <*> pure LegacyHoleImplementation+    <*> genMaybe genExpr+    <*> smallList ((,) <$> genName <*> genExpr)+    <*> smallList genName+    <*> pure Nothing+    <*> pure []+    <*> genName+    <*> elements [TmLive, TmReplayOnly]+    <*> pure noLoc++genWireSpec :: Gen WireSpec+genWireSpec = WireSpec <$> genWire <*> genWire <*> (getNonNegative <$> arbitrary)++genProjection :: Gen ProjectionSpec+genProjection =+  ProjectionSpec+    <$> genName+    <*> genMaybe (elements [Strong, Eventual])+    <*> genName+    <*> genMaybe (Mapping <$> smallList ((,) <$> genName <*> genWire) <*> arbitrary)+    <*> pure noLoc++genAggregate :: Gen Aggregate+genAggregate =+  Aggregate+    <$> genName+    <*> smallList genReg+    <*> smallList genState+    <*> smallList genCommand+    <*> smallList genEvent+    <*> smallList genTransition+    <*> pure Nothing+    <*> pure []+    <*> genMaybe genWireSpec+    <*> genMaybe genProjection+    <*> genMaybe (SnapshotSpec <$> oneof [SnapEvery <$> choose (0, 5), pure SnapOnTerminal] <*> choose (0, 5) <*> genAdversarialText <*> pure noLoc)+    <*> pure noLoc++genDottedRef :: Gen T.Text+genDottedRef = elements ["input.id", "input.hospitalId", "timer.id", "correlationId", "payload.messageId"]++genWindow :: Gen T.Text+genWindow = elements ["0s", "5s", "2m", "1h"]++genFieldBinding :: Gen FieldBinding+genFieldBinding =+  FieldBinding+    <$> genName+    <*> oneof+      [ pure Nothing,+        Just <$> genDottedRef,+        Just . (\raw -> "\"" <> raw <> "\"") <$> genAdversarialText+      ]++genDispatchDisposition :: Gen DispatchDisposition+genDispatchDisposition = DispatchDisposition <$> genDisp <*> genDisp <*> genDisp+  where+    genDisp = oneof [pure DAckOk, pure DRetry, DDeadLetter <$> genAdversarialText]++genDispatchNode :: Gen DispatchNode+genDispatchNode =+  DispatchNode+    <$> genName+    <*> genDottedRef+    <*> genName+    <*> smallList genFieldBinding+    <*> genDispatchDisposition+    <*> pure noLoc++genFireDisposition :: Gen FireDisposition+genFireDisposition =+  FireDisposition+    <$> elements [OFired, ORetry]+    <*> elements [OFired, ORetry]+    <*> elements [OFired, ORetry]+    <*> elements [OFired, ORetry]+    <*> elements [OFired, ORetry]++genIdExpr :: Gen IdExpr+genIdExpr = IdExpr UuidV5Id <$> genAdversarialText <*> pure "correlationId"++genFireNode :: Gen FireNode+genFireNode =+  FireNode+    <$> genName+    <*> genDottedRef+    <*> genName+    <*> smallList genFieldBinding+    <*> genIdExpr+    <*> genFireDisposition++genTimerNode :: Gen TimerNode+genTimerNode =+  TimerNode+    <$> genName+    <*> genIdExpr+    <*> (FireAtExpr <$> genName <*> genWindow)+    <*> smallList genFieldBinding+    <*> genFireNode+    <*> genName+    <*> choose (0, 5)+    <*> genAdversarialText+    <*> pure noLoc++genProcess :: Gen ProcessNode+genProcess =+  ProcessNode+    <$> genName+    <*> genAdversarialText+    <*> (InputDecl <$> genName <*> smallList genField <*> pure Nothing <*> pure noLoc)+    <*> (CorrelateDecl <$> genName <*> genName)+    <*> (SagaRef <$> genName <*> genAdversarialText)+    <*> genName+    <*> smallList genName+    <*> (HandleNode <$> genName <*> (AdvanceNode <$> genName <*> smallList genFieldBinding) <*> smallList genDispatchNode <*> genName)+    <*> elements [PolHalt, PolDeadLetter, PolSkip]+    <*> elements [PolHalt, PolDeadLetter, PolSkip]+    <*> genTimerNode+    <*> pure noLoc++genResolveSource :: Gen ResolveSource+genResolveSource = oneof [ResolveReadModel <$> genName, pure ResolveHole]++genRouter :: Gen RouterNode+genRouter =+  RouterNode+    <$> genName+    <*> genAdversarialText+    <*> (InputDecl <$> genName <*> smallList genField <*> pure Nothing <*> pure noLoc)+    <*> (CorrelateDecl <$> genName <*> genName)+    <*> (ResolveDecl <$> genResolveSource <*> smallList genName <*> pure noLoc)+    <*> genName+    <*> smallList genName+    <*> (RouterDispatchNode <$> genName <*> smallList genFieldBinding <*> genDispatchDisposition <*> pure noLoc)+    <*> elements [PolHalt, PolDeadLetter, PolSkip]+    <*> elements [PolHalt, PolDeadLetter, PolSkip]+    <*> pure noLoc++genContractField :: Gen ContractField+genContractField = ContractField <$> genName <*> pure Nothing <*> pure Nothing <*> oneof [CTypeId <$> genAdversarialText, pure CText, pure CInt] <*> pure noLoc++genContractEvent :: Gen ContractEvent+genContractEvent = ContractEvent <$> genName <*> genName <*> smallList genContractField++genContract :: Gen ContractNode+genContract =+  ContractNode+    <$> genName+    <*> choose (0, 5)+    <*> genName+    <*> smallList ((,) <$> genName <*> genAdversarialText)+    <*> smallList genContractEvent+    <*> pure noLoc++genWireSource :: Gen WireSource+genWireSource = oneof [SrcHeader <$> genAdversarialText, pure SrcBody, pure SrcKafkaKey, pure SrcKafkaCursor]++genInboxAction :: Gen InboxAction+genInboxAction = oneof [pure IAckOk, IRetry <$> genWindow, IDeadLetter <$> genMaybe genAdversarialText]++genDispositionRow :: Gen DispositionRow+genDispositionRow = DispositionRow <$> genName <*> genInboxAction <*> pure noLoc++genDecodeSpec :: Gen DecodeSpec+genDecodeSpec =+  DecodeSpec+    <$> ((\first second -> first <> " " <> second) <$> genWireWord <*> genWireWord)+    <*> arbitrary+    <*> choose (0, 5)++genIntake :: Gen IntakeNode+genIntake =+  IntakeNode+    <$> genName+    <*> genName+    <*> genName+    <*> nonEmptyList genName+    <*> smallList (BindRow <$> genName <*> genWireSource <*> arbitrary <*> arbitrary)+    <*> genName+    <*> genName+    <*> elements [InkPersistFull, InkPersistDedupeOnly]+    <*> genDecodeSpec+    <*> smallList genDispositionRow+    <*> pure noLoc++genDeriveSpec :: Gen DeriveSpec+genDeriveSpec = DeriveSpec <$> genMaybe genAdversarialText++genEmit :: Gen EmitNode+genEmit =+  EmitNode+    <$> genName+    <*> genName+    <*> genName+    <*> genAdversarialText+    <*> genName+    <*> genName+    <*> smallList (EmitMapRow <$> genAdversarialText <*> genName <*> pure noLoc)+    <*> arbitrary+    <*> genDeriveSpec+    <*> genDeriveSpec+    <*> pure noLoc++genPublisher :: Gen PublisherNode+genPublisher =+  PublisherNode+    <$> genName+    <*> genName+    <*> genName+    <*> choose (0, 5)+    <*> (BackoffSpec <$> genName <*> genWindow <*> genMaybe genWindow <*> genMaybe (elements ["1.0", "2.0", "3"]))+    <*> genName+    <*> pure noLoc++genWqField :: Gen WqField+genWqField = WqField <$> genName <*> genAdversarialText <*> (LegacyQueueScalar . QueueOther <$> genName) <*> pure noLoc++genWqDispRow :: Gen WqDispRow+genWqDispRow = WqDispRow <$> genName <*> genInboxAction <*> pure noLoc++genWorkqueue :: Gen WorkqueueNode+genWorkqueue =+  WorkqueueNode+    <$> genName+    <*> genAdversarialText+    <*> genAdversarialText+    <*> genAdversarialText+    <*> genAdversarialText+    <*> elements [WqUnordered, WqFifoThroughput, WqFifoRoundRobin]+    <*> genMaybe (WqGroupKey <$> genName <*> genName <*> genMaybe genAdversarialText)+    <*> oneof [pure WqStandard, pure WqUnlogged, WqPartitioned <$> genAdversarialText <*> genAdversarialText]+    <*> genName+    <*> smallList genWqField+    <*> choose (0, 5)+    <*> genWindow+    <*> arbitrary+    <*> smallList genWqDispRow+    <*> pure noLoc++genReadModel :: Gen ReadModelNode+genReadModel = do+  consistency <- elements [Strong, Eventual]+  scope <- genMaybe (oneof [pure RmEntireLog, RmCategory <$> genAdversarialText])+  feed <- elements [RmInline, RmSubscription]+  subscription <- genMaybe genAdversarialText+  ReadModelNode+    <$> genName+    <*> nonEmptyText+    <*> nonEmptyText+    <*> smallList (RmColumn <$> genWireWord <*> genName <*> arbitrary)+    <*> choose (0, 5)+    <*> genAdversarialText+    <*> pure (case consistency of Eventual -> FreshnessImmediate; Strong -> FreshnessWaitForHead (maybe RmEntireLog id scope))+    <*> pure (LegacyReadModelSupply consistency scope feed subscription)+    <*> pure Nothing+    <*> pure []+    <*> pure Nothing+    <*> pure Nothing+    <*> pure noLoc+  where+    nonEmptyText = genAdversarialText `suchThat` (not . T.null)++genPgmqDispatch :: Gen PgmqDispatchNode+genPgmqDispatch =+  PgmqDispatchNode+    <$> genName+    <*> genName+    <*> genName+    <*> genName+    <*> genName+    <*> genName+    <*> genName+    <*> genName+    <*> genName+    <*> genName+    <*> pure noLoc++genWfBodyItem :: Gen WfBodyItem+genWfBodyItem = sized go+  where+    go size =+      oneof $+        [ WfStep <$> genWireWord <*> genName <*> pure noLoc,+          WfAwait <$> genWireWord <*> genName <*> pure noLoc,+          WfSleep <$> genWireWord <*> genName <*> pure noLoc,+          WfChild <$> genWireWord <*> genName <*> genName <*> pure noLoc,+          WfContinueAsNew <$> genName <*> pure noLoc+        ]+          ++ [ WfPatch <$> genWireWord <*> resize (size `div` 2) (smallList genWfBodyItem) <*> pure noLoc+             | size > 0+             ]++genWorkflow :: Gen WorkflowNode+genWorkflow =+  WorkflowNode+    <$> genName+    <*> genAdversarialText+    <*> genName+    <*> smallList genField+    <*> genName+    <*> genMaybe genName+    <*> genName+    <*> smallList genWfBodyItem+    <*> pure noLoc++genOperationShape :: Gen OperationShape+genOperationShape =+  oneof+    [ CommandOp <$> genName <*> genName <*> genName <*> smallList genName,+      QueryOp <$> genName <*> genName <*> ((\parts -> T.unwords parts) <$> nonEmptyList genName) <*> genName,+      SignalOp <$> genWireWord <*> genName <*> genName <*> genName <*> genName,+      RunOp <$> genName <*> genName <*> genName+    ]++genOperation :: Gen OperationNode+genOperation = OperationNode <$> genName <*> genOperationShape <*> pure noLoc++allNodeTags :: [String]+allNodeTags = ["aggregate", "process", "router", "contract", "intake", "emit", "publisher", "workqueue", "pgmq-dispatch", "readmodel", "workflow", "operation"]++nodeTag :: Node -> String+nodeTag = \case+  NAggregate _ -> "aggregate"+  NProcess _ -> "process"+  NRouter _ -> "router"+  NContract _ -> "contract"+  NIntake _ -> "intake"+  NEmit _ -> "emit"+  NPublisher _ -> "publisher"+  NWorkqueue _ -> "workqueue"+  NPgmqDispatch _ -> "pgmq-dispatch"+  NReadModel _ -> "readmodel"+  NProjectionTarget _ -> "projection-target"+  NRebuildGroup _ -> "rebuild-group"+  NProjectionRevision _ -> "projection-revision"+  NExternalRead _ -> "external-read"+  NProjectionOwner _ -> "projection-owner"   NWorkflow _ -> "workflow"   NOperation _ -> "operation"

+ test/conformance-aggregate-scalars/Generated/AggregateScalars/BehaviorSourceMap.hs view

@@ -0,0 +1,30 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context aggregate-scalars behavior source map; do not edit.+module Generated.AggregateScalars.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-4e461a9ba9271054" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/aggregate-scalars.keiro" 28 3)+  "behavior-v1-d15e326edfa1a438" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/aggregate-scalars.keiro" 8 16)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-aggregate-scalars/Generated/AggregateScalars/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context aggregate-scalars replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context aggregate-scalars replay-audit assembly; do not edit. -- -- Deployment contract: --   * replay-neutral diff: no data audit is required;

test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit. module Generated.AggregateScalars.ScalarLedger.Codec (     scalarLedgerCodec,     parseScalarLedgerEvent,

test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Domain.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit. module Generated.AggregateScalars.ScalarLedger.Domain where  import Data.Aeson (FromJSON, ToJSON)

test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit. module Generated.AggregateScalars.ScalarLedger.EventStream   ( scalarLedgerCategory   , scalarLedgerCommandCategory

test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Harness.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit. module Generated.AggregateScalars.ScalarLedger.Harness (harnessAssertions) where  import Generated.AggregateScalars.ScalarLedger.Domain

test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit. module Generated.AggregateScalars.ScalarLedger.Projection () where  -- No projection declarations are present; this module keeps the generated manifest inventory total.

test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Transducer.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit. module Generated.AggregateScalars.ScalarLedger.Transducer   ( scalarLedgerTransducer   , scalarLedgerFoldFingerprint

+ test/conformance-behavior-complete/Generated/BehaviorComplete/BehaviorSourceMap.hs view

@@ -0,0 +1,47 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context behavior-complete behavior source map; do not edit.+module Generated.BehaviorComplete.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-0128e858fee6f2b3" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 62 3)+  "behavior-v1-08a2bda57424a16e" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 50 3)+  "behavior-v1-2e1fd6b9580e1a3d" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 21 23)+  "behavior-v1-2f3ebf37a55781db" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 44 3)+  "behavior-v1-43b8fc7fa48595dd" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 21 16)+  "behavior-v1-68e75665b789892c" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 70 3)+  "behavior-v1-76005937ded24bec" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 21 16)+  "behavior-v1-7ea811586a738ee5" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 21 23)+  "behavior-v1-83b0a46823e1a788" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 21 10)+  "behavior-v1-8f79f2e40d8b3bd5" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 21 10)+  "behavior-v1-926739ffb27d20e7" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 21 10)+  "behavior-v1-9c61af3593764622" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 21 23)+  "behavior-v1-ba7053f86d15e1b0" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 21 10)+  "behavior-v1-be8b08a049ab4d8b" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 21 23)+  "behavior-v1-d2fc3eca5c449e84" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 38 3)+  "behavior-v1-db1a553baa3eda84" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 56 3)+  "behavior-v1-ea258e9c47d66aac" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 67 3)+  "behavior-v1-f0fbe3a3ba0b40e8" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 77 3)+  "behavior-v1-f9cae2bf4c0d0562" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/behavior-complete.keiro" 21 23)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/BehaviorContract.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit. module Generated.BehaviorComplete.Journey.BehaviorContract   ( BehaviorKey (..)   , ObligationKind (..)@@ -21,6 +21,7 @@ import Generated.BehaviorComplete.Journey.Codec (encodeJourneyEvent, parseJourneyEvent, journeyCodec) import Generated.BehaviorComplete.Journey.Domain import Generated.BehaviorComplete.Journey.Transducer (journeyTransducer)+import Generated.BehaviorComplete.BehaviorSourceMap qualified as BehaviorSourceMap import Data.Aeson (ToJSON (..), object, (.=)) import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty)@@ -53,7 +54,6 @@   , requirementExpectedEdge :: !(Maybe (K.EdgeRef JourneyVertex))   , requirementTarget :: !(Maybe JourneyVertex)   , requirementEventKinds :: ![Text]-  , requirementLine :: !Int   }   deriving stock (Eq, Show) @@ -126,7 +126,7 @@  behaviorRequirements :: [BehaviorRequirement] behaviorRequirements =-  [ -- JourneyEmpty x LegacyStart: replay-only transition (spec line 62)+  [ -- JourneyEmpty x LegacyStart: replay-only transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-0128e858fee6f2b3"       , requirementKind = ReplayTransition@@ -137,9 +137,8 @@       , requirementExpectedEdge = (Just (K.EdgeRef JourneyEmpty 2))       , requirementTarget = Just JourneyActive       , requirementEventKinds = ["LegacyStarted"]-      , requirementLine = 62       }-  , -- JourneyEmpty x Start: replay-only transition (spec line 50)+  , -- JourneyEmpty x Start: replay-only transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-08a2bda57424a16e"       , requirementKind = ReplayTransition@@ -150,9 +149,8 @@       , requirementExpectedEdge = (Just (K.EdgeRef JourneyEmpty 1))       , requirementTarget = Just JourneyActive       , requirementEventKinds = ["Started"]-      , requirementLine = 50       }-  , -- JourneyClosed x Ping: required rejection (spec line 21)+  , -- JourneyClosed x Ping: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-2e1fd6b9580e1a3d"       , requirementKind = RequiredRejection@@ -163,9 +161,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 21       }-  , -- JourneyActive x Decide: live transition (spec line 44)+  , -- JourneyActive x Decide: live transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-2f3ebf37a55781db"       , requirementKind = LiveTransition@@ -176,9 +173,8 @@       , requirementExpectedEdge = (Just (K.EdgeRef JourneyActive 0))       , requirementTarget = Just JourneyActive       , requirementEventKinds = ["DecisionRecorded"]-      , requirementLine = 44       }-  , -- JourneyActive x Start: required rejection (spec line 21)+  , -- JourneyActive x Start: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-43b8fc7fa48595dd"       , requirementKind = RequiredRejection@@ -189,9 +185,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 21       }-  , -- JourneyActive x Retire: live transition (spec line 70)+  , -- JourneyActive x Retire: live transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-68e75665b789892c"       , requirementKind = LiveTransition@@ -202,9 +197,8 @@       , requirementExpectedEdge = (Just (K.EdgeRef JourneyActive 3))       , requirementTarget = Just JourneyClosed       , requirementEventKinds = ["Retired", "RetirementAudited"]-      , requirementLine = 70       }-  , -- JourneyActive x LegacyStart: required rejection (spec line 21)+  , -- JourneyActive x LegacyStart: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-76005937ded24bec"       , requirementKind = RequiredRejection@@ -215,9 +209,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 21       }-  , -- JourneyClosed x Decide: required rejection (spec line 21)+  , -- JourneyClosed x Decide: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-7ea811586a738ee5"       , requirementKind = RequiredRejection@@ -228,9 +221,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 21       }-  , -- JourneyEmpty x Ping: required rejection (spec line 21)+  , -- JourneyEmpty x Ping: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-83b0a46823e1a788"       , requirementKind = RequiredRejection@@ -241,9 +233,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 21       }-  , -- JourneyEmpty x LegacyStart: required rejection (spec line 21)+  , -- JourneyEmpty x LegacyStart: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-8f79f2e40d8b3bd5"       , requirementKind = RequiredRejection@@ -254,9 +245,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 21       }-  , -- JourneyEmpty x Retire: required rejection (spec line 21)+  , -- JourneyEmpty x Retire: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-926739ffb27d20e7"       , requirementKind = RequiredRejection@@ -267,9 +257,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 21       }-  , -- JourneyClosed x LegacyStart: required rejection (spec line 21)+  , -- JourneyClosed x LegacyStart: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-9c61af3593764622"       , requirementKind = RequiredRejection@@ -280,9 +269,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 21       }-  , -- JourneyEmpty x Decide: required rejection (spec line 21)+  , -- JourneyEmpty x Decide: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-ba7053f86d15e1b0"       , requirementKind = RequiredRejection@@ -293,9 +281,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 21       }-  , -- JourneyClosed x Start: required rejection (spec line 21)+  , -- JourneyClosed x Start: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-be8b08a049ab4d8b"       , requirementKind = RequiredRejection@@ -306,9 +293,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 21       }-  , -- JourneyEmpty x Start: live transition (spec line 38)+  , -- JourneyEmpty x Start: live transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-d2fc3eca5c449e84"       , requirementKind = LiveTransition@@ -319,9 +305,8 @@       , requirementExpectedEdge = (Just (K.EdgeRef JourneyEmpty 0))       , requirementTarget = Just JourneyActive       , requirementEventKinds = ["Started"]-      , requirementLine = 38       }-  , -- JourneyActive x Decide: live transition (spec line 56)+  , -- JourneyActive x Decide: live transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-db1a553baa3eda84"       , requirementKind = LiveTransition@@ -332,9 +317,8 @@       , requirementExpectedEdge = (Just (K.EdgeRef JourneyActive 1))       , requirementTarget = Just JourneyActive       , requirementEventKinds = ["DecisionRecorded"]-      , requirementLine = 56       }-  , -- JourneyActive x Ping: live transition (spec line 67)+  , -- JourneyActive x Ping: live transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-ea258e9c47d66aac"       , requirementKind = LiveTransition@@ -345,9 +329,8 @@       , requirementExpectedEdge = (Just (K.EdgeRef JourneyActive 2))       , requirementTarget = Just JourneyActive       , requirementEventKinds = []-      , requirementLine = 67       }-  , -- JourneyActive x Retire: replay-only transition (spec line 77)+  , -- JourneyActive x Retire: replay-only transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-f0fbe3a3ba0b40e8"       , requirementKind = ReplayTransition@@ -358,9 +341,8 @@       , requirementExpectedEdge = (Just (K.EdgeRef JourneyActive 4))       , requirementTarget = Just JourneyClosed       , requirementEventKinds = ["Retired", "RetirementAudited"]-      , requirementLine = 77       }-  , -- JourneyClosed x Retire: required rejection (spec line 21)+  , -- JourneyClosed x Retire: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-f9cae2bf4c0d0562"       , requirementKind = RequiredRejection@@ -371,7 +353,6 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 21       }   ] @@ -554,7 +535,7 @@   Left     ( BehaviorFailure         (requirementKey requirement)-        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (spec line " <> tshow (requirementLine requirement) <> ")")+        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey requirement)) <> ")")         code         detail     )

test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit. module Generated.BehaviorComplete.Journey.Codec (     journeyCodec,     parseJourneyEvent,

test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Domain.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit. module Generated.BehaviorComplete.Journey.Domain where  import Data.Aeson (FromJSON, ToJSON)

test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit. module Generated.BehaviorComplete.Journey.EventStream   ( journeyCategory   , journeyCommandCategory

test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Harness.hs view

@@ -1,30 +1,23 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit. module Generated.BehaviorComplete.Journey.Harness (harnessAssertions) where  import Generated.BehaviorComplete.Journey.Domain import Generated.BehaviorComplete.Journey.Codec (encodeJourneyEvent, parseJourneyEvent, journeyCodec, encodeStartPayloadMapped, decodeStartPayloadMapped) import Generated.BehaviorComplete.Journey.Transducer (journeyTransducer)-import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, fieldWitnessAgrees, (!))+import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!)) import Keiro.Codec (eventType) import Generated.BehaviorComplete.Nominals (RequestId, parseRequestId) 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 Generated.BehaviorComplete.StructuralProjections qualified as StructuralProjections+import Keiro.Codec.Structural (FixtureCases (..)) import Data.Time.Calendar (fromGregorian) import Data.Time.Clock (UTCTime (..), picosecondsToDiffTime) import BehaviorComplete.Bindings qualified as Bindings-import BehaviorComplete.Domain (StartPayload)-import Generated.BehaviorComplete.Structural.Shape.StartPayload qualified as ShapeStartPayload  -- | (label, passed). A driver runs these and exits non-zero on any False, -- naming the failing assertion. Filling a hole wrongly turns a specific@@ -98,37 +91,10 @@ mappedConformanceAssertions :: [(String, Bool)] mappedConformanceAssertions =   concat-    [ startPayloadBindingAssertions-    , [("fixture coverage: behavior-complete.StartPayload.v1", coverageStartPayload)]-    , startedDetailsAssertions+    [ startedDetailsAssertions     , structuralWirePolicyAssertions-    , structuralProjectionAssertions     ] -validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool-validFixtureLabels cases =-  all (not . T.null) labels && length labels == length (nub labels)-  where-    labels = map fst (NonEmpty.toList cases)--startPayloadBindingAssertions :: [(String, Bool)]-startPayloadBindingAssertions =-  ("fixture labels: behavior-complete.StartPayload.v1", validFixtureLabels cases) :-  ("canonical identity: behavior-complete.StartPayload.v1", canonicalTypeName (Proxy @StartPayload) == "behavior-complete.StartPayload.v1") :-  concat-    [ [ ("binding domain round-trip: behavior-complete.StartPayload.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.startPayloadBinding value)-      , ("binding shape round-trip: behavior-complete.StartPayload.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.startPayloadBinding (bindingToShape Bindings.startPayloadBinding value))-      ]-    | (label, value) <- NonEmpty.toList cases-    ]-  where-    cases = fixtureCases Bindings.startPayloadCases--coverageStartPayload :: Bool-coverageStartPayload = any (isNothing . ShapeStartPayload.note) shapes && any (isJust . ShapeStartPayload.note) shapes-  where-    shapes = map (bindingToShape Bindings.startPayloadBinding . snd) (NonEmpty.toList (fixtureCases Bindings.startPayloadCases))- startedDetailsAssertions :: [(String, Bool)] startedDetailsAssertions =   [ ("mapped codec round-trip: Started/details/" <> T.unpack label, roundTrips (Started (StartedData sampleRequestId sampleObservedAt 0 mappedValue)))@@ -140,11 +106,6 @@   [ ("wire policy missing default: behavior-complete.StartPayload.v1/optional_note", case decodeStartPayloadMapped (deleteObjectField "optional_note" (encodeStartPayloadMapped (snd (NonEmpty.head (fixtureCases Bindings.startPayloadCases))))) of Left _ -> False; Right decoded -> objectField "optional_note" (encodeStartPayloadMapped decoded) == Just (Aeson.Null))   , ("wire policy explicit null: behavior-complete.StartPayload.v1/optional_note", isRight (decodeStartPayloadMapped (insertObjectField "optional_note" Aeson.Null (encodeStartPayloadMapped (snd (NonEmpty.head (fixtureCases Bindings.startPayloadCases)))))))   , ("wire policy unknown fields: behavior-complete.StartPayload.v1", all (\(_, value) -> isLeft (decodeStartPayloadMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeStartPayloadMapped value)))) (NonEmpty.toList (fixtureCases Bindings.startPayloadCases)))-  ]--structuralProjectionAssertions :: [(String, Bool)]-structuralProjectionAssertions =-  [ ("projection witness agreement: behavior-complete.StartPayload.v1/display_label", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.startPayloadDisplayLabelWitness (\referenceOwner -> ShapeStartPayload.label (bindingToShape Bindings.startPayloadBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.startPayloadCases)))   ]  deleteObjectField :: T.Text -> Aeson.Value -> Aeson.Value

test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit. module Generated.BehaviorComplete.Journey.Projection () where  -- No projection declarations are present; this module keeps the generated manifest inventory total.

test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Transducer.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit. module Generated.BehaviorComplete.Journey.Transducer   ( journeyTransducer   , journeyFoldFingerprint

test/conformance-behavior-complete/Generated/BehaviorComplete/Nominals.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context behavior-complete generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context behavior-complete generated nominal declarations; do not edit. module Generated.BehaviorComplete.Nominals   ( RequestId   , parseRequestId

test/conformance-behavior-complete/Generated/BehaviorComplete/Nominals/Internal.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context behavior-complete generated nominal ID internals; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context behavior-complete generated nominal ID internals; do not edit. module Generated.BehaviorComplete.Nominals.Internal   ( RequestId   , parseRequestId

test/conformance-behavior-complete/Generated/BehaviorComplete/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context behavior-complete replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context behavior-complete replay-audit assembly; do not edit. -- -- Deployment contract: --   * replay-neutral diff: no data audit is required;

test/conformance-behavior-complete/Generated/BehaviorComplete/Structural/Shape/StartPayload.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from mapped structural StartPayload; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from mapped structural StartPayload; do not edit. module Generated.BehaviorComplete.Structural.Shape.StartPayload (StartPayloadShape (..)) where  import Data.Text (Text)

+ test/conformance-behavior-complete/Generated/BehaviorComplete/StructuralConformance.hs view

@@ -0,0 +1,54 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context behavior-complete structural conformance; do not edit.+module Generated.BehaviorComplete.StructuralConformance+  ( structuralConformanceAssertions+  ) where++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.Core (fieldWitnessAgrees)+import Keiki.Shape (CanonicalTypeName (..))+import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape)+import Generated.BehaviorComplete.StructuralProjections qualified as StructuralProjections+import BehaviorComplete.Bindings qualified as Bindings+import BehaviorComplete.Domain (StartPayload)+import Generated.BehaviorComplete.Structural.Shape.StartPayload qualified as ShapeStartPayload++structuralConformanceAssertions :: [(String, Bool)]+structuralConformanceAssertions =+  concat+    [ startPayloadBindingAssertions+    , [("fixture coverage: behavior-complete.StartPayload.v1", coverageStartPayload)]+    , structuralProjectionAssertions+    ]++validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool+validFixtureLabels cases =+  all (not . T.null) labels && length labels == length (nub labels)+  where+    labels = map fst (NonEmpty.toList cases)++startPayloadBindingAssertions :: [(String, Bool)]+startPayloadBindingAssertions =+  ("fixture labels: behavior-complete.StartPayload.v1", validFixtureLabels cases) :+  ("canonical identity: behavior-complete.StartPayload.v1", canonicalTypeName (Proxy @StartPayload) == "behavior-complete.StartPayload.v1") :+  concat+    [ [ ("binding domain round-trip: behavior-complete.StartPayload.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.startPayloadBinding value)+      , ("binding shape round-trip: behavior-complete.StartPayload.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.startPayloadBinding (bindingToShape Bindings.startPayloadBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.startPayloadCases++coverageStartPayload :: Bool+coverageStartPayload = any (isNothing . ShapeStartPayload.note) shapes && any (isJust . ShapeStartPayload.note) shapes+  where+    shapes = map (bindingToShape Bindings.startPayloadBinding . snd) (NonEmpty.toList (fixtureCases Bindings.startPayloadCases))++structuralProjectionAssertions :: [(String, Bool)]+structuralProjectionAssertions =+  [ ("projection witness agreement: behavior-complete.StartPayload.v1/display_label", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.startPayloadDisplayLabelWitness (\referenceOwner -> ShapeStartPayload.label (bindingToShape Bindings.startPayloadBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.startPayloadCases)))+  ]

test/conformance-behavior-complete/Generated/BehaviorComplete/StructuralProjections.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context behavior-complete mapped structural facade; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context behavior-complete mapped structural facade; do not edit. -- Equality witnesses are emitted for Text, Int, Bool, Natural, and UTCTime. -- Int, Natural, and UTCTime belong to Keiki's ordered subset. module Generated.BehaviorComplete.StructuralProjections

+ test/conformance-coldstart/Generated/Billing/BehaviorSourceMap.hs view

@@ -0,0 +1,34 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context billing behavior source map; do not edit.+module Generated.Billing.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-09842123ac52dd63" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/subscription.keiro" 12 19)+  "behavior-v1-9399755ba2b617d6" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/subscription.keiro" 20 3)+  "behavior-v1-93f6f3f8cb36420d" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/subscription.keiro" 12 10)+  "behavior-v1-99ac0c974e512f76" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/subscription.keiro" 12 26)+  "behavior-v1-9b81e070774b3ae1" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/subscription.keiro" 12 26)+  "behavior-v1-b5d1ca5d9ad9b2ec" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/subscription.keiro" 24 3)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-coldstart/Generated/Billing/Nominals.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context billing generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context billing generated nominal declarations; do not edit. module Generated.Billing.Nominals   ( CustomerId   , parseCustomerId

test/conformance-coldstart/Generated/Billing/Nominals/Internal.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context billing generated nominal ID internals; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context billing generated nominal ID internals; do not edit. module Generated.Billing.Nominals.Internal   ( CustomerId   , parseCustomerId

test/conformance-coldstart/Generated/Billing/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context billing replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context billing replay-audit assembly; do not edit. -- -- Deployment contract: --   * replay-neutral diff: no data audit is required;

test/conformance-coldstart/Generated/Billing/Subscription/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit. module Generated.Billing.Subscription.Codec (     subscriptionCodec,     parseSubscriptionEvent,

test/conformance-coldstart/Generated/Billing/Subscription/Domain.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit. module Generated.Billing.Subscription.Domain where  import Data.Proxy (Proxy (..))

test/conformance-coldstart/Generated/Billing/Subscription/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit. module Generated.Billing.Subscription.EventStream   ( subscriptionCategory   , subscriptionCommandCategory

test/conformance-coldstart/Generated/Billing/Subscription/Harness.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit. module Generated.Billing.Subscription.Harness (harnessAssertions) where  import Generated.Billing.Subscription.Domain

test/conformance-coldstart/Generated/Billing/Subscription/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit. module Generated.Billing.Subscription.Projection   ( subscriptionsProjection   , subscriptionsStatusFor

test/conformance-coldstart/Generated/Billing/Subscription/Transducer.hs view

@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit. module Generated.Billing.Subscription.Transducer   ( subscriptionTransducer   , subscriptionFoldFingerprint

test/conformance-contract-v1-compat/Generated/HospitalCapacity/Emergency/Contract.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 1) from contract emergency; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 1) from contract emergency; do not edit. module Generated.HospitalCapacity.Emergency.Contract   ( EmergencyPayload (..)   , IncidentTransferNeedDeclaredData (..)

test/conformance-contract/Generated/HospitalCapacity/Emergency/Contract.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from contract emergency; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from contract emergency; do not edit. module Generated.HospitalCapacity.Emergency.Contract   ( EmergencyPayload (..)   , IncidentTransferNeedDeclaredData (..)

+ test/conformance-declarative-router/Conformance/DeclarativeRouter/Bindings.hs view

@@ -0,0 +1,45 @@+module Conformance.DeclarativeRouter.Bindings+  ( transferRouteInputCases,+    transferRouteInputBinding,+    hospitalLoadRowCases,+    hospitalLoadRowBinding,+  )+where++import Conformance.DeclarativeRouter.Domain qualified as Domain+import Data.List.NonEmpty (NonEmpty (..))+import Generated.TransferRouting.Structural.Shape.HospitalLoadRow qualified as ShapeHospitalLoadRow+import Generated.TransferRouting.Structural.Shape.TransferRouteInput qualified as ShapeTransferRouteInput+import Keiro.Codec.Structural (FixtureCases (..), StructuralBinding (..))++transferRouteInputCases :: FixtureCases Domain.TransferRouteInput+transferRouteInputCases =+  FixtureCases+    ( ("west", Domain.TransferRouteInput "transfer-7" "west")+        :| [("east", Domain.TransferRouteInput "transfer-8" "east")]+    )++transferRouteInputBinding :: StructuralBinding Domain.TransferRouteInput ShapeTransferRouteInput.TransferRouteInputShape+transferRouteInputBinding =+  StructuralBinding+    { bindingToShape = \(Domain.TransferRouteInput transferNeedId region) ->+        ShapeTransferRouteInput.TransferRouteInput transferNeedId region,+      bindingFromShape = \(ShapeTransferRouteInput.TransferRouteInput transferNeedId region) ->+        Domain.TransferRouteInput transferNeedId region+    }++hospitalLoadRowCases :: FixtureCases Domain.HospitalLoadRow+hospitalLoadRowCases =+  FixtureCases+    ( ("eligible", Domain.HospitalLoadRow "hospital-a" "west" 2)+        :| [("ineligible", Domain.HospitalLoadRow "hospital-z" "east" 0)]+    )++hospitalLoadRowBinding :: StructuralBinding Domain.HospitalLoadRow ShapeHospitalLoadRow.HospitalLoadRowShape+hospitalLoadRowBinding =+  StructuralBinding+    { bindingToShape = \(Domain.HospitalLoadRow hospitalId region availableBeds) ->+        ShapeHospitalLoadRow.HospitalLoadRow hospitalId region availableBeds,+      bindingFromShape = \(ShapeHospitalLoadRow.HospitalLoadRow hospitalId region availableBeds) ->+        Domain.HospitalLoadRow hospitalId region availableBeds+    }

+ test/conformance-declarative-router/Conformance/DeclarativeRouter/Domain.hs view

@@ -0,0 +1,33 @@+{-# LANGUAGE DuplicateRecordFields #-}++module Conformance.DeclarativeRouter.Domain+  ( TransferRouteInput (..),+    HospitalLoadRow (..),+  )+where++import Data.Proxy (Proxy)+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Shape (CanonicalTypeName (..))++data TransferRouteInput = TransferRouteInput+  { transferNeedId :: !Text,+    region :: !Text+  }+  deriving stock (Eq, Show, Generic)++data HospitalLoadRow = HospitalLoadRow+  { hospitalId :: !Text,+    region :: !Text,+    availableBeds :: !Int+  }+  deriving stock (Eq, Show, Generic)++instance CanonicalTypeName TransferRouteInput where+  canonicalTypeName :: Proxy TransferRouteInput -> Text+  canonicalTypeName _ = "conformance.declarative-router.TransferRouteInput.v1"++instance CanonicalTypeName HospitalLoadRow where+  canonicalTypeName :: Proxy HospitalLoadRow -> Text+  canonicalTypeName _ = "conformance.declarative-router.HospitalLoadRow.v1"

+ test/conformance-declarative-router/Generated/TransferRouting/BehaviorSourceMap.hs view

@@ -0,0 +1,30 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from context transfer-routing behavior source map; do not edit.+module Generated.TransferRouting.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-51a443ca8bbb0eab" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/declarative-router/valid.keiro" 66 15)+  "behavior-v1-6dc56a81dec7fe2b" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/declarative-router/valid.keiro" 71 3)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

+ test/conformance-declarative-router/Generated/TransferRouting/Hospital/BehaviorContract.hs view

@@ -0,0 +1,346 @@+{-# LANGUAGE OverloadedLabels #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit.+module Generated.TransferRouting.Hospital.BehaviorContract+  ( BehaviorKey (..)+  , ObligationKind (..)+  , EvidenceLevel (..)+  , GuardCoverage (..)+  , BehaviorRequirement (..)+  , RejectionClass (..)+  , LiveExpectation (..)+  , BehaviorWitness (..)+  , BehaviorFailure (..)+  , BehaviorConformanceReport (..)+  , behaviorRequirements+  , behaviorCoverageReport+  , behaviorConformancePassed+  , behaviorConformancePassedWith+  , renderBehaviorConformanceText+  ) where++import Generated.TransferRouting.Hospital.Codec (encodeHospitalEvent, parseHospitalEvent, hospitalCodec)+import Generated.TransferRouting.Hospital.Domain+import Generated.TransferRouting.Hospital.Transducer (hospitalTransducer)+import Generated.TransferRouting.BehaviorSourceMap qualified as BehaviorSourceMap+import Data.Aeson (ToJSON (..), object, (.=))+import Data.List (sortOn)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Keiki.Core qualified as K (EdgeMode (..), EdgeRef (..), RegFile, ReplayAttribution (..), ReplayEventSpan (..), ReplaySuccess (..), StepFailure (..), StepSuccess (..), applyEventsDetailedEither, stepDetailedEither, (!))+import Keiro.Codec qualified as Codec (Codec (eventType), EventType (..))++newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }+  deriving stock (Eq, Ord, Show)++data ObligationKind = LiveTransition | RequiredRejection | ReplayTransition+  deriving stock (Eq, Ord, Show)++data EvidenceLevel = GeneratedAuthoritative | HoleWitnessed | LegacyRuntimeWitness+  deriving stock (Eq, Ord, Show)++data GuardCoverage = GuardTotal | GuardPartial | GuardUnknown | GuardNotApplicable+  deriving stock (Eq, Ord, Show)++data BehaviorRequirement = BehaviorRequirement+  { requirementKey :: !BehaviorKey+  , requirementKind :: !ObligationKind+  , requirementEvidence :: !EvidenceLevel+  , requirementGuardCoverage :: !GuardCoverage+  , requirementSource :: !HospitalVertex+  , requirementCommandName :: !Text+  , requirementExpectedEdge :: !(Maybe (K.EdgeRef HospitalVertex))+  , requirementTarget :: !(Maybe HospitalVertex)+  , requirementEventKinds :: ![Text]+  }+  deriving stock (Eq, Show)++data RejectionClass = RejectNoOutgoingEdges | RejectNoMatchingEdge+  deriving stock (Eq, Show)++data LiveExpectation+  = Emits (NonEmpty HospitalEvent)+  | Rejects RejectionClass+  | NoOp+  deriving stock (Eq, Show)++data BehaviorWitness+  = Pending BehaviorKey+  | LiveWitness+      { witnessKey :: BehaviorKey+      , witnessHistory :: [HospitalEvent]+      , witnessCommand :: HospitalCommand+      , witnessExpected :: LiveExpectation+      }+  | ReplayWitness+      { witnessKey :: BehaviorKey+      , witnessHistoryPrefix :: [HospitalEvent]+      , witnessObservedChunk :: [HospitalEvent]+      }+  deriving stock (Eq, Show)++data BehaviorFailure = BehaviorFailure+  { failureKey :: !BehaviorKey+  , failureSubject :: !Text+  , failureCode :: !Text+  , failureDetail :: !Text+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorFailure where+  toJSON behaviorFailure = object+    [ "key" .= unBehaviorKey (failureKey behaviorFailure)+    , "subject" .= failureSubject behaviorFailure+    , "code" .= failureCode behaviorFailure+    , "detail" .= failureDetail behaviorFailure+    ]++data BehaviorConformanceReport = BehaviorConformanceReport+  { reportRequired :: ![BehaviorKey]+  , reportFilled :: ![BehaviorKey]+  , reportPending :: ![BehaviorKey]+  , reportMissing :: ![BehaviorKey]+  , reportDuplicate :: ![BehaviorKey]+  , reportStale :: ![BehaviorKey]+  , reportFailed :: ![BehaviorFailure]+  , reportVerified :: ![BehaviorKey]+  , reportUnverified :: ![BehaviorKey]+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorConformanceReport where+  toJSON report = object+    [ "schema" .= ("keiro/behavior-conformance/1" :: Text)+    , "required" .= keyTexts (reportRequired report)+    , "filled" .= keyTexts (reportFilled report)+    , "pending" .= keyTexts (reportPending report)+    , "missing" .= keyTexts (reportMissing report)+    , "duplicate" .= keyTexts (reportDuplicate report)+    , "stale" .= keyTexts (reportStale report)+    , "failed" .= reportFailed report+    , "verified" .= keyTexts (reportVerified report)+    , "unverified" .= keyTexts (reportUnverified report)+    ]++behaviorRequirements :: [BehaviorRequirement]+behaviorRequirements =+  [ -- HospitalRouted x RouteAcceptedTransferNeed: required rejection+    BehaviorRequirement+      { requirementKey = BehaviorKey "behavior-v1-51a443ca8bbb0eab"+      , requirementKind = RequiredRejection+      , requirementEvidence = GeneratedAuthoritative+      , requirementGuardCoverage = GuardNotApplicable+      , requirementSource = HospitalRouted+      , requirementCommandName = "RouteAcceptedTransferNeed"+      , requirementExpectedEdge = Nothing+      , requirementTarget = Nothing+      , requirementEventKinds = []+      }+  , -- HospitalOpen x RouteAcceptedTransferNeed: live transition+    BehaviorRequirement+      { requirementKey = BehaviorKey "behavior-v1-6dc56a81dec7fe2b"+      , requirementKind = LiveTransition+      , requirementEvidence = GeneratedAuthoritative+      , requirementGuardCoverage = GuardTotal+      , requirementSource = HospitalOpen+      , requirementCommandName = "RouteAcceptedTransferNeed"+      , requirementExpectedEdge = (Just (K.EdgeRef HospitalOpen 0))+      , requirementTarget = Just HospitalRouted+      , requirementEventKinds = ["TransferNeedRouted"]+      }+  ]++behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport+behaviorCoverageReport witnesses =+  BehaviorConformanceReport+    { reportRequired = sortedKeys (Map.keys requiredByKey)+    , reportFilled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , reportPending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , reportMissing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , reportDuplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , reportStale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , reportFailed = sortOn (unBehaviorKey . failureKey) failures+    , reportVerified = sortedKeys [requirementKey requirement | (requirement, Right ()) <- executions, proofStrength requirement]+    , reportUnverified = sortedKeys [requirementKey requirement | (requirement, Right ()) <- executions, not (proofStrength requirement)]+    }+ where+  requiredByKey = Map.fromList [(requirementKey requirement, requirement) | requirement <- behaviorRequirements]+  witnessGroups = Map.fromListWith (flip (<>)) [(behaviorWitnessKey witness, [witness]) | witness <- witnesses]+  executions =+    [ (requirement, runWitness requirement witness)+    | (key, [witness]) <- Map.toList witnessGroups+    , not (isPending witness)+    , Just requirement <- [Map.lookup key requiredByKey]+    ]+  failures = [behaviorFailure | (_, Left behaviorFailure) <- executions]++behaviorConformancePassed :: BehaviorConformanceReport -> Bool+behaviorConformancePassed = behaviorConformancePassedWith False++behaviorConformancePassedWith :: Bool -> BehaviorConformanceReport -> Bool+behaviorConformancePassedWith failOnUnverified report =+  null (reportPending report)+    && null (reportMissing report)+    && null (reportDuplicate report)+    && null (reportStale report)+    && null (reportFailed report)+    && (not failOnUnverified || null (reportUnverified report))++renderBehaviorConformanceText :: BehaviorConformanceReport -> Text+renderBehaviorConformanceText report = T.unlines+  [ "behavior conformance: Hospital"+  , "schema: keiro/behavior-conformance/1"+  , countLine "required" (reportRequired report)+  , countLine "filled" (reportFilled report)+  , countLine "pending" (reportPending report)+  , countLine "missing" (reportMissing report)+  , countLine "duplicate" (reportDuplicate report)+  , countLine "stale" (reportStale report)+  , "failed: " <> tshow (length (reportFailed report))+  , countLine "verified" (reportVerified report)+  , countLine "unverified" (reportUnverified report)+  ] <> T.unlines ["FAIL " <> unBehaviorKey (failureKey behaviorFailure) <> " " <> failureSubject behaviorFailure <> " [" <> failureCode behaviorFailure <> "] " <> failureDetail behaviorFailure | behaviorFailure <- reportFailed report]++runWitness :: BehaviorRequirement -> BehaviorWitness -> Either BehaviorFailure ()+runWitness requirement witness = case witness of+  Pending _ -> failure requirement "pending" "witness is still Pending"+  LiveWitness _ history command expectation -> runLive requirement history command expectation+  ReplayWitness _ prefix chunk -> runReplay requirement prefix chunk++runLive :: BehaviorRequirement -> [HospitalEvent] -> HospitalCommand -> LiveExpectation -> Either BehaviorFailure ()+runLive requirement history command expectation = do+  settled <- settleHistory requirement "history" history+  ensure requirement (K.replaySuccessState settled == requirementSource requirement) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirementCommandName requirement) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirementKind requirement of+    ReplayTransition -> failure requirement "witness-kind" "a replay-only requirement needs ReplayWitness"+    RequiredRejection -> runRejection requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation+    LiveTransition -> runAcceptance requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation++runRejection :: BehaviorRequirement -> (HospitalVertex, K.RegFile HospitalRegs) -> HospitalCommand -> 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"+  Rejects expectedClass -> case K.stepDetailedEither hospitalTransducer seed command of+    Left K.NoOutgoingEdges {} -> ensure requirement (expectedClass == RejectNoOutgoingEdges) "rejection-class" "expected NoMatchingEdge but runtime returned NoOutgoingEdges"+    Left K.NoMatchingEdge {} -> ensure requirement (expectedClass == RejectNoMatchingEdge) "rejection-class" "expected NoOutgoingEdges but runtime returned NoMatchingEdge"+    Left K.AmbiguousEdges {} -> failure requirement "ambiguous-edges" "AmbiguousEdges can never satisfy a rejection witness"+    Right _ -> failure requirement "unexpected-acceptance" "runtime accepted a command required to reject"++runAcceptance :: BehaviorRequirement -> (HospitalVertex, K.RegFile HospitalRegs) -> HospitalCommand -> 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 hospitalTransducer seed command of+    Left stepFailure -> failure requirement "unexpected-rejection" (tshow stepFailure)+    Right success -> do+      checkAcceptedEnvelope requirement success+      ensure requirement (null (K.stepSuccessOutputs success)) "noop-emitted" "NoOp emitted one or more events"+      ensure requirement (K.stepSuccessState success == fst seed) "noop-vertex-change" "NoOp changed the control vertex"+      ensure requirement (regsEqual (K.stepSuccessRegs success) (snd seed)) "noop-register-change" "NoOp changed one or more registers"+  Emits expectedEvents -> case K.stepDetailedEither hospitalTransducer seed command of+    Left stepFailure -> failure requirement "unexpected-rejection" (tshow stepFailure)+    Right success -> do+      checkAcceptedEnvelope requirement success+      let expected = NonEmpty.toList expectedEvents+          actual = K.stepSuccessOutputs success+      ensure requirement (actual == expected) "event-value-mismatch" ("runtime event values differ from the exact witness expectation; 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 hospitalTransducer seed decoded of+        Left replayFailure -> failure requirement "emitted-replay-failed" (tshow replayFailure)+        Right replaySuccess -> Right replaySuccess+      ensure requirement (K.replaySuccessState replayed == K.stepSuccessState success) "forward-replay-vertex" "decoded emissions replay to a different vertex"+      ensure requirement (regsEqual (K.replaySuccessRegs replayed) (K.stepSuccessRegs success)) "forward-replay-registers" "decoded emissions replay to different registers"+      checkSingleAttribution requirement K.Live (length decoded) (K.replaySuccessTrace replayed)++checkAcceptedEnvelope :: BehaviorRequirement -> K.StepSuccess HospitalRegs HospitalVertex HospitalEvent -> Either BehaviorFailure ()+checkAcceptedEnvelope requirement success = do+  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 -> [HospitalEvent] -> [HospitalEvent] -> Either BehaviorFailure ()+runReplay requirement prefix chunk = case requirementKind requirement of+  ReplayTransition -> do+    settled <- settleHistory requirement "history-prefix" prefix+    ensure requirement (K.replaySuccessState settled == requirementSource requirement) "history-wrong-source" "history prefix does not settle at the replay edge source"+    ensure requirement (not (null chunk)) "empty-replay-chunk" "a replay-only edge has no observable empty chunk"+    decoded <- either (failure requirement "replay-chunk-codec-decode") Right (decodeEvents chunk)+    replayed <- case K.applyEventsDetailedEither hospitalTransducer (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; 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 HospitalVertex] -> 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; 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 -> [HospitalEvent] -> Either BehaviorFailure (K.ReplaySuccess HospitalRegs HospitalVertex)+settleHistory requirement label history = do+  decoded <- either (failure requirement (label <> "-codec-decode")) Right (decodeEvents history)+  case K.applyEventsDetailedEither hospitalTransducer (HospitalOpen, initialHospitalRegs) decoded of+    Left replayFailure -> failure requirement (label <> "-replay-failed") (tshow replayFailure)+    Right replaySuccess -> Right replaySuccess++decodeEvents :: [HospitalEvent] -> Either Text [HospitalEvent]+decodeEvents = traverse (\event -> parseHospitalEvent (Codec.eventType hospitalCodec event) (encodeHospitalEvent event))++commandKind :: HospitalCommand -> Text+commandKind command = case command of+  RouteAcceptedTransferNeed _ -> "RouteAcceptedTransferNeed"++eventKind :: HospitalEvent -> Text+eventKind event = case Codec.eventType hospitalCodec event of Codec.EventType tag -> tag++regsEqual :: K.RegFile HospitalRegs -> K.RegFile HospitalRegs -> Bool+regsEqual left right = (left K.! #routed) == (right K.! #routed)++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 :: BehaviorRequirement -> Text -> Text -> Either BehaviorFailure failed+failure requirement code detail =+  Left+    ( BehaviorFailure+        (requirementKey requirement)+        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey 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

+ test/conformance-declarative-router/Generated/TransferRouting/Hospital/Codec.hs view

@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedRecordDot #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit.+module Generated.TransferRouting.Hospital.Codec (+    hospitalCodec,+    parseHospitalEvent,+    encodeHospitalEvent,+) where++import Generated.TransferRouting.Hospital.Domain+import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty+import Data.Text (Text)+import qualified Data.Text as T+import Keiro.Codec (Codec (..), EventType (..))++++++hospitalEventTypes :: NonEmpty EventType+hospitalEventTypes = EventType "TransferNeedRouted" :| []++hospitalCodec :: Codec HospitalEvent+hospitalCodec =+  Codec+    { eventTypes = hospitalEventTypes+    , eventType = \case+        TransferNeedRouted{} -> EventType "TransferNeedRouted"+    , schemaVersion = 1+    , encode = encodeHospitalEvent+    , decode = parseHospitalEvent+    , upcasters = []+    }++encodeHospitalEvent :: HospitalEvent -> Value+encodeHospitalEvent = \case+  TransferNeedRouted payload ->+    object+      [ "kind" .= ("TransferNeedRouted" :: Text)+      , "transferNeedId" .= payload.transferNeedId+      , "hospitalId" .= payload.hospitalId+      ]++parseHospitalEvent :: EventType -> Value -> Either Text HospitalEvent+parseHospitalEvent (EventType tag) = mapLeftText . parseEither (withObject "HospitalEvent" go)+  where+    go o = do+      case tag of+        "TransferNeedRouted" ->+          TransferNeedRouted+            <$> ( TransferNeedRoutedData+                    <$> o .: "transferNeedId"+                    <*> o .: "hospitalId"+                )+        _ -> fail ("unknown event type " <> show tag <> "; expected one of: " <> renderExpectedEventTypes hospitalEventTypes)++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right++renderExpectedEventTypes :: NonEmpty EventType -> String+renderExpectedEventTypes =+  T.unpack+    . T.intercalate ", "+    . map (\(EventType eventTypeName) -> eventTypeName)+    . NonEmpty.toList

+ test/conformance-declarative-router/Generated/TransferRouting/Hospital/Domain.hs view

@@ -0,0 +1,45 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TemplateHaskell #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit.+module Generated.TransferRouting.Hospital.Domain where++import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++data HospitalVertex = HospitalOpen | HospitalRouted+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data RouteAcceptedTransferNeedData = RouteAcceptedTransferNeedData+  { transferNeedId :: !Text+  , hospitalId :: !Text+  }+  deriving stock (Generic, Eq, Show)++data HospitalCommand = RouteAcceptedTransferNeed !RouteAcceptedTransferNeedData+  deriving stock (Generic, Eq, Show)++data TransferNeedRoutedData = TransferNeedRoutedData+  { transferNeedId :: !Text+  , hospitalId :: !Text+  }+  deriving stock (Generic, Eq, Show)++data HospitalEvent = TransferNeedRouted !TransferNeedRoutedData+  deriving stock (Generic, Eq, Show)++type HospitalRegs =+  '[ '("routed", Bool)+   ]++initialHospitalRegs :: RegFile HospitalRegs+initialHospitalRegs =+  RCons (Proxy @"routed") False RNil++$(deriveAggregateCtorsAll ''HospitalCommand ''HospitalRegs)++++$(deriveWireCtorsAll ''HospitalEvent)

+ test/conformance-declarative-router/Generated/TransferRouting/Hospital/EventStream.hs view

@@ -0,0 +1,49 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit.+module Generated.TransferRouting.Hospital.EventStream+  ( hospitalCategory+  , hospitalCommandCategory+  , hospitalEventStream+  , hospitalEventStreamDef+  , HospitalEventStream+  , HospitalEventStreamDef+  ) where++import Generated.TransferRouting.Hospital.Domain+import Generated.TransferRouting.Hospital.Codec (hospitalCodec)+import Generated.TransferRouting.Hospital.Transducer (hospitalTransducer)+import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Stream qualified as Stream++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+hospitalCategory :: Stream.StreamCategory HospitalEventStreamDef+hospitalCategory = Stream.categoryUnsafe "hospital"++-- The same category text, typed for command envelopes such as PMCommand.+hospitalCommandCategory :: Stream.StreamCategory HospitalCommand+hospitalCommandCategory = Stream.categoryUnsafe "hospital"++type HospitalEventStreamDef =+  EventStream (HsPred HospitalRegs HospitalCommand) HospitalRegs HospitalVertex HospitalCommand HospitalEvent++type HospitalEventStream =+  ValidatedEventStream (HsPred HospitalRegs HospitalCommand) HospitalRegs HospitalVertex HospitalCommand HospitalEvent++hospitalEventStreamDef :: HospitalEventStreamDef+hospitalEventStreamDef =+  EventStream+    { transducer = hospitalTransducer,+      initialState = HospitalOpen,+      initialRegisters = initialHospitalRegs,+      eventCodec = hospitalCodec,+      resolveStreamName = Stream.streamName,+      snapshotPolicy = Never,+      stateCodec = Nothing+    }++hospitalEventStream :: HospitalEventStream+hospitalEventStream =+  mkEventStreamOrThrow "Hospital" hospitalEventStreamDef

+ test/conformance-declarative-router/Generated/TransferRouting/Hospital/Harness.hs view

@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedLabels #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit.+module Generated.TransferRouting.Hospital.Harness (harnessAssertions) where++import Generated.TransferRouting.Hospital.Domain+import Generated.TransferRouting.Hospital.Codec (encodeHospitalEvent, parseHospitalEvent, hospitalCodec)+import Generated.TransferRouting.Hospital.Transducer (hospitalTransducer)+import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!))+import Keiro.Codec (eventType)++-- | (label, passed). A driver runs these and exits non-zero on any False,+-- naming the failing assertion. Filling a hole wrongly turns a specific+-- entry False; the scaffold cannot.+harnessAssertions :: [(String, Bool)]+harnessAssertions =+  [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions hospitalTransducer))+  -- clock-free: spec samples no wall clock (verified at scaffold time)+  , ("golden round-trip: TransferNeedRouted", roundTrips sampleEventTransferNeedRouted)+  , ("accepts RouteAcceptedTransferNeed from HospitalOpen", acceptRouteAcceptedTransferNeed)+  ]+  ++ forwardReplayRouteAcceptedTransferNeed++roundTrips :: HospitalEvent -> Bool+roundTrips e = parseHospitalEvent (eventType hospitalCodec e) (encodeHospitalEvent e) == Right e++sampleEventTransferNeedRouted :: HospitalEvent+sampleEventTransferNeedRouted = TransferNeedRouted (TransferNeedRoutedData "sample-transferNeedId" "sample-hospitalId")++acceptRouteAcceptedTransferNeed :: Bool+acceptRouteAcceptedTransferNeed =+  case step hospitalTransducer (HospitalOpen, initialHospitalRegs) (RouteAcceptedTransferNeed (RouteAcceptedTransferNeedData "sample-transferNeedId" "sample-hospitalId")) of+    Just (v, _, _) -> v == HospitalRouted+    Nothing -> False++-- forward/replay equality (plan 147): cross the persisted codec boundary,+-- replay the emitted chain, and compare the final vertex and every register.+forwardReplayRouteAcceptedTransferNeed :: [(String, Bool)]+forwardReplayRouteAcceptedTransferNeed =+  case step hospitalTransducer (HospitalOpen, initialHospitalRegs) (RouteAcceptedTransferNeed (RouteAcceptedTransferNeedData "sample-transferNeedId" "sample-hospitalId")) of+    Nothing -> [(prefix <> "forward step accepted", False)]+    Just (forwardVertex, forwardRegs, emitted) ->+      case mapM (\event -> parseHospitalEvent (eventType hospitalCodec event) (encodeHospitalEvent event)) emitted of+        Left _ -> [(prefix <> "emitted chain decodes", False)]+        Right decodedEvents ->+          case applyEventsEither hospitalTransducer (HospitalOpen, initialHospitalRegs) decodedEvents of+            Left _ -> [(prefix <> "replay succeeds", False)]+            Right (replayVertex, replayRegs) ->+              [ (prefix <> "final vertex", replayVertex == forwardVertex)+              , (prefix <> "register routed", (replayRegs ! #routed) == (forwardRegs ! #routed))+              ]+  where+    prefix = "forward/replay equality: RouteAcceptedTransferNeed from HospitalOpen -- "

+ test/conformance-declarative-router/Generated/TransferRouting/Hospital/Projection.hs view

@@ -0,0 +1,4 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit.+module Generated.TransferRouting.Hospital.Projection () where++-- No projection declarations are present; this module keeps the generated manifest inventory total.

+ test/conformance-declarative-router/Generated/TransferRouting/Hospital/Transducer.hs view

@@ -0,0 +1,58 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit.+module Generated.TransferRouting.Hospital.Transducer+  ( hospitalTransducer+  , hospitalFoldFingerprint+  , BehaviorOwnership (..)+  , hospitalPredicateVerifications+  ) where++import Generated.TransferRouting.Hospital.Domain+import Data.Text (Text)+import Keiki.Builder qualified as B+import Keiki.Core (HsPred, SymTransducer)+import Keiki.Core qualified as K+import Keiki.Symbolic qualified as S+import Keiki.Builder ((=:))++hospitalTransducer+  :: SymTransducer+       (HsPred HospitalRegs HospitalCommand)+       HospitalRegs+       HospitalVertex+       HospitalCommand+       HospitalEvent+hospitalTransducer =+  B.buildTransducer HospitalOpen initialHospitalRegs isTerminal do+    B.from HospitalOpen do+      B.onCmd inCtorRouteAcceptedTransferNeed $ \d -> B.do+        B.slot @"routed" =: K.lit True+        B.emit wireTransferNeedRouted (TransferNeedRoutedTermFields+          { transferNeedId = d.transferNeedId+          , hospitalId = d.hospitalId+          })+        B.goto HospitalRouted+ where+  isTerminal = \case+    HospitalRouted -> True+    _ -> False++hospitalFoldFingerprint :: Text+hospitalFoldFingerprint = "35b11fb3a22be866c7e627b14a77d272"++data BehaviorOwnership = GeneratedOwned | HoleOwned+  deriving stock (Eq, Show)++-- Every checked transition predicate is audited through Keiki's conservative+-- symbolic verifier. Opaque Hole terms remain explicitly unverified.+hospitalPredicateVerifications :: IO [(Text, BehaviorOwnership, S.PredicateVerification)]+hospitalPredicateVerifications = sequence+  [ verifyTransition "transition1OpenRouteAcceptedTransferNeed" GeneratedOwned HospitalOpen 0+  ]+ where+  verifyTransition label owner source edgeIndex =+    case drop edgeIndex (K.edgesOut hospitalTransducer source) of+      K.Edge predicate _ _ _ _ : _ -> (\result -> (label, owner, result)) <$> S.verifyPredicate predicate+      [] -> pure (label, owner, S.UnverifiedSolverFailure "generated transition edge missing")

+ test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/QueryContract.hs view

@@ -0,0 +1,10 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel hospital_load; do not edit.+module Generated.TransferRouting.HospitalLoad.QueryContract+  ( HospitalLoadQueryInput+  , HospitalLoadQueryResult+  ) where++import Conformance.DeclarativeRouter.Domain (HospitalLoadRow, TransferRouteInput)++type HospitalLoadQueryInput = TransferRouteInput+type HospitalLoadQueryResult = [HospitalLoadRow]

+ test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/ReadModel.hs view

@@ -0,0 +1,28 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel hospital_load; do not edit.+module Generated.TransferRouting.HospitalLoad.ReadModel+  ( hospitalLoadReadModel+  , hospitalLoadQualifiedTable+  ) where++import Generated.TransferRouting.HospitalLoad.ReadModelTable (hospitalLoadQualifiedTable)+import Generated.TransferRouting.HospitalLoad.QueryContract (HospitalLoadQueryInput, HospitalLoadQueryResult)+import TransferRouting.HospitalLoad.ReadModelHoles (hospitalLoadQuery)+import Keiro.ReadModel (QueryCursorAuthority (..), ReadModel, ReadModelBlueprint (..), HeadScope (..), headWaitingReadModel)++hospitalLoadReadModel :: ReadModel HospitalLoadQueryInput HospitalLoadQueryResult+hospitalLoadReadModel =+  case headWaitingReadModel (CategoryVisibleHead "hospitalLoad") hospitalLoadReadModelBlueprint of+    Left definitionError -> error ("keiro-dsl generated an invalid waiting read model: " <> show definitionError)+    Right model -> model++hospitalLoadReadModelBlueprint :: ReadModelBlueprint HospitalLoadQueryInput HospitalLoadQueryResult+hospitalLoadReadModelBlueprint =+  ReadModelBlueprint+    { name = "transfer-routing-hospital-load"+    , tableName = "hospital_load"+    , schema = "public"+    , version = 1+    , shapeHash = "fnv1a:3c07a19c552c3547"+    , cursorAuthority = DurableQueryCursor "declarative-router-hospital-load"+    , query = hospitalLoadQuery+    }

+ test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/ReadModelHarness.hs view

@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedRecordDot #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel hospital_load; do not edit.+module Generated.TransferRouting.HospitalLoad.ReadModelHarness (readModelFacts, readModelFactResults, runReadModelFacts, catalogFactsAgainst) where++import Generated.TransferRouting.HospitalLoad.ReadModel (hospitalLoadReadModel)+import Data.Text qualified as T+import Data.List.NonEmpty qualified as NE+import Generated.TransferRouting.ProjectionCatalog qualified as ProjectionCatalog+import Keiro.Projection.Catalog qualified as Catalog+import Keiro.ReadModel (ReadModel (..), readModelCursorAuthority, readModelDefaultFreshness)++-- | (fact, expected from notation, actual generated runtime value).+readModelFacts :: [(String, String, String)]+readModelFacts =+  [ ("registryName", "transfer-routing-hospital-load", T.unpack hospitalLoadReadModel.name)+  , ("shapeHash", "fnv1a:3c07a19c552c3547", T.unpack hospitalLoadReadModel.shapeHash)+  , ("freshness", "WaitForHead (CategoryVisibleHead \"hospitalLoad\")", show (readModelDefaultFreshness hospitalLoadReadModel))+  , ("cursorAuthority", "DurableQueryCursor \"declarative-router-hospital-load\"", show (readModelCursorAuthority hospitalLoadReadModel))+  ]+    <> catalogFactsAgainst ProjectionCatalog.projectionCatalogRegistrations ProjectionCatalog.projectionCatalogAsyncRegistrations ProjectionCatalog.projectionCatalogQuerySupplies++catalogFactsAgainst :: [Catalog.CatalogRegistration] -> [Catalog.AsyncProjectionRegistration] -> [Catalog.ResolvedQuerySupply] -> [(String, String, String)]+catalogFactsAgainst registrations asyncRegistrations supplies =+  [ ("catalogRegistration", "transfer-routing-hospital-load|1|fnv1a:3c07a19c552c3547|reporting", renderRegistration [entry | entry <- registrations, Catalog.queryModelIdText entry.queryModelId == "hospital_load"])+  , ("querySupply", "hospital_load_writer|reporting|hospital_load_table", renderSupply [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "hospital_load"])+  , ("projectionDelivery", "subscription", renderDelivery [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "hospital_load"])+  , ("asyncRegistration:hospital_load_writer", "declarative-router-hospital-load|declarative-router-hospital-load-v1", renderAsync [entry | entry <- asyncRegistrations, Catalog.projectionIdText entry.projectionId == "hospital_load_writer"])+  ]++renderRegistration :: [Catalog.CatalogRegistration] -> String+renderRegistration [entry] = T.unpack entry.registryName <> "|" <> show entry.version <> "|" <> T.unpack entry.shapeHash <> "|" <> T.unpack (Catalog.rebuildGroupIdText entry.rebuildGroupId)+renderRegistration _ = "missing"++renderSupply :: [Catalog.ResolvedQuerySupply] -> String+renderSupply [entry] = T.unpack (Catalog.projectionIdText entry.resolvedProjectionId) <> "|" <> T.unpack (Catalog.rebuildGroupIdText entry.resolvedRebuildGroupId) <> "|" <> T.unpack (T.intercalate "," (map Catalog.targetIdText (NE.toList entry.resolvedObservedTargets)))+renderSupply _ = "missing"++renderDelivery :: [Catalog.ResolvedQuerySupply] -> String+renderDelivery [entry] = T.unpack (T.intercalate "," (map renderCapability (NE.toList entry.resolvedHandlerCapabilities)))+renderDelivery _ = "missing"++renderCapability :: Catalog.ProjectionHandlerCapability -> T.Text+renderCapability Catalog.InlineCapability {} = "inline"+renderCapability Catalog.SubscriptionCapability {} = "subscription"++renderAsync :: [Catalog.AsyncProjectionRegistration] -> String+renderAsync [entry] = T.unpack entry.subscriptionName <> "|" <> T.unpack entry.dedupName+renderAsync _ = "missing"++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)

+ test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/ReadModelTable.hs view

@@ -0,0 +1,9 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel hospital_load; do not edit.+module Generated.TransferRouting.HospitalLoad.ReadModelTable (hospitalLoadQualifiedTable) where++import Data.Text (Text)+import Keiro.Connection (qualifyTable)++-- The fully-qualified, double-quoted data-table reference.+hospitalLoadQualifiedTable :: Text+hospitalLoadQualifiedTable = qualifyTable "public" "hospital_load"

+ test/conformance-declarative-router/Generated/TransferRouting/HospitalTransferRouter/Router.hs view

@@ -0,0 +1,118 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from router HospitalTransferRouter; do not edit.+module Generated.TransferRouting.HospitalTransferRouter.Router+  ( hospitalTransferRouterName+  , hospitalTransferRouterWorkerOptions+  , hospitalTransferRouterSelectionFingerprint+  , hospitalTransferRouterSelectionContract+  , hospitalTransferRouterSelect+  , hospitalTransferRouter+  ) where++import Data.Text (Text)+import Effectful (Eff, IOE, (:>))+import Generated.TransferRouting.StructuralProjections qualified as StructuralProjections+import Generated.TransferRouting.HospitalLoad.QueryContract (HospitalLoadQueryInput)+import Generated.TransferRouting.HospitalLoad.ReadModel qualified as SelectionQuery+import Generated.TransferRouting.Hospital.Domain qualified as TargetDomain+import Generated.TransferRouting.Hospital.EventStream qualified as TargetStream+import Keiki.Core (HsPred, fieldWitnessGet)+import Keiro.ProcessManager (PMCommand (..), PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))+import Keiro.ReadModel (runQuery)+import Keiro.Router+  ( DeclarativeRouter (..)+  , EmptySelectionPolicy (..)+  , PartialDispatchPolicy (..)+  , RedeliveryPolicy (..)+  , RouterSelectionContract (..)+  , RouterSelectionFailure (..)+  , SelectionDedupe (..)+  , SelectionFailurePolicy (..)+  , SelectionFingerprint (..)+  , SelectionIdentity (..)+  , SelectionOrder (..)+  , mkRecipientLimit+  , mkSelectionVersion+  )+import Keiro.Stream (entityStream)+import Kiroku.Store.Effect (Store)+import Shibuya.Core.Ack (RetryDelay (..))++-- The STABLE router name. It remains part of every target-keyed+-- deterministic router command id; selection metadata never re-keys dispatches.+hospitalTransferRouterName :: Text+hospitalTransferRouterName = "hospital-transfer-router"++-- SHA-256 of the checked selection semantics (locations and formatting excluded).+hospitalTransferRouterSelectionFingerprint :: Text+hospitalTransferRouterSelectionFingerprint = "64cef46d4f1d19cda4ed0cf91b1e0d783f72580ef0cbabdd2b52c83a6fadc3a9"++hospitalTransferRouterSelectionContract :: RouterSelectionContract+hospitalTransferRouterSelectionContract =+  RouterSelectionContract+    { identity = SelectionIdentity "hospital-transfer-selection"+    , version = checkedSelectionVersion+    , fingerprint = SelectionFingerprint hospitalTransferRouterSelectionFingerprint+    , limit = checkedRecipientLimit+    , order = OrderByTargetStream+    , dedupe = DedupeByTargetStream+    , emptyPolicy = EmptyAck+    , failurePolicy = FailureRetry+    , redeliveryPolicy = StableUnion+    , partialPolicy = RetainSuccesses+    }+  where+    checkedSelectionVersion = case mkSelectionVersion 1 of+      Right value -> value+      Left _ -> error "keiro-dsl emitted a non-positive checked selection version"+    checkedRecipientLimit = case mkRecipientLimit 64 of+      Right value -> value+      Left _ -> error "keiro-dsl emitted a non-positive checked recipient limit"++hospitalTransferRouterSelect ::+  (IOE :> es, Store :> es) =>+  HospitalLoadQueryInput ->+  Eff es (Either RouterSelectionFailure [PMCommand TargetDomain.HospitalCommand])+hospitalTransferRouterSelect input = do+  queryResult <- runQuery Nothing SelectionQuery.hospitalLoadReadModel input+  pure $ case queryResult of+    Left _ -> Left (SelectionQueryFailed "read-model hospital_load query failed")+    Right rows ->+      Right+        [ PMCommand+            { target = entityStream TargetStream.hospitalCommandCategory ((fieldWitnessGet StructuralProjections.hospitalLoadRowHospitalIdWitness row))+            , command = TargetDomain.RouteAcceptedTransferNeed (TargetDomain.RouteAcceptedTransferNeedData ((fieldWitnessGet StructuralProjections.transferRouteInputTransferNeedIdWitness input)) ((fieldWitnessGet StructuralProjections.hospitalLoadRowHospitalIdWitness row)))+            }+        | row <- rows+        , (((fieldWitnessGet StructuralProjections.hospitalLoadRowRegionWitness row) == (fieldWitnessGet StructuralProjections.transferRouteInputRegionWitness input)) && ((fieldWitnessGet StructuralProjections.hospitalLoadRowAvailableBedsWitness row) > 0))+        ]++hospitalTransferRouter ::+  (IOE :> es, Store :> es) =>+  DeclarativeRouter+    HospitalLoadQueryInput+    (HsPred TargetDomain.HospitalRegs TargetDomain.HospitalCommand)+    TargetDomain.HospitalRegs+    TargetDomain.HospitalVertex+    TargetDomain.HospitalCommand+    TargetDomain.HospitalEvent+    es+hospitalTransferRouter =+  DeclarativeRouter+    { name = hospitalTransferRouterName+    , key = \input -> (fieldWitnessGet StructuralProjections.transferRouteInputTransferNeedIdWitness input)+    , selectionContract = hospitalTransferRouterSelectionContract+    , select = hospitalTransferRouterSelect+    , targetEventStream = TargetStream.hospitalEventStream+    , targetProjections = const []+    }++-- Node-level worker policy. Pair it with runDeclarativeRouterWorkerWith.+-- Selection empty/failure policy remains in the generated selection contract.+hospitalTransferRouterWorkerOptions :: WorkerOptions es msg+hospitalTransferRouterWorkerOptions =+  WorkerOptions+    { poisonPolicy = PoisonHalt,+      rejectedCommandPolicy = RejectedDeadLetter,+      transientRetryDelay = RetryDelay 5, -- matches defaultWorkerOptions; runtime tuning+      metrics = Nothing -- runtime configuration; install at call site+    }

+ test/conformance-declarative-router/Generated/TransferRouting/HospitalTransferRouter/RouterHarness.hs view

@@ -0,0 +1,28 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from router HospitalTransferRouter; do not edit.+module Generated.TransferRouting.HospitalTransferRouter.RouterHarness (routerHarnessValues) where++routerHarnessValues :: [(String, String)]+routerHarnessValues =+  [ ("routerName", "hospital-transfer-router")+  , ("keyField", "transferNeedId")+  , ("resolveSource", "declarative hospital-transfer-selection")+  , ("resolveRow", "")+  , ("dispatchCommand", "RouteAcceptedTransferNeed")+  , ("dispatchIdInputs", "(name, key, sourceEventId, targetStreamName, occurrence)")+  , ("onDuplicate", "AckOk")+  , ("onFailed", "Retry")+  , ("rejectedPolicy", "deadLetter")+  , ("poisonPolicy", "halt")+  , ("resolverOwnership", "generated-declarative")+  , ("queryIdentity", "hospital_load")+  , ("selectionIdentity", "hospital-transfer-selection")+  , ("selectionVersion", "1")+  , ("selectionFingerprint", "64cef46d4f1d19cda4ed0cf91b1e0d783f72580ef0cbabdd2b52c83a6fadc3a9")+  , ("maxRecipients", "64")+  , ("selectionOrder", "target-stream")+  , ("selectionDedupe", "target-stream")+  , ("emptyPolicy", "ack")+  , ("failurePolicy", "retry")+  , ("redeliveryPolicy", "stable-union")+  , ("partialPolicy", "retain-successes")+  ]

+ test/conformance-declarative-router/Generated/TransferRouting/ProjectionCatalog.hs view

@@ -0,0 +1,81 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from projection-catalog transfer-routing; do not edit.+{-# LANGUAGE OverloadedStrings #-}+module Generated.TransferRouting.ProjectionCatalog+  ( projectionCatalog+  , validatedProjectionCatalog+  , projectionCatalogInventory+  , projectionCatalogRegistrations+  , projectionCatalogAsyncRegistrations+  , projectionCatalogQuerySupplies+  , registerProjectionCatalog+  , hospitalLoadWriterProjectionSet+  , reportingRebuildGroupId+  , startReportingRebuild+  ) where++import Data.List.NonEmpty (NonEmpty (..))+import Effectful (Eff, IOE, (:>))+import Keiro.Projection (AsyncProjection (..))+import Keiro.Projection.Catalog qualified as Catalog+import Keiro.ReadModel.Rebuild qualified as Rebuild+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Types qualified as Kiroku+import Kiroku.Store.Subscription.Types qualified as KirokuSubscription+import TransferRouting.ProjectionCatalog.ProjectionCatalogHoles qualified as Holes+import Generated.TransferRouting.HospitalLoad.ReadModel qualified as RMHospitalLoad++must :: Show error => Either error value -> value+must = either (error . show) id++hospitalLoadWriterProjectionSet :: Catalog.ProjectionSet Holes.HospitalLoadWriterEvent+hospitalLoadWriterProjectionSet =+  Catalog.ProjectionSet+    (must (Catalog.mkSourceId "category:hospitalLoad"))+    (Catalog.ProjectionDefinition+      (must (Catalog.mkProjectionId "hospital_load_writer"))+      (must (Catalog.mkRebuildGroupId "reporting"))+      ((must (Catalog.mkTargetId "hospital_load_table")) :| [])+      (Catalog.Replayable (Catalog.ReplayAdapter Holes.decodeHospitalLoadWriterReplay Holes.applyHospitalLoadWriterReplay))+      (Catalog.AsyncHandler (AsyncProjection "declarative-router-hospital-load-v1" "transfer-routing-hospital-load" "declarative-router-hospital-load" Holes.applyHospitalLoadWriterLive Holes.hospitalLoadWriterIdempotencyKey) (must (Catalog.mkSubscriptionId "declarative-router-hospital-load")) (must (Catalog.mkDedupKeyId "declarative-router-hospital-load-v1")) (must (Catalog.mkClaimSite "projection-owner hospital_load_writer async-handler")) :| [])+      (must (Catalog.mkClaimSite "projection-owner hospital_load_writer"))+      :| [])+    (must (Catalog.mkClaimSite "projection-owner hospital_load_writer source"))++projectionCatalog :: Catalog.ProjectionCatalog+projectionCatalog =+  Catalog.ProjectionCatalog+    [Catalog.SourceDeclaration (must (Catalog.mkSourceId "category:hospitalLoad")) (Catalog.CategorySource (Kiroku.CategoryName "hospitalLoad")) "category:hospitalLoad/application-decoder/v1" (must (Catalog.mkClaimSite "source category:hospitalLoad"))]+    [Catalog.TargetDeclaration (must (Catalog.mkTargetId "hospital_load_table")) (Catalog.QualifiedTable "public" "hospital_load") Catalog.ClearBeforeReplay [] (must (Catalog.mkClaimSite "target hospital_load_table"))]+    [Catalog.RebuildGroupDeclaration (must (Catalog.mkRebuildGroupId "reporting")) [(must (Catalog.mkTargetId "hospital_load_table"))] [] (must (Catalog.mkClaimSite "rebuild-group reporting"))]+    []+    []+    [Catalog.SubscriptionDeclaration (must (Catalog.mkSubscriptionId "declarative-router-hospital-load")) "declarative-router-hospital-load" (must (Catalog.mkSourceId "category:hospitalLoad")) KirokuSubscription.FailIfMissing (must (Catalog.mkClaimSite "projection-owner hospital_load_writer subscription"))]+    [Catalog.DedupKeyDeclaration (must (Catalog.mkDedupKeyId "declarative-router-hospital-load-v1")) "declarative-router-hospital-load-v1" (must (Catalog.mkClaimSite "projection-owner hospital_load_writer dedup"))]+    [Catalog.SomeQueryModelBinding (Catalog.QueryModelBinding (must (Catalog.mkQueryModelId "hospital_load")) RMHospitalLoad.hospitalLoadReadModel (must (Catalog.mkRebuildGroupId "reporting")) [(must (Catalog.mkTargetId "hospital_load_table"))] (must (Catalog.mkClaimSite "readmodel hospital_load")))]+    [Catalog.SomeProjectionSet hospitalLoadWriterProjectionSet]++validatedProjectionCatalog :: Catalog.ValidatedProjectionCatalog+validatedProjectionCatalog = case Catalog.validateProjectionCatalog projectionCatalog of+  Catalog.Success catalog -> catalog+  Catalog.Failure diagnostics -> error ("keiro-dsl generated an invalid projection catalog: " <> show diagnostics)++projectionCatalogInventory :: Catalog.CatalogInventory+projectionCatalogInventory = Catalog.catalogInventory validatedProjectionCatalog++projectionCatalogRegistrations :: [Catalog.CatalogRegistration]+projectionCatalogRegistrations = Catalog.catalogRegistrations validatedProjectionCatalog++projectionCatalogAsyncRegistrations :: [Catalog.AsyncProjectionRegistration]+projectionCatalogAsyncRegistrations = Catalog.asyncProjectionRegistrations validatedProjectionCatalog++projectionCatalogQuerySupplies :: [Catalog.ResolvedQuerySupply]+projectionCatalogQuerySupplies = Catalog.resolvedQuerySupplies validatedProjectionCatalog++registerProjectionCatalog :: (Store :> es) => Eff es (Either Rebuild.CatalogRegistrationError [Rebuild.GroupRebuildMetadata])+registerProjectionCatalog = Rebuild.registerProjectionCatalog validatedProjectionCatalog++reportingRebuildGroupId :: Catalog.RebuildGroupId+reportingRebuildGroupId = (must (Catalog.mkRebuildGroupId "reporting"))++startReportingRebuild :: (IOE :> es, Store :> es) => Rebuild.RebuildOptions -> Eff es (Either Rebuild.CatalogRebuildError Rebuild.RebuildRunReport)+startReportingRebuild = Rebuild.startCatalogRebuild validatedProjectionCatalog reportingRebuildGroupId

+ test/conformance-declarative-router/Generated/TransferRouting/ReplayAudit.hs view

@@ -0,0 +1,23 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from context transfer-routing replay-audit assembly; do not edit.+--+-- Deployment contract:+--   * replay-neutral diff: no data audit is required;+--   * affected diff: run AuditTargeted with the emitted affected set+--     against a production copy under the candidate binary;+--   * one-time runtime cutover: run AuditFull;+--   * any non-zero audit exit blocks deployment.+module Generated.TransferRouting.ReplayAudit (auditTargets) where++import Generated.TransferRouting.Hospital.EventStream qualified as Hospital+import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory)+import Keiro.Stream qualified as Stream++auditTargets :: [SomeAuditTarget]+auditTargets =+  [ SomeAuditTarget+      AuditTarget+        { eventStream = Hospital.hospitalEventStream+        , category = Stream.categoryText Hospital.hospitalCategory+        , mkStream = streamInCategory (Stream.categoryText Hospital.hospitalCategory)+        }+  ]

+ test/conformance-declarative-router/Generated/TransferRouting/Structural/Shape/HospitalLoadRow.hs view

@@ -0,0 +1,12 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from mapped structural HospitalLoadRow; do not edit.+module Generated.TransferRouting.Structural.Shape.HospitalLoadRow (HospitalLoadRowShape (..)) where++import Data.Text (Text)+import GHC.Generics (Generic)++data HospitalLoadRowShape = HospitalLoadRow+  { hospitalId :: !Text+  , region :: !Text+  , availableBeds :: !Int+  }+  deriving stock (Eq, Generic, Show)

+ test/conformance-declarative-router/Generated/TransferRouting/Structural/Shape/TransferRouteInput.hs view

@@ -0,0 +1,11 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from mapped structural TransferRouteInput; do not edit.+module Generated.TransferRouting.Structural.Shape.TransferRouteInput (TransferRouteInputShape (..)) where++import Data.Text (Text)+import GHC.Generics (Generic)++data TransferRouteInputShape = TransferRouteInput+  { transferNeedId :: !Text+  , region :: !Text+  }+  deriving stock (Eq, Generic, Show)

+ test/conformance-declarative-router/Generated/TransferRouting/StructuralConformance.hs view

@@ -0,0 +1,74 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from context transfer-routing structural conformance; do not edit.+module Generated.TransferRouting.StructuralConformance+  ( structuralConformanceAssertions+  ) where++import Data.List (nub)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Proxy (Proxy (..))+import Data.Text qualified as T+import Keiki.Core (fieldWitnessAgrees)+import Keiki.Shape (CanonicalTypeName (..))+import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape)+import Generated.TransferRouting.StructuralProjections qualified as StructuralProjections+import Conformance.DeclarativeRouter.Bindings qualified as Bindings+import Conformance.DeclarativeRouter.Domain (HospitalLoadRow, TransferRouteInput)+import Generated.TransferRouting.Structural.Shape.HospitalLoadRow qualified as ShapeHospitalLoadRow+import Generated.TransferRouting.Structural.Shape.TransferRouteInput qualified as ShapeTransferRouteInput++structuralConformanceAssertions :: [(String, Bool)]+structuralConformanceAssertions =+  concat+    [ hospitalLoadRowBindingAssertions+    , transferRouteInputBindingAssertions+    , [("fixture coverage: conformance.declarative-router.HospitalLoadRow.v1", coverageHospitalLoadRow)]+    , [("fixture coverage: conformance.declarative-router.TransferRouteInput.v1", coverageTransferRouteInput)]+    , structuralProjectionAssertions+    ]++validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool+validFixtureLabels cases =+  all (not . T.null) labels && length labels == length (nub labels)+  where+    labels = map fst (NonEmpty.toList cases)++hospitalLoadRowBindingAssertions :: [(String, Bool)]+hospitalLoadRowBindingAssertions =+  ("fixture labels: conformance.declarative-router.HospitalLoadRow.v1", validFixtureLabels cases) :+  ("canonical identity: conformance.declarative-router.HospitalLoadRow.v1", canonicalTypeName (Proxy @HospitalLoadRow) == "conformance.declarative-router.HospitalLoadRow.v1") :+  concat+    [ [ ("binding domain round-trip: conformance.declarative-router.HospitalLoadRow.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.hospitalLoadRowBinding value)+      , ("binding shape round-trip: conformance.declarative-router.HospitalLoadRow.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.hospitalLoadRowBinding (bindingToShape Bindings.hospitalLoadRowBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.hospitalLoadRowCases++transferRouteInputBindingAssertions :: [(String, Bool)]+transferRouteInputBindingAssertions =+  ("fixture labels: conformance.declarative-router.TransferRouteInput.v1", validFixtureLabels cases) :+  ("canonical identity: conformance.declarative-router.TransferRouteInput.v1", canonicalTypeName (Proxy @TransferRouteInput) == "conformance.declarative-router.TransferRouteInput.v1") :+  concat+    [ [ ("binding domain round-trip: conformance.declarative-router.TransferRouteInput.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.transferRouteInputBinding value)+      , ("binding shape round-trip: conformance.declarative-router.TransferRouteInput.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.transferRouteInputBinding (bindingToShape Bindings.transferRouteInputBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.transferRouteInputCases++coverageHospitalLoadRow :: Bool+coverageHospitalLoadRow = True++coverageTransferRouteInput :: Bool+coverageTransferRouteInput = True++structuralProjectionAssertions :: [(String, Bool)]+structuralProjectionAssertions =+  [ ("projection witness agreement: conformance.declarative-router.HospitalLoadRow.v1/available_beds", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.hospitalLoadRowAvailableBedsWitness (\referenceOwner -> ShapeHospitalLoadRow.availableBeds (bindingToShape Bindings.hospitalLoadRowBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.hospitalLoadRowCases)))+  , ("projection witness agreement: conformance.declarative-router.HospitalLoadRow.v1/hospital_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.hospitalLoadRowHospitalIdWitness (\referenceOwner -> ShapeHospitalLoadRow.hospitalId (bindingToShape Bindings.hospitalLoadRowBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.hospitalLoadRowCases)))+  , ("projection witness agreement: conformance.declarative-router.HospitalLoadRow.v1/region", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.hospitalLoadRowRegionWitness (\referenceOwner -> ShapeHospitalLoadRow.region (bindingToShape Bindings.hospitalLoadRowBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.hospitalLoadRowCases)))+  , ("projection witness agreement: conformance.declarative-router.TransferRouteInput.v1/region", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.transferRouteInputRegionWitness (\referenceOwner -> ShapeTransferRouteInput.region (bindingToShape Bindings.transferRouteInputBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.transferRouteInputCases)))+  , ("projection witness agreement: conformance.declarative-router.TransferRouteInput.v1/transfer_need_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.transferRouteInputTransferNeedIdWitness (\referenceOwner -> ShapeTransferRouteInput.transferNeedId (bindingToShape Bindings.transferRouteInputBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.transferRouteInputCases)))+  ]

+ test/conformance-declarative-router/Generated/TransferRouting/StructuralProjections.hs view

@@ -0,0 +1,79 @@+{-# LANGUAGE TypeFamilies #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from context transfer-routing mapped structural facade; do not edit.+-- Equality witnesses are emitted for Text, Int, Bool, Natural, and UTCTime.+-- Int, Natural, and UTCTime belong to Keiki's ordered subset.+module Generated.TransferRouting.StructuralProjections+  ( hospitalLoadRowAvailableBedsWitness+  , hospitalLoadRowHospitalIdWitness+  , hospitalLoadRowRegionWitness+  , transferRouteInputRegionWitness+  , transferRouteInputTransferNeedIdWitness+  ) where++import Data.Text (Text)+import Keiro.Codec.Structural (bindingToShape)+import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)+import Conformance.DeclarativeRouter.Bindings qualified as Bindings+import Conformance.DeclarativeRouter.Domain (HospitalLoadRow, TransferRouteInput)+import Generated.TransferRouting.Structural.Shape.HospitalLoadRow qualified as ShapeHospitalLoadRow+import Generated.TransferRouting.Structural.Shape.TransferRouteInput qualified as ShapeTransferRouteInput++data HospitalLoadRowAvailableBedsProjection++instance FieldProjection HospitalLoadRowAvailableBedsProjection where+  type FieldName HospitalLoadRowAvailableBedsProjection = "/available_beds"+  type FieldOwner HospitalLoadRowAvailableBedsProjection = HospitalLoadRow+  type FieldResult HospitalLoadRowAvailableBedsProjection = Int+  fieldShapeId _ = "conformance.declarative-router.HospitalLoadRow.v1"+  projectFieldValue _ owner = ShapeHospitalLoadRow.availableBeds (bindingToShape Bindings.hospitalLoadRowBinding owner)++hospitalLoadRowAvailableBedsWitness :: FieldWitness HospitalLoadRowAvailableBedsProjection+hospitalLoadRowAvailableBedsWitness = fieldWitness @HospitalLoadRowAvailableBedsProjection++data HospitalLoadRowHospitalIdProjection++instance FieldProjection HospitalLoadRowHospitalIdProjection where+  type FieldName HospitalLoadRowHospitalIdProjection = "/hospital_id"+  type FieldOwner HospitalLoadRowHospitalIdProjection = HospitalLoadRow+  type FieldResult HospitalLoadRowHospitalIdProjection = Text+  fieldShapeId _ = "conformance.declarative-router.HospitalLoadRow.v1"+  projectFieldValue _ owner = ShapeHospitalLoadRow.hospitalId (bindingToShape Bindings.hospitalLoadRowBinding owner)++hospitalLoadRowHospitalIdWitness :: FieldWitness HospitalLoadRowHospitalIdProjection+hospitalLoadRowHospitalIdWitness = fieldWitness @HospitalLoadRowHospitalIdProjection++data HospitalLoadRowRegionProjection++instance FieldProjection HospitalLoadRowRegionProjection where+  type FieldName HospitalLoadRowRegionProjection = "/region"+  type FieldOwner HospitalLoadRowRegionProjection = HospitalLoadRow+  type FieldResult HospitalLoadRowRegionProjection = Text+  fieldShapeId _ = "conformance.declarative-router.HospitalLoadRow.v1"+  projectFieldValue _ owner = ShapeHospitalLoadRow.region (bindingToShape Bindings.hospitalLoadRowBinding owner)++hospitalLoadRowRegionWitness :: FieldWitness HospitalLoadRowRegionProjection+hospitalLoadRowRegionWitness = fieldWitness @HospitalLoadRowRegionProjection++data TransferRouteInputRegionProjection++instance FieldProjection TransferRouteInputRegionProjection where+  type FieldName TransferRouteInputRegionProjection = "/region"+  type FieldOwner TransferRouteInputRegionProjection = TransferRouteInput+  type FieldResult TransferRouteInputRegionProjection = Text+  fieldShapeId _ = "conformance.declarative-router.TransferRouteInput.v1"+  projectFieldValue _ owner = ShapeTransferRouteInput.region (bindingToShape Bindings.transferRouteInputBinding owner)++transferRouteInputRegionWitness :: FieldWitness TransferRouteInputRegionProjection+transferRouteInputRegionWitness = fieldWitness @TransferRouteInputRegionProjection++data TransferRouteInputTransferNeedIdProjection++instance FieldProjection TransferRouteInputTransferNeedIdProjection where+  type FieldName TransferRouteInputTransferNeedIdProjection = "/transfer_need_id"+  type FieldOwner TransferRouteInputTransferNeedIdProjection = TransferRouteInput+  type FieldResult TransferRouteInputTransferNeedIdProjection = Text+  fieldShapeId _ = "conformance.declarative-router.TransferRouteInput.v1"+  projectFieldValue _ owner = ShapeTransferRouteInput.transferNeedId (bindingToShape Bindings.transferRouteInputBinding owner)++transferRouteInputTransferNeedIdWitness :: FieldWitness TransferRouteInputTransferNeedIdProjection+transferRouteInputTransferNeedIdWitness = fieldWitness @TransferRouteInputTransferNeedIdProjection

+ test/conformance-declarative-router/Main.hs view

@@ -0,0 +1,203 @@+{-# LANGUAGE MultilineStrings #-}++module Main (main) where++import Conformance.DeclarativeRouter.Domain (TransferRouteInput (..))+import Control.Monad (unless)+import Data.Aeson (Value (Null))+import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (UTCTime (..), secondsToDiffTime)+import Data.Time.Calendar (Day (ModifiedJulianDay))+import Data.UUID qualified as UUID+import Data.Vector qualified as Vector+import Generated.TransferRouting.Hospital.Domain+  ( HospitalCommand (RouteAcceptedTransferNeed),+    RouteAcceptedTransferNeedData (..),+  )+import Generated.TransferRouting.Hospital.EventStream (hospitalCommandCategory, hospitalEventStream)+import Generated.TransferRouting.HospitalTransferRouter.Router+  ( hospitalTransferRouter,+    hospitalTransferRouterName,+    hospitalTransferRouterSelect,+    hospitalTransferRouterSelectionContract,+    hospitalTransferRouterSelectionFingerprint,+  )+import Generated.TransferRouting.HospitalTransferRouter.RouterHarness (routerHarnessValues)+import Generated.TransferRouting.StructuralConformance (structuralConformanceAssertions)+import Keiro.Command (defaultRunCommandOptions)+import Keiro.ProcessManager (PMCommand (..), PMCommandResult (..))+import Keiro.ReadModel (registerReadModel)+import Keiro.Router+  ( DeclarativeRouter (..),+    DeclarativeRouterResult (..),+    RouterResult (..),+    RouterSelectionFailure (..),+    mkRecipientLimit,+    normalizeRecipients,+    runDeclarativeRouterOnce,+  )+import Keiro.Stream (entityStream, streamName)+import Keiro.Test.Postgres (StoreRunner (..), withFreshResourceStore, withMigratedSuite)+import Kiroku.Store qualified as Store+import Kiroku.Store.Types+  ( EventId (..),+    EventType (..),+    GlobalPosition (..),+    RecordedEvent (..),+    StreamId (..),+    StreamName (..),+    StreamVersion (..),+  )+import Hasql.Transaction qualified as Tx++main :: IO ()+main =+  withMigratedSuite $ \fixture ->+    withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runStore) -> do+      mapM_ (uncurry assert) structuralConformanceAssertions+      assert "generated selection fingerprint is observable" (lengthText hospitalTransferRouterSelectionFingerprint == 64)+      assert "generated harness owns selection" (("resolverOwnership", "generated-declarative") `elem` routerHarnessValues)++      expectRight =<< runStore (Store.runTransaction (Tx.sql initialRowsSql))+      _ <- expectRight =<< runStore (registerReadModel readModelName 1 readModelShape)++      let input = TransferRouteInput "transfer-7" "west"+      selected <- expectRight =<< runStore (hospitalTransferRouterSelect input)+      selectedCommands <- expectSelection selected+      assert+        "query deliberately returns unstable order with an exact duplicate"+        (commandStreamNames selectedCommands == map StreamName ["hospital-hospital-b", "hospital-hospital-a", "hospital-hospital-a"])++      recipientLimit <- expectSelection (mkRecipientLimit 64)+      normalized <- expectSelection (normalizeRecipients recipientLimit selectedCommands)+      assert+        "generated selection normalizes to sorted unique physical targets"+        (commandStreamNames normalized == map StreamName ["hospital-hospital-a", "hospital-hospital-b"])++      first <- expectRight =<< runStore (runDeclarativeRouterOnce defaultRunCommandOptions hospitalTransferRouter sourceEvent input)+      assert "first attempt appends A and B in normalized order" (appendedThenAppended first)++      expectRight =<< runStore (Store.runTransaction (Tx.sql driftRowsSql))+      second <- expectRight =<< runStore (runDeclarativeRouterOnce defaultRunCommandOptions hospitalTransferRouter sourceEvent input)+      assert "redelivery keeps B and appends C" (duplicateThenAppended second)++      mapM_ (assertOneEvent runStore) ["hospital-hospital-a", "hospital-hospital-b", "hospital-hospital-c"]++      let conflictTarget = entityStream hospitalCommandCategory "conflict"+          conflictingCommands =+            [ PMCommand conflictTarget (RouteAcceptedTransferNeed (RouteAcceptedTransferNeedData "transfer-7" "conflict")),+              PMCommand conflictTarget (RouteAcceptedTransferNeed (RouteAcceptedTransferNeedData "transfer-mutated" "conflict"))+            ]+      conflict <-+        expectRight+          =<< runStore+            ( runDeclarativeRouterOnce+                defaultRunCommandOptions+                DeclarativeRouter+                  { name = hospitalTransferRouterName,+                    key = const "transfer-7",+                    selectionContract = hospitalTransferRouterSelectionContract,+                    select = \_ -> pure (Right conflictingCommands),+                    targetEventStream = hospitalEventStream,+                    targetProjections = const []+                  }+                sourceEvent+                input+            )+      assert "conflicting commands fail before dispatch" (isConflict conflict)+      assertNoEvents runStore "hospital-conflict"++      putStrLn "declarative router conformance: PASS"++readModelName :: Text+readModelName = "transfer-routing-hospital-load"++readModelShape :: Text+readModelShape = "fnv1a:3c07a19c552c3547"++initialRowsSql :: ByteString+initialRowsSql =+  """+  CREATE TABLE public.hospital_load (+    hospital_id text NOT NULL,+    region text NOT NULL,+    available_beds integer NOT NULL,+    query_order integer NOT NULL+  );+  INSERT INTO public.hospital_load (hospital_id, region, available_beds, query_order) VALUES+    ('hospital-b', 'west', 1, 1),+    ('hospital-a', 'west', 2, 2),+    ('hospital-a', 'west', 2, 3),+    ('hospital-z', 'west', 0, 4),+    ('hospital-east', 'east', 5, 5);+  """++driftRowsSql :: ByteString+driftRowsSql =+  """+  TRUNCATE public.hospital_load;+  INSERT INTO public.hospital_load (hospital_id, region, available_beds, query_order) VALUES+    ('hospital-c', 'west', 3, 1),+    ('hospital-b', 'west', 1, 2);+  """++sourceEvent :: RecordedEvent+sourceEvent =+  RecordedEvent+    { eventId = EventId sourceUuid,+      eventType = EventType "AcceptedHospitalTransferNeed",+      streamVersion = StreamVersion 1,+      globalPosition = GlobalPosition 1,+      originalStreamId = StreamId 1,+      originalVersion = StreamVersion 1,+      payload = Null,+      metadata = Nothing,+      causationId = Nothing,+      correlationId = Nothing,+      createdAt = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0)+    }++sourceUuid :: UUID.UUID+sourceUuid = case UUID.fromString "123e4567-e89b-12d3-a456-426614174000" of+  Just value -> value+  Nothing -> error "invalid static source UUID"++commandStreamNames :: [PMCommand command] -> [StreamName]+commandStreamNames = map (\(PMCommand target _) -> streamName target)++appendedThenAppended :: DeclarativeRouterResult target -> Bool+appendedThenAppended = \case+  DeclarativeSelectionDispatched (RouterResult [PMCommandAppended {}, PMCommandAppended {}]) -> True+  _ -> False++duplicateThenAppended :: DeclarativeRouterResult target -> Bool+duplicateThenAppended = \case+  DeclarativeSelectionDispatched (RouterResult [PMCommandDuplicate {}, PMCommandAppended {}]) -> True+  _ -> False++isConflict :: DeclarativeRouterResult target -> Bool+isConflict = \case+  DeclarativeSelectionFailed SelectionConflictingCommands {} -> True+  _ -> False++assertOneEvent runStore streamNameValue = do+  events <- expectRight =<< runStore (Store.readStreamForward (StreamName streamNameValue) (StreamVersion 0) 10)+  assert ("one event in " <> show streamNameValue) (Vector.length events == 1)++assertNoEvents runStore streamNameValue = do+  events <- expectRight =<< runStore (Store.readStreamForward (StreamName streamNameValue) (StreamVersion 0) 10)+  assert ("no event in " <> show streamNameValue) (Vector.null events)++expectRight :: (Show problem) => Either problem value -> IO value+expectRight = either (error . show) pure++expectSelection :: (Show problem) => Either problem value -> IO value+expectSelection = expectRight++lengthText :: Text -> Int+lengthText = Text.length++assert :: String -> Bool -> IO ()+assert label condition = unless condition (error ("declarative router conformance failed: " <> label))

+ test/conformance-declarative-router/TransferRouting/Hospital/BehaviorHoles.hs view

@@ -0,0 +1,10 @@+-- Consumer-owned behavioral witnesses. Created once; never overwritten.+module TransferRouting.Hospital.BehaviorHoles (behaviorWitnesses) where++import Generated.TransferRouting.Hospital.BehaviorContract++behaviorWitnesses :: [BehaviorWitness]+behaviorWitnesses =+  [ Pending (BehaviorKey "behavior-v1-51a443ca8bbb0eab") -- HospitalRouted x RouteAcceptedTransferNeed: required rejection+  , Pending (BehaviorKey "behavior-v1-6dc56a81dec7fe2b") -- HospitalOpen x RouteAcceptedTransferNeed: live transition+  ]

+ test/conformance-declarative-router/TransferRouting/HospitalLoad/ReadModelHoles.hs view

@@ -0,0 +1,38 @@+{-# LANGUAGE MultilineStrings #-}++-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.+module TransferRouting.HospitalLoad.ReadModelHoles+  ( hospitalLoadQuery+  ) where++import Generated.TransferRouting.HospitalLoad.ReadModelTable (hospitalLoadQualifiedTable)+import Generated.TransferRouting.HospitalLoad.QueryContract (HospitalLoadQueryInput, HospitalLoadQueryResult)+import Conformance.DeclarativeRouter.Domain (HospitalLoadRow (..), TransferRouteInput (..))+import Data.Text (Text)+import Hasql.Decoders qualified as D+import Hasql.Encoders qualified as E+import Hasql.Statement (Statement, preparable)+import Hasql.Transaction qualified as Tx++hospitalLoadQuery :: HospitalLoadQueryInput -> Tx.Transaction HospitalLoadQueryResult+hospitalLoadQuery (TransferRouteInput _transferNeedId inputRegion) =+  hospitalLoadQualifiedTable `seq` Tx.statement inputRegion hospitalLoadQueryStatement++hospitalLoadQueryStatement :: Statement Text [HospitalLoadRow]+hospitalLoadQueryStatement =+  preparable+    """+    SELECT hospital_id, region, available_beds+    FROM public.hospital_load+    WHERE region = $1+      AND available_beds > 0+    ORDER BY query_order+    """+    (E.param (E.nonNullable E.text))+    ( D.rowList+        ( HospitalLoadRow+            <$> D.column (D.nonNullable D.text)+            <*> D.column (D.nonNullable D.text)+            <*> (fromIntegral <$> D.column (D.nonNullable D.int4))+        )+    )

+ test/conformance-declarative-router/TransferRouting/ProjectionCatalog/ProjectionCatalogHoles.hs view

@@ -0,0 +1,23 @@+-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.+module TransferRouting.ProjectionCatalog.ProjectionCatalogHoles+  ( HospitalLoadWriterEvent+  , applyHospitalLoadWriterLive+  , hospitalLoadWriterIdempotencyKey+  , applyHospitalLoadWriterReplay+  , decodeHospitalLoadWriterReplay+  ) where++import Hasql.Transaction qualified as Tx+import Keiro.Projection.Catalog qualified as Catalog+import Kiroku.Store.Types (EventId, RecordedEvent)++-- Projection owner hospital_load_writer (order 10).+data HospitalLoadWriterEvent = HospitalLoadWriterEvent+applyHospitalLoadWriterLive :: RecordedEvent -> Tx.Transaction ()+applyHospitalLoadWriterLive = error "HOLE: fill hospital_load_writer live apply"+hospitalLoadWriterIdempotencyKey :: RecordedEvent -> EventId+hospitalLoadWriterIdempotencyKey = error "HOLE: return the durable event id for hospital_load_writer"+decodeHospitalLoadWriterReplay :: RecordedEvent -> Catalog.ReplayDecodeResult HospitalLoadWriterEvent+decodeHospitalLoadWriterReplay = error "HOLE: classify and decode every hospital_load_writer source event"+applyHospitalLoadWriterReplay :: HospitalLoadWriterEvent -> RecordedEvent -> Tx.Transaction ()+applyHospitalLoadWriterReplay = error "HOLE: fill hospital_load_writer replay apply without live-only side effects"

test/conformance-dispatch-full/Generated/HospitalCapacity/ReservationWork/Queue.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit. module Generated.HospitalCapacity.ReservationWork.Queue   ( ReservationWorkItem (..)   , encodeReservationWorkItem

test/conformance-dispatch-full/Generated/HospitalCapacity/ReservationWork/QueueCodec.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit. -- | Versioned job payload envelope: @{\"v\",\"t\",\"data\"}@. -- -- Deploy workers before producers when raising its schema version. Do not

test/conformance-dispatch-full/Generated/HospitalCapacity/ReservationWork/QueuePolicy.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit. module Generated.HospitalCapacity.ReservationWork.QueuePolicy   ( ReservationWorkOutcome (..)   , retryPolicy, jobOutcomeFor

+ test/conformance-domain-outcomes/DomainOutcomes/Reservation/BehaviorHoles.hs view

@@ -0,0 +1,31 @@+-- Consumer-owned behavioral witnesses. Created once; never overwritten.+module DomainOutcomes.Reservation.BehaviorHoles (behaviorWitnesses) where++import Generated.DomainOutcomes.Reservation.BehaviorContract+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Generated.DomainOutcomes.Nominals (ReservationNoOp (..), ReservationRejection (..))+import Generated.DomainOutcomes.Reservation.Domain++behaviorWitnesses :: [BehaviorWitness]+behaviorWitnesses =+  [ live "behavior-v1-0b1588f69a27bc77" [] firstRequest (Emits (cancelled "request-1" :| [])),+    live "behavior-v1-316c9e96fc1a94b1" cancelledHistory secondRequest (RejectedWith AlreadyCancelled),+    live "behavior-v1-fd391b55fbbfa640" cancelledHistory firstRequest (NoOpWith DuplicateRequest)+  ]++live :: Text -> [ReservationEvent] -> ReservationCommand -> LiveExpectation -> BehaviorWitness+live rawKey history command expectation =+  LiveWitness (BehaviorKey rawKey) history command expectation++cancelledHistory :: [ReservationEvent]+cancelledHistory = [cancelled "request-1"]++firstRequest :: ReservationCommand+firstRequest = Cancel (CancelData "request-1")++secondRequest :: ReservationCommand+secondRequest = Cancel (CancelData "request-2")++cancelled :: Text -> ReservationEvent+cancelled requestIdValue = Cancelled (CancelledData requestIdValue)

+ test/conformance-domain-outcomes/Generated/DomainOutcomes/BehaviorSourceMap.hs view

@@ -0,0 +1,31 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from context domain-outcomes behavior source map; do not edit.+module Generated.DomainOutcomes.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-0b1588f69a27bc77" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/domain-command-outcomes.keiro" 17 3)+  "behavior-v1-316c9e96fc1a94b1" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/domain-command-outcomes.keiro" 23 3)+  "behavior-v1-fd391b55fbbfa640" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/domain-command-outcomes.keiro" 28 3)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

+ test/conformance-domain-outcomes/Generated/DomainOutcomes/Nominals.hs view

@@ -0,0 +1,29 @@+{-# LANGUAGE DeriveAnyClass #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from context domain-outcomes generated nominal declarations; do not edit.+module Generated.DomainOutcomes.Nominals where++import Data.Aeson (FromJSON, ToJSON)+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Shape (CanonicalTypeName)++data ReservationNoOp = DuplicateRequest+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)+  deriving anyclass (ToJSON, FromJSON)++instance CanonicalTypeName ReservationNoOp++reservationNoOpText :: ReservationNoOp -> Text+reservationNoOpText = \case+  DuplicateRequest -> "duplicate-request"++data ReservationRejection = AlreadyCancelled | CapacityUnavailable+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)+  deriving anyclass (ToJSON, FromJSON)++instance CanonicalTypeName ReservationRejection++reservationRejectionText :: ReservationRejection -> Text+reservationRejectionText = \case+  AlreadyCancelled -> "already-cancelled"+  CapacityUnavailable -> "capacity-unavailable"

+ test/conformance-domain-outcomes/Generated/DomainOutcomes/ReplayAudit.hs view

@@ -0,0 +1,23 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from context domain-outcomes replay-audit assembly; do not edit.+--+-- Deployment contract:+--   * replay-neutral diff: no data audit is required;+--   * affected diff: run AuditTargeted with the emitted affected set+--     against a production copy under the candidate binary;+--   * one-time runtime cutover: run AuditFull;+--   * any non-zero audit exit blocks deployment.+module Generated.DomainOutcomes.ReplayAudit (auditTargets) where++import Generated.DomainOutcomes.Reservation.EventStream qualified as Reservation+import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory)+import Keiro.Stream qualified as Stream++auditTargets :: [SomeAuditTarget]+auditTargets =+  [ SomeAuditTarget+      AuditTarget+        { eventStream = Reservation.reservationEventStream+        , category = Stream.categoryText Reservation.reservationCategory+        , mkStream = streamInCategory (Stream.categoryText Reservation.reservationCategory)+        }+  ]

+ test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/BehaviorContract.hs view

@@ -0,0 +1,385 @@+{-# LANGUAGE OverloadedLabels #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit.+module Generated.DomainOutcomes.Reservation.BehaviorContract+  ( BehaviorKey (..)+  , ObligationKind (..)+  , EvidenceLevel (..)+  , GuardCoverage (..)+  , BehaviorRequirement (..)+  , RejectionClass (..)+  , LiveExpectation (..)+  , BehaviorWitness (..)+  , BehaviorFailure (..)+  , BehaviorConformanceReport (..)+  , behaviorRequirements+  , behaviorCoverageReport+  , behaviorConformancePassed+  , behaviorConformancePassedWith+  , renderBehaviorConformanceText+  ) where++import Generated.DomainOutcomes.Reservation.Codec (encodeReservationEvent, parseReservationEvent, reservationCodec)+import Generated.DomainOutcomes.Reservation.Domain+import Generated.DomainOutcomes.Reservation.Transducer (reservationTransducer)+import Generated.DomainOutcomes.BehaviorSourceMap qualified as BehaviorSourceMap+import Generated.DomainOutcomes.Reservation.EventStream (reservationDomainCommandHandler)+import Generated.DomainOutcomes.Nominals (ReservationNoOp, ReservationRejection)+import Keiro.Command (DomainCommandHandler (..), SilentCommandContext (..), SilentDomainDecision (..))+import Data.Aeson (ToJSON (..), object, (.=))+import Data.List (sortOn)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Keiki.Core qualified as K (EdgeMode (..), EdgeRef (..), RegFile, ReplayAttribution (..), ReplayEventSpan (..), ReplaySuccess (..), StepFailure (..), StepSuccess (..), applyEventsDetailedEither, stepDetailedEither, (!))+import Keiro.Codec qualified as Codec (Codec (eventType), EventType (..))++newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }+  deriving stock (Eq, Ord, Show)++data ObligationKind = LiveTransition | RequiredRejection | ReplayTransition+  deriving stock (Eq, Ord, Show)++data EvidenceLevel = GeneratedAuthoritative | HoleWitnessed | LegacyRuntimeWitness+  deriving stock (Eq, Ord, Show)++data GuardCoverage = GuardTotal | GuardPartial | GuardUnknown | GuardNotApplicable+  deriving stock (Eq, Ord, Show)++data BehaviorRequirement = BehaviorRequirement+  { requirementKey :: !BehaviorKey+  , requirementKind :: !ObligationKind+  , requirementEvidence :: !EvidenceLevel+  , requirementGuardCoverage :: !GuardCoverage+  , requirementSource :: !ReservationVertex+  , requirementCommandName :: !Text+  , requirementExpectedEdge :: !(Maybe (K.EdgeRef ReservationVertex))+  , requirementTarget :: !(Maybe ReservationVertex)+  , requirementEventKinds :: ![Text]+  }+  deriving stock (Eq, Show)++data RejectionClass = RejectNoOutgoingEdges | RejectNoMatchingEdge+  deriving stock (Eq, Show)++data LiveExpectation+  = Emits (NonEmpty ReservationEvent)+  | Rejects RejectionClass+  | RejectedWith ReservationRejection+  | NoOpWith ReservationNoOp+  | NoOp+  deriving stock (Eq, Show)++data BehaviorWitness+  = Pending BehaviorKey+  | LiveWitness+      { witnessKey :: BehaviorKey+      , witnessHistory :: [ReservationEvent]+      , witnessCommand :: ReservationCommand+      , witnessExpected :: LiveExpectation+      }+  | ReplayWitness+      { witnessKey :: BehaviorKey+      , witnessHistoryPrefix :: [ReservationEvent]+      , witnessObservedChunk :: [ReservationEvent]+      }+  deriving stock (Eq, Show)++data BehaviorFailure = BehaviorFailure+  { failureKey :: !BehaviorKey+  , failureSubject :: !Text+  , failureCode :: !Text+  , failureDetail :: !Text+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorFailure where+  toJSON behaviorFailure = object+    [ "key" .= unBehaviorKey (failureKey behaviorFailure)+    , "subject" .= failureSubject behaviorFailure+    , "code" .= failureCode behaviorFailure+    , "detail" .= failureDetail behaviorFailure+    ]++data BehaviorConformanceReport = BehaviorConformanceReport+  { reportRequired :: ![BehaviorKey]+  , reportFilled :: ![BehaviorKey]+  , reportPending :: ![BehaviorKey]+  , reportMissing :: ![BehaviorKey]+  , reportDuplicate :: ![BehaviorKey]+  , reportStale :: ![BehaviorKey]+  , reportFailed :: ![BehaviorFailure]+  , reportVerified :: ![BehaviorKey]+  , reportUnverified :: ![BehaviorKey]+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorConformanceReport where+  toJSON report = object+    [ "schema" .= ("keiro/behavior-conformance/1" :: Text)+    , "required" .= keyTexts (reportRequired report)+    , "filled" .= keyTexts (reportFilled report)+    , "pending" .= keyTexts (reportPending report)+    , "missing" .= keyTexts (reportMissing report)+    , "duplicate" .= keyTexts (reportDuplicate report)+    , "stale" .= keyTexts (reportStale report)+    , "failed" .= reportFailed report+    , "verified" .= keyTexts (reportVerified report)+    , "unverified" .= keyTexts (reportUnverified report)+    ]++behaviorRequirements :: [BehaviorRequirement]+behaviorRequirements =+  [ -- ReservationEligible x Cancel: live transition+    BehaviorRequirement+      { requirementKey = BehaviorKey "behavior-v1-0b1588f69a27bc77"+      , requirementKind = LiveTransition+      , requirementEvidence = GeneratedAuthoritative+      , requirementGuardCoverage = GuardTotal+      , requirementSource = ReservationEligible+      , requirementCommandName = "Cancel"+      , requirementExpectedEdge = (Just (K.EdgeRef ReservationEligible 0))+      , requirementTarget = Just ReservationCancelledState+      , requirementEventKinds = ["Cancelled"]+      }+  , -- ReservationCancelledState x Cancel: live transition+    BehaviorRequirement+      { requirementKey = BehaviorKey "behavior-v1-316c9e96fc1a94b1"+      , requirementKind = LiveTransition+      , requirementEvidence = GeneratedAuthoritative+      , requirementGuardCoverage = GuardTotal+      , requirementSource = ReservationCancelledState+      , requirementCommandName = "Cancel"+      , requirementExpectedEdge = (Just (K.EdgeRef ReservationCancelledState 0))+      , requirementTarget = Just ReservationCancelledState+      , requirementEventKinds = []+      }+  , -- ReservationCancelledState x Cancel: live transition+    BehaviorRequirement+      { requirementKey = BehaviorKey "behavior-v1-fd391b55fbbfa640"+      , requirementKind = LiveTransition+      , requirementEvidence = GeneratedAuthoritative+      , requirementGuardCoverage = GuardTotal+      , requirementSource = ReservationCancelledState+      , requirementCommandName = "Cancel"+      , requirementExpectedEdge = (Just (K.EdgeRef ReservationCancelledState 1))+      , requirementTarget = Just ReservationCancelledState+      , requirementEventKinds = []+      }+  ]++behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport+behaviorCoverageReport witnesses =+  BehaviorConformanceReport+    { reportRequired = sortedKeys (Map.keys requiredByKey)+    , reportFilled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , reportPending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , reportMissing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , reportDuplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , reportStale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , reportFailed = sortOn (unBehaviorKey . failureKey) failures+    , reportVerified = sortedKeys [requirementKey requirement | (requirement, Right ()) <- executions, proofStrength requirement]+    , reportUnverified = sortedKeys [requirementKey requirement | (requirement, Right ()) <- executions, not (proofStrength requirement)]+    }+ where+  requiredByKey = Map.fromList [(requirementKey requirement, requirement) | requirement <- behaviorRequirements]+  witnessGroups = Map.fromListWith (flip (<>)) [(behaviorWitnessKey witness, [witness]) | witness <- witnesses]+  executions =+    [ (requirement, runWitness requirement witness)+    | (key, [witness]) <- Map.toList witnessGroups+    , not (isPending witness)+    , Just requirement <- [Map.lookup key requiredByKey]+    ]+  failures = [behaviorFailure | (_, Left behaviorFailure) <- executions]++behaviorConformancePassed :: BehaviorConformanceReport -> Bool+behaviorConformancePassed = behaviorConformancePassedWith False++behaviorConformancePassedWith :: Bool -> BehaviorConformanceReport -> Bool+behaviorConformancePassedWith failOnUnverified report =+  null (reportPending report)+    && null (reportMissing report)+    && null (reportDuplicate report)+    && null (reportStale report)+    && null (reportFailed report)+    && (not failOnUnverified || null (reportUnverified report))++renderBehaviorConformanceText :: BehaviorConformanceReport -> Text+renderBehaviorConformanceText report = T.unlines+  [ "behavior conformance: Reservation"+  , "schema: keiro/behavior-conformance/1"+  , countLine "required" (reportRequired report)+  , countLine "filled" (reportFilled report)+  , countLine "pending" (reportPending report)+  , countLine "missing" (reportMissing report)+  , countLine "duplicate" (reportDuplicate report)+  , countLine "stale" (reportStale report)+  , "failed: " <> tshow (length (reportFailed report))+  , countLine "verified" (reportVerified report)+  , countLine "unverified" (reportUnverified report)+  ] <> T.unlines ["FAIL " <> unBehaviorKey (failureKey behaviorFailure) <> " " <> failureSubject behaviorFailure <> " [" <> failureCode behaviorFailure <> "] " <> failureDetail behaviorFailure | behaviorFailure <- reportFailed report]++runWitness :: BehaviorRequirement -> BehaviorWitness -> Either BehaviorFailure ()+runWitness requirement witness = case witness of+  Pending _ -> failure requirement "pending" "witness is still Pending"+  LiveWitness _ history command expectation -> runLive requirement history command expectation+  ReplayWitness _ prefix chunk -> runReplay requirement prefix chunk++runLive :: BehaviorRequirement -> [ReservationEvent] -> ReservationCommand -> LiveExpectation -> Either BehaviorFailure ()+runLive requirement history command expectation = do+  settled <- settleHistory requirement "history" history+  ensure requirement (K.replaySuccessState settled == requirementSource requirement) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirementCommandName requirement) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirementKind requirement of+    ReplayTransition -> failure requirement "witness-kind" "a replay-only requirement needs ReplayWitness"+    RequiredRejection -> runRejection requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation+    LiveTransition -> runAcceptance requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation++runRejection :: BehaviorRequirement -> (ReservationVertex, K.RegFile ReservationRegs) -> ReservationCommand -> LiveExpectation -> Either BehaviorFailure ()+runRejection requirement seed command expectation = case expectation of+  Emits _ -> failure requirement "expectation-kind" "a rejection requirement cannot expect emitted events"+  RejectedWith _ -> failure requirement "expectation-kind" "an unmatched-command rejection cannot expect a selected domain rejection"+  NoOpWith _ -> failure requirement "expectation-kind" "an unmatched-command rejection cannot expect a selected domain no-op"+  NoOp -> failure requirement "expectation-kind" "a rejection requirement cannot expect an accepted no-op"+  Rejects expectedClass -> case K.stepDetailedEither reservationTransducer seed command of+    Left K.NoOutgoingEdges {} -> ensure requirement (expectedClass == RejectNoOutgoingEdges) "rejection-class" "expected NoMatchingEdge but runtime returned NoOutgoingEdges"+    Left K.NoMatchingEdge {} -> ensure requirement (expectedClass == RejectNoMatchingEdge) "rejection-class" "expected NoOutgoingEdges but runtime returned NoMatchingEdge"+    Left K.AmbiguousEdges {} -> failure requirement "ambiguous-edges" "AmbiguousEdges can never satisfy a rejection witness"+    Right _ -> failure requirement "unexpected-acceptance" "runtime accepted a command required to reject"++runAcceptance :: BehaviorRequirement -> (ReservationVertex, K.RegFile ReservationRegs) -> ReservationCommand -> LiveExpectation -> Either BehaviorFailure ()+runAcceptance requirement seed command expectation = case expectation of+  Rejects _ -> failure requirement "expectation-kind" "a live-transition requirement needs Emits or NoOp"+  RejectedWith expectedReason -> do+    decision <- runSilentDecision requirement seed command+    case decision of+      SilentRejected actualReason -> ensure requirement (actualReason == expectedReason) "domain-rejection-reason" ("selected rejection reason differs; actual=" <> tshow actualReason <> " expected=" <> tshow expectedReason)+      SilentNoOp actualReason -> failure requirement "domain-outcome-kind" ("expected a selected rejection but classifier returned no-op " <> tshow actualReason)+  NoOpWith expectedReason -> do+    decision <- runSilentDecision requirement seed command+    case decision of+      SilentRejected actualReason -> failure requirement "domain-outcome-kind" ("expected a selected no-op but classifier returned rejection " <> tshow actualReason)+      SilentNoOp actualReason -> ensure requirement (actualReason == expectedReason) "domain-noop-reason" ("selected no-op reason differs; actual=" <> tshow actualReason <> " expected=" <> tshow expectedReason)+  NoOp -> failure requirement "expectation-kind" "an outcome-enabled transition requires RejectedWith or NoOpWith exact reason evidence"+  Emits expectedEvents -> case K.stepDetailedEither reservationTransducer seed command of+    Left stepFailure -> failure requirement "unexpected-rejection" (tshow stepFailure)+    Right success -> do+      checkAcceptedEnvelope requirement success+      let expected = NonEmpty.toList expectedEvents+          actual = K.stepSuccessOutputs success+      ensure requirement (actual == expected) "event-value-mismatch" ("runtime event values differ from the exact witness expectation; 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 reservationTransducer seed decoded of+        Left replayFailure -> failure requirement "emitted-replay-failed" (tshow replayFailure)+        Right replaySuccess -> Right replaySuccess+      ensure requirement (K.replaySuccessState replayed == K.stepSuccessState success) "forward-replay-vertex" "decoded emissions replay to a different vertex"+      ensure requirement (regsEqual (K.replaySuccessRegs replayed) (K.stepSuccessRegs success)) "forward-replay-registers" "decoded emissions replay to different registers"+      checkSingleAttribution requirement K.Live (length decoded) (K.replaySuccessTrace replayed)++runSilentDecision+  :: BehaviorRequirement+  -> (ReservationVertex, K.RegFile ReservationRegs)+  -> ReservationCommand+  -> Either BehaviorFailure (SilentDomainDecision ReservationRejection ReservationNoOp)+runSilentDecision requirement seed command = case K.stepDetailedEither reservationTransducer seed command of+  Left stepFailure -> failure requirement "unexpected-rejection" (tshow stepFailure)+  Right success -> do+    checkAcceptedEnvelope requirement success+    ensure requirement (null (K.stepSuccessOutputs success)) "silent-emitted" "typed silent outcome emitted one or more events"+    ensure requirement (K.stepSuccessState success == fst seed) "silent-vertex-change" "typed silent outcome changed the control vertex"+    ensure requirement (regsEqual (K.stepSuccessRegs success) (snd seed)) "silent-register-change" "typed silent outcome changed one or more registers"+    case reservationDomainCommandHandler of+      DomainCommandHandler _ classify ->+        Right (classify (SilentCommandContext (fst seed) (snd seed) command (K.stepSuccessEdge success)))++checkAcceptedEnvelope :: BehaviorRequirement -> K.StepSuccess ReservationRegs ReservationVertex ReservationEvent -> Either BehaviorFailure ()+checkAcceptedEnvelope requirement success = do+  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 -> [ReservationEvent] -> [ReservationEvent] -> Either BehaviorFailure ()+runReplay requirement prefix chunk = case requirementKind requirement of+  ReplayTransition -> do+    settled <- settleHistory requirement "history-prefix" prefix+    ensure requirement (K.replaySuccessState settled == requirementSource requirement) "history-wrong-source" "history prefix does not settle at the replay edge source"+    ensure requirement (not (null chunk)) "empty-replay-chunk" "a replay-only edge has no observable empty chunk"+    decoded <- either (failure requirement "replay-chunk-codec-decode") Right (decodeEvents chunk)+    replayed <- case K.applyEventsDetailedEither reservationTransducer (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; 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 ReservationVertex] -> 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; 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 -> [ReservationEvent] -> Either BehaviorFailure (K.ReplaySuccess ReservationRegs ReservationVertex)+settleHistory requirement label history = do+  decoded <- either (failure requirement (label <> "-codec-decode")) Right (decodeEvents history)+  case K.applyEventsDetailedEither reservationTransducer (ReservationEligible, initialReservationRegs) decoded of+    Left replayFailure -> failure requirement (label <> "-replay-failed") (tshow replayFailure)+    Right replaySuccess -> Right replaySuccess++decodeEvents :: [ReservationEvent] -> Either Text [ReservationEvent]+decodeEvents = traverse (\event -> parseReservationEvent (Codec.eventType reservationCodec event) (encodeReservationEvent event))++commandKind :: ReservationCommand -> Text+commandKind command = case command of+  Cancel _ -> "Cancel"++eventKind :: ReservationEvent -> Text+eventKind event = case Codec.eventType reservationCodec event of Codec.EventType tag -> tag++regsEqual :: K.RegFile ReservationRegs -> K.RegFile ReservationRegs -> Bool+regsEqual left right = (left K.! #lastRequestId) == (right K.! #lastRequestId)++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 :: BehaviorRequirement -> Text -> Text -> Either BehaviorFailure failed+failure requirement code detail =+  Left+    ( BehaviorFailure+        (requirementKey requirement)+        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey 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

+ test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Codec.hs view

@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedRecordDot #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit.+module Generated.DomainOutcomes.Reservation.Codec (+    reservationCodec,+    parseReservationEvent,+    encodeReservationEvent,+) where++import Generated.DomainOutcomes.Reservation.Domain+import Data.Aeson (Value, object, withObject, (.:), (.=))+import Data.Aeson.Types (parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty+import Data.Text (Text)+import qualified Data.Text as T+import Keiro.Codec (Codec (..), EventType (..))++++++reservationEventTypes :: NonEmpty EventType+reservationEventTypes = EventType "Cancelled" :| []++reservationCodec :: Codec ReservationEvent+reservationCodec =+  Codec+    { eventTypes = reservationEventTypes+    , eventType = \case+        Cancelled{} -> EventType "Cancelled"+    , schemaVersion = 1+    , encode = encodeReservationEvent+    , decode = parseReservationEvent+    , upcasters = []+    }++encodeReservationEvent :: ReservationEvent -> Value+encodeReservationEvent = \case+  Cancelled payload ->+    object+      [ "kind" .= ("Cancelled" :: Text)+      , "requestId" .= payload.requestId+      ]++parseReservationEvent :: EventType -> Value -> Either Text ReservationEvent+parseReservationEvent (EventType tag) = mapLeftText . parseEither (withObject "ReservationEvent" go)+  where+    go o = do+      case tag of+        "Cancelled" ->+          Cancelled+            <$> ( CancelledData+                    <$> o .: "requestId"+                )+        _ -> fail ("unknown event type " <> show tag <> "; expected one of: " <> renderExpectedEventTypes reservationEventTypes)++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right++renderExpectedEventTypes :: NonEmpty EventType -> String+renderExpectedEventTypes =+  T.unpack+    . T.intercalate ", "+    . map (\(EventType eventTypeName) -> eventTypeName)+    . NonEmpty.toList

+ test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Domain.hs view

@@ -0,0 +1,43 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TemplateHaskell #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit.+module Generated.DomainOutcomes.Reservation.Domain where++import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++data ReservationVertex = ReservationEligible | ReservationCancelledState+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data CancelData = CancelData+  { requestId :: !Text+  }+  deriving stock (Generic, Eq, Show)++data ReservationCommand = Cancel !CancelData+  deriving stock (Generic, Eq, Show)++data CancelledData = CancelledData+  { requestId :: !Text+  }+  deriving stock (Generic, Eq, Show)++data ReservationEvent = Cancelled !CancelledData+  deriving stock (Generic, Eq, Show)++type ReservationRegs =+  '[ '("lastRequestId", Text)+   ]++initialReservationRegs :: RegFile ReservationRegs+initialReservationRegs =+  RCons (Proxy @"lastRequestId") "none" RNil++$(deriveAggregateCtorsAll ''ReservationCommand ''ReservationRegs)++++$(deriveWireCtorsAll ''ReservationEvent)

+ test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/EventStream.hs view

@@ -0,0 +1,82 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit.+module Generated.DomainOutcomes.Reservation.EventStream+  ( reservationCategory+  , reservationCommandCategory+  , reservationEventStream+  , reservationEventStreamDef+  , ReservationEventStream+  , ReservationEventStreamDef+  , reservationDomainCommandHandler+  ) where++import Generated.DomainOutcomes.Reservation.Domain+import Generated.DomainOutcomes.Reservation.Codec (reservationCodec)+import Generated.DomainOutcomes.Reservation.Transducer (reservationTransducer)+import Generated.DomainOutcomes.Nominals (ReservationNoOp (..), ReservationRejection (..))+import Keiki.Core (EdgeRef (..), HsPred)+import Keiki.Core qualified as K+import Keiro.Command (DomainCommandHandler (..), SilentCommandContext (..), SilentDomainDecision (..))+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Stream qualified as Stream++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+reservationCategory :: Stream.StreamCategory ReservationEventStreamDef+reservationCategory = Stream.categoryUnsafe "reservation"++-- The same category text, typed for command envelopes such as PMCommand.+reservationCommandCategory :: Stream.StreamCategory ReservationCommand+reservationCommandCategory = Stream.categoryUnsafe "reservation"++type ReservationEventStreamDef =+  EventStream (HsPred ReservationRegs ReservationCommand) ReservationRegs ReservationVertex ReservationCommand ReservationEvent++type ReservationEventStream =+  ValidatedEventStream (HsPred ReservationRegs ReservationCommand) ReservationRegs ReservationVertex ReservationCommand ReservationEvent++reservationEventStreamDef :: ReservationEventStreamDef+reservationEventStreamDef =+  EventStream+    { transducer = reservationTransducer,+      initialState = ReservationEligible,+      initialRegisters = initialReservationRegs,+      eventCodec = reservationCodec,+      resolveStreamName = Stream.streamName,+      snapshotPolicy = Never,+      stateCodec = Nothing+    }++reservationEventStream :: ReservationEventStream+reservationEventStream =+  mkEventStreamOrThrow "Reservation" reservationEventStreamDef++reservationDomainCommandHandler+  :: DomainCommandHandler+       (HsPred ReservationRegs ReservationCommand)+       ReservationRegs+       ReservationVertex+       ReservationCommand+       ReservationEvent+       ReservationRejection+       ReservationNoOp+reservationDomainCommandHandler =+  DomainCommandHandler reservationEventStream reservationSilentDecision++reservationSilentDecision+  :: SilentCommandContext ReservationRegs ReservationVertex ReservationCommand+  -> SilentDomainDecision+       ReservationRejection+       ReservationNoOp+reservationSilentDecision (SilentCommandContext _ registers command (EdgeRef edgeSource edgeIndex)) =+  case edgeSource of+    ReservationCancelledState ->+      case edgeIndex of+        0 -> SilentRejected (K.evalTerm (K.lit AlreadyCancelled) registers command)+        1 -> SilentNoOp (K.evalTerm (K.lit DuplicateRequest) registers command)+        _ -> outcomeInvariant edgeSource edgeIndex+    _ -> outcomeInvariant edgeSource edgeIndex+ where+  outcomeInvariant source index =+    error ("generated domain outcome invariant failed for aggregate Reservation edge " <> show source <> "#" <> show index)

+ test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Harness.hs view

@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedLabels #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit.+module Generated.DomainOutcomes.Reservation.Harness (harnessAssertions) where++import Generated.DomainOutcomes.Reservation.Domain+import Generated.DomainOutcomes.Reservation.Codec (encodeReservationEvent, parseReservationEvent, reservationCodec)+import Generated.DomainOutcomes.Reservation.Transducer (reservationTransducer)+import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!))+import Keiro.Codec (eventType)++-- | (label, passed). A driver runs these and exits non-zero on any False,+-- naming the failing assertion. Filling a hole wrongly turns a specific+-- entry False; the scaffold cannot.+harnessAssertions :: [(String, Bool)]+harnessAssertions =+  [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions reservationTransducer))+  -- clock-free: spec samples no wall clock (verified at scaffold time)+  , ("golden round-trip: Cancelled", roundTrips sampleEventCancelled)+  , ("accepts Cancel from ReservationEligible", acceptCancel)+  ]+  ++ forwardReplayCancel++roundTrips :: ReservationEvent -> Bool+roundTrips e = parseReservationEvent (eventType reservationCodec e) (encodeReservationEvent e) == Right e++sampleEventCancelled :: ReservationEvent+sampleEventCancelled = Cancelled (CancelledData "sample-requestId")++acceptCancel :: Bool+acceptCancel =+  case step reservationTransducer (ReservationEligible, initialReservationRegs) (Cancel (CancelData "sample-requestId")) of+    Just (v, _, _) -> v == ReservationCancelledState+    Nothing -> False++-- forward/replay equality (plan 147): cross the persisted codec boundary,+-- replay the emitted chain, and compare the final vertex and every register.+forwardReplayCancel :: [(String, Bool)]+forwardReplayCancel =+  case step reservationTransducer (ReservationEligible, initialReservationRegs) (Cancel (CancelData "sample-requestId")) of+    Nothing -> [(prefix <> "forward step accepted", False)]+    Just (forwardVertex, forwardRegs, emitted) ->+      case mapM (\event -> parseReservationEvent (eventType reservationCodec event) (encodeReservationEvent event)) emitted of+        Left _ -> [(prefix <> "emitted chain decodes", False)]+        Right decodedEvents ->+          case applyEventsEither reservationTransducer (ReservationEligible, initialReservationRegs) decodedEvents of+            Left _ -> [(prefix <> "replay succeeds", False)]+            Right (replayVertex, replayRegs) ->+              [ (prefix <> "final vertex", replayVertex == forwardVertex)+              , (prefix <> "register lastRequestId", (replayRegs ! #lastRequestId) == (forwardRegs ! #lastRequestId))+              ]+  where+    prefix = "forward/replay equality: Cancel from ReservationEligible -- "

+ test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Projection.hs view

@@ -0,0 +1,4 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit.+module Generated.DomainOutcomes.Reservation.Projection () where++-- No projection declarations are present; this module keeps the generated manifest inventory total.

+ test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Transducer.hs view

@@ -0,0 +1,70 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit.+module Generated.DomainOutcomes.Reservation.Transducer+  ( reservationTransducer+  , reservationFoldFingerprint+  , BehaviorOwnership (..)+  , reservationPredicateVerifications+  ) where++import Generated.DomainOutcomes.Reservation.Domain+import Data.Text (Text)+import Keiki.Builder qualified as B+import Keiki.Core (HsPred, SymTransducer, (.==), (./=))+import Keiki.Core qualified as K+import Keiki.Symbolic qualified as S+import Keiki.Builder ((=:))++reservationTransducer+  :: SymTransducer+       (HsPred ReservationRegs ReservationCommand)+       ReservationRegs+       ReservationVertex+       ReservationCommand+       ReservationEvent+reservationTransducer =+  B.buildTransducer ReservationEligible initialReservationRegs isTerminal do+    B.from ReservationEligible do+      B.onCmd inCtorCancel $ \d -> B.do+        B.slot @"lastRequestId" =: d.requestId+        B.emit wireCancelled (CancelledTermFields+          { requestId = d.requestId+          })+        B.goto ReservationCancelledState+    B.from ReservationCancelledState do+      B.onCmd inCtorCancel $ \d -> B.do+        B.requireGuard $+          d.requestId ./= B.reg @"lastRequestId"+        B.noEmit+        B.goto ReservationCancelledState+      B.onCmd inCtorCancel $ \d -> B.do+        B.requireGuard $+          d.requestId .== B.reg @"lastRequestId"+        B.noEmit+        B.goto ReservationCancelledState+ where+  isTerminal = \case++    _ -> False++reservationFoldFingerprint :: Text+reservationFoldFingerprint = "a1d8c04b7c9f5541e83081e8d7c51cad"++data BehaviorOwnership = GeneratedOwned | HoleOwned+  deriving stock (Eq, Show)++-- Every checked transition predicate is audited through Keiki's conservative+-- symbolic verifier. Opaque Hole terms remain explicitly unverified.+reservationPredicateVerifications :: IO [(Text, BehaviorOwnership, S.PredicateVerification)]+reservationPredicateVerifications = sequence+  [ verifyTransition "transition1EligibleCancel" GeneratedOwned ReservationEligible 0+  , verifyTransition "transition2CancelledStateCancel" GeneratedOwned ReservationCancelledState 0+  , verifyTransition "transition3CancelledStateCancel" GeneratedOwned ReservationCancelledState 1+  ]+ where+  verifyTransition label owner source edgeIndex =+    case drop edgeIndex (K.edgesOut reservationTransducer source) of+      K.Edge predicate _ _ _ _ : _ -> (\result -> (label, owner, result)) <$> S.verifyPredicate predicate+      [] -> pure (label, owner, S.UnverifiedSolverFailure "generated transition edge missing")

+ test/conformance-domain-outcomes/Main.hs view

@@ -0,0 +1,14 @@+module Main (main) where++import DomainOutcomes.Reservation.BehaviorHoles (behaviorWitnesses)+import Generated.DomainOutcomes.Reservation.BehaviorContract+import System.Exit (exitFailure)++main :: IO ()+main = do+  let report = behaviorCoverageReport behaviorWitnesses+  if behaviorConformancePassedWith True report+    then pure ()+    else do+      putStrLn (show report)+      exitFailure

+ test/conformance-id-domain-migration/Generated/IdDomainMigration/BehaviorSourceMap.hs view

@@ -0,0 +1,30 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 3) from context id-domain-migration behavior source map; do not edit.+module Generated.IdDomainMigration.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-6b331af859e674ea" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/id-domain-migration-v3.keiro" 9 16)+  "behavior-v1-a396f60ddb8f99be" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/id-domain-migration-v3.keiro" 14 3)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-id-domain-migration/Generated/IdDomainMigration/Nominals.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 3) from context id-domain-migration generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 3) from context id-domain-migration generated nominal declarations; do not edit. module Generated.IdDomainMigration.Nominals   ( OrderId   , parseOrderId

test/conformance-id-domain-migration/Generated/IdDomainMigration/Nominals/Internal.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 3) from context id-domain-migration generated nominal ID internals; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 3) from context id-domain-migration generated nominal ID internals; do not edit. module Generated.IdDomainMigration.Nominals.Internal   ( OrderId   , parseOrderId

test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 3) from aggregate OrderBook; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 3) from aggregate OrderBook; do not edit. module Generated.IdDomainMigration.OrderBook.Codec (     orderBookCodec,     parseOrderBookEvent,

test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Domain.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 3) from aggregate OrderBook; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 3) from aggregate OrderBook; do not edit. module Generated.IdDomainMigration.OrderBook.Domain where  import Data.Aeson (FromJSON, ToJSON)

+ test/conformance-import-planning/Generated/ImportPlanningCollisions/BehaviorSourceMap.hs view

@@ -0,0 +1,30 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context import-planning-collisions behavior source map; do not edit.+module Generated.ImportPlanningCollisions.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-2134fce4a19c59d7" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/import-planning-collisions.keiro" 49 3)+  "behavior-v1-995f9bf710ce7c6c" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/import-planning-collisions.keiro" 41 16)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/BehaviorContract.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit. module Generated.ImportPlanningCollisions.CollisionLedger.BehaviorContract   ( BehaviorKey (..)   , ObligationKind (..)@@ -20,6 +20,7 @@ import Generated.ImportPlanningCollisions.CollisionLedger.Codec (encodeCollisionLedgerEvent, parseCollisionLedgerEvent, collisionLedgerCodec) import Generated.ImportPlanningCollisions.CollisionLedger.Domain import Generated.ImportPlanningCollisions.CollisionLedger.Transducer (collisionLedgerTransducer)+import Generated.ImportPlanningCollisions.BehaviorSourceMap qualified as BehaviorSourceMap import Data.Aeson (ToJSON (..), object, (.=)) import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty)@@ -52,7 +53,6 @@   , requirementExpectedEdge :: !(Maybe (K.EdgeRef CollisionLedgerVertex))   , requirementTarget :: !(Maybe CollisionLedgerVertex)   , requirementEventKinds :: ![Text]-  , requirementLine :: !Int   }   deriving stock (Eq, Show) @@ -125,7 +125,7 @@  behaviorRequirements :: [BehaviorRequirement] behaviorRequirements =-  [ -- CollisionLedgerEmpty x Record: live transition (spec line 49)+  [ -- CollisionLedgerEmpty x Record: live transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-2134fce4a19c59d7"       , requirementKind = LiveTransition@@ -136,9 +136,8 @@       , requirementExpectedEdge = (Just (K.EdgeRef CollisionLedgerEmpty 0))       , requirementTarget = Just CollisionLedgerRecorded       , requirementEventKinds = ["RecordedValues"]-      , requirementLine = 49       }-  , -- CollisionLedgerRecorded x Record: required rejection (spec line 41)+  , -- CollisionLedgerRecorded x Record: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-995f9bf710ce7c6c"       , requirementKind = RequiredRejection@@ -149,7 +148,6 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 41       }   ] @@ -328,7 +326,7 @@   Left     ( BehaviorFailure         (requirementKey requirement)-        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (spec line " <> tshow (requirementLine requirement) <> ")")+        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey requirement)) <> ")")         code         detail     )

test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit. module Generated.ImportPlanningCollisions.CollisionLedger.Codec (     collisionLedgerCodec,     parseCollisionLedgerEvent,

test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Domain.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit. module Generated.ImportPlanningCollisions.CollisionLedger.Domain where  import GHC.Generics (Generic)

test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit. module Generated.ImportPlanningCollisions.CollisionLedger.EventStream   ( collisionLedgerCategory   , collisionLedgerCommandCategory

test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Harness.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit. module Generated.ImportPlanningCollisions.CollisionLedger.Harness (harnessAssertions) where  import Generated.ImportPlanningCollisions.CollisionLedger.Domain@@ -10,18 +10,12 @@ import Data.Aeson.Key qualified as AesonKey import Data.Aeson.KeyMap qualified as AesonKeyMap import Data.Either (isLeft)-import Data.List (nub)-import Data.Proxy (Proxy (..)) import Data.Text qualified as T-import Keiki.Shape (CanonicalTypeName (..))-import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape)-import Generated.ImportPlanningCollisions.StructuralProjections qualified as StructuralProjections+import Keiro.Codec.Structural (FixtureCases (..)) import Data.List.NonEmpty qualified as NonEmpty import Keiro.Codec.Nominal (nominalDomainRoundTrip, nominalFixtureCases, nominalFixtureDomain, nominalRepresentationRoundTrip, nominalToRepresentation) import Generated.ImportPlanningCollisions.NominalProjections qualified as NominalProjections-import Generated.ImportPlanningCollisions.Structural.Shape.Details qualified as ShapeDetails import ImportPlanning.Bindings qualified as Bindings-import ImportPlanning.Consumer.Shared.Types (Details)  -- | (label, passed). A driver runs these and exits non-zero on any False, -- naming the failing assertion. Filling a hole wrongly turns a specific@@ -70,35 +64,10 @@ mappedConformanceAssertions :: [(String, Bool)] mappedConformanceAssertions =   concat-    [ detailsBindingAssertions-    , [("fixture coverage: import-planning.Details.v1", coverageDetails)]-    , recordedValuesDetailsAssertions+    [ recordedValuesDetailsAssertions     , structuralWirePolicyAssertions-    , structuralProjectionAssertions     ] -validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool-validFixtureLabels cases =-  all (not . T.null) labels && length labels == length (nub labels)-  where-    labels = map fst (NonEmpty.toList cases)--detailsBindingAssertions :: [(String, Bool)]-detailsBindingAssertions =-  ("fixture labels: import-planning.Details.v1", validFixtureLabels cases) :-  ("canonical identity: import-planning.Details.v1", canonicalTypeName (Proxy @Details) == "import-planning.Details.v1") :-  concat-    [ [ ("binding domain round-trip: import-planning.Details.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.detailsBinding value)-      , ("binding shape round-trip: import-planning.Details.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.detailsBinding (bindingToShape Bindings.detailsBinding value))-      ]-    | (label, value) <- NonEmpty.toList cases-    ]-  where-    cases = fixtureCases Bindings.detailsFixtures--coverageDetails :: Bool-coverageDetails = True- recordedValuesDetailsAssertions :: [(String, Bool)] recordedValuesDetailsAssertions =   [ ("mapped codec round-trip: RecordedValues/details/" <> T.unpack label, roundTrips (RecordedValues (RecordedValuesData (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.orderStatusFixtures))) (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.invoiceStatusFixtures))) (nominalFixtureDomain (NonEmpty.head (nominalFixtureCases Bindings.localCollisionFixtures))) mappedValue)))@@ -108,11 +77,6 @@ structuralWirePolicyAssertions :: [(String, Bool)] structuralWirePolicyAssertions =   [ ("wire policy unknown fields: import-planning.Details.v1", all (\(_, value) -> isLeft (decodeDetailsMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeDetailsMapped value)))) (NonEmpty.toList (fixtureCases Bindings.detailsFixtures)))-  ]--structuralProjectionAssertions :: [(String, Bool)]-structuralProjectionAssertions =-  [ ("projection witness agreement: import-planning.Details.v1/label", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.detailsLabelWitness (\referenceOwner -> ShapeDetails.label (bindingToShape Bindings.detailsBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.detailsFixtures)))   ]  insertObjectField :: T.Text -> Aeson.Value -> Aeson.Value -> Aeson.Value

test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit. module Generated.ImportPlanningCollisions.CollisionLedger.Projection () where  -- No projection declarations are present; this module keeps the generated manifest inventory total.

test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Transducer.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit. module Generated.ImportPlanningCollisions.CollisionLedger.Transducer   ( collisionLedgerTransducer   , collisionLedgerFoldFingerprint

test/conformance-import-planning/Generated/ImportPlanningCollisions/NominalProjections.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context import-planning-collisions nominal scalar projection facade; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context import-planning-collisions nominal scalar projection facade; do not edit. module Generated.ImportPlanningCollisions.NominalProjections where  import Data.Text (Text)

test/conformance-import-planning/Generated/ImportPlanningCollisions/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context import-planning-collisions replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context import-planning-collisions replay-audit assembly; do not edit. -- -- Deployment contract: --   * replay-neutral diff: no data audit is required;

test/conformance-import-planning/Generated/ImportPlanningCollisions/Structural/Shape/Details.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from mapped structural Details; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from mapped structural Details; do not edit. module Generated.ImportPlanningCollisions.Structural.Shape.Details (DetailsShape (..)) where  import Data.Text (Text)

+ test/conformance-import-planning/Generated/ImportPlanningCollisions/StructuralConformance.hs view

@@ -0,0 +1,51 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context import-planning-collisions structural conformance; do not edit.+module Generated.ImportPlanningCollisions.StructuralConformance+  ( structuralConformanceAssertions+  ) where++import Data.List (nub)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Proxy (Proxy (..))+import Data.Text qualified as T+import Keiki.Core (fieldWitnessAgrees)+import Keiki.Shape (CanonicalTypeName (..))+import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape)+import Generated.ImportPlanningCollisions.StructuralProjections qualified as StructuralProjections+import Generated.ImportPlanningCollisions.Structural.Shape.Details qualified as ShapeDetails+import ImportPlanning.Bindings qualified as Bindings+import ImportPlanning.Consumer.Shared.Types (Details)++structuralConformanceAssertions :: [(String, Bool)]+structuralConformanceAssertions =+  concat+    [ detailsBindingAssertions+    , [("fixture coverage: import-planning.Details.v1", coverageDetails)]+    , structuralProjectionAssertions+    ]++validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool+validFixtureLabels cases =+  all (not . T.null) labels && length labels == length (nub labels)+  where+    labels = map fst (NonEmpty.toList cases)++detailsBindingAssertions :: [(String, Bool)]+detailsBindingAssertions =+  ("fixture labels: import-planning.Details.v1", validFixtureLabels cases) :+  ("canonical identity: import-planning.Details.v1", canonicalTypeName (Proxy @Details) == "import-planning.Details.v1") :+  concat+    [ [ ("binding domain round-trip: import-planning.Details.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.detailsBinding value)+      , ("binding shape round-trip: import-planning.Details.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.detailsBinding (bindingToShape Bindings.detailsBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.detailsFixtures++coverageDetails :: Bool+coverageDetails = True++structuralProjectionAssertions :: [(String, Bool)]+structuralProjectionAssertions =+  [ ("projection witness agreement: import-planning.Details.v1/label", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.detailsLabelWitness (\referenceOwner -> ShapeDetails.label (bindingToShape Bindings.detailsBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.detailsFixtures)))+  ]

test/conformance-import-planning/Generated/ImportPlanningCollisions/StructuralProjections.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context import-planning-collisions mapped structural facade; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context import-planning-collisions mapped structural facade; do not edit. -- Equality witnesses are emitted for Text, Int, Bool, Natural, and UTCTime. -- Int, Natural, and UTCTime belong to Keiki's ordered subset. module Generated.ImportPlanningCollisions.StructuralProjections

test/conformance-intake-full/Generated/HospitalCapacity/IncidentInbox/Inbox.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from intake incidentInbox; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from intake incidentInbox; do not edit. module Generated.HospitalCapacity.IncidentInbox.Inbox   ( InboxFailure (..)   , IncidentInboxOutcome (..)

test/conformance-intake-runtime/Generated/HospitalCapacity/IncidentInbox/Inbox.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from intake incidentInbox; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from intake incidentInbox; do not edit. module Generated.HospitalCapacity.IncidentInbox.Inbox   ( InboxFailure (..)   , IncidentInboxOutcome (..)

+ test/conformance-mapped-queue/Conformance/MappedQueue/Bindings.hs view

@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Conformance.MappedQueue.Bindings+  ( geometryCases,+    jobMetadataBinding,+    jobMetadataCases,+    jobPayloadBinding,+    jobPayloadCases,+  )+where++import Conformance.MappedQueue.Domain qualified as Domain+import Data.List.NonEmpty (NonEmpty (..))+import Generated.MappedQueue.Structural.Shape.JobMetadata qualified as MetadataShape+import Generated.MappedQueue.Structural.Shape.JobPayload qualified as PayloadShape+import Keiro.Codec.Structural (FixtureCases (..), StructuralBinding (..))+import Keiro.Codec.Structural.Generic (genericStructuralBinding)++jobMetadataBinding :: StructuralBinding Domain.JobMetadata MetadataShape.JobMetadataShape+jobMetadataBinding = genericStructuralBinding++jobPayloadBinding :: StructuralBinding Domain.JobPayload PayloadShape.JobPayloadShape+jobPayloadBinding =+  StructuralBinding+    { bindingToShape = \value ->+        PayloadShape.JobPayload+          value.jobId+          value.label+          (bindingToShape jobMetadataBinding <$> value.metadata)+          value.geometry,+      bindingFromShape = \(PayloadShape.JobPayload jobId label metadata geometry) ->+        Domain.JobPayload+          jobId+          label+          (bindingFromShape jobMetadataBinding <$> metadata)+          geometry+    }++geometryCases :: FixtureCases Domain.Geometry+geometryCases =+  FixtureCases+    ( ("point", Domain.Geometry "POINT (1 2)")+        :| [("empty", Domain.Geometry "GEOMETRYCOLLECTION EMPTY")]+    )++jobMetadataCases :: FixtureCases Domain.JobMetadata+jobMetadataCases =+  FixtureCases+    ( ("none", Domain.JobMetadata Nothing)+        :| [("some", Domain.JobMetadata (Just "priority"))]+    )++jobPayloadCases :: FixtureCases Domain.JobPayload+jobPayloadCases =+  FixtureCases+    ( ( "without-metadata",+        Domain.JobPayload "job-1" "primary" Nothing (Domain.Geometry "POINT (1 2)")+      )+        :| [ ( "with-metadata",+               Domain.JobPayload "job-2" "secondary" (Just (Domain.JobMetadata (Just "priority"))) (Domain.Geometry "POINT (3 4)")+             )+           ]+    )

+ test/conformance-mapped-queue/Conformance/MappedQueue/Domain.hs view

@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++module Conformance.MappedQueue.Domain+  ( Geometry (..),+    JobMetadata (..),+    JobPayload (..),+  )+where++import Data.Aeson (FromJSON (..), ToJSON (..), withText)+import Data.Proxy (Proxy)+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Shape (CanonicalTypeName (..))++newtype Geometry = Geometry {geometryText :: Text}+  deriving stock (Eq, Show, Generic)++instance ToJSON Geometry where+  toJSON (Geometry value) = toJSON value++instance FromJSON Geometry where+  parseJSON = withText "Geometry" (pure . Geometry)++data JobMetadata = JobMetadata+  { note :: !(Maybe Text)+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++data JobPayload = JobPayload+  { jobId :: !Text,+    label :: !Text,+    metadata :: !(Maybe JobMetadata),+    geometry :: !Geometry+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++instance CanonicalTypeName JobMetadata where+  canonicalTypeName :: Proxy JobMetadata -> Text+  canonicalTypeName _ = "conformance.mapped-queue.JobMetadata.v1"++instance CanonicalTypeName JobPayload where+  canonicalTypeName :: Proxy JobPayload -> Text+  canonicalTypeName _ = "conformance.mapped-queue.JobPayload.v1"

+ test/conformance-mapped-queue/Generated/MappedQueue/MappedJobs/Queue.hs view

@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedRecordDot #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from workqueue mapped_jobs; do not edit.+module Generated.MappedQueue.MappedJobs.Queue+  ( MappedJob (..)+  , encodeMappedJob+  , parseMappedJob+  , encodeJobMetadataMapped+  , decodeJobMetadataMapped+  , encodeJobPayloadMapped+  , decodeJobPayloadMapped+  , queuePhysical, queueDlq, queueTable++  ) where++import Control.Monad (unless)+import Data.Aeson (Value (..), object, parseJSON, toJSON, withObject, (.=))+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (Parser, explicitParseField, parseEither)+import Data.Text (Text)+import qualified Data.Text as T+import Keiro.Codec.Structural (bindingFromShape, bindingToShape)+import Conformance.MappedQueue.Bindings qualified as Bindings+import Conformance.MappedQueue.Domain (JobMetadata, JobPayload)+import Generated.MappedQueue.Structural.Shape.JobMetadata qualified as ShapeJobMetadata+import Generated.MappedQueue.Structural.Shape.JobPayload qualified as ShapeJobPayload++queuePhysical, queueDlq, queueTable :: Text+queuePhysical = "mapped_jobs"+queueDlq = "mapped_jobs_dlq"+queueTable = "pgmq.q_mapped_jobs"++data MappedJob = MappedJob+  { job :: !JobPayload+  , maybeJob :: !(Maybe JobPayload)+  , trace :: !Value+  }+  deriving stock (Eq, Show)++encodeJobMetadataMapped :: JobMetadata -> Value+encodeJobMetadataMapped = encodeJobMetadataShape . bindingToShape Bindings.jobMetadataBinding++parseJobMetadataMapped :: Value -> Parser JobMetadata+parseJobMetadataMapped value = bindingFromShape Bindings.jobMetadataBinding <$> parseJobMetadataShape value++decodeJobMetadataMapped :: Value -> Either Text JobMetadata+decodeJobMetadataMapped = mapLeftText . parseEither parseJobMetadataMapped++encodeJobMetadataShape :: ShapeJobMetadata.JobMetadataShape -> Value+encodeJobMetadataShape shape =+  object+      [ "note" .= maybe Null (\item -> toJSON (item)) (ShapeJobMetadata.note shape)+      ]++parseJobMetadataShape :: Value -> Parser ShapeJobMetadata.JobMetadataShape+parseJobMetadataShape = withObject "JobMetadataShape" $ \objectValue -> do+  ShapeJobMetadata.JobMetadata+    <$> explicitParseField (\value -> case value of Null -> pure Nothing; other -> Just <$> parseJSON other) objectValue "note"++encodeJobPayloadMapped :: JobPayload -> Value+encodeJobPayloadMapped = encodeJobPayloadShape . bindingToShape Bindings.jobPayloadBinding++parseJobPayloadMapped :: Value -> Parser JobPayload+parseJobPayloadMapped value = bindingFromShape Bindings.jobPayloadBinding <$> parseJobPayloadShape value++decodeJobPayloadMapped :: Value -> Either Text JobPayload+decodeJobPayloadMapped = mapLeftText . parseEither parseJobPayloadMapped++encodeJobPayloadShape :: ShapeJobPayload.JobPayloadShape -> Value+encodeJobPayloadShape shape =+  object+      [ "job_id" .= toJSON (ShapeJobPayload.jobId shape)+      , "label" .= toJSON (ShapeJobPayload.label shape)+      , "metadata" .= maybe Null (\item -> encodeJobMetadataShape (item)) (ShapeJobPayload.metadata shape)+      , "geometry" .= toJSON (ShapeJobPayload.geometry shape)+      ]++parseJobPayloadShape :: Value -> Parser ShapeJobPayload.JobPayloadShape+parseJobPayloadShape = withObject "JobPayloadShape" $ \objectValue -> do+  rejectUnknownFields "JobPayload" ["job_id", "label", "metadata", "geometry"] objectValue+  ShapeJobPayload.JobPayload+    <$> explicitParseField (parseJSON) objectValue "job_id"+    <*> explicitParseField (parseJSON) objectValue "label"+    <*> explicitParseField (\value -> case value of Null -> pure Nothing; other -> Just <$> parseJobMetadataShape other) objectValue "metadata"+    <*> explicitParseField (parseJSON) objectValue "geometry"++encodeMappedJob :: MappedJob -> Value+encodeMappedJob payload =+  object+    [ "job" .= encodeJobPayloadMapped payload.job+    , "maybe_job" .= maybe Null (\item -> encodeJobPayloadMapped item) (payload.maybeJob)+    , "trace" .= payload.trace+    ]++parseMappedJob :: Value -> Either Text MappedJob+parseMappedJob = mapLeftText . parseEither (withObject "MappedJob" go)+  where+    go objectValue = MappedJob <$> explicitParseField (parseJobPayloadMapped) objectValue "job" <*> explicitParseField (\value -> case value of Null -> pure Nothing; other -> Just <$> parseJobPayloadMapped other) objectValue "maybe_job" <*> explicitParseField (pure) objectValue "trace"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right++rejectUnknownFields :: String -> [Text] -> KeyMap.KeyMap Value -> Parser ()+rejectUnknownFields label allowed objectValue =+  unless (null extras) (fail (label <> " contains unknown fields: " <> show extras))+  where+    extras = filter (`notElem` allowed) (map Key.toText (KeyMap.keys objectValue))

+ test/conformance-mapped-queue/Generated/MappedQueue/MappedJobs/QueueCodec.hs view

@@ -0,0 +1,29 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from workqueue mapped_jobs; do not edit.+-- | Versioned job payload envelope: @{\"v\",\"t\",\"data\"}@.+--+-- Deploy workers before producers when raising its schema version. Do not+-- adopt this codec on a non-empty bare-payload queue without draining it+-- (or supplying a transitional codec), or in-flight messages will+-- dead-letter. This is telemetry-neutral:+-- docs/adr/0001-keiro-pgmq-job-processing-telemetry-contract.md owns+-- spans and acknowledgement vocabulary.+module Generated.MappedQueue.MappedJobs.QueueCodec (mappedJobsPayloadCodec, mappedJobsJobCodec) where++import Data.List.NonEmpty (NonEmpty (..))+import Keiro.Codec (Codec (..), EventType (..))+import Keiro.PGMQ.Codec (JobCodec, keiroJobCodec)+import Generated.MappedQueue.MappedJobs.Queue (MappedJob, encodeMappedJob, parseMappedJob)++mappedJobsPayloadCodec :: Codec MappedJob+mappedJobsPayloadCodec =+  Codec+    { eventTypes = EventType "MappedJob" :| []+    , eventType = \_ -> EventType "MappedJob"+    , schemaVersion = 1+    , encode = encodeMappedJob+    , decode = \_ -> parseMappedJob+    , upcasters = []+    }++mappedJobsJobCodec :: JobCodec MappedJob+mappedJobsJobCodec = keiroJobCodec mappedJobsPayloadCodec

+ test/conformance-mapped-queue/Generated/MappedQueue/MappedJobs/QueuePolicy.hs view

@@ -0,0 +1,43 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from workqueue mapped_jobs; do not edit.+module Generated.MappedQueue.MappedJobs.QueuePolicy+  ( MappedJobsOutcome (..)+  , retryPolicy, jobOutcomeFor+  , jobOrdering, jobTuningFor, queueProvision+  ) where++import Keiro.PGMQ.Job (JobOrdering (..), JobOutcome (..), JobTuning, QueueProvision, RetryDelay (..), RetryPolicy (..), standardProvision, withOrdering)++jobOrdering :: JobOrdering+jobOrdering = Unordered++-- Deployment owns visibility timeout, batch size, and polling; the spec owns ordering.+jobTuningFor :: JobTuning -> JobTuning+jobTuningFor = withOrdering jobOrdering++-- Pass this to ensureJobQueueWith at worker startup. FIFO adds the required GIN index; the DLQ remains standard.+queueProvision :: QueueProvision+queueProvision = standardProvision++retryPolicy :: RetryPolicy+retryPolicy =+  RetryPolicy+    { maxRetries = 3+    , defaultRetryDelay = RetryDelay 1+    , useDeadLetter = True+    }++-- The consumer JobOutcome disposition over the spec's named domain outcomes,+-- lowered to the live Keiro.PGMQ.Job.JobOutcome.+data MappedJobsOutcome+  = StoreFailure+  | CommandRejected+  | DecodeFailure+  | OnCodecReject+  deriving stock (Eq, Show)++jobOutcomeFor :: MappedJobsOutcome -> JobOutcome+jobOutcomeFor o = case o of+  StoreFailure -> Retry (RetryDelay 1)+  CommandRejected -> Dead "dead-lettered"+  DecodeFailure -> Dead "dead-lettered"+  OnCodecReject -> Dead "dead-lettered"

+ test/conformance-mapped-queue/Generated/MappedQueue/Structural/Shape/JobMetadata.hs view

@@ -0,0 +1,10 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from mapped structural JobMetadata; do not edit.+module Generated.MappedQueue.Structural.Shape.JobMetadata (JobMetadataShape (..)) where++import Data.Text (Text)+import GHC.Generics (Generic)++data JobMetadataShape = JobMetadata+  { note :: !(Maybe Text)+  }+  deriving stock (Eq, Generic, Show)

+ test/conformance-mapped-queue/Generated/MappedQueue/Structural/Shape/JobPayload.hs view

@@ -0,0 +1,15 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from mapped structural JobPayload; do not edit.+module Generated.MappedQueue.Structural.Shape.JobPayload (JobPayloadShape (..)) where++import Data.Text (Text)+import GHC.Generics (Generic)+import Conformance.MappedQueue.Domain (Geometry)+import Generated.MappedQueue.Structural.Shape.JobMetadata qualified as JobMetadata++data JobPayloadShape = JobPayload+  { jobId :: !Text+  , label :: !Text+  , metadata :: !(Maybe JobMetadata.JobMetadataShape)+  , geometry :: !Geometry+  }+  deriving stock (Eq, Generic, Show)

+ test/conformance-mapped-queue/Generated/MappedQueue/StructuralConformance.hs view

@@ -0,0 +1,87 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from context mapped-queue structural conformance; do not edit.+module Generated.MappedQueue.StructuralConformance+  ( structuralConformanceAssertions+  ) where++import Data.Aeson qualified as Aeson+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.Core (fieldWitnessAgrees)+import Keiki.Shape (CanonicalTypeName (..))+import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape)+import Generated.MappedQueue.StructuralProjections qualified as StructuralProjections+import Conformance.MappedQueue.Bindings qualified as Bindings+import Conformance.MappedQueue.Domain (JobMetadata, JobPayload)+import Generated.MappedQueue.Structural.Shape.JobMetadata qualified as ShapeJobMetadata+import Generated.MappedQueue.Structural.Shape.JobPayload qualified as ShapeJobPayload++structuralConformanceAssertions :: [(String, Bool)]+structuralConformanceAssertions =+  concat+    [ jobMetadataBindingAssertions+    , jobPayloadBindingAssertions+    , vendorGeometryOpaqueAssertions+    , [("fixture coverage: conformance.mapped-queue.JobMetadata.v1", coverageJobMetadata)]+    , [("fixture coverage: conformance.mapped-queue.JobPayload.v1", coverageJobPayload)]+    , structuralProjectionAssertions+    ]++validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool+validFixtureLabels cases =+  all (not . T.null) labels && length labels == length (nub labels)+  where+    labels = map fst (NonEmpty.toList cases)++jobMetadataBindingAssertions :: [(String, Bool)]+jobMetadataBindingAssertions =+  ("fixture labels: conformance.mapped-queue.JobMetadata.v1", validFixtureLabels cases) :+  ("canonical identity: conformance.mapped-queue.JobMetadata.v1", canonicalTypeName (Proxy @JobMetadata) == "conformance.mapped-queue.JobMetadata.v1") :+  concat+    [ [ ("binding domain round-trip: conformance.mapped-queue.JobMetadata.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.jobMetadataBinding value)+      , ("binding shape round-trip: conformance.mapped-queue.JobMetadata.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.jobMetadataBinding (bindingToShape Bindings.jobMetadataBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.jobMetadataCases++jobPayloadBindingAssertions :: [(String, Bool)]+jobPayloadBindingAssertions =+  ("fixture labels: conformance.mapped-queue.JobPayload.v1", validFixtureLabels cases) :+  ("canonical identity: conformance.mapped-queue.JobPayload.v1", canonicalTypeName (Proxy @JobPayload) == "conformance.mapped-queue.JobPayload.v1") :+  concat+    [ [ ("binding domain round-trip: conformance.mapped-queue.JobPayload.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.jobPayloadBinding value)+      , ("binding shape round-trip: conformance.mapped-queue.JobPayload.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.jobPayloadBinding (bindingToShape Bindings.jobPayloadBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.jobPayloadCases++vendorGeometryOpaqueAssertions :: [(String, Bool)]+vendorGeometryOpaqueAssertions =+  ("opaque boundary fixtures: vendor.geometry.json@3", validFixtureLabels cases) :+  [ ("opaque codec round-trip: vendor.geometry.json@3/" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False)+  | (caseLabel, value) <- NonEmpty.toList cases+  ]+  where+    cases = fixtureCases Bindings.geometryCases++coverageJobMetadata :: Bool+coverageJobMetadata = any (isNothing . ShapeJobMetadata.note) shapes && any (isJust . ShapeJobMetadata.note) shapes+  where+    shapes = map (bindingToShape Bindings.jobMetadataBinding . snd) (NonEmpty.toList (fixtureCases Bindings.jobMetadataCases))++coverageJobPayload :: Bool+coverageJobPayload = any (isNothing . ShapeJobPayload.metadata) shapes && any (isJust . ShapeJobPayload.metadata) shapes+  where+    shapes = map (bindingToShape Bindings.jobPayloadBinding . snd) (NonEmpty.toList (fixtureCases Bindings.jobPayloadCases))++structuralProjectionAssertions :: [(String, Bool)]+structuralProjectionAssertions =+  [ ("projection witness agreement: conformance.mapped-queue.JobPayload.v1/job_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.jobPayloadJobIdWitness (\referenceOwner -> ShapeJobPayload.jobId (bindingToShape Bindings.jobPayloadBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.jobPayloadCases)))+  , ("projection witness agreement: conformance.mapped-queue.JobPayload.v1/label", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.jobPayloadLabelWitness (\referenceOwner -> ShapeJobPayload.label (bindingToShape Bindings.jobPayloadBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.jobPayloadCases)))+  ]

+ test/conformance-mapped-queue/Generated/MappedQueue/StructuralProjections.hs view

@@ -0,0 +1,39 @@+{-# LANGUAGE TypeFamilies #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from context mapped-queue mapped structural facade; do not edit.+-- Equality witnesses are emitted for Text, Int, Bool, Natural, and UTCTime.+-- Int, Natural, and UTCTime belong to Keiki's ordered subset.+module Generated.MappedQueue.StructuralProjections+  ( jobPayloadJobIdWitness+  , jobPayloadLabelWitness+  ) where++import Data.Text (Text)+import Keiro.Codec.Structural (bindingToShape)+import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)+import Conformance.MappedQueue.Bindings qualified as Bindings+import Conformance.MappedQueue.Domain (JobPayload)+import Generated.MappedQueue.Structural.Shape.JobPayload qualified as ShapeJobPayload++data JobPayloadJobIdProjection++instance FieldProjection JobPayloadJobIdProjection where+  type FieldName JobPayloadJobIdProjection = "/job_id"+  type FieldOwner JobPayloadJobIdProjection = JobPayload+  type FieldResult JobPayloadJobIdProjection = Text+  fieldShapeId _ = "conformance.mapped-queue.JobPayload.v1"+  projectFieldValue _ owner = ShapeJobPayload.jobId (bindingToShape Bindings.jobPayloadBinding owner)++jobPayloadJobIdWitness :: FieldWitness JobPayloadJobIdProjection+jobPayloadJobIdWitness = fieldWitness @JobPayloadJobIdProjection++data JobPayloadLabelProjection++instance FieldProjection JobPayloadLabelProjection where+  type FieldName JobPayloadLabelProjection = "/label"+  type FieldOwner JobPayloadLabelProjection = JobPayload+  type FieldResult JobPayloadLabelProjection = Text+  fieldShapeId _ = "conformance.mapped-queue.JobPayload.v1"+  projectFieldValue _ owner = ShapeJobPayload.label (bindingToShape Bindings.jobPayloadBinding owner)++jobPayloadLabelWitness :: FieldWitness JobPayloadLabelProjection+jobPayloadLabelWitness = fieldWitness @JobPayloadLabelProjection

+ test/conformance-mapped-queue/Main.hs view

@@ -0,0 +1,62 @@+module Main (main) where++import Conformance.MappedQueue.Domain (Geometry (..), JobMetadata (..), JobPayload (..))+import Control.Monad (forM_, unless)+import Data.Aeson (Value (..), object, (.=))+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Text (Text)+import Generated.MappedQueue.MappedJobs.Queue+import Generated.MappedQueue.MappedJobs.QueueCodec (mappedJobsJobCodec)+import Generated.MappedQueue.StructuralConformance (structuralConformanceAssertions)+import Keiro.PGMQ.Codec (JobCodec (..))+import System.Exit (exitFailure)++main :: IO ()+main = do+  let job = JobPayload "job-7" "priority-job" (Just (JobMetadata (Just "priority"))) (Geometry "POINT (1 2)")+      payload = MappedJob job Nothing (object ["trace_id" .= ("trace-7" :: Text)])+      encoded = encodeMappedJob payload+      expectedPayload =+        object+          [ "job"+              .= object+                [ "job_id" .= ("job-7" :: Text),+                  "label" .= ("priority-job" :: Text),+                  "metadata" .= object ["note" .= ("priority" :: Text)],+                  "geometry" .= ("POINT (1 2)" :: Text)+                ],+            "maybe_job" .= Null,+            "trace" .= object ["trace_id" .= ("trace-7" :: Text)]+          ]+      envelope =+        object+          [ "v" .= (1 :: Int),+            "t" .= ("MappedJob" :: Text),+            "data" .= expectedPayload+          ]+      missingRequired = case encoded of+        Object fields -> parseMappedJob (Object (KeyMap.delete "job" fields))+        _ -> error "mapped queue encoder did not produce an object"+      unknownNested = case encoded of+        Object fields -> case KeyMap.lookup "job" fields of+          Just (Object jobFields) ->+            parseMappedJob (Object (KeyMap.insert "job" (Object (KeyMap.insert "extra" Null jobFields)) fields))+          _ -> error "mapped queue job field was not an object"+        _ -> error "mapped queue encoder did not produce an object"+      assertions =+        [ ("payload bytes", encoded == expectedPayload),+          ("domain round-trip", parseMappedJob encoded == Right payload),+          ("required key rejects omission", isLeft missingRequired),+          ("present null admits Optional", (maybeJob <$> parseMappedJob encoded) == Right Nothing),+          ("nested reject-unknown policy", isLeft unknownNested),+          ("versioned {v,t,data} envelope", encodeJob mappedJobsJobCodec payload == envelope && decodeJob mappedJobsJobCodec envelope == Right payload),+          ("schema-v1 physical queue", queuePhysical == "mapped_jobs")+        ]+          <> [("structural/" <> label, passed) | (label, passed) <- structuralConformanceAssertions]+  forM_ assertions $ \(label, passed) ->+    putStrLn ((if passed then "PASS  " else "FAIL  ") <> label)+  unless (all snd assertions) exitFailure++isLeft :: Either problem value -> Bool+isLeft (Left _) = True+isLeft (Right _) = False

+ test/conformance-mapped-readmodel/Conformance/MappedReadModel/Bindings.hs view

@@ -0,0 +1,86 @@+module Conformance.MappedReadModel.Bindings+  ( accountLookupBinding,+    accountLookupCases,+    accountProfileBinding,+    accountProfileCases,+    accountSummaryBinding,+    accountSummaryCases,+    tenantKeyBinding,+    tenantKeyCases,+    unusedFilterBinding,+    unusedFilterCases,+  )+where++import Conformance.MappedReadModel.Domain qualified as Domain+import Data.List.NonEmpty (NonEmpty (..))+import Generated.MappedReadmodel.Structural.Shape.AccountLookup qualified as LookupShape+import Generated.MappedReadmodel.Structural.Shape.AccountProfile qualified as ProfileShape+import Generated.MappedReadmodel.Structural.Shape.AccountSummary qualified as SummaryShape+import Generated.MappedReadmodel.Structural.Shape.TenantKey qualified as TenantShape+import Generated.MappedReadmodel.Structural.Shape.UnusedFilter qualified as FilterShape+import Keiro.Codec.Structural (FixtureCases (..), StructuralBinding (..))++tenantKeyBinding :: StructuralBinding Domain.TenantKey TenantShape.TenantKeyShape+tenantKeyBinding =+  StructuralBinding+    { bindingToShape = \(Domain.TenantKey tenantId) -> TenantShape.TenantKey tenantId,+      bindingFromShape = \(TenantShape.TenantKey tenantId) -> Domain.TenantKey tenantId+    }++accountLookupBinding :: StructuralBinding Domain.AccountLookup LookupShape.AccountLookupShape+accountLookupBinding =+  StructuralBinding+    { bindingToShape = \(Domain.AccountLookup accountId tenant) ->+        LookupShape.AccountLookup accountId (bindingToShape tenantKeyBinding tenant),+      bindingFromShape = \(LookupShape.AccountLookup accountId tenant) ->+        Domain.AccountLookup accountId (bindingFromShape tenantKeyBinding tenant)+    }++accountProfileBinding :: StructuralBinding Domain.AccountProfile ProfileShape.AccountProfileShape+accountProfileBinding =+  StructuralBinding+    { bindingToShape = \(Domain.AccountProfile displayName) -> ProfileShape.AccountProfile displayName,+      bindingFromShape = \(ProfileShape.AccountProfile displayName) -> Domain.AccountProfile displayName+    }++accountSummaryBinding :: StructuralBinding Domain.AccountSummary SummaryShape.AccountSummaryShape+accountSummaryBinding =+  StructuralBinding+    { bindingToShape = \(Domain.AccountSummary accountId tenant profile) ->+        SummaryShape.AccountSummary+          accountId+          (bindingToShape tenantKeyBinding tenant)+          (bindingToShape accountProfileBinding <$> profile),+      bindingFromShape = \(SummaryShape.AccountSummary accountId tenant profile) ->+        Domain.AccountSummary+          accountId+          (bindingFromShape tenantKeyBinding tenant)+          (bindingFromShape accountProfileBinding <$> profile)+    }++unusedFilterBinding :: StructuralBinding Domain.UnusedFilter FilterShape.UnusedFilterShape+unusedFilterBinding =+  StructuralBinding+    { bindingToShape = \(Domain.UnusedFilter prefix) -> FilterShape.UnusedFilter prefix,+      bindingFromShape = \(FilterShape.UnusedFilter prefix) -> Domain.UnusedFilter prefix+    }++tenantKeyCases :: FixtureCases Domain.TenantKey+tenantKeyCases = FixtureCases (("main", Domain.TenantKey "tenant-main") :| [])++accountLookupCases :: FixtureCases Domain.AccountLookup+accountLookupCases = FixtureCases (("known", Domain.fixtureAccountLookup) :| [])++accountProfileCases :: FixtureCases Domain.AccountProfile+accountProfileCases = FixtureCases (("named", Domain.AccountProfile "Ada") :| [])++accountSummaryCases :: FixtureCases Domain.AccountSummary+accountSummaryCases =+  FixtureCases+    ( ("without-profile", Domain.AccountSummary "account-6" (Domain.TenantKey "tenant-main") Nothing)+        :| [("with-profile", Domain.fixtureAccountSummary)]+    )++unusedFilterCases :: FixtureCases Domain.UnusedFilter+unusedFilterCases = FixtureCases (("unused", Domain.UnusedFilter "acct-") :| [])

+ test/conformance-mapped-readmodel/Conformance/MappedReadModel/Domain.hs view

@@ -0,0 +1,76 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++module Conformance.MappedReadModel.Domain+  ( AccountLookup (..),+    AccountProfile (..),+    AccountSummary (..),+    TenantKey (..),+    UnusedFilter (..),+    fixtureAccountLookup,+    fixtureAccountSummary,+  )+where++import Data.Proxy (Proxy)+import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Shape (CanonicalTypeName (..))++newtype TenantKey = TenantKey+  { tenantId :: Text+  }+  deriving stock (Eq, Show, Generic)++data AccountLookup = AccountLookup+  { lookupAccountId :: !Text,+    lookupTenant :: !TenantKey+  }+  deriving stock (Eq, Show, Generic)++newtype AccountProfile = AccountProfile+  { displayName :: Text+  }+  deriving stock (Eq, Show, Generic)++data AccountSummary = AccountSummary+  { summaryAccountId :: !Text,+    summaryTenant :: !TenantKey,+    summaryProfile :: !(Maybe AccountProfile)+  }+  deriving stock (Eq, Show, Generic)++newtype UnusedFilter = UnusedFilter+  { prefix :: Text+  }+  deriving stock (Eq, Show, Generic)++fixtureAccountLookup :: AccountLookup+fixtureAccountLookup = AccountLookup "account-7" (TenantKey "tenant-main")++fixtureAccountSummary :: AccountSummary+fixtureAccountSummary =+  AccountSummary+    "account-7"+    (TenantKey "tenant-main")+    (Just (AccountProfile "Ada"))++instance CanonicalTypeName TenantKey where+  canonicalTypeName :: Proxy TenantKey -> Text+  canonicalTypeName _ = "conformance.mapped-readmodel.TenantKey.v1"++instance CanonicalTypeName AccountLookup where+  canonicalTypeName :: Proxy AccountLookup -> Text+  canonicalTypeName _ = "conformance.mapped-readmodel.AccountLookup.v1"++instance CanonicalTypeName AccountProfile where+  canonicalTypeName :: Proxy AccountProfile -> Text+  canonicalTypeName _ = "conformance.mapped-readmodel.AccountProfile.v1"++instance CanonicalTypeName AccountSummary where+  canonicalTypeName :: Proxy AccountSummary -> Text+  canonicalTypeName _ = "conformance.mapped-readmodel.AccountSummary.v1"++instance CanonicalTypeName UnusedFilter where+  canonicalTypeName :: Proxy UnusedFilter -> Text+  canonicalTypeName _ = "conformance.mapped-readmodel.UnusedFilter.v1"

+ test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/QueryContract.hs view

@@ -0,0 +1,10 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel account_summary; do not edit.+module Generated.MappedReadmodel.AccountSummary.QueryContract+  ( AccountSummaryQueryInput+  , AccountSummaryQueryResult+  ) where++import Conformance.MappedReadModel.Domain (AccountLookup, AccountSummary)++type AccountSummaryQueryInput = AccountLookup+type AccountSummaryQueryResult = Maybe AccountSummary

+ test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/ReadModel.hs view

@@ -0,0 +1,28 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel account_summary; do not edit.+module Generated.MappedReadmodel.AccountSummary.ReadModel+  ( accountSummaryReadModel+  , accountSummaryQualifiedTable+  ) where++import Generated.MappedReadmodel.AccountSummary.ReadModelTable (accountSummaryQualifiedTable)+import Generated.MappedReadmodel.AccountSummary.QueryContract (AccountSummaryQueryInput, AccountSummaryQueryResult)+import MappedReadmodel.AccountSummary.ReadModelHoles (accountSummaryQuery)+import Keiro.ReadModel (QueryCursorAuthority (..), ReadModel, ReadModelBlueprint (..), HeadScope (..), headWaitingReadModel)++accountSummaryReadModel :: ReadModel AccountSummaryQueryInput AccountSummaryQueryResult+accountSummaryReadModel =+  case headWaitingReadModel EntireVisibleLog accountSummaryReadModelBlueprint of+    Left definitionError -> error ("keiro-dsl generated an invalid waiting read model: " <> show definitionError)+    Right model -> model++accountSummaryReadModelBlueprint :: ReadModelBlueprint AccountSummaryQueryInput AccountSummaryQueryResult+accountSummaryReadModelBlueprint =+  ReadModelBlueprint+    { name = "mapped-readmodel-account-summary"+    , tableName = "account_summary"+    , schema = "public"+    , version = 1+    , shapeHash = "fnv1a:3c07a19c552c3547"+    , cursorAuthority = DurableQueryCursor "mapped-readmodel-account-summary"+    , query = accountSummaryQuery+    }

+ test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/ReadModelHarness.hs view

@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedRecordDot #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel account_summary; do not edit.+module Generated.MappedReadmodel.AccountSummary.ReadModelHarness (readModelFacts, readModelFactResults, runReadModelFacts, catalogFactsAgainst) where++import Generated.MappedReadmodel.AccountSummary.ReadModel (accountSummaryReadModel)+import Data.Text qualified as T+import Data.List.NonEmpty qualified as NE+import Generated.MappedReadmodel.ProjectionCatalog qualified as ProjectionCatalog+import Keiro.Projection.Catalog qualified as Catalog+import Keiro.ReadModel (ReadModel (..), readModelCursorAuthority, readModelDefaultFreshness)++-- | (fact, expected from notation, actual generated runtime value).+readModelFacts :: [(String, String, String)]+readModelFacts =+  [ ("registryName", "mapped-readmodel-account-summary", T.unpack accountSummaryReadModel.name)+  , ("shapeHash", "fnv1a:3c07a19c552c3547", T.unpack accountSummaryReadModel.shapeHash)+  , ("freshness", "WaitForHead EntireVisibleLog", show (readModelDefaultFreshness accountSummaryReadModel))+  , ("cursorAuthority", "DurableQueryCursor \"mapped-readmodel-account-summary\"", show (readModelCursorAuthority accountSummaryReadModel))+  ]+    <> catalogFactsAgainst ProjectionCatalog.projectionCatalogRegistrations ProjectionCatalog.projectionCatalogAsyncRegistrations ProjectionCatalog.projectionCatalogQuerySupplies++catalogFactsAgainst :: [Catalog.CatalogRegistration] -> [Catalog.AsyncProjectionRegistration] -> [Catalog.ResolvedQuerySupply] -> [(String, String, String)]+catalogFactsAgainst registrations asyncRegistrations supplies =+  [ ("catalogRegistration", "mapped-readmodel-account-summary|1|fnv1a:3c07a19c552c3547|reporting", renderRegistration [entry | entry <- registrations, Catalog.queryModelIdText entry.queryModelId == "account_summary"])+  , ("querySupply", "account_summary_writer|reporting|account_summary_table", renderSupply [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "account_summary"])+  , ("projectionDelivery", "subscription", renderDelivery [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "account_summary"])+  , ("asyncRegistration:account_summary_writer", "mapped-readmodel-account-summary|mapped-readmodel-account-summary-v1", renderAsync [entry | entry <- asyncRegistrations, Catalog.projectionIdText entry.projectionId == "account_summary_writer"])+  ]++renderRegistration :: [Catalog.CatalogRegistration] -> String+renderRegistration [entry] = T.unpack entry.registryName <> "|" <> show entry.version <> "|" <> T.unpack entry.shapeHash <> "|" <> T.unpack (Catalog.rebuildGroupIdText entry.rebuildGroupId)+renderRegistration _ = "missing"++renderSupply :: [Catalog.ResolvedQuerySupply] -> String+renderSupply [entry] = T.unpack (Catalog.projectionIdText entry.resolvedProjectionId) <> "|" <> T.unpack (Catalog.rebuildGroupIdText entry.resolvedRebuildGroupId) <> "|" <> T.unpack (T.intercalate "," (map Catalog.targetIdText (NE.toList entry.resolvedObservedTargets)))+renderSupply _ = "missing"++renderDelivery :: [Catalog.ResolvedQuerySupply] -> String+renderDelivery [entry] = T.unpack (T.intercalate "," (map renderCapability (NE.toList entry.resolvedHandlerCapabilities)))+renderDelivery _ = "missing"++renderCapability :: Catalog.ProjectionHandlerCapability -> T.Text+renderCapability Catalog.InlineCapability {} = "inline"+renderCapability Catalog.SubscriptionCapability {} = "subscription"++renderAsync :: [Catalog.AsyncProjectionRegistration] -> String+renderAsync [entry] = T.unpack entry.subscriptionName <> "|" <> T.unpack entry.dedupName+renderAsync _ = "missing"++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)

+ test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/ReadModelTable.hs view

@@ -0,0 +1,9 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel account_summary; do not edit.+module Generated.MappedReadmodel.AccountSummary.ReadModelTable (accountSummaryQualifiedTable) where++import Data.Text (Text)+import Keiro.Connection (qualifyTable)++-- The fully-qualified, double-quoted data-table reference.+accountSummaryQualifiedTable :: Text+accountSummaryQualifiedTable = qualifyTable "public" "account_summary"

+ test/conformance-mapped-readmodel/Generated/MappedReadmodel/ProjectionCatalog.hs view

@@ -0,0 +1,80 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from projection-catalog mapped-readmodel; do not edit.+{-# LANGUAGE OverloadedStrings #-}+module Generated.MappedReadmodel.ProjectionCatalog+  ( projectionCatalog+  , validatedProjectionCatalog+  , projectionCatalogInventory+  , projectionCatalogRegistrations+  , projectionCatalogAsyncRegistrations+  , projectionCatalogQuerySupplies+  , registerProjectionCatalog+  , accountSummaryWriterProjectionSet+  , reportingRebuildGroupId+  , startReportingRebuild+  ) where++import Data.List.NonEmpty (NonEmpty (..))+import Effectful (Eff, IOE, (:>))+import Keiro.Projection (AsyncProjection (..))+import Keiro.Projection.Catalog qualified as Catalog+import Keiro.ReadModel.Rebuild qualified as Rebuild+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Subscription.Types qualified as KirokuSubscription+import MappedReadmodel.ProjectionCatalog.ProjectionCatalogHoles qualified as Holes+import Generated.MappedReadmodel.AccountSummary.ReadModel qualified as RMAccountSummary++must :: Show error => Either error value -> value+must = either (error . show) id++accountSummaryWriterProjectionSet :: Catalog.ProjectionSet Holes.AccountSummaryWriterEvent+accountSummaryWriterProjectionSet =+  Catalog.ProjectionSet+    (must (Catalog.mkSourceId "all"))+    (Catalog.ProjectionDefinition+      (must (Catalog.mkProjectionId "account_summary_writer"))+      (must (Catalog.mkRebuildGroupId "reporting"))+      ((must (Catalog.mkTargetId "account_summary_table")) :| [])+      (Catalog.Replayable (Catalog.ReplayAdapter Holes.decodeAccountSummaryWriterReplay Holes.applyAccountSummaryWriterReplay))+      (Catalog.AsyncHandler (AsyncProjection "mapped-readmodel-account-summary-v1" "mapped-readmodel-account-summary" "mapped-readmodel-account-summary" Holes.applyAccountSummaryWriterLive Holes.accountSummaryWriterIdempotencyKey) (must (Catalog.mkSubscriptionId "mapped-readmodel-account-summary")) (must (Catalog.mkDedupKeyId "mapped-readmodel-account-summary-v1")) (must (Catalog.mkClaimSite "projection-owner account_summary_writer async-handler")) :| [])+      (must (Catalog.mkClaimSite "projection-owner account_summary_writer"))+      :| [])+    (must (Catalog.mkClaimSite "projection-owner account_summary_writer source"))++projectionCatalog :: Catalog.ProjectionCatalog+projectionCatalog =+  Catalog.ProjectionCatalog+    [Catalog.SourceDeclaration (must (Catalog.mkSourceId "all")) Catalog.AllStreams "all-streams/generated-codec/v1" (must (Catalog.mkClaimSite "source all"))]+    [Catalog.TargetDeclaration (must (Catalog.mkTargetId "account_summary_table")) (Catalog.QualifiedTable "public" "account_summary") Catalog.ClearBeforeReplay [] (must (Catalog.mkClaimSite "target account_summary_table"))]+    [Catalog.RebuildGroupDeclaration (must (Catalog.mkRebuildGroupId "reporting")) [(must (Catalog.mkTargetId "account_summary_table"))] [] (must (Catalog.mkClaimSite "rebuild-group reporting"))]+    []+    []+    [Catalog.SubscriptionDeclaration (must (Catalog.mkSubscriptionId "mapped-readmodel-account-summary")) "mapped-readmodel-account-summary" (must (Catalog.mkSourceId "all")) KirokuSubscription.FromBeginning (must (Catalog.mkClaimSite "projection-owner account_summary_writer subscription"))]+    [Catalog.DedupKeyDeclaration (must (Catalog.mkDedupKeyId "mapped-readmodel-account-summary-v1")) "mapped-readmodel-account-summary-v1" (must (Catalog.mkClaimSite "projection-owner account_summary_writer dedup"))]+    [Catalog.SomeQueryModelBinding (Catalog.QueryModelBinding (must (Catalog.mkQueryModelId "account_summary")) RMAccountSummary.accountSummaryReadModel (must (Catalog.mkRebuildGroupId "reporting")) [(must (Catalog.mkTargetId "account_summary_table"))] (must (Catalog.mkClaimSite "readmodel account_summary")))]+    [Catalog.SomeProjectionSet accountSummaryWriterProjectionSet]++validatedProjectionCatalog :: Catalog.ValidatedProjectionCatalog+validatedProjectionCatalog = case Catalog.validateProjectionCatalog projectionCatalog of+  Catalog.Success catalog -> catalog+  Catalog.Failure diagnostics -> error ("keiro-dsl generated an invalid projection catalog: " <> show diagnostics)++projectionCatalogInventory :: Catalog.CatalogInventory+projectionCatalogInventory = Catalog.catalogInventory validatedProjectionCatalog++projectionCatalogRegistrations :: [Catalog.CatalogRegistration]+projectionCatalogRegistrations = Catalog.catalogRegistrations validatedProjectionCatalog++projectionCatalogAsyncRegistrations :: [Catalog.AsyncProjectionRegistration]+projectionCatalogAsyncRegistrations = Catalog.asyncProjectionRegistrations validatedProjectionCatalog++projectionCatalogQuerySupplies :: [Catalog.ResolvedQuerySupply]+projectionCatalogQuerySupplies = Catalog.resolvedQuerySupplies validatedProjectionCatalog++registerProjectionCatalog :: (Store :> es) => Eff es (Either Rebuild.CatalogRegistrationError [Rebuild.GroupRebuildMetadata])+registerProjectionCatalog = Rebuild.registerProjectionCatalog validatedProjectionCatalog++reportingRebuildGroupId :: Catalog.RebuildGroupId+reportingRebuildGroupId = (must (Catalog.mkRebuildGroupId "reporting"))++startReportingRebuild :: (IOE :> es, Store :> es) => Rebuild.RebuildOptions -> Eff es (Either Rebuild.CatalogRebuildError Rebuild.RebuildRunReport)+startReportingRebuild = Rebuild.startCatalogRebuild validatedProjectionCatalog reportingRebuildGroupId

+ test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/AccountLookup.hs view

@@ -0,0 +1,12 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from mapped structural AccountLookup; do not edit.+module Generated.MappedReadmodel.Structural.Shape.AccountLookup (AccountLookupShape (..)) where++import Data.Text (Text)+import GHC.Generics (Generic)+import Generated.MappedReadmodel.Structural.Shape.TenantKey qualified as TenantKey++data AccountLookupShape = AccountLookup+  { accountId :: !Text+  , tenant :: !TenantKey.TenantKeyShape+  }+  deriving stock (Eq, Generic, Show)

+ test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/AccountProfile.hs view

@@ -0,0 +1,10 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from mapped structural AccountProfile; do not edit.+module Generated.MappedReadmodel.Structural.Shape.AccountProfile (AccountProfileShape (..)) where++import Data.Text (Text)+import GHC.Generics (Generic)++data AccountProfileShape = AccountProfile+  { displayName :: !Text+  }+  deriving stock (Eq, Generic, Show)

+ test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/AccountSummary.hs view

@@ -0,0 +1,14 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from mapped structural AccountSummary; do not edit.+module Generated.MappedReadmodel.Structural.Shape.AccountSummary (AccountSummaryShape (..)) where++import Data.Text (Text)+import GHC.Generics (Generic)+import Generated.MappedReadmodel.Structural.Shape.AccountProfile qualified as AccountProfile+import Generated.MappedReadmodel.Structural.Shape.TenantKey qualified as TenantKey++data AccountSummaryShape = AccountSummary+  { accountId :: !Text+  , tenant :: !TenantKey.TenantKeyShape+  , profile :: !(Maybe AccountProfile.AccountProfileShape)+  }+  deriving stock (Eq, Generic, Show)

+ test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/TenantKey.hs view

@@ -0,0 +1,10 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from mapped structural TenantKey; do not edit.+module Generated.MappedReadmodel.Structural.Shape.TenantKey (TenantKeyShape (..)) where++import Data.Text (Text)+import GHC.Generics (Generic)++data TenantKeyShape = TenantKey+  { tenantId :: !Text+  }+  deriving stock (Eq, Generic, Show)

+ test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/UnusedFilter.hs view

@@ -0,0 +1,10 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from mapped structural UnusedFilter; do not edit.+module Generated.MappedReadmodel.Structural.Shape.UnusedFilter (UnusedFilterShape (..)) where++import Data.Text (Text)+import GHC.Generics (Generic)++data UnusedFilterShape = UnusedFilter+  { prefix :: !Text+  }+  deriving stock (Eq, Generic, Show)

+ test/conformance-mapped-readmodel/Generated/MappedReadmodel/StructuralConformance.hs view

@@ -0,0 +1,136 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from context mapped-readmodel structural conformance; do not edit.+module Generated.MappedReadmodel.StructuralConformance+  ( structuralConformanceAssertions+  ) where++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.Core (fieldWitnessAgrees)+import Keiki.Shape (CanonicalTypeName (..))+import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape)+import Generated.MappedReadmodel.StructuralProjections qualified as StructuralProjections+import Conformance.MappedReadModel.Bindings qualified as Bindings+import Conformance.MappedReadModel.Domain (AccountLookup, AccountProfile, AccountSummary, TenantKey, UnusedFilter)+import Generated.MappedReadmodel.Structural.Shape.AccountLookup qualified as ShapeAccountLookup+import Generated.MappedReadmodel.Structural.Shape.AccountProfile qualified as ShapeAccountProfile+import Generated.MappedReadmodel.Structural.Shape.AccountSummary qualified as ShapeAccountSummary+import Generated.MappedReadmodel.Structural.Shape.TenantKey qualified as ShapeTenantKey+import Generated.MappedReadmodel.Structural.Shape.UnusedFilter qualified as ShapeUnusedFilter++structuralConformanceAssertions :: [(String, Bool)]+structuralConformanceAssertions =+  concat+    [ accountLookupBindingAssertions+    , accountProfileBindingAssertions+    , accountSummaryBindingAssertions+    , tenantKeyBindingAssertions+    , unusedFilterBindingAssertions+    , [("fixture coverage: conformance.mapped-readmodel.AccountLookup.v1", coverageAccountLookup)]+    , [("fixture coverage: conformance.mapped-readmodel.AccountProfile.v1", coverageAccountProfile)]+    , [("fixture coverage: conformance.mapped-readmodel.AccountSummary.v1", coverageAccountSummary)]+    , [("fixture coverage: conformance.mapped-readmodel.TenantKey.v1", coverageTenantKey)]+    , [("fixture coverage: conformance.mapped-readmodel.UnusedFilter.v1", coverageUnusedFilter)]+    , structuralProjectionAssertions+    ]++validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool+validFixtureLabels cases =+  all (not . T.null) labels && length labels == length (nub labels)+  where+    labels = map fst (NonEmpty.toList cases)++accountLookupBindingAssertions :: [(String, Bool)]+accountLookupBindingAssertions =+  ("fixture labels: conformance.mapped-readmodel.AccountLookup.v1", validFixtureLabels cases) :+  ("canonical identity: conformance.mapped-readmodel.AccountLookup.v1", canonicalTypeName (Proxy @AccountLookup) == "conformance.mapped-readmodel.AccountLookup.v1") :+  concat+    [ [ ("binding domain round-trip: conformance.mapped-readmodel.AccountLookup.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.accountLookupBinding value)+      , ("binding shape round-trip: conformance.mapped-readmodel.AccountLookup.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.accountLookupBinding (bindingToShape Bindings.accountLookupBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.accountLookupCases++accountProfileBindingAssertions :: [(String, Bool)]+accountProfileBindingAssertions =+  ("fixture labels: conformance.mapped-readmodel.AccountProfile.v1", validFixtureLabels cases) :+  ("canonical identity: conformance.mapped-readmodel.AccountProfile.v1", canonicalTypeName (Proxy @AccountProfile) == "conformance.mapped-readmodel.AccountProfile.v1") :+  concat+    [ [ ("binding domain round-trip: conformance.mapped-readmodel.AccountProfile.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.accountProfileBinding value)+      , ("binding shape round-trip: conformance.mapped-readmodel.AccountProfile.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.accountProfileBinding (bindingToShape Bindings.accountProfileBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.accountProfileCases++accountSummaryBindingAssertions :: [(String, Bool)]+accountSummaryBindingAssertions =+  ("fixture labels: conformance.mapped-readmodel.AccountSummary.v1", validFixtureLabels cases) :+  ("canonical identity: conformance.mapped-readmodel.AccountSummary.v1", canonicalTypeName (Proxy @AccountSummary) == "conformance.mapped-readmodel.AccountSummary.v1") :+  concat+    [ [ ("binding domain round-trip: conformance.mapped-readmodel.AccountSummary.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.accountSummaryBinding value)+      , ("binding shape round-trip: conformance.mapped-readmodel.AccountSummary.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.accountSummaryBinding (bindingToShape Bindings.accountSummaryBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.accountSummaryCases++tenantKeyBindingAssertions :: [(String, Bool)]+tenantKeyBindingAssertions =+  ("fixture labels: conformance.mapped-readmodel.TenantKey.v1", validFixtureLabels cases) :+  ("canonical identity: conformance.mapped-readmodel.TenantKey.v1", canonicalTypeName (Proxy @TenantKey) == "conformance.mapped-readmodel.TenantKey.v1") :+  concat+    [ [ ("binding domain round-trip: conformance.mapped-readmodel.TenantKey.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.tenantKeyBinding value)+      , ("binding shape round-trip: conformance.mapped-readmodel.TenantKey.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.tenantKeyBinding (bindingToShape Bindings.tenantKeyBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.tenantKeyCases++unusedFilterBindingAssertions :: [(String, Bool)]+unusedFilterBindingAssertions =+  ("fixture labels: conformance.mapped-readmodel.UnusedFilter.v1", validFixtureLabels cases) :+  ("canonical identity: conformance.mapped-readmodel.UnusedFilter.v1", canonicalTypeName (Proxy @UnusedFilter) == "conformance.mapped-readmodel.UnusedFilter.v1") :+  concat+    [ [ ("binding domain round-trip: conformance.mapped-readmodel.UnusedFilter.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.unusedFilterBinding value)+      , ("binding shape round-trip: conformance.mapped-readmodel.UnusedFilter.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.unusedFilterBinding (bindingToShape Bindings.unusedFilterBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.unusedFilterCases++coverageAccountLookup :: Bool+coverageAccountLookup = True++coverageAccountProfile :: Bool+coverageAccountProfile = True++coverageAccountSummary :: Bool+coverageAccountSummary = any (isNothing . ShapeAccountSummary.profile) shapes && any (isJust . ShapeAccountSummary.profile) shapes+  where+    shapes = map (bindingToShape Bindings.accountSummaryBinding . snd) (NonEmpty.toList (fixtureCases Bindings.accountSummaryCases))++coverageTenantKey :: Bool+coverageTenantKey = True++coverageUnusedFilter :: Bool+coverageUnusedFilter = True++structuralProjectionAssertions :: [(String, Bool)]+structuralProjectionAssertions =+  [ ("projection witness agreement: conformance.mapped-readmodel.AccountLookup.v1/account_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.accountLookupAccountIdWitness (\referenceOwner -> ShapeAccountLookup.accountId (bindingToShape Bindings.accountLookupBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.accountLookupCases)))+  , ("projection witness agreement: conformance.mapped-readmodel.AccountLookup.v1/tenant/tenant_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.accountLookupTenantTenantIdWitness (\referenceOwner -> ShapeTenantKey.tenantId (ShapeAccountLookup.tenant (bindingToShape Bindings.accountLookupBinding referenceOwner))) owner) (NonEmpty.toList (fixtureCases Bindings.accountLookupCases)))+  , ("projection witness agreement: conformance.mapped-readmodel.AccountProfile.v1/display_name", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.accountProfileDisplayNameWitness (\referenceOwner -> ShapeAccountProfile.displayName (bindingToShape Bindings.accountProfileBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.accountProfileCases)))+  , ("projection witness agreement: conformance.mapped-readmodel.AccountSummary.v1/account_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.accountSummaryAccountIdWitness (\referenceOwner -> ShapeAccountSummary.accountId (bindingToShape Bindings.accountSummaryBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.accountSummaryCases)))+  , ("projection witness agreement: conformance.mapped-readmodel.AccountSummary.v1/tenant/tenant_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.accountSummaryTenantTenantIdWitness (\referenceOwner -> ShapeTenantKey.tenantId (ShapeAccountSummary.tenant (bindingToShape Bindings.accountSummaryBinding referenceOwner))) owner) (NonEmpty.toList (fixtureCases Bindings.accountSummaryCases)))+  , ("projection witness agreement: conformance.mapped-readmodel.TenantKey.v1/tenant_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.tenantKeyTenantIdWitness (\referenceOwner -> ShapeTenantKey.tenantId (bindingToShape Bindings.tenantKeyBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.tenantKeyCases)))+  , ("projection witness agreement: conformance.mapped-readmodel.UnusedFilter.v1/prefix", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.unusedFilterPrefixWitness (\referenceOwner -> ShapeUnusedFilter.prefix (bindingToShape Bindings.unusedFilterBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.unusedFilterCases)))+  ]

+ test/conformance-mapped-readmodel/Generated/MappedReadmodel/StructuralProjections.hs view

@@ -0,0 +1,108 @@+{-# LANGUAGE TypeFamilies #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from context mapped-readmodel mapped structural facade; do not edit.+-- Equality witnesses are emitted for Text, Int, Bool, Natural, and UTCTime.+-- Int, Natural, and UTCTime belong to Keiki's ordered subset.+module Generated.MappedReadmodel.StructuralProjections+  ( accountLookupAccountIdWitness+  , accountLookupTenantTenantIdWitness+  , accountProfileDisplayNameWitness+  , accountSummaryAccountIdWitness+  , accountSummaryTenantTenantIdWitness+  , tenantKeyTenantIdWitness+  , unusedFilterPrefixWitness+  ) where++import Data.Text (Text)+import Keiro.Codec.Structural (bindingToShape)+import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)+import Conformance.MappedReadModel.Bindings qualified as Bindings+import Conformance.MappedReadModel.Domain (AccountLookup, AccountProfile, AccountSummary, TenantKey, UnusedFilter)+import Generated.MappedReadmodel.Structural.Shape.AccountLookup qualified as ShapeAccountLookup+import Generated.MappedReadmodel.Structural.Shape.AccountProfile qualified as ShapeAccountProfile+import Generated.MappedReadmodel.Structural.Shape.AccountSummary qualified as ShapeAccountSummary+import Generated.MappedReadmodel.Structural.Shape.TenantKey qualified as ShapeTenantKey+import Generated.MappedReadmodel.Structural.Shape.UnusedFilter qualified as ShapeUnusedFilter++data AccountLookupAccountIdProjection++instance FieldProjection AccountLookupAccountIdProjection where+  type FieldName AccountLookupAccountIdProjection = "/account_id"+  type FieldOwner AccountLookupAccountIdProjection = AccountLookup+  type FieldResult AccountLookupAccountIdProjection = Text+  fieldShapeId _ = "conformance.mapped-readmodel.AccountLookup.v1"+  projectFieldValue _ owner = ShapeAccountLookup.accountId (bindingToShape Bindings.accountLookupBinding owner)++accountLookupAccountIdWitness :: FieldWitness AccountLookupAccountIdProjection+accountLookupAccountIdWitness = fieldWitness @AccountLookupAccountIdProjection++data AccountLookupTenantTenantIdProjection++instance FieldProjection AccountLookupTenantTenantIdProjection where+  type FieldName AccountLookupTenantTenantIdProjection = "/tenant/tenant_id"+  type FieldOwner AccountLookupTenantTenantIdProjection = AccountLookup+  type FieldResult AccountLookupTenantTenantIdProjection = Text+  fieldShapeId _ = "conformance.mapped-readmodel.AccountLookup.v1"+  projectFieldValue _ owner = ShapeTenantKey.tenantId (ShapeAccountLookup.tenant (bindingToShape Bindings.accountLookupBinding owner))++accountLookupTenantTenantIdWitness :: FieldWitness AccountLookupTenantTenantIdProjection+accountLookupTenantTenantIdWitness = fieldWitness @AccountLookupTenantTenantIdProjection++data AccountProfileDisplayNameProjection++instance FieldProjection AccountProfileDisplayNameProjection where+  type FieldName AccountProfileDisplayNameProjection = "/display_name"+  type FieldOwner AccountProfileDisplayNameProjection = AccountProfile+  type FieldResult AccountProfileDisplayNameProjection = Text+  fieldShapeId _ = "conformance.mapped-readmodel.AccountProfile.v1"+  projectFieldValue _ owner = ShapeAccountProfile.displayName (bindingToShape Bindings.accountProfileBinding owner)++accountProfileDisplayNameWitness :: FieldWitness AccountProfileDisplayNameProjection+accountProfileDisplayNameWitness = fieldWitness @AccountProfileDisplayNameProjection++data AccountSummaryAccountIdProjection++instance FieldProjection AccountSummaryAccountIdProjection where+  type FieldName AccountSummaryAccountIdProjection = "/account_id"+  type FieldOwner AccountSummaryAccountIdProjection = AccountSummary+  type FieldResult AccountSummaryAccountIdProjection = Text+  fieldShapeId _ = "conformance.mapped-readmodel.AccountSummary.v1"+  projectFieldValue _ owner = ShapeAccountSummary.accountId (bindingToShape Bindings.accountSummaryBinding owner)++accountSummaryAccountIdWitness :: FieldWitness AccountSummaryAccountIdProjection+accountSummaryAccountIdWitness = fieldWitness @AccountSummaryAccountIdProjection++data AccountSummaryTenantTenantIdProjection++instance FieldProjection AccountSummaryTenantTenantIdProjection where+  type FieldName AccountSummaryTenantTenantIdProjection = "/tenant/tenant_id"+  type FieldOwner AccountSummaryTenantTenantIdProjection = AccountSummary+  type FieldResult AccountSummaryTenantTenantIdProjection = Text+  fieldShapeId _ = "conformance.mapped-readmodel.AccountSummary.v1"+  projectFieldValue _ owner = ShapeTenantKey.tenantId (ShapeAccountSummary.tenant (bindingToShape Bindings.accountSummaryBinding owner))++accountSummaryTenantTenantIdWitness :: FieldWitness AccountSummaryTenantTenantIdProjection+accountSummaryTenantTenantIdWitness = fieldWitness @AccountSummaryTenantTenantIdProjection++data TenantKeyTenantIdProjection++instance FieldProjection TenantKeyTenantIdProjection where+  type FieldName TenantKeyTenantIdProjection = "/tenant_id"+  type FieldOwner TenantKeyTenantIdProjection = TenantKey+  type FieldResult TenantKeyTenantIdProjection = Text+  fieldShapeId _ = "conformance.mapped-readmodel.TenantKey.v1"+  projectFieldValue _ owner = ShapeTenantKey.tenantId (bindingToShape Bindings.tenantKeyBinding owner)++tenantKeyTenantIdWitness :: FieldWitness TenantKeyTenantIdProjection+tenantKeyTenantIdWitness = fieldWitness @TenantKeyTenantIdProjection++data UnusedFilterPrefixProjection++instance FieldProjection UnusedFilterPrefixProjection where+  type FieldName UnusedFilterPrefixProjection = "/prefix"+  type FieldOwner UnusedFilterPrefixProjection = UnusedFilter+  type FieldResult UnusedFilterPrefixProjection = Text+  fieldShapeId _ = "conformance.mapped-readmodel.UnusedFilter.v1"+  projectFieldValue _ owner = ShapeUnusedFilter.prefix (bindingToShape Bindings.unusedFilterBinding owner)++unusedFilterPrefixWitness :: FieldWitness UnusedFilterPrefixProjection+unusedFilterPrefixWitness = fieldWitness @UnusedFilterPrefixProjection

+ test/conformance-mapped-readmodel/Main.hs view

@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Main (main) where++import Conformance.MappedReadModel.Domain (AccountLookup, AccountSummary, fixtureAccountLookup)+import Control.Monad (forM_, unless)+import Generated.MappedReadmodel.AccountSummary.QueryContract (AccountSummaryQueryInput, AccountSummaryQueryResult)+import Generated.MappedReadmodel.AccountSummary.ReadModel (accountSummaryReadModel)+import Generated.MappedReadmodel.AccountSummary.ReadModelHarness (runReadModelFacts)+import Generated.MappedReadmodel.StructuralConformance (structuralConformanceAssertions)+import Hasql.Transaction qualified as Tx+import Keiro.ReadModel (ReadModel (..))+import MappedReadmodel.AccountSummary.ReadModelHoles (accountSummaryQuery)+import System.Exit (exitFailure)++main :: IO ()+main = do+  readModelFactsOk <- runReadModelFacts+  let queryInput :: AccountSummaryQueryInput+      queryInput = fixtureAccountLookup+      queryContractOk = queryInput == fixtureAccountLookup+      runtimeTypeOk = accountSummaryReadModel.name == "mapped-readmodel-account-summary"+      assertions =+        [ ("generated query input is AccountLookup", queryContractOk),+          ("generated ReadModel carries the typed query", runtimeTypeOk),+          ("read-model runtime facts", readModelFactsOk)+        ]+          <> [("structural/" <> label, passed) | (label, passed) <- structuralConformanceAssertions]+  forM_ assertions $ \(label, passed) ->+    putStrLn ((if passed then "PASS  " else "FAIL  ") <> label)+  unless (all snd assertions) exitFailure++_queryReturnsMappedDomain :: AccountLookup -> Tx.Transaction (Maybe AccountSummary)+_queryReturnsMappedDomain = accountSummaryQuery++_generatedContractAgrees :: AccountSummaryQueryInput -> Tx.Transaction AccountSummaryQueryResult+_generatedContractAgrees = accountSummaryQuery

+ test/conformance-mapped-readmodel/MappedReadmodel/AccountSummary/ReadModelHoles.hs view

@@ -0,0 +1,14 @@+-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.+module MappedReadmodel.AccountSummary.ReadModelHoles+  ( accountSummaryQuery,+  )+where++import Conformance.MappedReadModel.Domain (fixtureAccountSummary)+import Generated.MappedReadmodel.AccountSummary.QueryContract (AccountSummaryQueryInput, AccountSummaryQueryResult)+import Generated.MappedReadmodel.AccountSummary.ReadModelTable (accountSummaryQualifiedTable)+import Hasql.Transaction qualified as Tx++accountSummaryQuery :: AccountSummaryQueryInput -> Tx.Transaction AccountSummaryQueryResult+accountSummaryQuery _input =+  accountSummaryQualifiedTable `seq` pure (Just fixtureAccountSummary)

+ test/conformance-mapped-readmodel/MappedReadmodel/ProjectionCatalog/ProjectionCatalogHoles.hs view

@@ -0,0 +1,26 @@+module MappedReadmodel.ProjectionCatalog.ProjectionCatalogHoles+  ( AccountSummaryWriterEvent,+    accountSummaryWriterIdempotencyKey,+    applyAccountSummaryWriterLive,+    applyAccountSummaryWriterReplay,+    decodeAccountSummaryWriterReplay,+  )+where++import Hasql.Transaction qualified as Tx+import Keiro.Projection.Catalog qualified as Catalog+import Kiroku.Store.Types (EventId, RecordedEvent (..))++data AccountSummaryWriterEvent = AccountSummaryWriterEvent++applyAccountSummaryWriterLive :: RecordedEvent -> Tx.Transaction ()+applyAccountSummaryWriterLive _recorded = pure ()++accountSummaryWriterIdempotencyKey :: RecordedEvent -> EventId+accountSummaryWriterIdempotencyKey RecordedEvent {eventId} = eventId++decodeAccountSummaryWriterReplay :: RecordedEvent -> Catalog.ReplayDecodeResult AccountSummaryWriterEvent+decodeAccountSummaryWriterReplay _recorded = Catalog.ReplayRelevant AccountSummaryWriterEvent++applyAccountSummaryWriterReplay :: AccountSummaryWriterEvent -> RecordedEvent -> Tx.Transaction ()+applyAccountSummaryWriterReplay _event _recorded = pure ()

+ test/conformance-newsurface/Generated/TransferRouting/BehaviorSourceMap.hs view

@@ -0,0 +1,29 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context transfer-routing behavior source map; do not edit.+module Generated.TransferRouting.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-8c1612ae6464bb11" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/transfer-routing.keiro" 39 3)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-newsurface/Generated/TransferRouting/Hospital/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit. module Generated.TransferRouting.Hospital.Codec (     hospitalCodec,     parseHospitalEvent,

test/conformance-newsurface/Generated/TransferRouting/Hospital/Domain.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit. module Generated.TransferRouting.Hospital.Domain where  import Data.Text (Text)

test/conformance-newsurface/Generated/TransferRouting/Hospital/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit. module Generated.TransferRouting.Hospital.EventStream   ( hospitalCategory   , hospitalCommandCategory

test/conformance-newsurface/Generated/TransferRouting/Hospital/Harness.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit. module Generated.TransferRouting.Hospital.Harness (harnessAssertions) where  import Generated.TransferRouting.Hospital.Domain

test/conformance-newsurface/Generated/TransferRouting/Hospital/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit. module Generated.TransferRouting.Hospital.Projection () where  -- No projection declarations are present; this module keeps the generated manifest inventory total.

test/conformance-newsurface/Generated/TransferRouting/Hospital/Transducer.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit. module Generated.TransferRouting.Hospital.Transducer   ( hospitalTransducer   , hospitalFoldFingerprint

test/conformance-newsurface/Generated/TransferRouting/HospitalLoad/ReadModel.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from readmodel hospital_load; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from readmodel hospital_load; do not edit. module Generated.TransferRouting.HospitalLoad.ReadModel   ( hospitalLoadReadModel   , hospitalLoadQualifiedTable

test/conformance-newsurface/Generated/TransferRouting/HospitalLoad/ReadModelHarness.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from readmodel hospital_load; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from readmodel hospital_load; do not edit. module Generated.TransferRouting.HospitalLoad.ReadModelHarness (readModelFacts, readModelFactResults, runReadModelFacts) where  import Generated.TransferRouting.HospitalLoad.ReadModel (hospitalLoadReadModel, hospitalLoadAsyncProjection)

test/conformance-newsurface/Generated/TransferRouting/HospitalLoad/ReadModelTable.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from readmodel hospital_load; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from readmodel hospital_load; do not edit. module Generated.TransferRouting.HospitalLoad.ReadModelTable (hospitalLoadQualifiedTable) where  import Data.Text (Text)

test/conformance-newsurface/Generated/TransferRouting/HospitalTransferRouter/Router.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from router HospitalTransferRouter; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from router HospitalTransferRouter; do not edit. module Generated.TransferRouting.HospitalTransferRouter.Router   ( hospitalTransferRouterName   , hospitalTransferRouterWorkerOptions

test/conformance-newsurface/Generated/TransferRouting/HospitalTransferRouter/RouterHarness.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from router HospitalTransferRouter; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from router HospitalTransferRouter; do not edit. module Generated.TransferRouting.HospitalTransferRouter.RouterHarness (routerHarnessValues) where  routerHarnessValues :: [(String, String)]

test/conformance-newsurface/Generated/TransferRouting/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context transfer-routing replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context transfer-routing replay-audit assembly; do not edit. -- -- Deployment contract: --   * replay-neutral diff: no data audit is required;

+ test/conformance-nominal-scalars/Generated/NominalScalars/BehaviorSourceMap.hs view

@@ -0,0 +1,30 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context nominal-scalars behavior source map; do not edit.+module Generated.NominalScalars.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-274eaf83d346048a" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/nominal-scalars.keiro" 84 3)+  "behavior-v1-971c0c80ffdfe018" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/nominal-scalars.keiro" 76 16)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-nominal-scalars/Generated/NominalScalars/Nominal/Shape/OrderStatus.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from bound nominal enum representation OrderStatus; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from bound nominal enum representation OrderStatus; do not edit. module Generated.NominalScalars.Nominal.Shape.OrderStatus (OrderStatusRepresentation (..), orderStatusRepresentationText) where  import Data.Text (Text)

test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/BehaviorContract.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit. module Generated.NominalScalars.NominalLedger.BehaviorContract   ( BehaviorKey (..)   , ObligationKind (..)@@ -21,6 +21,7 @@ import Generated.NominalScalars.NominalLedger.Codec (encodeNominalLedgerEvent, parseNominalLedgerEvent, nominalLedgerCodec) import Generated.NominalScalars.NominalLedger.Domain import Generated.NominalScalars.NominalLedger.Transducer (nominalLedgerTransducer)+import Generated.NominalScalars.BehaviorSourceMap qualified as BehaviorSourceMap import Data.Aeson (ToJSON (..), object, (.=)) import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty)@@ -53,7 +54,6 @@   , requirementExpectedEdge :: !(Maybe (K.EdgeRef NominalLedgerVertex))   , requirementTarget :: !(Maybe NominalLedgerVertex)   , requirementEventKinds :: ![Text]-  , requirementLine :: !Int   }   deriving stock (Eq, Show) @@ -126,7 +126,7 @@  behaviorRequirements :: [BehaviorRequirement] behaviorRequirements =-  [ -- NominalLedgerEmpty x RecordNominals: live transition (spec line 84)+  [ -- NominalLedgerEmpty x RecordNominals: live transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-274eaf83d346048a"       , requirementKind = LiveTransition@@ -137,9 +137,8 @@       , requirementExpectedEdge = (Just (K.EdgeRef NominalLedgerEmpty 0))       , requirementTarget = Just NominalLedgerRecorded       , requirementEventKinds = ["NominalsRecorded"]-      , requirementLine = 84       }-  , -- NominalLedgerRecorded x RecordNominals: required rejection (spec line 76)+  , -- NominalLedgerRecorded x RecordNominals: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-971c0c80ffdfe018"       , requirementKind = RequiredRejection@@ -150,7 +149,6 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 76       }   ] @@ -329,7 +327,7 @@   Left     ( BehaviorFailure         (requirementKey requirement)-        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (spec line " <> tshow (requirementLine requirement) <> ")")+        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey requirement)) <> ")")         code         detail     )

test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit. module Generated.NominalScalars.NominalLedger.Codec (     nominalLedgerCodec,     parseNominalLedgerEvent,

test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Domain.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit. module Generated.NominalScalars.NominalLedger.Domain where  import Data.Aeson (FromJSON, ToJSON)

test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit. module Generated.NominalScalars.NominalLedger.EventStream   ( nominalLedgerCategory   , nominalLedgerCommandCategory

test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Harness.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit. module Generated.NominalScalars.NominalLedger.Harness (harnessAssertions) where  import Generated.NominalScalars.NominalLedger.Domain

test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit. module Generated.NominalScalars.NominalLedger.Projection () where  -- No projection declarations are present; this module keeps the generated manifest inventory total.

test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Transducer.hs view

@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit. module Generated.NominalScalars.NominalLedger.Transducer   ( nominalLedgerTransducer   , nominalLedgerFoldFingerprint

test/conformance-nominal-scalars/Generated/NominalScalars/NominalProjections.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context nominal-scalars nominal scalar projection facade; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context nominal-scalars nominal scalar projection facade; do not edit. module Generated.NominalScalars.NominalProjections where  import Data.KindID qualified as KindID

test/conformance-nominal-scalars/Generated/NominalScalars/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context nominal-scalars replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context nominal-scalars replay-audit assembly; do not edit. -- -- Deployment contract: --   * replay-neutral diff: no data audit is required;

+ test/conformance-process-full/Generated/SurgeDemo/BehaviorSourceMap.hs view

@@ -0,0 +1,36 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context surge-demo behavior source map; do not edit.+module Generated.SurgeDemo.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-364cc8c97a1dccd7" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/surge-service.keiro" 36 25)+  "behavior-v1-4738b03b129c9778" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/surge-service.keiro" 57 3)+  "behavior-v1-7bd417bb60f14aea" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/surge-service.keiro" 43 3)+  "behavior-v1-8303777877a78d98" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/surge-service.keiro" 36 10)+  "behavior-v1-8cc737e3759c26c7" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/surge-service.keiro" 52 15)+  "behavior-v1-9d1377f4e60cd45a" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/surge-service.keiro" 36 25)+  "behavior-v1-c7783d8bb46678fe" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/surge-service.keiro" 36 19)+  "behavior-v1-db2fec76864e5867" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/surge-service.keiro" 44 3)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-process-full/Generated/SurgeDemo/Hospital/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit. module Generated.SurgeDemo.Hospital.Codec (     hospitalCodec,     parseHospitalEvent,

test/conformance-process-full/Generated/SurgeDemo/Hospital/Domain.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit. module Generated.SurgeDemo.Hospital.Domain where  import GHC.Generics (Generic)

test/conformance-process-full/Generated/SurgeDemo/Hospital/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit. module Generated.SurgeDemo.Hospital.EventStream   ( hospitalCategory   , hospitalCommandCategory

test/conformance-process-full/Generated/SurgeDemo/Hospital/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit. module Generated.SurgeDemo.Hospital.Projection   ( hospitalProjection   , hospitalStatusFor

test/conformance-process-full/Generated/SurgeDemo/Hospital/Transducer.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit. module Generated.SurgeDemo.Hospital.Transducer   ( hospitalTransducer   , hospitalFoldFingerprint

test/conformance-process-full/Generated/SurgeDemo/Nominals.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context surge-demo generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context surge-demo generated nominal declarations; do not edit. module Generated.SurgeDemo.Nominals   ( HospitalId   , parseHospitalId

test/conformance-process-full/Generated/SurgeDemo/Nominals/Internal.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context surge-demo generated nominal ID internals; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context surge-demo generated nominal ID internals; do not edit. module Generated.SurgeDemo.Nominals.Internal   ( HospitalId   , parseHospitalId

test/conformance-process-full/Generated/SurgeDemo/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context surge-demo replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context surge-demo replay-audit assembly; do not edit. -- -- Deployment contract: --   * replay-neutral diff: no data audit is required;

test/conformance-process-full/Generated/SurgeDemo/Surge/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit. module Generated.SurgeDemo.Surge.Codec (     surgeCodec,     parseSurgeEvent,

test/conformance-process-full/Generated/SurgeDemo/Surge/Domain.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit. module Generated.SurgeDemo.Surge.Domain where  import GHC.Generics (Generic)

test/conformance-process-full/Generated/SurgeDemo/Surge/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit. module Generated.SurgeDemo.Surge.EventStream   ( surgeCategory   , surgeCommandCategory

test/conformance-process-full/Generated/SurgeDemo/Surge/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit. module Generated.SurgeDemo.Surge.Projection   ( surgeProjection   , surgeStatusFor

test/conformance-process-full/Generated/SurgeDemo/Surge/Transducer.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit. module Generated.SurgeDemo.Surge.Transducer   ( surgeTransducer   , surgeFoldFingerprint

test/conformance-process-full/Generated/SurgeDemo/SurgeFlow/Process.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from process SurgeFlow; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from process SurgeFlow; do not edit. module Generated.SurgeDemo.SurgeFlow.Process   ( surgeFlowProcessName   , surgeFlowCategory

+ test/conformance-process-runtime/Generated/HospitalCapacity/BehaviorSourceMap.hs view

@@ -0,0 +1,31 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity behavior source map; do not edit.+module Generated.HospitalCapacity.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-5198a253324042e6" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/hospital-surge.keiro" 44 3)+  "behavior-v1-6721e0b61aa38780" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/hospital-surge.keiro" 45 3)+  "behavior-v1-69ac3daa8569d350" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/hospital-surge.keiro" 54 3)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-process-runtime/Generated/HospitalCapacity/HospitalSurge/Process.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from process HospitalSurge; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from process HospitalSurge; do not edit. module Generated.HospitalCapacity.HospitalSurge.Process   ( hospitalSurgeProcessName   , hospitalSurgeCategory

test/conformance-process-runtime/Generated/HospitalCapacity/Nominals.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal declarations; do not edit. module Generated.HospitalCapacity.Nominals   ( CommandId   , parseCommandId

test/conformance-process-runtime/Generated/HospitalCapacity/Nominals/Internal.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal ID internals; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal ID internals; do not edit. module Generated.HospitalCapacity.Nominals.Internal   ( CommandId   , parseCommandId

test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit. module Generated.HospitalCapacity.Surge.Codec (     surgeCodec,     parseSurgeEvent,

test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Domain.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit. module Generated.HospitalCapacity.Surge.Domain where  import Data.Text (Text)

test/conformance-process-runtime/Generated/HospitalCapacity/Surge/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit. module Generated.HospitalCapacity.Surge.EventStream   ( surgeCategory   , surgeCommandCategory

test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Transducer.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit. module Generated.HospitalCapacity.Surge.Transducer   ( surgeTransducer   , surgeFoldFingerprint

+ test/conformance-process/Generated/HospitalCapacity/BehaviorSourceMap.hs view

@@ -0,0 +1,31 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity behavior source map; do not edit.+module Generated.HospitalCapacity.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-5198a253324042e6" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/hospital-surge.keiro" 44 3)+  "behavior-v1-6721e0b61aa38780" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/hospital-surge.keiro" 45 3)+  "behavior-v1-69ac3daa8569d350" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/hospital-surge.keiro" 54 3)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-process/Generated/HospitalCapacity/HospitalSurge/ProcessHarness.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from process HospitalSurge; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from process HospitalSurge; do not edit. module Generated.HospitalCapacity.HospitalSurge.ProcessHarness (processHarnessValues) where  -- | (label, value): the spec's deterministic process/timer decisions,

+ test/conformance-projection-catalog/CatalogDemo/CatalogAudit/ReadModelHoles.hs view

@@ -0,0 +1,19 @@+-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.+module CatalogDemo.CatalogAudit.ReadModelHoles+  ( CatalogAuditQueryInput+  , CatalogAuditQueryResult+  , catalogAuditQuery+  ) where++import Generated.CatalogDemo.CatalogAudit.ReadModelTable (catalogAuditQualifiedTable)+import Hasql.Transaction qualified as Tx++-- HOLE: replace these aliases with the real query input and result types.+type CatalogAuditQueryInput = ()+type CatalogAuditQueryResult = ()++-- HOLE: query "sales"."audit_log" via catalogAuditQualifiedTable; never rely on search_path.+-- Declared columns:+--   event_id text NOT NULL+catalogAuditQuery :: CatalogAuditQueryInput -> Tx.Transaction CatalogAuditQueryResult+catalogAuditQuery _input = catalogAuditQualifiedTable `seq` error "HOLE: fill catalogAudit query"

+ test/conformance-projection-catalog/CatalogDemo/MappedBindings.hs view

@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}++module CatalogDemo.MappedBindings+  ( orderPayloadCases,+    qualificationPayloadBinding,+    qualificationPayloadCases,+    qualificationResultCases,+    queryCriteriaCases,+    queueMetadataCases,+    registerStateCases,+    initialRegisterState,+    sharedReferenceCases,+    unusedQualificationCases,+  )+where++import CatalogDemo.MappedDomain+import Data.List.NonEmpty (NonEmpty (..))+import Generated.CatalogDemo.Structural.Shape.QualificationPayload (QualificationPayloadShape)+import Keiro.Codec.Structural (FixtureCases (..), StructuralBinding)+import Keiro.Codec.Structural.Generic (genericStructuralBinding)++qualificationPayloadBinding :: StructuralBinding QualificationPayload QualificationPayloadShape+qualificationPayloadBinding = genericStructuralBinding++orderPayloadCases :: FixtureCases OrderPayload+orderPayloadCases =+  FixtureCases+    ( ("primary", OrderPayload "order-primary")+        :| [("secondary", OrderPayload "order-secondary")]+    )++sharedReferenceCases :: FixtureCases SharedReference+sharedReferenceCases =+  FixtureCases+    ( ("shared-a", SharedReference "shared-a")+        :| [("shared-b", SharedReference "shared-b")]+    )++qualificationPayloadCases :: FixtureCases QualificationPayload+qualificationPayloadCases =+  FixtureCases+    ( ("without-note", QualificationPayload "qualification-a" Nothing)+        :| [("with-note", QualificationPayload "qualification-b" (Just "priority"))]+    )++queueMetadataCases :: FixtureCases QueueMetadata+queueMetadataCases =+  FixtureCases+    ( ("primary", QueueMetadata "queue-primary")+        :| [("secondary", QueueMetadata "queue-secondary")]+    )++queryCriteriaCases :: FixtureCases QueryCriteria+queryCriteriaCases =+  FixtureCases+    ( ("primary", QueryCriteria "query-primary")+        :| [("secondary", QueryCriteria "query-secondary")]+    )++qualificationResultCases :: FixtureCases QualificationResult+qualificationResultCases =+  FixtureCases+    ( ("accepted", QualificationResult "accepted")+        :| [("rejected", QualificationResult "rejected")]+    )++registerStateCases :: FixtureCases RegisterState+registerStateCases =+  FixtureCases+    ( ("initial", initialRegisterState)+        :| [("updated", RegisterState "updated")]+    )++initialRegisterState :: RegisterState+initialRegisterState = RegisterState "initial"++unusedQualificationCases :: FixtureCases UnusedQualification+unusedQualificationCases =+  FixtureCases+    (("unused", UnusedQualification "unused") :| [])

+ test/conformance-projection-catalog/CatalogDemo/MappedDomain.hs view

@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++module CatalogDemo.MappedDomain+  ( OrderPayload (..),+    QualificationPayload (..),+    QualificationResult (..),+    QueryCriteria (..),+    QueueMetadata (..),+    RegisterState (..),+    SharedReference (..),+    UnusedQualification (..),+  )+where++import Data.Aeson (FromJSON, ToJSON)+import Data.Text (Text)+import Data.Proxy (Proxy)+import GHC.Generics (Generic)+import Keiki.Shape (CanonicalTypeName (..))++newtype OrderPayload = OrderPayload {orderPayloadText :: Text}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++newtype SharedReference = SharedReference {sharedReferenceText :: Text}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++data QualificationPayload = QualificationPayload+  { qualificationId :: !Text,+    note :: !(Maybe Text)+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++newtype QueueMetadata = QueueMetadata {queueMetadataText :: Text}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++newtype QueryCriteria = QueryCriteria {queryCriteriaText :: Text}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++newtype QualificationResult = QualificationResult {qualificationResultText :: Text}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++newtype RegisterState = RegisterState {registerStateText :: Text}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++newtype UnusedQualification = UnusedQualification {unusedQualificationText :: Text}+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++instance CanonicalTypeName QualificationPayload where+  canonicalTypeName :: Proxy QualificationPayload -> Text+  canonicalTypeName _ = "catalog-demo.QualificationPayload.v1"

+ test/conformance-projection-catalog/CatalogDemo/OrderInline/ReadModelHoles.hs view

@@ -0,0 +1,15 @@+-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.+module CatalogDemo.OrderInline.ReadModelHoles+  ( orderInlineQuery+  ) where++import CatalogDemo.MappedDomain (QualificationResult (..))+import Generated.CatalogDemo.OrderInline.QueryContract (OrderInlineQueryInput, OrderInlineQueryResult)+import Generated.CatalogDemo.OrderInline.ReadModelTable (orderInlineQualifiedTable)+import Hasql.Transaction qualified as Tx++-- HOLE: query "sales"."order_summary" via orderInlineQualifiedTable; never rely on search_path.+-- Declared columns:+--   order_id text NOT NULL+orderInlineQuery :: OrderInlineQueryInput -> Tx.Transaction OrderInlineQueryResult+orderInlineQuery _input = orderInlineQualifiedTable `seq` pure (Just (QualificationResult "qualified"))

+ test/conformance-projection-catalog/CatalogDemo/OrderTotalsLookup/ReadModelHoles.hs view

@@ -0,0 +1,18 @@+-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.+module CatalogDemo.OrderTotalsLookup.ReadModelHoles+  ( OrderTotalsLookupQueryInput+  , OrderTotalsLookupQueryResult+  , orderTotalsLookupQuery+  ) where++import Generated.CatalogDemo.OrderTotalsLookup.ReadModelTable (orderTotalsLookupQualifiedTable)+import Hasql.Transaction qualified as Tx++type OrderTotalsLookupQueryInput = ()+type OrderTotalsLookupQueryResult = ()++-- HOLE: query "sales"."order_totals" via orderTotalsLookupQualifiedTable; never rely on search_path.+-- Declared columns:+--   total bigint NOT NULL+orderTotalsLookupQuery :: OrderTotalsLookupQueryInput -> Tx.Transaction OrderTotalsLookupQueryResult+orderTotalsLookupQuery _input = orderTotalsLookupQualifiedTable `seq` pure ()

+ test/conformance-projection-catalog/CatalogDemo/Orders/BehaviorHoles.hs view

@@ -0,0 +1,10 @@+-- Consumer-owned behavioral witnesses. Created once; never overwritten.+module CatalogDemo.Orders.BehaviorHoles (behaviorWitnesses) where++import Generated.CatalogDemo.Orders.BehaviorContract++behaviorWitnesses :: [BehaviorWitness]+behaviorWitnesses =+  [ Pending (BehaviorKey "behavior-v1-8861ebe94ff5f68a") -- OrdersEmpty x RecordOrder: live transition+  , Pending (BehaviorKey "behavior-v1-badd7ebab3a3a844") -- OrdersRecorded x RecordOrder: required rejection+  ]

+ test/conformance-projection-catalog/CatalogDemo/Orders/Holes.hs view

@@ -0,0 +1,27 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TypeApplications #-}+-- This is a HAND-OWNED version-2 hook module. keiro-dsl creates it once+-- and never overwrites it. Generated code owns every transition envelope+-- and every declared guard/write. This module supplies explicit event-field+-- mappings and explicitly selected Hole behavior only; fields(Command)+-- identity mappings are generated directly and have no hook.+module CatalogDemo.Orders.Holes+  ( applyOrderInline+  ) where++import Generated.CatalogDemo.Orders.Domain+import Generated.CatalogDemo.OrderInline.ReadModelTable (orderInlineQualifiedTable)+import Hasql.Transaction qualified as Tx+import Kiroku.Store.Types (RecordedEvent)++-- HOLE: the read-model SQL for the projection (a DB-coupled hole; the+-- pure event->status mapping is generated as orderInlineStatusFor).+-- Table: ""."". Use orderInlineQualifiedTable; never rely on search_path.+-- Declared columns:+--   order_id text NOT NULL+applyOrderInline :: OrdersEvent -> RecordedEvent -> Tx.Transaction ()+applyOrderInline _event _recorded = orderInlineQualifiedTable `seq` pure ()

+ test/conformance-projection-catalog/CatalogDemo/ProjectionCatalog/ProjectionCatalogHoles.hs view

@@ -0,0 +1,139 @@+module CatalogDemo.ProjectionCatalog.ProjectionCatalogHoles+  ( applyOrderSummaryWriterLive+  , applyOrderSummaryWriterReplay+  , applyShipmentWriterLive+  , AuditWriterEvent+  , applyAuditWriterLive+  , auditWriterIdempotencyKey+  , applyAuditWriterReplay+  , decodeAuditWriterReplay+  , provisionReportingV1OrderSummary+  , validateReportingV1OrderSummary+  , provisionReportingV1OrderTotals+  , validateReportingV1OrderTotals+  , provisionReportingV1AuditLog+  , validateReportingV1AuditLog+  , applyReportingV1OrderSummaryWriterLive+  , applyReportingV1AuditWriterLive+  , applyReportingV1Replay+  , verifyReportingV1+  , provisionReportingV2OrderSummary+  , validateReportingV2OrderSummary+  , provisionReportingV2OrderTotals+  , validateReportingV2OrderTotals+  , provisionReportingV2AuditLog+  , validateReportingV2AuditLog+  , applyReportingV2OrderSummaryWriterLive+  , applyReportingV2AuditWriterLive+  , applyReportingV2Replay+  , verifyReportingV2+  , orderTotalsReaderV1KeyedExternalRead+  ) where++import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Hasql.Transaction qualified as Tx+import Generated.CatalogDemo.Orders.Domain (OrdersEvent)+import Generated.CatalogDemo.Shipments.Domain (ShipmentsEvent)+import Keiro.Projection.Catalog qualified as Catalog+import Kiroku.Store.Types (EventId, RecordedEvent (..))++applyOrderSummaryWriterLive :: OrdersEvent -> RecordedEvent -> Tx.Transaction ()+applyOrderSummaryWriterLive _event _recorded = pure ()++applyOrderSummaryWriterReplay :: OrdersEvent -> RecordedEvent -> Tx.Transaction ()+applyOrderSummaryWriterReplay _event _recorded = pure ()++applyShipmentWriterLive :: ShipmentsEvent -> RecordedEvent -> Tx.Transaction ()+applyShipmentWriterLive _event _recorded = pure ()++data AuditWriterEvent = AuditWriterEvent++applyAuditWriterLive :: RecordedEvent -> Tx.Transaction ()+applyAuditWriterLive _recorded = pure ()++auditWriterIdempotencyKey :: RecordedEvent -> EventId+auditWriterIdempotencyKey RecordedEvent {eventId} = eventId++decodeAuditWriterReplay :: RecordedEvent -> Catalog.ReplayDecodeResult AuditWriterEvent+decodeAuditWriterReplay _recorded = Catalog.ReplayRelevant AuditWriterEvent++applyAuditWriterReplay :: AuditWriterEvent -> RecordedEvent -> Tx.Transaction ()+applyAuditWriterReplay _event _recorded = pure ()++provisionReportingV1OrderSummary, provisionReportingV1OrderTotals, provisionReportingV1AuditLog :: Catalog.TargetProvisioningContext -> Tx.Transaction ()+provisionReportingV1OrderSummary = provisionNothing+provisionReportingV1OrderTotals = provisionNothing+provisionReportingV1AuditLog = provisionNothing++validateReportingV1OrderSummary, validateReportingV1OrderTotals, validateReportingV1AuditLog :: Catalog.TargetProvisioningContext -> Tx.Transaction (Either [Catalog.TargetSchemaViolation] Catalog.TargetSchemaEvidence)+validateReportingV1OrderSummary = validateAs "order-summary-v1" [promotion Catalog.PromotionIndex "order_summary_status_idx__v1" "order_summary_status_idx"]+validateReportingV1OrderTotals = validateAs "order-totals-v1" [promotion Catalog.PromotionConstraint "order_totals_pkey__v1" "order_totals_pkey"]+validateReportingV1AuditLog = validateAs "audit-log-v1" [promotion Catalog.PromotionOwnedSequence "audit_log_id_seq__v1" "audit_log_id_seq"]++applyReportingV1OrderSummaryWriterLive, applyReportingV1AuditWriterLive :: Catalog.PhysicalTargets -> RecordedEvent -> Tx.Transaction ()+applyReportingV1OrderSummaryWriterLive _targets _recorded = pure ()+applyReportingV1AuditWriterLive _targets _recorded = pure ()++applyReportingV1Replay :: Catalog.PhysicalTargets -> RecordedEvent -> Tx.Transaction (Either Catalog.ReplayDecodeError Bool)+applyReportingV1Replay _targets _recorded = pure (Right False)++verifyReportingV1 :: Catalog.PhysicalTargets -> Tx.Transaction (Either Text ())+verifyReportingV1 _targets = pure (Right ())++provisionReportingV2OrderSummary, provisionReportingV2OrderTotals, provisionReportingV2AuditLog :: Catalog.TargetProvisioningContext -> Tx.Transaction ()+provisionReportingV2OrderSummary = provisionNothing+provisionReportingV2OrderTotals = provisionNothing+provisionReportingV2AuditLog = provisionNothing++validateReportingV2OrderSummary, validateReportingV2OrderTotals, validateReportingV2AuditLog :: Catalog.TargetProvisioningContext -> Tx.Transaction (Either [Catalog.TargetSchemaViolation] Catalog.TargetSchemaEvidence)+validateReportingV2OrderSummary = validateAs "order-summary-v2" [promotion Catalog.PromotionIndex "order_summary_status_idx__v2" "order_summary_status_idx"]+validateReportingV2OrderTotals = validateAs "order-totals-v2" [promotion Catalog.PromotionConstraint "order_totals_pkey__v2" "order_totals_pkey"]+validateReportingV2AuditLog = validateAs "audit-log-v2" [promotion Catalog.PromotionOwnedSequence "audit_log_id_seq__v2" "audit_log_id_seq"]++applyReportingV2OrderSummaryWriterLive, applyReportingV2AuditWriterLive :: Catalog.PhysicalTargets -> RecordedEvent -> Tx.Transaction ()+applyReportingV2OrderSummaryWriterLive _targets _recorded = pure ()+applyReportingV2AuditWriterLive _targets _recorded = pure ()++applyReportingV2Replay :: Catalog.PhysicalTargets -> RecordedEvent -> Tx.Transaction (Either Catalog.ReplayDecodeError Bool)+applyReportingV2Replay _targets _recorded = pure (Right False)++verifyReportingV2 :: Catalog.PhysicalTargets -> Tx.Transaction (Either Text ())+verifyReportingV2 _targets = pure (Right ())++-- Application-owned keyed alternative to the bounded generated all-row contract.+orderTotalsReaderV1KeyedExternalRead :: [Catalog.SqlFunctionArgument] -> Catalog.QualifiedFunction -> Int -> Catalog.ExternalReadContract+orderTotalsReaderV1KeyedExternalRead arguments privateImplementation privateImplementationVersion =+  Catalog.KeyedExternalRead+    (must (Catalog.mkExternalReadContractId "order_totals_reader"))+    (Catalog.ExternalReadContractVersion 1)+    (must (Catalog.mkQueryModelId "order_totals_lookup"))+    arguments+    (Catalog.QualifiedSqlType "app_contract" "order_totals_row_v1")+    privateImplementation+    privateImplementationVersion+    "fnv1a:768a23d719dcb4d4"+    (must (Catalog.mkProjectionRevisionId "reporting_v1") :| [must (Catalog.mkProjectionRevisionId "reporting_v2")])+    1+    (must (Catalog.mkClaimSite "external-read order_totals_reader v1 keyed helper"))++provisionNothing :: Catalog.TargetProvisioningContext -> Tx.Transaction ()+provisionNothing _context = pure ()++validateAs :: Text -> [Catalog.PromotionObjectName] -> Catalog.TargetProvisioningContext -> Tx.Transaction (Either [Catalog.TargetSchemaViolation] Catalog.TargetSchemaEvidence)+validateAs shape promotionObjects _context =+  pure+    ( Right+        Catalog.TargetSchemaEvidence+          { relationOid = 1,+            observedShapeFingerprint = shape,+            observedPromotionObjects = promotionObjects,+            catalogSnapshot = "conformance-catalog-snapshot-v1"+          }+    )++promotion :: Catalog.PromotionObjectKind -> Text -> Text -> Catalog.PromotionObjectName+promotion = Catalog.PromotionObjectName++must :: Show error => Either error value -> value+must = either (error . show) id

+ test/conformance-projection-catalog/CatalogDemo/ShipmentLookup/ReadModelHoles.hs view

@@ -0,0 +1,19 @@+-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.+module CatalogDemo.ShipmentLookup.ReadModelHoles+  ( ShipmentLookupQueryInput+  , ShipmentLookupQueryResult+  , shipmentLookupQuery+  ) where++import Generated.CatalogDemo.ShipmentLookup.ReadModelTable (shipmentLookupQualifiedTable)+import Hasql.Transaction qualified as Tx++-- HOLE: replace these aliases with the real query input and result types.+type ShipmentLookupQueryInput = ()+type ShipmentLookupQueryResult = ()++-- HOLE: query "sales"."shipment_summary" via shipmentLookupQualifiedTable; never rely on search_path.+-- Declared columns:+--   shipment_id text NOT NULL+shipmentLookupQuery :: ShipmentLookupQueryInput -> Tx.Transaction ShipmentLookupQueryResult+shipmentLookupQuery _input = shipmentLookupQualifiedTable `seq` pure ()

+ test/conformance-projection-catalog/CatalogDemo/Shipments/BehaviorHoles.hs view

@@ -0,0 +1,10 @@+-- Consumer-owned behavioral witnesses. Created once; never overwritten.+module CatalogDemo.Shipments.BehaviorHoles (behaviorWitnesses) where++import Generated.CatalogDemo.Shipments.BehaviorContract++behaviorWitnesses :: [BehaviorWitness]+behaviorWitnesses =+  [ Pending (BehaviorKey "behavior-v1-89eeb23ded471fe8") -- ShipmentsRecorded x RecordShipment: required rejection+  , Pending (BehaviorKey "behavior-v1-b0a7e39ecba10454") -- ShipmentsEmpty x RecordShipment: live transition+  ]

+ test/conformance-projection-catalog/Generated/CatalogDemo/BehaviorSourceMap.hs view

@@ -0,0 +1,32 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from context catalog-demo behavior source map; do not edit.+module Generated.CatalogDemo.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-8861ebe94ff5f68a" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/projection-catalog.keiro" 282 3)+  "behavior-v1-89eeb23ded471fe8" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/projection-catalog.keiro" 289 16)+  "behavior-v1-b0a7e39ecba10454" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/projection-catalog.keiro" 294 3)+  "behavior-v1-badd7ebab3a3a844" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/projection-catalog.keiro" 277 16)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

+ test/conformance-projection-catalog/Generated/CatalogDemo/CatalogAudit/ReadModel.hs view

@@ -0,0 +1,25 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel catalogAudit; do not edit.+module Generated.CatalogDemo.CatalogAudit.ReadModel+  ( catalogAuditReadModel+  , catalogAuditQualifiedTable+  ) where++import Generated.CatalogDemo.CatalogAudit.ReadModelTable (catalogAuditQualifiedTable)+import CatalogDemo.CatalogAudit.ReadModelHoles (CatalogAuditQueryInput, CatalogAuditQueryResult, catalogAuditQuery)+import Keiro.ReadModel (QueryCursorAuthority (..), ReadModel, ReadModelBlueprint (..), immediateReadModel)++catalogAuditReadModel :: ReadModel CatalogAuditQueryInput CatalogAuditQueryResult+catalogAuditReadModel =+  immediateReadModel catalogAuditReadModelBlueprint++catalogAuditReadModelBlueprint :: ReadModelBlueprint CatalogAuditQueryInput CatalogAuditQueryResult+catalogAuditReadModelBlueprint =+  ReadModelBlueprint+    { name = "catalog-demo-catalogAudit"+    , tableName = "audit_log"+    , schema = "sales"+    , version = 1+    , shapeHash = "fnv1a:9682af3ada04bf50"+    , cursorAuthority = DurableQueryCursor "catalog-demo-audit"+    , query = catalogAuditQuery+    }

+ test/conformance-projection-catalog/Generated/CatalogDemo/CatalogAudit/ReadModelHarness.hs view

@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedRecordDot #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel catalogAudit; do not edit.+module Generated.CatalogDemo.CatalogAudit.ReadModelHarness (readModelFacts, readModelFactResults, runReadModelFacts, catalogFactsAgainst) where++import Generated.CatalogDemo.CatalogAudit.ReadModel (catalogAuditReadModel)+import Data.Text qualified as T+import Data.List.NonEmpty qualified as NE+import Generated.CatalogDemo.ProjectionCatalog qualified as ProjectionCatalog+import Keiro.Projection.Catalog qualified as Catalog+import Keiro.ReadModel (ReadModel (..), readModelCursorAuthority, readModelDefaultFreshness)++-- | (fact, expected from notation, actual generated runtime value).+readModelFacts :: [(String, String, String)]+readModelFacts =+  [ ("registryName", "catalog-demo-catalogAudit", T.unpack catalogAuditReadModel.name)+  , ("shapeHash", "fnv1a:9682af3ada04bf50", T.unpack catalogAuditReadModel.shapeHash)+  , ("freshness", "Immediate", show (readModelDefaultFreshness catalogAuditReadModel))+  , ("cursorAuthority", "DurableQueryCursor \"catalog-demo-audit\"", show (readModelCursorAuthority catalogAuditReadModel))+  ]+    <> catalogFactsAgainst ProjectionCatalog.projectionCatalogRegistrations ProjectionCatalog.projectionCatalogAsyncRegistrations ProjectionCatalog.projectionCatalogQuerySupplies++catalogFactsAgainst :: [Catalog.CatalogRegistration] -> [Catalog.AsyncProjectionRegistration] -> [Catalog.ResolvedQuerySupply] -> [(String, String, String)]+catalogFactsAgainst registrations asyncRegistrations supplies =+  [ ("catalogRegistration", "catalog-demo-catalogAudit|1|fnv1a:9682af3ada04bf50|reporting", renderRegistration [entry | entry <- registrations, Catalog.queryModelIdText entry.queryModelId == "catalogAudit"])+  , ("querySupply", "audit_writer|reporting|audit_log", renderSupply [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "catalogAudit"])+  , ("projectionDelivery", "subscription", renderDelivery [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "catalogAudit"])+  , ("asyncRegistration:audit_writer", "catalog-demo-audit|catalog-demo-audit-v1", renderAsync [entry | entry <- asyncRegistrations, Catalog.projectionIdText entry.projectionId == "audit_writer"])+  ]++renderRegistration :: [Catalog.CatalogRegistration] -> String+renderRegistration [entry] = T.unpack entry.registryName <> "|" <> show entry.version <> "|" <> T.unpack entry.shapeHash <> "|" <> T.unpack (Catalog.rebuildGroupIdText entry.rebuildGroupId)+renderRegistration _ = "missing"++renderSupply :: [Catalog.ResolvedQuerySupply] -> String+renderSupply [entry] = T.unpack (Catalog.projectionIdText entry.resolvedProjectionId) <> "|" <> T.unpack (Catalog.rebuildGroupIdText entry.resolvedRebuildGroupId) <> "|" <> T.unpack (T.intercalate "," (map Catalog.targetIdText (NE.toList entry.resolvedObservedTargets)))+renderSupply _ = "missing"++renderDelivery :: [Catalog.ResolvedQuerySupply] -> String+renderDelivery [entry] = T.unpack (T.intercalate "," (map renderCapability (NE.toList entry.resolvedHandlerCapabilities)))+renderDelivery _ = "missing"++renderCapability :: Catalog.ProjectionHandlerCapability -> T.Text+renderCapability Catalog.InlineCapability {} = "inline"+renderCapability Catalog.SubscriptionCapability {} = "subscription"++renderAsync :: [Catalog.AsyncProjectionRegistration] -> String+renderAsync [entry] = T.unpack entry.subscriptionName <> "|" <> T.unpack entry.dedupName+renderAsync _ = "missing"++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)

+ test/conformance-projection-catalog/Generated/CatalogDemo/CatalogAudit/ReadModelTable.hs view

@@ -0,0 +1,9 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel catalogAudit; do not edit.+module Generated.CatalogDemo.CatalogAudit.ReadModelTable (catalogAuditQualifiedTable) where++import Data.Text (Text)+import Keiro.Connection (qualifyTable)++-- The fully-qualified, double-quoted data-table reference.+catalogAuditQualifiedTable :: Text+catalogAuditQualifiedTable = qualifyTable "sales" "audit_log"

+ test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/QueryContract.hs view

@@ -0,0 +1,10 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel order_inline; do not edit.+module Generated.CatalogDemo.OrderInline.QueryContract+  ( OrderInlineQueryInput+  , OrderInlineQueryResult+  ) where++import CatalogDemo.MappedDomain (QualificationResult, QueryCriteria)++type OrderInlineQueryInput = QueryCriteria+type OrderInlineQueryResult = Maybe QualificationResult

+ test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/ReadModel.hs view

@@ -0,0 +1,26 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel order_inline; do not edit.+module Generated.CatalogDemo.OrderInline.ReadModel+  ( orderInlineReadModel+  , orderInlineQualifiedTable+  ) where++import Generated.CatalogDemo.OrderInline.ReadModelTable (orderInlineQualifiedTable)+import Generated.CatalogDemo.OrderInline.QueryContract (OrderInlineQueryInput, OrderInlineQueryResult)+import CatalogDemo.OrderInline.ReadModelHoles (orderInlineQuery)+import Keiro.ReadModel (QueryCursorAuthority (..), ReadModel, ReadModelBlueprint (..), immediateReadModel)++orderInlineReadModel :: ReadModel OrderInlineQueryInput OrderInlineQueryResult+orderInlineReadModel =+  immediateReadModel orderInlineReadModelBlueprint++orderInlineReadModelBlueprint :: ReadModelBlueprint OrderInlineQueryInput OrderInlineQueryResult+orderInlineReadModelBlueprint =+  ReadModelBlueprint+    { name = "catalog-demo-order-inline"+    , tableName = "order_summary"+    , schema = "sales"+    , version = 1+    , shapeHash = "fnv1a:784e511a19f74c58"+    , cursorAuthority = NoQueryCursor+    , query = orderInlineQuery+    }

+ test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/ReadModelHarness.hs view

@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedRecordDot #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel order_inline; do not edit.+module Generated.CatalogDemo.OrderInline.ReadModelHarness (readModelFacts, readModelFactResults, runReadModelFacts, catalogFactsAgainst) where++import Generated.CatalogDemo.OrderInline.ReadModel (orderInlineReadModel)+import Data.Text qualified as T+import Data.List.NonEmpty qualified as NE+import Generated.CatalogDemo.ProjectionCatalog qualified as ProjectionCatalog+import Keiro.Projection.Catalog qualified as Catalog+import Keiro.ReadModel (ReadModel (..), readModelCursorAuthority, readModelDefaultFreshness)++-- | (fact, expected from notation, actual generated runtime value).+readModelFacts :: [(String, String, String)]+readModelFacts =+  [ ("registryName", "catalog-demo-order-inline", T.unpack orderInlineReadModel.name)+  , ("shapeHash", "fnv1a:784e511a19f74c58", T.unpack orderInlineReadModel.shapeHash)+  , ("freshness", "Immediate", show (readModelDefaultFreshness orderInlineReadModel))+  , ("cursorAuthority", "NoQueryCursor", show (readModelCursorAuthority orderInlineReadModel))+  ]+    <> catalogFactsAgainst ProjectionCatalog.projectionCatalogRegistrations ProjectionCatalog.projectionCatalogAsyncRegistrations ProjectionCatalog.projectionCatalogQuerySupplies++catalogFactsAgainst :: [Catalog.CatalogRegistration] -> [Catalog.AsyncProjectionRegistration] -> [Catalog.ResolvedQuerySupply] -> [(String, String, String)]+catalogFactsAgainst registrations _asyncRegistrations supplies =+  [ ("catalogRegistration", "catalog-demo-order-inline|1|fnv1a:784e511a19f74c58|reporting", renderRegistration [entry | entry <- registrations, Catalog.queryModelIdText entry.queryModelId == "order_inline"])+  , ("querySupply", "order_summary_writer|reporting|order_summary", renderSupply [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "order_inline"])+  , ("projectionDelivery", "inline", renderDelivery [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "order_inline"])+  ]++renderRegistration :: [Catalog.CatalogRegistration] -> String+renderRegistration [entry] = T.unpack entry.registryName <> "|" <> show entry.version <> "|" <> T.unpack entry.shapeHash <> "|" <> T.unpack (Catalog.rebuildGroupIdText entry.rebuildGroupId)+renderRegistration _ = "missing"++renderSupply :: [Catalog.ResolvedQuerySupply] -> String+renderSupply [entry] = T.unpack (Catalog.projectionIdText entry.resolvedProjectionId) <> "|" <> T.unpack (Catalog.rebuildGroupIdText entry.resolvedRebuildGroupId) <> "|" <> T.unpack (T.intercalate "," (map Catalog.targetIdText (NE.toList entry.resolvedObservedTargets)))+renderSupply _ = "missing"++renderDelivery :: [Catalog.ResolvedQuerySupply] -> String+renderDelivery [entry] = T.unpack (T.intercalate "," (map renderCapability (NE.toList entry.resolvedHandlerCapabilities)))+renderDelivery _ = "missing"++renderCapability :: Catalog.ProjectionHandlerCapability -> T.Text+renderCapability Catalog.InlineCapability {} = "inline"+renderCapability Catalog.SubscriptionCapability {} = "subscription"++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)

+ test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/ReadModelTable.hs view

@@ -0,0 +1,9 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel order_inline; do not edit.+module Generated.CatalogDemo.OrderInline.ReadModelTable (orderInlineQualifiedTable) where++import Data.Text (Text)+import Keiro.Connection (qualifyTable)++-- The fully-qualified, double-quoted data-table reference.+orderInlineQualifiedTable :: Text+orderInlineQualifiedTable = qualifyTable "sales" "order_summary"

+ test/conformance-projection-catalog/Generated/CatalogDemo/OrderTotalsLookup/ReadModel.hs view

@@ -0,0 +1,25 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel order_totals_lookup; do not edit.+module Generated.CatalogDemo.OrderTotalsLookup.ReadModel+  ( orderTotalsLookupReadModel+  , orderTotalsLookupQualifiedTable+  ) where++import Generated.CatalogDemo.OrderTotalsLookup.ReadModelTable (orderTotalsLookupQualifiedTable)+import CatalogDemo.OrderTotalsLookup.ReadModelHoles (OrderTotalsLookupQueryInput, OrderTotalsLookupQueryResult, orderTotalsLookupQuery)+import Keiro.ReadModel (QueryCursorAuthority (..), ReadModel, ReadModelBlueprint (..), immediateReadModel)++orderTotalsLookupReadModel :: ReadModel OrderTotalsLookupQueryInput OrderTotalsLookupQueryResult+orderTotalsLookupReadModel =+  immediateReadModel orderTotalsLookupReadModelBlueprint++orderTotalsLookupReadModelBlueprint :: ReadModelBlueprint OrderTotalsLookupQueryInput OrderTotalsLookupQueryResult+orderTotalsLookupReadModelBlueprint =+  ReadModelBlueprint+    { name = "catalog-demo-order-totals-lookup"+    , tableName = "order_totals"+    , schema = "sales"+    , version = 1+    , shapeHash = "fnv1a:768a23d719dcb4d4"+    , cursorAuthority = NoQueryCursor+    , query = orderTotalsLookupQuery+    }

+ test/conformance-projection-catalog/Generated/CatalogDemo/OrderTotalsLookup/ReadModelHarness.hs view

@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedRecordDot #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel order_totals_lookup; do not edit.+module Generated.CatalogDemo.OrderTotalsLookup.ReadModelHarness (readModelFacts, readModelFactResults, runReadModelFacts, catalogFactsAgainst) where++import Generated.CatalogDemo.OrderTotalsLookup.ReadModel (orderTotalsLookupReadModel)+import Data.Text qualified as T+import Data.List.NonEmpty qualified as NE+import Generated.CatalogDemo.ProjectionCatalog qualified as ProjectionCatalog+import Keiro.Projection.Catalog qualified as Catalog+import Keiro.ReadModel (ReadModel (..), readModelCursorAuthority, readModelDefaultFreshness)++-- | (fact, expected from notation, actual generated runtime value).+readModelFacts :: [(String, String, String)]+readModelFacts =+  [ ("registryName", "catalog-demo-order-totals-lookup", T.unpack orderTotalsLookupReadModel.name)+  , ("shapeHash", "fnv1a:768a23d719dcb4d4", T.unpack orderTotalsLookupReadModel.shapeHash)+  , ("freshness", "Immediate", show (readModelDefaultFreshness orderTotalsLookupReadModel))+  , ("cursorAuthority", "NoQueryCursor", show (readModelCursorAuthority orderTotalsLookupReadModel))+  ]+    <> catalogFactsAgainst ProjectionCatalog.projectionCatalogRegistrations ProjectionCatalog.projectionCatalogAsyncRegistrations ProjectionCatalog.projectionCatalogQuerySupplies++catalogFactsAgainst :: [Catalog.CatalogRegistration] -> [Catalog.AsyncProjectionRegistration] -> [Catalog.ResolvedQuerySupply] -> [(String, String, String)]+catalogFactsAgainst registrations _asyncRegistrations supplies =+  [ ("catalogRegistration", "catalog-demo-order-totals-lookup|1|fnv1a:768a23d719dcb4d4|reporting", renderRegistration [entry | entry <- registrations, Catalog.queryModelIdText entry.queryModelId == "order_totals_lookup"])+  , ("querySupply", "order_summary_writer|reporting|order_totals", renderSupply [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "order_totals_lookup"])+  , ("projectionDelivery", "inline", renderDelivery [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "order_totals_lookup"])+  ]++renderRegistration :: [Catalog.CatalogRegistration] -> String+renderRegistration [entry] = T.unpack entry.registryName <> "|" <> show entry.version <> "|" <> T.unpack entry.shapeHash <> "|" <> T.unpack (Catalog.rebuildGroupIdText entry.rebuildGroupId)+renderRegistration _ = "missing"++renderSupply :: [Catalog.ResolvedQuerySupply] -> String+renderSupply [entry] = T.unpack (Catalog.projectionIdText entry.resolvedProjectionId) <> "|" <> T.unpack (Catalog.rebuildGroupIdText entry.resolvedRebuildGroupId) <> "|" <> T.unpack (T.intercalate "," (map Catalog.targetIdText (NE.toList entry.resolvedObservedTargets)))+renderSupply _ = "missing"++renderDelivery :: [Catalog.ResolvedQuerySupply] -> String+renderDelivery [entry] = T.unpack (T.intercalate "," (map renderCapability (NE.toList entry.resolvedHandlerCapabilities)))+renderDelivery _ = "missing"++renderCapability :: Catalog.ProjectionHandlerCapability -> T.Text+renderCapability Catalog.InlineCapability {} = "inline"+renderCapability Catalog.SubscriptionCapability {} = "subscription"++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)

+ test/conformance-projection-catalog/Generated/CatalogDemo/OrderTotalsLookup/ReadModelTable.hs view

@@ -0,0 +1,9 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel order_totals_lookup; do not edit.+module Generated.CatalogDemo.OrderTotalsLookup.ReadModelTable (orderTotalsLookupQualifiedTable) where++import Data.Text (Text)+import Keiro.Connection (qualifyTable)++-- The fully-qualified, double-quoted data-table reference.+orderTotalsLookupQualifiedTable :: Text+orderTotalsLookupQualifiedTable = qualifyTable "sales" "order_totals"

+ test/conformance-projection-catalog/Generated/CatalogDemo/Orders/BehaviorContract.hs view

@@ -0,0 +1,346 @@+{-# LANGUAGE OverloadedLabels #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit.+module Generated.CatalogDemo.Orders.BehaviorContract+  ( BehaviorKey (..)+  , ObligationKind (..)+  , EvidenceLevel (..)+  , GuardCoverage (..)+  , BehaviorRequirement (..)+  , RejectionClass (..)+  , LiveExpectation (..)+  , BehaviorWitness (..)+  , BehaviorFailure (..)+  , BehaviorConformanceReport (..)+  , behaviorRequirements+  , behaviorCoverageReport+  , behaviorConformancePassed+  , behaviorConformancePassedWith+  , renderBehaviorConformanceText+  ) where++import Generated.CatalogDemo.Orders.Codec (encodeOrdersEvent, parseOrdersEvent, ordersCodec)+import Generated.CatalogDemo.Orders.Domain+import Generated.CatalogDemo.Orders.Transducer (ordersTransducer)+import Generated.CatalogDemo.BehaviorSourceMap qualified as BehaviorSourceMap+import Data.Aeson (ToJSON (..), object, (.=))+import Data.List (sortOn)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Keiki.Core qualified as K (EdgeMode (..), EdgeRef (..), RegFile, ReplayAttribution (..), ReplayEventSpan (..), ReplaySuccess (..), StepFailure (..), StepSuccess (..), applyEventsDetailedEither, stepDetailedEither, (!))+import Keiro.Codec qualified as Codec (Codec (eventType), EventType (..))++newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }+  deriving stock (Eq, Ord, Show)++data ObligationKind = LiveTransition | RequiredRejection | ReplayTransition+  deriving stock (Eq, Ord, Show)++data EvidenceLevel = GeneratedAuthoritative | HoleWitnessed | LegacyRuntimeWitness+  deriving stock (Eq, Ord, Show)++data GuardCoverage = GuardTotal | GuardPartial | GuardUnknown | GuardNotApplicable+  deriving stock (Eq, Ord, Show)++data BehaviorRequirement = BehaviorRequirement+  { requirementKey :: !BehaviorKey+  , requirementKind :: !ObligationKind+  , requirementEvidence :: !EvidenceLevel+  , requirementGuardCoverage :: !GuardCoverage+  , requirementSource :: !OrdersVertex+  , requirementCommandName :: !Text+  , requirementExpectedEdge :: !(Maybe (K.EdgeRef OrdersVertex))+  , requirementTarget :: !(Maybe OrdersVertex)+  , requirementEventKinds :: ![Text]+  }+  deriving stock (Eq, Show)++data RejectionClass = RejectNoOutgoingEdges | RejectNoMatchingEdge+  deriving stock (Eq, Show)++data LiveExpectation+  = Emits (NonEmpty OrdersEvent)+  | Rejects RejectionClass+  | NoOp+  deriving stock (Eq, Show)++data BehaviorWitness+  = Pending BehaviorKey+  | LiveWitness+      { witnessKey :: BehaviorKey+      , witnessHistory :: [OrdersEvent]+      , witnessCommand :: OrdersCommand+      , witnessExpected :: LiveExpectation+      }+  | ReplayWitness+      { witnessKey :: BehaviorKey+      , witnessHistoryPrefix :: [OrdersEvent]+      , witnessObservedChunk :: [OrdersEvent]+      }+  deriving stock (Eq, Show)++data BehaviorFailure = BehaviorFailure+  { failureKey :: !BehaviorKey+  , failureSubject :: !Text+  , failureCode :: !Text+  , failureDetail :: !Text+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorFailure where+  toJSON behaviorFailure = object+    [ "key" .= unBehaviorKey (failureKey behaviorFailure)+    , "subject" .= failureSubject behaviorFailure+    , "code" .= failureCode behaviorFailure+    , "detail" .= failureDetail behaviorFailure+    ]++data BehaviorConformanceReport = BehaviorConformanceReport+  { reportRequired :: ![BehaviorKey]+  , reportFilled :: ![BehaviorKey]+  , reportPending :: ![BehaviorKey]+  , reportMissing :: ![BehaviorKey]+  , reportDuplicate :: ![BehaviorKey]+  , reportStale :: ![BehaviorKey]+  , reportFailed :: ![BehaviorFailure]+  , reportVerified :: ![BehaviorKey]+  , reportUnverified :: ![BehaviorKey]+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorConformanceReport where+  toJSON report = object+    [ "schema" .= ("keiro/behavior-conformance/1" :: Text)+    , "required" .= keyTexts (reportRequired report)+    , "filled" .= keyTexts (reportFilled report)+    , "pending" .= keyTexts (reportPending report)+    , "missing" .= keyTexts (reportMissing report)+    , "duplicate" .= keyTexts (reportDuplicate report)+    , "stale" .= keyTexts (reportStale report)+    , "failed" .= reportFailed report+    , "verified" .= keyTexts (reportVerified report)+    , "unverified" .= keyTexts (reportUnverified report)+    ]++behaviorRequirements :: [BehaviorRequirement]+behaviorRequirements =+  [ -- OrdersEmpty x RecordOrder: live transition+    BehaviorRequirement+      { requirementKey = BehaviorKey "behavior-v1-8861ebe94ff5f68a"+      , requirementKind = LiveTransition+      , requirementEvidence = GeneratedAuthoritative+      , requirementGuardCoverage = GuardTotal+      , requirementSource = OrdersEmpty+      , requirementCommandName = "RecordOrder"+      , requirementExpectedEdge = (Just (K.EdgeRef OrdersEmpty 0))+      , requirementTarget = Just OrdersRecorded+      , requirementEventKinds = ["OrderRecorded"]+      }+  , -- OrdersRecorded x RecordOrder: required rejection+    BehaviorRequirement+      { requirementKey = BehaviorKey "behavior-v1-badd7ebab3a3a844"+      , requirementKind = RequiredRejection+      , requirementEvidence = GeneratedAuthoritative+      , requirementGuardCoverage = GuardNotApplicable+      , requirementSource = OrdersRecorded+      , requirementCommandName = "RecordOrder"+      , requirementExpectedEdge = Nothing+      , requirementTarget = Nothing+      , requirementEventKinds = []+      }+  ]++behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport+behaviorCoverageReport witnesses =+  BehaviorConformanceReport+    { reportRequired = sortedKeys (Map.keys requiredByKey)+    , reportFilled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , reportPending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , reportMissing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , reportDuplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , reportStale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , reportFailed = sortOn (unBehaviorKey . failureKey) failures+    , reportVerified = sortedKeys [requirementKey requirement | (requirement, Right ()) <- executions, proofStrength requirement]+    , reportUnverified = sortedKeys [requirementKey requirement | (requirement, Right ()) <- executions, not (proofStrength requirement)]+    }+ where+  requiredByKey = Map.fromList [(requirementKey requirement, requirement) | requirement <- behaviorRequirements]+  witnessGroups = Map.fromListWith (flip (<>)) [(behaviorWitnessKey witness, [witness]) | witness <- witnesses]+  executions =+    [ (requirement, runWitness requirement witness)+    | (key, [witness]) <- Map.toList witnessGroups+    , not (isPending witness)+    , Just requirement <- [Map.lookup key requiredByKey]+    ]+  failures = [behaviorFailure | (_, Left behaviorFailure) <- executions]++behaviorConformancePassed :: BehaviorConformanceReport -> Bool+behaviorConformancePassed = behaviorConformancePassedWith False++behaviorConformancePassedWith :: Bool -> BehaviorConformanceReport -> Bool+behaviorConformancePassedWith failOnUnverified report =+  null (reportPending report)+    && null (reportMissing report)+    && null (reportDuplicate report)+    && null (reportStale report)+    && null (reportFailed report)+    && (not failOnUnverified || null (reportUnverified report))++renderBehaviorConformanceText :: BehaviorConformanceReport -> Text+renderBehaviorConformanceText report = T.unlines+  [ "behavior conformance: Orders"+  , "schema: keiro/behavior-conformance/1"+  , countLine "required" (reportRequired report)+  , countLine "filled" (reportFilled report)+  , countLine "pending" (reportPending report)+  , countLine "missing" (reportMissing report)+  , countLine "duplicate" (reportDuplicate report)+  , countLine "stale" (reportStale report)+  , "failed: " <> tshow (length (reportFailed report))+  , countLine "verified" (reportVerified report)+  , countLine "unverified" (reportUnverified report)+  ] <> T.unlines ["FAIL " <> unBehaviorKey (failureKey behaviorFailure) <> " " <> failureSubject behaviorFailure <> " [" <> failureCode behaviorFailure <> "] " <> failureDetail behaviorFailure | behaviorFailure <- reportFailed report]++runWitness :: BehaviorRequirement -> BehaviorWitness -> Either BehaviorFailure ()+runWitness requirement witness = case witness of+  Pending _ -> failure requirement "pending" "witness is still Pending"+  LiveWitness _ history command expectation -> runLive requirement history command expectation+  ReplayWitness _ prefix chunk -> runReplay requirement prefix chunk++runLive :: BehaviorRequirement -> [OrdersEvent] -> OrdersCommand -> LiveExpectation -> Either BehaviorFailure ()+runLive requirement history command expectation = do+  settled <- settleHistory requirement "history" history+  ensure requirement (K.replaySuccessState settled == requirementSource requirement) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirementCommandName requirement) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirementKind requirement of+    ReplayTransition -> failure requirement "witness-kind" "a replay-only requirement needs ReplayWitness"+    RequiredRejection -> runRejection requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation+    LiveTransition -> runAcceptance requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation++runRejection :: BehaviorRequirement -> (OrdersVertex, K.RegFile OrdersRegs) -> OrdersCommand -> 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"+  Rejects expectedClass -> case K.stepDetailedEither ordersTransducer seed command of+    Left K.NoOutgoingEdges {} -> ensure requirement (expectedClass == RejectNoOutgoingEdges) "rejection-class" "expected NoMatchingEdge but runtime returned NoOutgoingEdges"+    Left K.NoMatchingEdge {} -> ensure requirement (expectedClass == RejectNoMatchingEdge) "rejection-class" "expected NoOutgoingEdges but runtime returned NoMatchingEdge"+    Left K.AmbiguousEdges {} -> failure requirement "ambiguous-edges" "AmbiguousEdges can never satisfy a rejection witness"+    Right _ -> failure requirement "unexpected-acceptance" "runtime accepted a command required to reject"++runAcceptance :: BehaviorRequirement -> (OrdersVertex, K.RegFile OrdersRegs) -> OrdersCommand -> 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 ordersTransducer seed command of+    Left stepFailure -> failure requirement "unexpected-rejection" (tshow stepFailure)+    Right success -> do+      checkAcceptedEnvelope requirement success+      ensure requirement (null (K.stepSuccessOutputs success)) "noop-emitted" "NoOp emitted one or more events"+      ensure requirement (K.stepSuccessState success == fst seed) "noop-vertex-change" "NoOp changed the control vertex"+      ensure requirement (regsEqual (K.stepSuccessRegs success) (snd seed)) "noop-register-change" "NoOp changed one or more registers"+  Emits expectedEvents -> case K.stepDetailedEither ordersTransducer seed command of+    Left stepFailure -> failure requirement "unexpected-rejection" (tshow stepFailure)+    Right success -> do+      checkAcceptedEnvelope requirement success+      let expected = NonEmpty.toList expectedEvents+          actual = K.stepSuccessOutputs success+      ensure requirement (actual == expected) "event-value-mismatch" ("runtime event values differ from the exact witness expectation; 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 ordersTransducer seed decoded of+        Left replayFailure -> failure requirement "emitted-replay-failed" (tshow replayFailure)+        Right replaySuccess -> Right replaySuccess+      ensure requirement (K.replaySuccessState replayed == K.stepSuccessState success) "forward-replay-vertex" "decoded emissions replay to a different vertex"+      ensure requirement (regsEqual (K.replaySuccessRegs replayed) (K.stepSuccessRegs success)) "forward-replay-registers" "decoded emissions replay to different registers"+      checkSingleAttribution requirement K.Live (length decoded) (K.replaySuccessTrace replayed)++checkAcceptedEnvelope :: BehaviorRequirement -> K.StepSuccess OrdersRegs OrdersVertex OrdersEvent -> Either BehaviorFailure ()+checkAcceptedEnvelope requirement success = do+  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 -> [OrdersEvent] -> [OrdersEvent] -> Either BehaviorFailure ()+runReplay requirement prefix chunk = case requirementKind requirement of+  ReplayTransition -> do+    settled <- settleHistory requirement "history-prefix" prefix+    ensure requirement (K.replaySuccessState settled == requirementSource requirement) "history-wrong-source" "history prefix does not settle at the replay edge source"+    ensure requirement (not (null chunk)) "empty-replay-chunk" "a replay-only edge has no observable empty chunk"+    decoded <- either (failure requirement "replay-chunk-codec-decode") Right (decodeEvents chunk)+    replayed <- case K.applyEventsDetailedEither ordersTransducer (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; 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 OrdersVertex] -> 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; 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 -> [OrdersEvent] -> Either BehaviorFailure (K.ReplaySuccess OrdersRegs OrdersVertex)+settleHistory requirement label history = do+  decoded <- either (failure requirement (label <> "-codec-decode")) Right (decodeEvents history)+  case K.applyEventsDetailedEither ordersTransducer (OrdersEmpty, initialOrdersRegs) decoded of+    Left replayFailure -> failure requirement (label <> "-replay-failed") (tshow replayFailure)+    Right replaySuccess -> Right replaySuccess++decodeEvents :: [OrdersEvent] -> Either Text [OrdersEvent]+decodeEvents = traverse (\event -> parseOrdersEvent (Codec.eventType ordersCodec event) (encodeOrdersEvent event))++commandKind :: OrdersCommand -> Text+commandKind command = case command of+  RecordOrder _ -> "RecordOrder"++eventKind :: OrdersEvent -> Text+eventKind event = case Codec.eventType ordersCodec event of Codec.EventType tag -> tag++regsEqual :: K.RegFile OrdersRegs -> K.RegFile OrdersRegs -> Bool+regsEqual left right = (left K.! #total) == (right K.! #total) && (left K.! #qualificationState) == (right K.! #qualificationState)++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 :: BehaviorRequirement -> Text -> Text -> Either BehaviorFailure failed+failure requirement code detail =+  Left+    ( BehaviorFailure+        (requirementKey requirement)+        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey 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

+ test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Codec.hs view

@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedRecordDot #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit.+module Generated.CatalogDemo.Orders.Codec (+    ordersCodec,+    parseOrdersEvent,+    encodeOrdersEvent,+) where++import Generated.CatalogDemo.Orders.Domain+import Data.Aeson (Value, object, toJSON, withObject, (.:), (.=))+import Data.Aeson.Types (parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty+import Data.Text (Text)+import qualified Data.Text as T+import Keiro.Codec (Codec (..), EventType (..))++import CatalogDemo.MappedDomain ()++++++ordersEventTypes :: NonEmpty EventType+ordersEventTypes = EventType "OrderRecorded" :| []++ordersCodec :: Codec OrdersEvent+ordersCodec =+  Codec+    { eventTypes = ordersEventTypes+    , eventType = \case+        OrderRecorded{} -> EventType "OrderRecorded"+    , schemaVersion = 1+    , encode = encodeOrdersEvent+    , decode = parseOrdersEvent+    , upcasters = []+    }++encodeOrdersEvent :: OrdersEvent -> Value+encodeOrdersEvent = \case+  OrderRecorded payload ->+    object+      [ "kind" .= ("OrderRecorded" :: Text)+      , "amount" .= payload.amount+      , "orderPayload" .= toJSON payload.orderPayload+      , "sharedReference" .= toJSON payload.sharedReference+      ]++parseOrdersEvent :: EventType -> Value -> Either Text OrdersEvent+parseOrdersEvent (EventType tag) = mapLeftText . parseEither (withObject "OrdersEvent" go)+  where+    go o = do+      case tag of+        "OrderRecorded" ->+          OrderRecorded+            <$> ( OrderRecordedData+                    <$> o .: "amount"+                    <*> o .: "orderPayload"+                    <*> o .: "sharedReference"+                )+        _ -> fail ("unknown event type " <> show tag <> "; expected one of: " <> renderExpectedEventTypes ordersEventTypes)++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right++renderExpectedEventTypes :: NonEmpty EventType -> String+renderExpectedEventTypes =+  T.unpack+    . T.intercalate ", "+    . map (\(EventType eventTypeName) -> eventTypeName)+    . NonEmpty.toList

+ test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Domain.hs view

@@ -0,0 +1,51 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TemplateHaskell #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit.+module Generated.CatalogDemo.Orders.Domain where++import Data.Proxy (Proxy (..))+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Numeric.Natural (Natural)+import CatalogDemo.MappedBindings qualified as MappedBindings+import CatalogDemo.MappedDomain (OrderPayload, RegisterState, SharedReference)+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++data OrdersVertex = OrdersEmpty | OrdersRecorded+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data RecordOrderData = RecordOrderData+  { amount :: !Natural+  , orderPayload :: !OrderPayload+  , sharedReference :: !SharedReference+  }+  deriving stock (Generic, Eq, Show)++data OrdersCommand = RecordOrder !RecordOrderData+  deriving stock (Generic, Eq, Show)++data OrderRecordedData = OrderRecordedData+  { amount :: !Natural+  , orderPayload :: !OrderPayload+  , sharedReference :: !SharedReference+  }+  deriving stock (Generic, Eq, Show)++data OrdersEvent = OrderRecorded !OrderRecordedData+  deriving stock (Generic, Eq, Show)++type OrdersRegs =+  '[ '("total", Natural)+   , '("qualificationState", RegisterState)+   ]++initialOrdersRegs :: RegFile OrdersRegs+initialOrdersRegs =+  RCons (Proxy @"total") 0 $+  RCons (Proxy @"qualificationState") MappedBindings.initialRegisterState RNil++$(deriveAggregateCtorsAll ''OrdersCommand ''OrdersRegs)++++$(deriveWireCtorsAll ''OrdersEvent)

+ test/conformance-projection-catalog/Generated/CatalogDemo/Orders/EventStream.hs view

@@ -0,0 +1,49 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit.+module Generated.CatalogDemo.Orders.EventStream+  ( ordersCategory+  , ordersCommandCategory+  , ordersEventStream+  , ordersEventStreamDef+  , OrdersEventStream+  , OrdersEventStreamDef+  ) where++import Generated.CatalogDemo.Orders.Domain+import Generated.CatalogDemo.Orders.Codec (ordersCodec)+import Generated.CatalogDemo.Orders.Transducer (ordersTransducer)+import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Stream qualified as Stream++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+ordersCategory :: Stream.StreamCategory OrdersEventStreamDef+ordersCategory = Stream.categoryUnsafe "orders"++-- The same category text, typed for command envelopes such as PMCommand.+ordersCommandCategory :: Stream.StreamCategory OrdersCommand+ordersCommandCategory = Stream.categoryUnsafe "orders"++type OrdersEventStreamDef =+  EventStream (HsPred OrdersRegs OrdersCommand) OrdersRegs OrdersVertex OrdersCommand OrdersEvent++type OrdersEventStream =+  ValidatedEventStream (HsPred OrdersRegs OrdersCommand) OrdersRegs OrdersVertex OrdersCommand OrdersEvent++ordersEventStreamDef :: OrdersEventStreamDef+ordersEventStreamDef =+  EventStream+    { transducer = ordersTransducer,+      initialState = OrdersEmpty,+      initialRegisters = initialOrdersRegs,+      eventCodec = ordersCodec,+      resolveStreamName = Stream.streamName,+      snapshotPolicy = Never,+      stateCodec = Nothing+    }++ordersEventStream :: OrdersEventStream+ordersEventStream =+  mkEventStreamOrThrow "Orders" ordersEventStreamDef

+ test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Harness.hs view

@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedLabels #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit.+module Generated.CatalogDemo.Orders.Harness (harnessAssertions) where++import Generated.CatalogDemo.Orders.Domain+import Generated.CatalogDemo.Orders.Codec (encodeOrdersEvent, parseOrdersEvent, ordersCodec)+import Generated.CatalogDemo.Orders.Transducer (ordersTransducer)+import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!))+import Keiro.Codec (eventType)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Text qualified as T+import Keiro.Codec.Structural (FixtureCases (..))+import CatalogDemo.MappedBindings qualified as MappedBindings++-- | (label, passed). A driver runs these and exits non-zero on any False,+-- naming the failing assertion. Filling a hole wrongly turns a specific+-- entry False; the scaffold cannot.+harnessAssertions :: [(String, Bool)]+harnessAssertions =+  [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions ordersTransducer))+  -- clock-free: spec samples no wall clock (verified at scaffold time)+  , ("golden round-trip: OrderRecorded", roundTrips sampleEventOrderRecorded)+  , ("accepts RecordOrder from OrdersEmpty", acceptRecordOrder)+  ]+  ++ mappedConformanceAssertions+  ++ forwardReplayRecordOrder++roundTrips :: OrdersEvent -> Bool+roundTrips e = parseOrdersEvent (eventType ordersCodec e) (encodeOrdersEvent e) == Right e++sampleEventOrderRecorded :: OrdersEvent+sampleEventOrderRecorded = OrderRecorded (OrderRecordedData 0 (snd (NonEmpty.head (fixtureCases MappedBindings.orderPayloadCases))) (snd (NonEmpty.head (fixtureCases MappedBindings.sharedReferenceCases))))++acceptRecordOrder :: Bool+acceptRecordOrder =+  case step ordersTransducer (OrdersEmpty, initialOrdersRegs) (RecordOrder (RecordOrderData 0 (snd (NonEmpty.head (fixtureCases MappedBindings.orderPayloadCases))) (snd (NonEmpty.head (fixtureCases MappedBindings.sharedReferenceCases))))) of+    Just (v, _, _) -> v == OrdersRecorded+    Nothing -> False++-- forward/replay equality (plan 147): cross the persisted codec boundary,+-- replay the emitted chain, and compare the final vertex and every register.+forwardReplayRecordOrder :: [(String, Bool)]+forwardReplayRecordOrder =+  case step ordersTransducer (OrdersEmpty, initialOrdersRegs) (RecordOrder (RecordOrderData 0 (snd (NonEmpty.head (fixtureCases MappedBindings.orderPayloadCases))) (snd (NonEmpty.head (fixtureCases MappedBindings.sharedReferenceCases))))) of+    Nothing -> [(prefix <> "forward step accepted", False)]+    Just (forwardVertex, forwardRegs, emitted) ->+      case mapM (\event -> parseOrdersEvent (eventType ordersCodec event) (encodeOrdersEvent event)) emitted of+        Left _ -> [(prefix <> "emitted chain decodes", False)]+        Right decodedEvents ->+          case applyEventsEither ordersTransducer (OrdersEmpty, initialOrdersRegs) decodedEvents of+            Left _ -> [(prefix <> "replay succeeds", False)]+            Right (replayVertex, replayRegs) ->+              [ (prefix <> "final vertex", replayVertex == forwardVertex)+              , (prefix <> "register total", (replayRegs ! #total) == (forwardRegs ! #total))+              , (prefix <> "register qualificationState", (replayRegs ! #qualificationState) == (forwardRegs ! #qualificationState))+              ]+  where+    prefix = "forward/replay equality: RecordOrder from OrdersEmpty -- "++mappedConformanceAssertions :: [(String, Bool)]+mappedConformanceAssertions =+  concat+    [ orderRecordedOrderPayloadAssertions+    , orderRecordedSharedReferenceAssertions+    ]++orderRecordedOrderPayloadAssertions :: [(String, Bool)]+orderRecordedOrderPayloadAssertions =+  [ ("mapped codec round-trip: OrderRecorded/orderPayload/" <> T.unpack label, roundTrips (OrderRecorded (OrderRecordedData 0 mappedValue (snd (NonEmpty.head (fixtureCases MappedBindings.sharedReferenceCases))))))+  | (label, mappedValue) <- NonEmpty.toList (fixtureCases MappedBindings.orderPayloadCases)+  ]++orderRecordedSharedReferenceAssertions :: [(String, Bool)]+orderRecordedSharedReferenceAssertions =+  [ ("mapped codec round-trip: OrderRecorded/sharedReference/" <> T.unpack label, roundTrips (OrderRecorded (OrderRecordedData 0 (snd (NonEmpty.head (fixtureCases MappedBindings.orderPayloadCases))) mappedValue)))+  | (label, mappedValue) <- NonEmpty.toList (fixtureCases MappedBindings.sharedReferenceCases)+  ]

+ test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Projection.hs view

@@ -0,0 +1,4 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit.+module Generated.CatalogDemo.Orders.Projection () where++-- No projection declarations are present; this module keeps the generated manifest inventory total.

+ test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Transducer.hs view

@@ -0,0 +1,59 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit.+module Generated.CatalogDemo.Orders.Transducer+  ( ordersTransducer+  , ordersFoldFingerprint+  , BehaviorOwnership (..)+  , ordersPredicateVerifications+  ) where++import Generated.CatalogDemo.Orders.Domain+import Data.Text (Text)+import Keiki.Builder qualified as B+import Keiki.Core (HsPred, SymTransducer)+import Keiki.Core qualified as K+import Keiki.Symbolic qualified as S+import Keiki.Builder ((=:))++ordersTransducer+  :: SymTransducer+       (HsPred OrdersRegs OrdersCommand)+       OrdersRegs+       OrdersVertex+       OrdersCommand+       OrdersEvent+ordersTransducer =+  B.buildTransducer OrdersEmpty initialOrdersRegs isTerminal do+    B.from OrdersEmpty do+      B.onCmd inCtorRecordOrder $ \d -> B.do+        B.slot @"total" =: d.amount+        B.emit wireOrderRecorded (OrderRecordedTermFields+          { amount = d.amount+          , orderPayload = d.orderPayload+          , sharedReference = d.sharedReference+          })+        B.goto OrdersRecorded+ where+  isTerminal = \case+    OrdersRecorded -> True+    _ -> False++ordersFoldFingerprint :: Text+ordersFoldFingerprint = "30ef09fd66e5b739d6b8855b3c20aec8"++data BehaviorOwnership = GeneratedOwned | HoleOwned+  deriving stock (Eq, Show)++-- Every checked transition predicate is audited through Keiki's conservative+-- symbolic verifier. Opaque Hole terms remain explicitly unverified.+ordersPredicateVerifications :: IO [(Text, BehaviorOwnership, S.PredicateVerification)]+ordersPredicateVerifications = sequence+  [ verifyTransition "transition1EmptyRecordOrder" GeneratedOwned OrdersEmpty 0+  ]+ where+  verifyTransition label owner source edgeIndex =+    case drop edgeIndex (K.edgesOut ordersTransducer source) of+      K.Edge predicate _ _ _ _ : _ -> (\result -> (label, owner, result)) <$> S.verifyPredicate predicate+      [] -> pure (label, owner, S.UnverifiedSolverFailure "generated transition edge missing")

+ test/conformance-projection-catalog/Generated/CatalogDemo/ProjectionCatalog.hs view

@@ -0,0 +1,142 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from projection-catalog catalog-demo; do not edit.+{-# LANGUAGE OverloadedStrings #-}+module Generated.CatalogDemo.ProjectionCatalog+  ( projectionCatalog+  , validatedProjectionCatalog+  , projectionCatalogInventory+  , projectionCatalogRegistrations+  , projectionCatalogAsyncRegistrations+  , projectionCatalogQuerySupplies+  , registerProjectionCatalog+  , orderSummaryWriterProjectionSet+  , shipmentWriterProjectionSet+  , auditWriterProjectionSet+  , orderSummaryWriterInlineProjections+  , shipmentWriterInlineProjections+  , ordersInlineProjections+  , shipmentsInlineProjections+  , reportingRebuildGroupId+  , startReportingRebuild+  , shippingRebuildGroupId+  , startShippingRebuild+  ) where++import Data.List.NonEmpty (NonEmpty (..))+import Effectful (Eff, IOE, (:>))+import Data.Map.Strict qualified as Map+import Generated.CatalogDemo.Orders.Codec qualified as OrdersCodec+import Generated.CatalogDemo.Orders.Domain qualified as OrdersDomain+import Generated.CatalogDemo.Shipments.Domain qualified as ShipmentsDomain+import Keiro.Projection (AsyncProjection (..), InlineProjection (..))+import Keiro.Projection.Catalog qualified as Catalog+import Keiro.ReadModel.Rebuild qualified as Rebuild+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Types qualified as Kiroku+import Kiroku.Store.Subscription.Types qualified as KirokuSubscription+import CatalogDemo.ProjectionCatalog.ProjectionCatalogHoles qualified as Holes+import Generated.CatalogDemo.OrderInline.ReadModel qualified as RMOrderInline+import Generated.CatalogDemo.OrderTotalsLookup.ReadModel qualified as RMOrderTotalsLookup+import Generated.CatalogDemo.ShipmentLookup.ReadModel qualified as RMShipmentLookup+import Generated.CatalogDemo.CatalogAudit.ReadModel qualified as RMCatalogAudit++must :: Show error => Either error value -> value+must = either (error . show) id++orderSummaryWriterProjectionSet :: Catalog.ProjectionSet OrdersDomain.OrdersEvent+orderSummaryWriterProjectionSet =+  Catalog.ProjectionSet+    (must (Catalog.mkSourceId "aggregate:Orders"))+    (Catalog.ProjectionDefinition+      (must (Catalog.mkProjectionId "order_summary_writer"))+      (must (Catalog.mkRebuildGroupId "reporting"))+      ((must (Catalog.mkTargetId "order_summary")) :| [(must (Catalog.mkTargetId "order_totals"))])+      (Catalog.Replayable (Catalog.replayAdapterFromCodec OrdersCodec.ordersCodec Holes.applyOrderSummaryWriterReplay))+      (Catalog.InlineHandler (InlineProjection "order_summary_writer" Holes.applyOrderSummaryWriterLive) (must (Catalog.mkClaimSite "projection-owner order_summary_writer inline-handler")) :| [])+      (must (Catalog.mkClaimSite "projection-owner order_summary_writer"))+      :| [])+    (must (Catalog.mkClaimSite "projection-owner order_summary_writer source"))++orderSummaryWriterInlineProjections :: [InlineProjection OrdersDomain.OrdersEvent]+orderSummaryWriterInlineProjections = Catalog.typedInlineProjections validatedProjectionCatalog orderSummaryWriterProjectionSet++shipmentWriterProjectionSet :: Catalog.ProjectionSet ShipmentsDomain.ShipmentsEvent+shipmentWriterProjectionSet =+  Catalog.ProjectionSet+    (must (Catalog.mkSourceId "aggregate:Shipments"))+    (Catalog.ProjectionDefinition+      (must (Catalog.mkProjectionId "shipment_writer"))+      (must (Catalog.mkRebuildGroupId "shipping"))+      ((must (Catalog.mkTargetId "shipment_summary")) :| [])+      (Catalog.LiveOnly (Catalog.LiveOnlyReason "carrier events cannot be replayed"))+      (Catalog.InlineHandler (InlineProjection "shipment_writer" Holes.applyShipmentWriterLive) (must (Catalog.mkClaimSite "projection-owner shipment_writer inline-handler")) :| [])+      (must (Catalog.mkClaimSite "projection-owner shipment_writer"))+      :| [])+    (must (Catalog.mkClaimSite "projection-owner shipment_writer source"))++shipmentWriterInlineProjections :: [InlineProjection ShipmentsDomain.ShipmentsEvent]+shipmentWriterInlineProjections = Catalog.typedInlineProjections validatedProjectionCatalog shipmentWriterProjectionSet++auditWriterProjectionSet :: Catalog.ProjectionSet Holes.AuditWriterEvent+auditWriterProjectionSet =+  Catalog.ProjectionSet+    (must (Catalog.mkSourceId "category:audit"))+    (Catalog.ProjectionDefinition+      (must (Catalog.mkProjectionId "audit_writer"))+      (must (Catalog.mkRebuildGroupId "reporting"))+      ((must (Catalog.mkTargetId "audit_log")) :| [])+      (Catalog.Replayable (Catalog.ReplayAdapter Holes.decodeAuditWriterReplay Holes.applyAuditWriterReplay))+      (Catalog.AsyncHandler (AsyncProjection "catalog-demo-audit-v1" "catalog-demo-catalogAudit" "catalog-demo-audit" Holes.applyAuditWriterLive Holes.auditWriterIdempotencyKey) (must (Catalog.mkSubscriptionId "catalog-demo-audit")) (must (Catalog.mkDedupKeyId "catalog-demo-audit-v1")) (must (Catalog.mkClaimSite "projection-owner audit_writer async-handler")) :| [])+      (must (Catalog.mkClaimSite "projection-owner audit_writer"))+      :| [])+    (must (Catalog.mkClaimSite "projection-owner audit_writer source"))++ordersInlineProjections :: [InlineProjection OrdersDomain.OrdersEvent]+ordersInlineProjections = concat [orderSummaryWriterInlineProjections]++shipmentsInlineProjections :: [InlineProjection ShipmentsDomain.ShipmentsEvent]+shipmentsInlineProjections = concat [shipmentWriterInlineProjections]++projectionCatalog :: Catalog.ProjectionCatalog+projectionCatalog =+  Catalog.ProjectionCatalog+    [Catalog.SourceDeclaration (must (Catalog.mkSourceId "aggregate:Orders")) (Catalog.CategorySource (Kiroku.CategoryName "orders")) "aggregate:Orders/generated-codec/v1/mapped-132056a8f2ee095d" (must (Catalog.mkClaimSite "source aggregate:Orders")), Catalog.SourceDeclaration (must (Catalog.mkSourceId "aggregate:Shipments")) (Catalog.CategorySource (Kiroku.CategoryName "shipments")) "aggregate:Shipments/generated-codec/v1/mapped-9456a95e380c74b5" (must (Catalog.mkClaimSite "source aggregate:Shipments")), Catalog.SourceDeclaration (must (Catalog.mkSourceId "category:audit")) (Catalog.CategorySource (Kiroku.CategoryName "audit")) "category:audit/application-decoder/v1" (must (Catalog.mkClaimSite "source category:audit"))]+    [Catalog.TargetDeclaration (must (Catalog.mkTargetId "order_summary")) (Catalog.QualifiedTable "sales" "order_summary") Catalog.ClearBeforeReplay [] (must (Catalog.mkClaimSite "target order_summary")), Catalog.TargetDeclaration (must (Catalog.mkTargetId "audit_log")) (Catalog.QualifiedTable "sales" "audit_log") Catalog.PreserveAndReconcile [] (must (Catalog.mkClaimSite "target audit_log")), Catalog.TargetDeclaration (must (Catalog.mkTargetId "order_totals")) (Catalog.QualifiedTable "sales" "order_totals") Catalog.ClearBeforeReplay [(must (Catalog.mkTargetId "order_summary"))] (must (Catalog.mkClaimSite "target order_totals")), Catalog.TargetDeclaration (must (Catalog.mkTargetId "shipment_summary")) (Catalog.QualifiedTable "sales" "shipment_summary") Catalog.PreserveAndReconcile [] (must (Catalog.mkClaimSite "target shipment_summary"))]+    [Catalog.RebuildGroupDeclaration (must (Catalog.mkRebuildGroupId "reporting")) [(must (Catalog.mkTargetId "order_summary")), (must (Catalog.mkTargetId "order_totals")), (must (Catalog.mkTargetId "audit_log"))] [] (must (Catalog.mkClaimSite "rebuild-group reporting")), Catalog.RebuildGroupDeclaration (must (Catalog.mkRebuildGroupId "shipping")) [(must (Catalog.mkTargetId "shipment_summary"))] [] (must (Catalog.mkClaimSite "rebuild-group shipping"))]+    [Catalog.ProjectionRevision (must (Catalog.mkProjectionRevisionId "reporting_v1")) (must (Catalog.mkRebuildGroupId "reporting")) (Map.fromList [((must (Catalog.mkTargetId "order_summary")), Catalog.TargetProvisioner "reporting-v1-order-summary" 1 (Catalog.TargetSchemaVersion "v1") "order-summary-v1" Holes.provisionReportingV1OrderSummary "reporting-v1-order-summary-validator" 1 (Just Holes.validateReportingV1OrderSummary) [Catalog.PromotionObjectName Catalog.PromotionIndex "order_summary_status_idx__v1" "order_summary_status_idx"]), ((must (Catalog.mkTargetId "order_totals")), Catalog.TargetProvisioner "reporting-v1-order-totals" 1 (Catalog.TargetSchemaVersion "v1") "order-totals-v1" Holes.provisionReportingV1OrderTotals "reporting-v1-order-totals-validator" 1 (Just Holes.validateReportingV1OrderTotals) [Catalog.PromotionObjectName Catalog.PromotionConstraint "order_totals_pkey__v1" "order_totals_pkey"]), ((must (Catalog.mkTargetId "audit_log")), Catalog.TargetProvisioner "reporting-v1-audit-log" 1 (Catalog.TargetSchemaVersion "v1") "audit-log-v1" Holes.provisionReportingV1AuditLog "reporting-v1-audit-log-validator" 1 (Just Holes.validateReportingV1AuditLog) [Catalog.PromotionObjectName Catalog.PromotionOwnedSequence "audit_log_id_seq__v1" "audit_log_id_seq"])]) [Catalog.RevisionLiveHandler "reporting_v1/order_summary_writer/live" 1 (Catalog.RevisionInlineDelivery (must (Catalog.mkProjectionId "order_summary_writer")) "order_summary_writer") [(must (Catalog.mkTargetId "order_summary")), (must (Catalog.mkTargetId "order_totals"))] Holes.applyReportingV1OrderSummaryWriterLive, Catalog.RevisionLiveHandler "reporting_v1/audit_writer/live" 1 (Catalog.RevisionSubscriptionDelivery (must (Catalog.mkProjectionId "audit_writer")) (must (Catalog.mkSubscriptionId "catalog-demo-audit")) (must (Catalog.mkDedupKeyId "catalog-demo-audit-v1"))) [(must (Catalog.mkTargetId "audit_log"))] Holes.applyReportingV1AuditWriterLive] [Catalog.RevisionReplayAdapter "reporting_v1/replay" 1 [(must (Catalog.mkTargetId "order_summary")), (must (Catalog.mkTargetId "order_totals")), (must (Catalog.mkTargetId "audit_log"))] Holes.applyReportingV1Replay] [Catalog.RevisionVerification "reporting_v1/verification" 1 [(must (Catalog.mkTargetId "order_summary")), (must (Catalog.mkTargetId "order_totals")), (must (Catalog.mkTargetId "audit_log"))] Holes.verifyReportingV1] [] (must (Catalog.mkClaimSite "projection-revision reporting_v1")), Catalog.ProjectionRevision (must (Catalog.mkProjectionRevisionId "reporting_v2")) (must (Catalog.mkRebuildGroupId "reporting")) (Map.fromList [((must (Catalog.mkTargetId "order_summary")), Catalog.TargetProvisioner "reporting-v2-order-summary" 1 (Catalog.TargetSchemaVersion "v2") "order-summary-v2" Holes.provisionReportingV2OrderSummary "reporting-v2-order-summary-validator" 1 (Just Holes.validateReportingV2OrderSummary) [Catalog.PromotionObjectName Catalog.PromotionIndex "order_summary_status_idx__v2" "order_summary_status_idx"]), ((must (Catalog.mkTargetId "order_totals")), Catalog.TargetProvisioner "reporting-v2-order-totals" 1 (Catalog.TargetSchemaVersion "v2") "order-totals-v2" Holes.provisionReportingV2OrderTotals "reporting-v2-order-totals-validator" 1 (Just Holes.validateReportingV2OrderTotals) [Catalog.PromotionObjectName Catalog.PromotionConstraint "order_totals_pkey__v2" "order_totals_pkey"]), ((must (Catalog.mkTargetId "audit_log")), Catalog.TargetProvisioner "reporting-v2-audit-log" 1 (Catalog.TargetSchemaVersion "v2") "audit-log-v2" Holes.provisionReportingV2AuditLog "reporting-v2-audit-log-validator" 1 (Just Holes.validateReportingV2AuditLog) [Catalog.PromotionObjectName Catalog.PromotionOwnedSequence "audit_log_id_seq__v2" "audit_log_id_seq"])]) [Catalog.RevisionLiveHandler "reporting_v2/order_summary_writer/live" 1 (Catalog.RevisionInlineDelivery (must (Catalog.mkProjectionId "order_summary_writer")) "order_summary_writer") [(must (Catalog.mkTargetId "order_summary")), (must (Catalog.mkTargetId "order_totals"))] Holes.applyReportingV2OrderSummaryWriterLive, Catalog.RevisionLiveHandler "reporting_v2/audit_writer/live" 1 (Catalog.RevisionSubscriptionDelivery (must (Catalog.mkProjectionId "audit_writer")) (must (Catalog.mkSubscriptionId "catalog-demo-audit")) (must (Catalog.mkDedupKeyId "catalog-demo-audit-v1"))) [(must (Catalog.mkTargetId "audit_log"))] Holes.applyReportingV2AuditWriterLive] [Catalog.RevisionReplayAdapter "reporting_v2/replay" 1 [(must (Catalog.mkTargetId "order_summary")), (must (Catalog.mkTargetId "order_totals")), (must (Catalog.mkTargetId "audit_log"))] Holes.applyReportingV2Replay] [Catalog.RevisionVerification "reporting_v2/verification" 1 [(must (Catalog.mkTargetId "order_summary")), (must (Catalog.mkTargetId "order_totals")), (must (Catalog.mkTargetId "audit_log"))] Holes.verifyReportingV2] [] (must (Catalog.mkClaimSite "projection-revision reporting_v2"))]+    [Catalog.AllRowsExternalRead (must (Catalog.mkExternalReadContractId "order_totals_reader")) (Catalog.ExternalReadContractVersion 1) (must (Catalog.mkQueryModelId "order_totals_lookup")) (Catalog.QualifiedSqlType "app_contract" "order_totals_row_v1") "fnv1a:768a23d719dcb4d4" ((must (Catalog.mkProjectionRevisionId "reporting_v1")) :| [(must (Catalog.mkProjectionRevisionId "reporting_v2"))]) 1 (must (Catalog.mkClaimSite "external-read order_totals_reader v1"))]+    [Catalog.SubscriptionDeclaration (must (Catalog.mkSubscriptionId "catalog-demo-audit")) "catalog-demo-audit" (must (Catalog.mkSourceId "category:audit")) KirokuSubscription.FromCurrentHead (must (Catalog.mkClaimSite "projection-owner audit_writer subscription"))]+    [Catalog.DedupKeyDeclaration (must (Catalog.mkDedupKeyId "catalog-demo-audit-v1")) "catalog-demo-audit-v1" (must (Catalog.mkClaimSite "projection-owner audit_writer dedup"))]+    [Catalog.SomeQueryModelBinding (Catalog.QueryModelBinding (must (Catalog.mkQueryModelId "catalogAudit")) RMCatalogAudit.catalogAuditReadModel (must (Catalog.mkRebuildGroupId "reporting")) [(must (Catalog.mkTargetId "audit_log"))] (must (Catalog.mkClaimSite "readmodel catalogAudit"))), Catalog.SomeQueryModelBinding (Catalog.QueryModelBinding (must (Catalog.mkQueryModelId "order_inline")) RMOrderInline.orderInlineReadModel (must (Catalog.mkRebuildGroupId "reporting")) [(must (Catalog.mkTargetId "order_summary"))] (must (Catalog.mkClaimSite "readmodel order_inline"))), Catalog.SomeQueryModelBinding (Catalog.QueryModelBinding (must (Catalog.mkQueryModelId "order_totals_lookup")) RMOrderTotalsLookup.orderTotalsLookupReadModel (must (Catalog.mkRebuildGroupId "reporting")) [(must (Catalog.mkTargetId "order_totals"))] (must (Catalog.mkClaimSite "readmodel order_totals_lookup"))), Catalog.SomeQueryModelBinding (Catalog.QueryModelBinding (must (Catalog.mkQueryModelId "shipmentLookup")) RMShipmentLookup.shipmentLookupReadModel (must (Catalog.mkRebuildGroupId "shipping")) [(must (Catalog.mkTargetId "shipment_summary"))] (must (Catalog.mkClaimSite "readmodel shipmentLookup")))]+    [Catalog.SomeProjectionSet orderSummaryWriterProjectionSet, Catalog.SomeProjectionSet shipmentWriterProjectionSet, Catalog.SomeProjectionSet auditWriterProjectionSet]++validatedProjectionCatalog :: Catalog.ValidatedProjectionCatalog+validatedProjectionCatalog = case Catalog.validateProjectionCatalog projectionCatalog of+  Catalog.Success catalog -> catalog+  Catalog.Failure diagnostics -> error ("keiro-dsl generated an invalid projection catalog: " <> show diagnostics)++projectionCatalogInventory :: Catalog.CatalogInventory+projectionCatalogInventory = Catalog.catalogInventory validatedProjectionCatalog++projectionCatalogRegistrations :: [Catalog.CatalogRegistration]+projectionCatalogRegistrations = Catalog.catalogRegistrations validatedProjectionCatalog++projectionCatalogAsyncRegistrations :: [Catalog.AsyncProjectionRegistration]+projectionCatalogAsyncRegistrations = Catalog.asyncProjectionRegistrations validatedProjectionCatalog++projectionCatalogQuerySupplies :: [Catalog.ResolvedQuerySupply]+projectionCatalogQuerySupplies = Catalog.resolvedQuerySupplies validatedProjectionCatalog++registerProjectionCatalog :: (Store :> es) => Eff es (Either Rebuild.CatalogRegistrationError [Rebuild.GroupRebuildMetadata])+registerProjectionCatalog = Rebuild.registerProjectionCatalog validatedProjectionCatalog++reportingRebuildGroupId :: Catalog.RebuildGroupId+reportingRebuildGroupId = (must (Catalog.mkRebuildGroupId "reporting"))++startReportingRebuild :: (IOE :> es, Store :> es) => Rebuild.RebuildOptions -> Eff es (Either Rebuild.CatalogRebuildError Rebuild.RebuildRunReport)+startReportingRebuild = Rebuild.startCatalogRebuild validatedProjectionCatalog reportingRebuildGroupId++shippingRebuildGroupId :: Catalog.RebuildGroupId+shippingRebuildGroupId = (must (Catalog.mkRebuildGroupId "shipping"))++startShippingRebuild :: (IOE :> es, Store :> es) => Rebuild.RebuildOptions -> Eff es (Either Rebuild.CatalogRebuildError Rebuild.RebuildRunReport)+startShippingRebuild = Rebuild.startCatalogRebuild validatedProjectionCatalog shippingRebuildGroupId

+ test/conformance-projection-catalog/Generated/CatalogDemo/QualificationJobs/Queue.hs view

@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedRecordDot #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from workqueue qualification_jobs; do not edit.+module Generated.CatalogDemo.QualificationJobs.Queue+  ( QualificationJob (..)+  , encodeQualificationJob+  , parseQualificationJob+  , encodeQualificationPayloadMapped+  , decodeQualificationPayloadMapped+  , queuePhysical, queueDlq, queueTable++  ) where++import Control.Monad (unless)+import Data.Aeson (Value (..), object, parseJSON, toJSON, withObject, (.:), (.=))+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (Parser, explicitParseField, parseEither)+import Data.Text (Text)+import qualified Data.Text as T+import Keiro.Codec.Structural (bindingFromShape, bindingToShape)+import CatalogDemo.MappedBindings qualified as MappedBindings+import CatalogDemo.MappedDomain (QualificationPayload, QueueMetadata, SharedReference)+import Generated.CatalogDemo.Structural.Shape.QualificationPayload qualified as ShapeQualificationPayload++queuePhysical, queueDlq, queueTable :: Text+queuePhysical = "catalog_demo_qualification_jobs"+queueDlq = "catalog_demo_qualification_jobs_dlq"+queueTable = "pgmq.q_catalog_demo_qualification_jobs"++data QualificationJob = QualificationJob+  { sharedReference :: !SharedReference+  , qualification :: !QualificationPayload+  , metadata :: !QueueMetadata+  , maybeMetadata :: !(Maybe QueueMetadata)+  , attempt :: !Int+  , trace :: !Value+  }+  deriving stock (Eq, Show)++encodeQualificationPayloadMapped :: QualificationPayload -> Value+encodeQualificationPayloadMapped = encodeQualificationPayloadShape . bindingToShape MappedBindings.qualificationPayloadBinding++parseQualificationPayloadMapped :: Value -> Parser QualificationPayload+parseQualificationPayloadMapped value = bindingFromShape MappedBindings.qualificationPayloadBinding <$> parseQualificationPayloadShape value++decodeQualificationPayloadMapped :: Value -> Either Text QualificationPayload+decodeQualificationPayloadMapped = mapLeftText . parseEither parseQualificationPayloadMapped++encodeQualificationPayloadShape :: ShapeQualificationPayload.QualificationPayloadShape -> Value+encodeQualificationPayloadShape shape =+  object+      [ "qualification_id" .= toJSON (ShapeQualificationPayload.qualificationId shape)+      , "note" .= maybe Null (\item -> toJSON (item)) (ShapeQualificationPayload.note shape)+      ]++parseQualificationPayloadShape :: Value -> Parser ShapeQualificationPayload.QualificationPayloadShape+parseQualificationPayloadShape = withObject "QualificationPayloadShape" $ \objectValue -> do+  rejectUnknownFields "QualificationPayload" ["qualification_id", "note"] objectValue+  ShapeQualificationPayload.QualificationPayload+    <$> explicitParseField (parseJSON) objectValue "qualification_id"+    <*> explicitParseField (\value -> case value of Null -> pure Nothing; other -> Just <$> parseJSON other) objectValue "note"++encodeQualificationJob :: QualificationJob -> Value+encodeQualificationJob payload =+  object+    [ "shared_reference" .= toJSON payload.sharedReference+    , "payload" .= encodeQualificationPayloadMapped payload.qualification+    , "metadata" .= toJSON payload.metadata+    , "maybe_metadata" .= maybe Null (\item -> toJSON item) (payload.maybeMetadata)+    , "attempt" .= payload.attempt+    , "trace" .= payload.trace+    ]++parseQualificationJob :: Value -> Either Text QualificationJob+parseQualificationJob = mapLeftText . parseEither (withObject "QualificationJob" go)+  where+    go objectValue = QualificationJob <$> explicitParseField (parseJSON) objectValue "shared_reference" <*> explicitParseField (parseQualificationPayloadMapped) objectValue "payload" <*> explicitParseField (parseJSON) objectValue "metadata" <*> explicitParseField (\value -> case value of Null -> pure Nothing; other -> Just <$> parseJSON other) objectValue "maybe_metadata" <*> objectValue .: "attempt" <*> explicitParseField (pure) objectValue "trace"++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right++rejectUnknownFields :: String -> [Text] -> KeyMap.KeyMap Value -> Parser ()+rejectUnknownFields label allowed objectValue =+  unless (null extras) (fail (label <> " contains unknown fields: " <> show extras))+  where+    extras = filter (`notElem` allowed) (map Key.toText (KeyMap.keys objectValue))

+ test/conformance-projection-catalog/Generated/CatalogDemo/QualificationJobs/QueueCodec.hs view

@@ -0,0 +1,29 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from workqueue qualification_jobs; do not edit.+-- | Versioned job payload envelope: @{\"v\",\"t\",\"data\"}@.+--+-- Deploy workers before producers when raising its schema version. Do not+-- adopt this codec on a non-empty bare-payload queue without draining it+-- (or supplying a transitional codec), or in-flight messages will+-- dead-letter. This is telemetry-neutral:+-- docs/adr/0001-keiro-pgmq-job-processing-telemetry-contract.md owns+-- spans and acknowledgement vocabulary.+module Generated.CatalogDemo.QualificationJobs.QueueCodec (qualificationJobsPayloadCodec, qualificationJobsJobCodec) where++import Data.List.NonEmpty (NonEmpty (..))+import Keiro.Codec (Codec (..), EventType (..))+import Keiro.PGMQ.Codec (JobCodec, keiroJobCodec)+import Generated.CatalogDemo.QualificationJobs.Queue (QualificationJob, encodeQualificationJob, parseQualificationJob)++qualificationJobsPayloadCodec :: Codec QualificationJob+qualificationJobsPayloadCodec =+  Codec+    { eventTypes = EventType "QualificationJob" :| []+    , eventType = \_ -> EventType "QualificationJob"+    , schemaVersion = 1+    , encode = encodeQualificationJob+    , decode = \_ -> parseQualificationJob+    , upcasters = []+    }++qualificationJobsJobCodec :: JobCodec QualificationJob+qualificationJobsJobCodec = keiroJobCodec qualificationJobsPayloadCodec

+ test/conformance-projection-catalog/Generated/CatalogDemo/QualificationJobs/QueuePolicy.hs view

@@ -0,0 +1,43 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from workqueue qualification_jobs; do not edit.+module Generated.CatalogDemo.QualificationJobs.QueuePolicy+  ( QualificationJobsOutcome (..)+  , retryPolicy, jobOutcomeFor+  , jobOrdering, jobTuningFor, queueProvision+  ) where++import Keiro.PGMQ.Job (JobOrdering (..), JobOutcome (..), JobTuning, QueueProvision, RetryDelay (..), RetryPolicy (..), standardProvision, withOrdering)++jobOrdering :: JobOrdering+jobOrdering = Unordered++-- Deployment owns visibility timeout, batch size, and polling; the spec owns ordering.+jobTuningFor :: JobTuning -> JobTuning+jobTuningFor = withOrdering jobOrdering++-- Pass this to ensureJobQueueWith at worker startup. FIFO adds the required GIN index; the DLQ remains standard.+queueProvision :: QueueProvision+queueProvision = standardProvision++retryPolicy :: RetryPolicy+retryPolicy =+  RetryPolicy+    { maxRetries = 3+    , defaultRetryDelay = RetryDelay 1+    , useDeadLetter = True+    }++-- The consumer JobOutcome disposition over the spec's named domain outcomes,+-- lowered to the live Keiro.PGMQ.Job.JobOutcome.+data QualificationJobsOutcome+  = StoreFailure+  | CommandRejected+  | DecodeFailure+  | OnCodecReject+  deriving stock (Eq, Show)++jobOutcomeFor :: QualificationJobsOutcome -> JobOutcome+jobOutcomeFor o = case o of+  StoreFailure -> Retry (RetryDelay 1)+  CommandRejected -> Dead "dead-lettered"+  DecodeFailure -> Dead "dead-lettered"+  OnCodecReject -> Dead "dead-lettered"

+ test/conformance-projection-catalog/Generated/CatalogDemo/ReplayAudit.hs view

@@ -0,0 +1,30 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from context catalog-demo replay-audit assembly; do not edit.+--+-- Deployment contract:+--   * replay-neutral diff: no data audit is required;+--   * affected diff: run AuditTargeted with the emitted affected set+--     against a production copy under the candidate binary;+--   * one-time runtime cutover: run AuditFull;+--   * any non-zero audit exit blocks deployment.+module Generated.CatalogDemo.ReplayAudit (auditTargets) where++import Generated.CatalogDemo.Orders.EventStream qualified as Orders+import Generated.CatalogDemo.Shipments.EventStream qualified as Shipments+import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory)+import Keiro.Stream qualified as Stream++auditTargets :: [SomeAuditTarget]+auditTargets =+  [ SomeAuditTarget+      AuditTarget+        { eventStream = Orders.ordersEventStream+        , category = Stream.categoryText Orders.ordersCategory+        , mkStream = streamInCategory (Stream.categoryText Orders.ordersCategory)+        }+  , SomeAuditTarget+      AuditTarget+        { eventStream = Shipments.shipmentsEventStream+        , category = Stream.categoryText Shipments.shipmentsCategory+        , mkStream = streamInCategory (Stream.categoryText Shipments.shipmentsCategory)+        }+  ]

+ test/conformance-projection-catalog/Generated/CatalogDemo/ShipmentLookup/ReadModel.hs view

@@ -0,0 +1,25 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel shipmentLookup; do not edit.+module Generated.CatalogDemo.ShipmentLookup.ReadModel+  ( shipmentLookupReadModel+  , shipmentLookupQualifiedTable+  ) where++import Generated.CatalogDemo.ShipmentLookup.ReadModelTable (shipmentLookupQualifiedTable)+import CatalogDemo.ShipmentLookup.ReadModelHoles (ShipmentLookupQueryInput, ShipmentLookupQueryResult, shipmentLookupQuery)+import Keiro.ReadModel (QueryCursorAuthority (..), ReadModel, ReadModelBlueprint (..), immediateReadModel)++shipmentLookupReadModel :: ReadModel ShipmentLookupQueryInput ShipmentLookupQueryResult+shipmentLookupReadModel =+  immediateReadModel shipmentLookupReadModelBlueprint++shipmentLookupReadModelBlueprint :: ReadModelBlueprint ShipmentLookupQueryInput ShipmentLookupQueryResult+shipmentLookupReadModelBlueprint =+  ReadModelBlueprint+    { name = "catalog-demo-shipmentLookup"+    , tableName = "shipment_summary"+    , schema = "sales"+    , version = 1+    , shapeHash = "fnv1a:d0c39c966ea2f0b4"+    , cursorAuthority = NoQueryCursor+    , query = shipmentLookupQuery+    }

+ test/conformance-projection-catalog/Generated/CatalogDemo/ShipmentLookup/ReadModelHarness.hs view

@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedRecordDot #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel shipmentLookup; do not edit.+module Generated.CatalogDemo.ShipmentLookup.ReadModelHarness (readModelFacts, readModelFactResults, runReadModelFacts, catalogFactsAgainst) where++import Generated.CatalogDemo.ShipmentLookup.ReadModel (shipmentLookupReadModel)+import Data.Text qualified as T+import Data.List.NonEmpty qualified as NE+import Generated.CatalogDemo.ProjectionCatalog qualified as ProjectionCatalog+import Keiro.Projection.Catalog qualified as Catalog+import Keiro.ReadModel (ReadModel (..), readModelCursorAuthority, readModelDefaultFreshness)++-- | (fact, expected from notation, actual generated runtime value).+readModelFacts :: [(String, String, String)]+readModelFacts =+  [ ("registryName", "catalog-demo-shipmentLookup", T.unpack shipmentLookupReadModel.name)+  , ("shapeHash", "fnv1a:d0c39c966ea2f0b4", T.unpack shipmentLookupReadModel.shapeHash)+  , ("freshness", "Immediate", show (readModelDefaultFreshness shipmentLookupReadModel))+  , ("cursorAuthority", "NoQueryCursor", show (readModelCursorAuthority shipmentLookupReadModel))+  ]+    <> catalogFactsAgainst ProjectionCatalog.projectionCatalogRegistrations ProjectionCatalog.projectionCatalogAsyncRegistrations ProjectionCatalog.projectionCatalogQuerySupplies++catalogFactsAgainst :: [Catalog.CatalogRegistration] -> [Catalog.AsyncProjectionRegistration] -> [Catalog.ResolvedQuerySupply] -> [(String, String, String)]+catalogFactsAgainst registrations _asyncRegistrations supplies =+  [ ("catalogRegistration", "catalog-demo-shipmentLookup|1|fnv1a:d0c39c966ea2f0b4|shipping", renderRegistration [entry | entry <- registrations, Catalog.queryModelIdText entry.queryModelId == "shipmentLookup"])+  , ("querySupply", "shipment_writer|shipping|shipment_summary", renderSupply [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "shipmentLookup"])+  , ("projectionDelivery", "inline", renderDelivery [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "shipmentLookup"])+  ]++renderRegistration :: [Catalog.CatalogRegistration] -> String+renderRegistration [entry] = T.unpack entry.registryName <> "|" <> show entry.version <> "|" <> T.unpack entry.shapeHash <> "|" <> T.unpack (Catalog.rebuildGroupIdText entry.rebuildGroupId)+renderRegistration _ = "missing"++renderSupply :: [Catalog.ResolvedQuerySupply] -> String+renderSupply [entry] = T.unpack (Catalog.projectionIdText entry.resolvedProjectionId) <> "|" <> T.unpack (Catalog.rebuildGroupIdText entry.resolvedRebuildGroupId) <> "|" <> T.unpack (T.intercalate "," (map Catalog.targetIdText (NE.toList entry.resolvedObservedTargets)))+renderSupply _ = "missing"++renderDelivery :: [Catalog.ResolvedQuerySupply] -> String+renderDelivery [entry] = T.unpack (T.intercalate "," (map renderCapability (NE.toList entry.resolvedHandlerCapabilities)))+renderDelivery _ = "missing"++renderCapability :: Catalog.ProjectionHandlerCapability -> T.Text+renderCapability Catalog.InlineCapability {} = "inline"+renderCapability Catalog.SubscriptionCapability {} = "subscription"++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)

+ test/conformance-projection-catalog/Generated/CatalogDemo/ShipmentLookup/ReadModelTable.hs view

@@ -0,0 +1,9 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from readmodel shipmentLookup; do not edit.+module Generated.CatalogDemo.ShipmentLookup.ReadModelTable (shipmentLookupQualifiedTable) where++import Data.Text (Text)+import Keiro.Connection (qualifyTable)++-- The fully-qualified, double-quoted data-table reference.+shipmentLookupQualifiedTable :: Text+shipmentLookupQualifiedTable = qualifyTable "sales" "shipment_summary"

+ test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/BehaviorContract.hs view

@@ -0,0 +1,346 @@+{-# LANGUAGE OverloadedLabels #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Shipments; do not edit.+module Generated.CatalogDemo.Shipments.BehaviorContract+  ( BehaviorKey (..)+  , ObligationKind (..)+  , EvidenceLevel (..)+  , GuardCoverage (..)+  , BehaviorRequirement (..)+  , RejectionClass (..)+  , LiveExpectation (..)+  , BehaviorWitness (..)+  , BehaviorFailure (..)+  , BehaviorConformanceReport (..)+  , behaviorRequirements+  , behaviorCoverageReport+  , behaviorConformancePassed+  , behaviorConformancePassedWith+  , renderBehaviorConformanceText+  ) where++import Generated.CatalogDemo.Shipments.Codec (encodeShipmentsEvent, parseShipmentsEvent, shipmentsCodec)+import Generated.CatalogDemo.Shipments.Domain+import Generated.CatalogDemo.Shipments.Transducer (shipmentsTransducer)+import Generated.CatalogDemo.BehaviorSourceMap qualified as BehaviorSourceMap+import Data.Aeson (ToJSON (..), object, (.=))+import Data.List (sortOn)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Keiki.Core qualified as K (EdgeMode (..), EdgeRef (..), RegFile, ReplayAttribution (..), ReplayEventSpan (..), ReplaySuccess (..), StepFailure (..), StepSuccess (..), applyEventsDetailedEither, stepDetailedEither, (!))+import Keiro.Codec qualified as Codec (Codec (eventType), EventType (..))++newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }+  deriving stock (Eq, Ord, Show)++data ObligationKind = LiveTransition | RequiredRejection | ReplayTransition+  deriving stock (Eq, Ord, Show)++data EvidenceLevel = GeneratedAuthoritative | HoleWitnessed | LegacyRuntimeWitness+  deriving stock (Eq, Ord, Show)++data GuardCoverage = GuardTotal | GuardPartial | GuardUnknown | GuardNotApplicable+  deriving stock (Eq, Ord, Show)++data BehaviorRequirement = BehaviorRequirement+  { requirementKey :: !BehaviorKey+  , requirementKind :: !ObligationKind+  , requirementEvidence :: !EvidenceLevel+  , requirementGuardCoverage :: !GuardCoverage+  , requirementSource :: !ShipmentsVertex+  , requirementCommandName :: !Text+  , requirementExpectedEdge :: !(Maybe (K.EdgeRef ShipmentsVertex))+  , requirementTarget :: !(Maybe ShipmentsVertex)+  , requirementEventKinds :: ![Text]+  }+  deriving stock (Eq, Show)++data RejectionClass = RejectNoOutgoingEdges | RejectNoMatchingEdge+  deriving stock (Eq, Show)++data LiveExpectation+  = Emits (NonEmpty ShipmentsEvent)+  | Rejects RejectionClass+  | NoOp+  deriving stock (Eq, Show)++data BehaviorWitness+  = Pending BehaviorKey+  | LiveWitness+      { witnessKey :: BehaviorKey+      , witnessHistory :: [ShipmentsEvent]+      , witnessCommand :: ShipmentsCommand+      , witnessExpected :: LiveExpectation+      }+  | ReplayWitness+      { witnessKey :: BehaviorKey+      , witnessHistoryPrefix :: [ShipmentsEvent]+      , witnessObservedChunk :: [ShipmentsEvent]+      }+  deriving stock (Eq, Show)++data BehaviorFailure = BehaviorFailure+  { failureKey :: !BehaviorKey+  , failureSubject :: !Text+  , failureCode :: !Text+  , failureDetail :: !Text+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorFailure where+  toJSON behaviorFailure = object+    [ "key" .= unBehaviorKey (failureKey behaviorFailure)+    , "subject" .= failureSubject behaviorFailure+    , "code" .= failureCode behaviorFailure+    , "detail" .= failureDetail behaviorFailure+    ]++data BehaviorConformanceReport = BehaviorConformanceReport+  { reportRequired :: ![BehaviorKey]+  , reportFilled :: ![BehaviorKey]+  , reportPending :: ![BehaviorKey]+  , reportMissing :: ![BehaviorKey]+  , reportDuplicate :: ![BehaviorKey]+  , reportStale :: ![BehaviorKey]+  , reportFailed :: ![BehaviorFailure]+  , reportVerified :: ![BehaviorKey]+  , reportUnverified :: ![BehaviorKey]+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorConformanceReport where+  toJSON report = object+    [ "schema" .= ("keiro/behavior-conformance/1" :: Text)+    , "required" .= keyTexts (reportRequired report)+    , "filled" .= keyTexts (reportFilled report)+    , "pending" .= keyTexts (reportPending report)+    , "missing" .= keyTexts (reportMissing report)+    , "duplicate" .= keyTexts (reportDuplicate report)+    , "stale" .= keyTexts (reportStale report)+    , "failed" .= reportFailed report+    , "verified" .= keyTexts (reportVerified report)+    , "unverified" .= keyTexts (reportUnverified report)+    ]++behaviorRequirements :: [BehaviorRequirement]+behaviorRequirements =+  [ -- ShipmentsRecorded x RecordShipment: required rejection+    BehaviorRequirement+      { requirementKey = BehaviorKey "behavior-v1-89eeb23ded471fe8"+      , requirementKind = RequiredRejection+      , requirementEvidence = GeneratedAuthoritative+      , requirementGuardCoverage = GuardNotApplicable+      , requirementSource = ShipmentsRecorded+      , requirementCommandName = "RecordShipment"+      , requirementExpectedEdge = Nothing+      , requirementTarget = Nothing+      , requirementEventKinds = []+      }+  , -- ShipmentsEmpty x RecordShipment: live transition+    BehaviorRequirement+      { requirementKey = BehaviorKey "behavior-v1-b0a7e39ecba10454"+      , requirementKind = LiveTransition+      , requirementEvidence = GeneratedAuthoritative+      , requirementGuardCoverage = GuardTotal+      , requirementSource = ShipmentsEmpty+      , requirementCommandName = "RecordShipment"+      , requirementExpectedEdge = (Just (K.EdgeRef ShipmentsEmpty 0))+      , requirementTarget = Just ShipmentsRecorded+      , requirementEventKinds = ["ShipmentRecorded"]+      }+  ]++behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport+behaviorCoverageReport witnesses =+  BehaviorConformanceReport+    { reportRequired = sortedKeys (Map.keys requiredByKey)+    , reportFilled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , reportPending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , reportMissing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , reportDuplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , reportStale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , reportFailed = sortOn (unBehaviorKey . failureKey) failures+    , reportVerified = sortedKeys [requirementKey requirement | (requirement, Right ()) <- executions, proofStrength requirement]+    , reportUnverified = sortedKeys [requirementKey requirement | (requirement, Right ()) <- executions, not (proofStrength requirement)]+    }+ where+  requiredByKey = Map.fromList [(requirementKey requirement, requirement) | requirement <- behaviorRequirements]+  witnessGroups = Map.fromListWith (flip (<>)) [(behaviorWitnessKey witness, [witness]) | witness <- witnesses]+  executions =+    [ (requirement, runWitness requirement witness)+    | (key, [witness]) <- Map.toList witnessGroups+    , not (isPending witness)+    , Just requirement <- [Map.lookup key requiredByKey]+    ]+  failures = [behaviorFailure | (_, Left behaviorFailure) <- executions]++behaviorConformancePassed :: BehaviorConformanceReport -> Bool+behaviorConformancePassed = behaviorConformancePassedWith False++behaviorConformancePassedWith :: Bool -> BehaviorConformanceReport -> Bool+behaviorConformancePassedWith failOnUnverified report =+  null (reportPending report)+    && null (reportMissing report)+    && null (reportDuplicate report)+    && null (reportStale report)+    && null (reportFailed report)+    && (not failOnUnverified || null (reportUnverified report))++renderBehaviorConformanceText :: BehaviorConformanceReport -> Text+renderBehaviorConformanceText report = T.unlines+  [ "behavior conformance: Shipments"+  , "schema: keiro/behavior-conformance/1"+  , countLine "required" (reportRequired report)+  , countLine "filled" (reportFilled report)+  , countLine "pending" (reportPending report)+  , countLine "missing" (reportMissing report)+  , countLine "duplicate" (reportDuplicate report)+  , countLine "stale" (reportStale report)+  , "failed: " <> tshow (length (reportFailed report))+  , countLine "verified" (reportVerified report)+  , countLine "unverified" (reportUnverified report)+  ] <> T.unlines ["FAIL " <> unBehaviorKey (failureKey behaviorFailure) <> " " <> failureSubject behaviorFailure <> " [" <> failureCode behaviorFailure <> "] " <> failureDetail behaviorFailure | behaviorFailure <- reportFailed report]++runWitness :: BehaviorRequirement -> BehaviorWitness -> Either BehaviorFailure ()+runWitness requirement witness = case witness of+  Pending _ -> failure requirement "pending" "witness is still Pending"+  LiveWitness _ history command expectation -> runLive requirement history command expectation+  ReplayWitness _ prefix chunk -> runReplay requirement prefix chunk++runLive :: BehaviorRequirement -> [ShipmentsEvent] -> ShipmentsCommand -> LiveExpectation -> Either BehaviorFailure ()+runLive requirement history command expectation = do+  settled <- settleHistory requirement "history" history+  ensure requirement (K.replaySuccessState settled == requirementSource requirement) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirementCommandName requirement) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirementKind requirement of+    ReplayTransition -> failure requirement "witness-kind" "a replay-only requirement needs ReplayWitness"+    RequiredRejection -> runRejection requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation+    LiveTransition -> runAcceptance requirement (K.replaySuccessState settled, K.replaySuccessRegs settled) command expectation++runRejection :: BehaviorRequirement -> (ShipmentsVertex, K.RegFile ShipmentsRegs) -> ShipmentsCommand -> 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"+  Rejects expectedClass -> case K.stepDetailedEither shipmentsTransducer seed command of+    Left K.NoOutgoingEdges {} -> ensure requirement (expectedClass == RejectNoOutgoingEdges) "rejection-class" "expected NoMatchingEdge but runtime returned NoOutgoingEdges"+    Left K.NoMatchingEdge {} -> ensure requirement (expectedClass == RejectNoMatchingEdge) "rejection-class" "expected NoOutgoingEdges but runtime returned NoMatchingEdge"+    Left K.AmbiguousEdges {} -> failure requirement "ambiguous-edges" "AmbiguousEdges can never satisfy a rejection witness"+    Right _ -> failure requirement "unexpected-acceptance" "runtime accepted a command required to reject"++runAcceptance :: BehaviorRequirement -> (ShipmentsVertex, K.RegFile ShipmentsRegs) -> ShipmentsCommand -> 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 shipmentsTransducer seed command of+    Left stepFailure -> failure requirement "unexpected-rejection" (tshow stepFailure)+    Right success -> do+      checkAcceptedEnvelope requirement success+      ensure requirement (null (K.stepSuccessOutputs success)) "noop-emitted" "NoOp emitted one or more events"+      ensure requirement (K.stepSuccessState success == fst seed) "noop-vertex-change" "NoOp changed the control vertex"+      ensure requirement (regsEqual (K.stepSuccessRegs success) (snd seed)) "noop-register-change" "NoOp changed one or more registers"+  Emits expectedEvents -> case K.stepDetailedEither shipmentsTransducer seed command of+    Left stepFailure -> failure requirement "unexpected-rejection" (tshow stepFailure)+    Right success -> do+      checkAcceptedEnvelope requirement success+      let expected = NonEmpty.toList expectedEvents+          actual = K.stepSuccessOutputs success+      ensure requirement (actual == expected) "event-value-mismatch" ("runtime event values differ from the exact witness expectation; 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 shipmentsTransducer seed decoded of+        Left replayFailure -> failure requirement "emitted-replay-failed" (tshow replayFailure)+        Right replaySuccess -> Right replaySuccess+      ensure requirement (K.replaySuccessState replayed == K.stepSuccessState success) "forward-replay-vertex" "decoded emissions replay to a different vertex"+      ensure requirement (regsEqual (K.replaySuccessRegs replayed) (K.stepSuccessRegs success)) "forward-replay-registers" "decoded emissions replay to different registers"+      checkSingleAttribution requirement K.Live (length decoded) (K.replaySuccessTrace replayed)++checkAcceptedEnvelope :: BehaviorRequirement -> K.StepSuccess ShipmentsRegs ShipmentsVertex ShipmentsEvent -> Either BehaviorFailure ()+checkAcceptedEnvelope requirement success = do+  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 -> [ShipmentsEvent] -> [ShipmentsEvent] -> Either BehaviorFailure ()+runReplay requirement prefix chunk = case requirementKind requirement of+  ReplayTransition -> do+    settled <- settleHistory requirement "history-prefix" prefix+    ensure requirement (K.replaySuccessState settled == requirementSource requirement) "history-wrong-source" "history prefix does not settle at the replay edge source"+    ensure requirement (not (null chunk)) "empty-replay-chunk" "a replay-only edge has no observable empty chunk"+    decoded <- either (failure requirement "replay-chunk-codec-decode") Right (decodeEvents chunk)+    replayed <- case K.applyEventsDetailedEither shipmentsTransducer (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; 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 ShipmentsVertex] -> 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; 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 -> [ShipmentsEvent] -> Either BehaviorFailure (K.ReplaySuccess ShipmentsRegs ShipmentsVertex)+settleHistory requirement label history = do+  decoded <- either (failure requirement (label <> "-codec-decode")) Right (decodeEvents history)+  case K.applyEventsDetailedEither shipmentsTransducer (ShipmentsEmpty, initialShipmentsRegs) decoded of+    Left replayFailure -> failure requirement (label <> "-replay-failed") (tshow replayFailure)+    Right replaySuccess -> Right replaySuccess++decodeEvents :: [ShipmentsEvent] -> Either Text [ShipmentsEvent]+decodeEvents = traverse (\event -> parseShipmentsEvent (Codec.eventType shipmentsCodec event) (encodeShipmentsEvent event))++commandKind :: ShipmentsCommand -> Text+commandKind command = case command of+  RecordShipment _ -> "RecordShipment"++eventKind :: ShipmentsEvent -> Text+eventKind event = case Codec.eventType shipmentsCodec event of Codec.EventType tag -> tag++regsEqual :: K.RegFile ShipmentsRegs -> K.RegFile ShipmentsRegs -> Bool+regsEqual left right = (left K.! #accepted) == (right K.! #accepted)++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 :: BehaviorRequirement -> Text -> Text -> Either BehaviorFailure failed+failure requirement code detail =+  Left+    ( BehaviorFailure+        (requirementKey requirement)+        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey 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

+ test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Codec.hs view

@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedRecordDot #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Shipments; do not edit.+module Generated.CatalogDemo.Shipments.Codec (+    shipmentsCodec,+    parseShipmentsEvent,+    encodeShipmentsEvent,+) where++import Generated.CatalogDemo.Shipments.Domain+import Data.Aeson (Value, object, toJSON, withObject, (.:), (.=))+import Data.Aeson.Types (parseEither)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty+import Data.Text (Text)+import qualified Data.Text as T+import Keiro.Codec (Codec (..), EventType (..))++import CatalogDemo.MappedDomain ()++++++shipmentsEventTypes :: NonEmpty EventType+shipmentsEventTypes = EventType "ShipmentRecorded" :| []++shipmentsCodec :: Codec ShipmentsEvent+shipmentsCodec =+  Codec+    { eventTypes = shipmentsEventTypes+    , eventType = \case+        ShipmentRecorded{} -> EventType "ShipmentRecorded"+    , schemaVersion = 1+    , encode = encodeShipmentsEvent+    , decode = parseShipmentsEvent+    , upcasters = []+    }++encodeShipmentsEvent :: ShipmentsEvent -> Value+encodeShipmentsEvent = \case+  ShipmentRecorded payload ->+    object+      [ "kind" .= ("ShipmentRecorded" :: Text)+      , "sharedReference" .= toJSON payload.sharedReference+      , "accepted" .= payload.accepted+      ]++parseShipmentsEvent :: EventType -> Value -> Either Text ShipmentsEvent+parseShipmentsEvent (EventType tag) = mapLeftText . parseEither (withObject "ShipmentsEvent" go)+  where+    go o = do+      case tag of+        "ShipmentRecorded" ->+          ShipmentRecorded+            <$> ( ShipmentRecordedData+                    <$> o .: "sharedReference"+                    <*> o .: "accepted"+                )+        _ -> fail ("unknown event type " <> show tag <> "; expected one of: " <> renderExpectedEventTypes shipmentsEventTypes)++mapLeftText :: Either String b -> Either Text b+mapLeftText = either (Left . T.pack) Right++renderExpectedEventTypes :: NonEmpty EventType -> String+renderExpectedEventTypes =+  T.unpack+    . T.intercalate ", "+    . map (\(EventType eventTypeName) -> eventTypeName)+    . NonEmpty.toList

+ test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Domain.hs view

@@ -0,0 +1,45 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TemplateHaskell #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Shipments; do not edit.+module Generated.CatalogDemo.Shipments.Domain where++import Data.Proxy (Proxy (..))+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import CatalogDemo.MappedDomain (SharedReference)+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++data ShipmentsVertex = ShipmentsEmpty | ShipmentsRecorded+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data RecordShipmentData = RecordShipmentData+  { sharedReference :: !SharedReference+  , accepted :: !Bool+  }+  deriving stock (Generic, Eq, Show)++data ShipmentsCommand = RecordShipment !RecordShipmentData+  deriving stock (Generic, Eq, Show)++data ShipmentRecordedData = ShipmentRecordedData+  { sharedReference :: !SharedReference+  , accepted :: !Bool+  }+  deriving stock (Generic, Eq, Show)++data ShipmentsEvent = ShipmentRecorded !ShipmentRecordedData+  deriving stock (Generic, Eq, Show)++type ShipmentsRegs =+  '[ '("accepted", Bool)+   ]++initialShipmentsRegs :: RegFile ShipmentsRegs+initialShipmentsRegs =+  RCons (Proxy @"accepted") False RNil++$(deriveAggregateCtorsAll ''ShipmentsCommand ''ShipmentsRegs)++++$(deriveWireCtorsAll ''ShipmentsEvent)

+ test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/EventStream.hs view

@@ -0,0 +1,49 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Shipments; do not edit.+module Generated.CatalogDemo.Shipments.EventStream+  ( shipmentsCategory+  , shipmentsCommandCategory+  , shipmentsEventStream+  , shipmentsEventStreamDef+  , ShipmentsEventStream+  , ShipmentsEventStreamDef+  ) where++import Generated.CatalogDemo.Shipments.Domain+import Generated.CatalogDemo.Shipments.Codec (shipmentsCodec)+import Generated.CatalogDemo.Shipments.Transducer (shipmentsTransducer)+import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Keiro.Stream qualified as Stream++-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).+-- Entity streams are '<category>-<id>' via Keiro.Stream.entityStream.+-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.+shipmentsCategory :: Stream.StreamCategory ShipmentsEventStreamDef+shipmentsCategory = Stream.categoryUnsafe "shipments"++-- The same category text, typed for command envelopes such as PMCommand.+shipmentsCommandCategory :: Stream.StreamCategory ShipmentsCommand+shipmentsCommandCategory = Stream.categoryUnsafe "shipments"++type ShipmentsEventStreamDef =+  EventStream (HsPred ShipmentsRegs ShipmentsCommand) ShipmentsRegs ShipmentsVertex ShipmentsCommand ShipmentsEvent++type ShipmentsEventStream =+  ValidatedEventStream (HsPred ShipmentsRegs ShipmentsCommand) ShipmentsRegs ShipmentsVertex ShipmentsCommand ShipmentsEvent++shipmentsEventStreamDef :: ShipmentsEventStreamDef+shipmentsEventStreamDef =+  EventStream+    { transducer = shipmentsTransducer,+      initialState = ShipmentsEmpty,+      initialRegisters = initialShipmentsRegs,+      eventCodec = shipmentsCodec,+      resolveStreamName = Stream.streamName,+      snapshotPolicy = Never,+      stateCodec = Nothing+    }++shipmentsEventStream :: ShipmentsEventStream+shipmentsEventStream =+  mkEventStreamOrThrow "Shipments" shipmentsEventStreamDef

+ test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Harness.hs view

@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedLabels #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Shipments; do not edit.+module Generated.CatalogDemo.Shipments.Harness (harnessAssertions) where++import Generated.CatalogDemo.Shipments.Domain+import Generated.CatalogDemo.Shipments.Codec (encodeShipmentsEvent, parseShipmentsEvent, shipmentsCodec)+import Generated.CatalogDemo.Shipments.Transducer (shipmentsTransducer)+import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!))+import Keiro.Codec (eventType)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Text qualified as T+import Keiro.Codec.Structural (FixtureCases (..))+import CatalogDemo.MappedBindings qualified as MappedBindings++-- | (label, passed). A driver runs these and exits non-zero on any False,+-- naming the failing assertion. Filling a hole wrongly turns a specific+-- entry False; the scaffold cannot.+harnessAssertions :: [(String, Bool)]+harnessAssertions =+  [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions shipmentsTransducer))+  -- clock-free: spec samples no wall clock (verified at scaffold time)+  , ("golden round-trip: ShipmentRecorded", roundTrips sampleEventShipmentRecorded)+  , ("accepts RecordShipment from ShipmentsEmpty", acceptRecordShipment)+  ]+  ++ mappedConformanceAssertions+  ++ forwardReplayRecordShipment++roundTrips :: ShipmentsEvent -> Bool+roundTrips e = parseShipmentsEvent (eventType shipmentsCodec e) (encodeShipmentsEvent e) == Right e++sampleEventShipmentRecorded :: ShipmentsEvent+sampleEventShipmentRecorded = ShipmentRecorded (ShipmentRecordedData (snd (NonEmpty.head (fixtureCases MappedBindings.sharedReferenceCases))) False)++acceptRecordShipment :: Bool+acceptRecordShipment =+  case step shipmentsTransducer (ShipmentsEmpty, initialShipmentsRegs) (RecordShipment (RecordShipmentData (snd (NonEmpty.head (fixtureCases MappedBindings.sharedReferenceCases))) False)) of+    Just (v, _, _) -> v == ShipmentsRecorded+    Nothing -> False++-- forward/replay equality (plan 147): cross the persisted codec boundary,+-- replay the emitted chain, and compare the final vertex and every register.+forwardReplayRecordShipment :: [(String, Bool)]+forwardReplayRecordShipment =+  case step shipmentsTransducer (ShipmentsEmpty, initialShipmentsRegs) (RecordShipment (RecordShipmentData (snd (NonEmpty.head (fixtureCases MappedBindings.sharedReferenceCases))) False)) of+    Nothing -> [(prefix <> "forward step accepted", False)]+    Just (forwardVertex, forwardRegs, emitted) ->+      case mapM (\event -> parseShipmentsEvent (eventType shipmentsCodec event) (encodeShipmentsEvent event)) emitted of+        Left _ -> [(prefix <> "emitted chain decodes", False)]+        Right decodedEvents ->+          case applyEventsEither shipmentsTransducer (ShipmentsEmpty, initialShipmentsRegs) decodedEvents of+            Left _ -> [(prefix <> "replay succeeds", False)]+            Right (replayVertex, replayRegs) ->+              [ (prefix <> "final vertex", replayVertex == forwardVertex)+              , (prefix <> "register accepted", (replayRegs ! #accepted) == (forwardRegs ! #accepted))+              ]+  where+    prefix = "forward/replay equality: RecordShipment from ShipmentsEmpty -- "++mappedConformanceAssertions :: [(String, Bool)]+mappedConformanceAssertions =+  concat+    [ shipmentRecordedSharedReferenceAssertions+    ]++shipmentRecordedSharedReferenceAssertions :: [(String, Bool)]+shipmentRecordedSharedReferenceAssertions =+  [ ("mapped codec round-trip: ShipmentRecorded/sharedReference/" <> T.unpack label, roundTrips (ShipmentRecorded (ShipmentRecordedData mappedValue False)))+  | (label, mappedValue) <- NonEmpty.toList (fixtureCases MappedBindings.sharedReferenceCases)+  ]

+ test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Projection.hs view

@@ -0,0 +1,4 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Shipments; do not edit.+module Generated.CatalogDemo.Shipments.Projection () where++-- No projection declarations are present; this module keeps the generated manifest inventory total.

+ test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Transducer.hs view

@@ -0,0 +1,58 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from aggregate Shipments; do not edit.+module Generated.CatalogDemo.Shipments.Transducer+  ( shipmentsTransducer+  , shipmentsFoldFingerprint+  , BehaviorOwnership (..)+  , shipmentsPredicateVerifications+  ) where++import Generated.CatalogDemo.Shipments.Domain+import Data.Text (Text)+import Keiki.Builder qualified as B+import Keiki.Core (HsPred, SymTransducer)+import Keiki.Core qualified as K+import Keiki.Symbolic qualified as S+import Keiki.Builder ((=:))++shipmentsTransducer+  :: SymTransducer+       (HsPred ShipmentsRegs ShipmentsCommand)+       ShipmentsRegs+       ShipmentsVertex+       ShipmentsCommand+       ShipmentsEvent+shipmentsTransducer =+  B.buildTransducer ShipmentsEmpty initialShipmentsRegs isTerminal do+    B.from ShipmentsEmpty do+      B.onCmd inCtorRecordShipment $ \d -> B.do+        B.slot @"accepted" =: d.accepted+        B.emit wireShipmentRecorded (ShipmentRecordedTermFields+          { sharedReference = d.sharedReference+          , accepted = d.accepted+          })+        B.goto ShipmentsRecorded+ where+  isTerminal = \case+    ShipmentsRecorded -> True+    _ -> False++shipmentsFoldFingerprint :: Text+shipmentsFoldFingerprint = "6108a2aa4b5d59c62a6e703eb7120853"++data BehaviorOwnership = GeneratedOwned | HoleOwned+  deriving stock (Eq, Show)++-- Every checked transition predicate is audited through Keiki's conservative+-- symbolic verifier. Opaque Hole terms remain explicitly unverified.+shipmentsPredicateVerifications :: IO [(Text, BehaviorOwnership, S.PredicateVerification)]+shipmentsPredicateVerifications = sequence+  [ verifyTransition "transition1EmptyRecordShipment" GeneratedOwned ShipmentsEmpty 0+  ]+ where+  verifyTransition label owner source edgeIndex =+    case drop edgeIndex (K.edgesOut shipmentsTransducer source) of+      K.Edge predicate _ _ _ _ : _ -> (\result -> (label, owner, result)) <$> S.verifyPredicate predicate+      [] -> pure (label, owner, S.UnverifiedSolverFailure "generated transition edge missing")

+ test/conformance-projection-catalog/Generated/CatalogDemo/Structural/Shape/QualificationPayload.hs view

@@ -0,0 +1,11 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from mapped structural QualificationPayload; do not edit.+module Generated.CatalogDemo.Structural.Shape.QualificationPayload (QualificationPayloadShape (..)) where++import Data.Text (Text)+import GHC.Generics (Generic)++data QualificationPayloadShape = QualificationPayload+  { qualificationId :: !Text+  , note :: !(Maybe Text)+  }+  deriving stock (Eq, Generic, Show)

+ test/conformance-projection-catalog/Generated/CatalogDemo/StructuralConformance.hs view

@@ -0,0 +1,125 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from context catalog-demo structural conformance; do not edit.+module Generated.CatalogDemo.StructuralConformance+  ( structuralConformanceAssertions+  ) where++import Data.Aeson qualified as Aeson+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.Core (fieldWitnessAgrees)+import Keiki.Shape (CanonicalTypeName (..))+import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape)+import Generated.CatalogDemo.StructuralProjections qualified as StructuralProjections+import CatalogDemo.MappedBindings qualified as MappedBindings+import CatalogDemo.MappedDomain (QualificationPayload)+import Generated.CatalogDemo.Structural.Shape.QualificationPayload qualified as ShapeQualificationPayload++structuralConformanceAssertions :: [(String, Bool)]+structuralConformanceAssertions =+  concat+    [ qualificationPayloadBindingAssertions+    , orderPayloadOpaqueAssertions+    , qualificationResultOpaqueAssertions+    , queryCriteriaOpaqueAssertions+    , queueMetadataOpaqueAssertions+    , registerStateOpaqueAssertions+    , sharedReferenceOpaqueAssertions+    , unusedQualificationOpaqueAssertions+    , [("fixture coverage: catalog-demo.QualificationPayload.v1", coverageQualificationPayload)]+    , structuralProjectionAssertions+    ]++validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool+validFixtureLabels cases =+  all (not . T.null) labels && length labels == length (nub labels)+  where+    labels = map fst (NonEmpty.toList cases)++qualificationPayloadBindingAssertions :: [(String, Bool)]+qualificationPayloadBindingAssertions =+  ("fixture labels: catalog-demo.QualificationPayload.v1", validFixtureLabels cases) :+  ("canonical identity: catalog-demo.QualificationPayload.v1", canonicalTypeName (Proxy @QualificationPayload) == "catalog-demo.QualificationPayload.v1") :+  concat+    [ [ ("binding domain round-trip: catalog-demo.QualificationPayload.v1/" <> T.unpack label, bindingDomainRoundTrip MappedBindings.qualificationPayloadBinding value)+      , ("binding shape round-trip: catalog-demo.QualificationPayload.v1/" <> T.unpack label, bindingShapeRoundTrip MappedBindings.qualificationPayloadBinding (bindingToShape MappedBindings.qualificationPayloadBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases MappedBindings.qualificationPayloadCases++orderPayloadOpaqueAssertions :: [(String, Bool)]+orderPayloadOpaqueAssertions =+  ("opaque boundary fixtures: catalog-demo.order-payload.json@1", validFixtureLabels cases) :+  [ ("opaque codec round-trip: catalog-demo.order-payload.json@1/" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False)+  | (caseLabel, value) <- NonEmpty.toList cases+  ]+  where+    cases = fixtureCases MappedBindings.orderPayloadCases++qualificationResultOpaqueAssertions :: [(String, Bool)]+qualificationResultOpaqueAssertions =+  ("opaque boundary fixtures: catalog-demo.qualification-result.json@1", validFixtureLabels cases) :+  [ ("opaque codec round-trip: catalog-demo.qualification-result.json@1/" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False)+  | (caseLabel, value) <- NonEmpty.toList cases+  ]+  where+    cases = fixtureCases MappedBindings.qualificationResultCases++queryCriteriaOpaqueAssertions :: [(String, Bool)]+queryCriteriaOpaqueAssertions =+  ("opaque boundary fixtures: catalog-demo.query-criteria.json@1", validFixtureLabels cases) :+  [ ("opaque codec round-trip: catalog-demo.query-criteria.json@1/" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False)+  | (caseLabel, value) <- NonEmpty.toList cases+  ]+  where+    cases = fixtureCases MappedBindings.queryCriteriaCases++queueMetadataOpaqueAssertions :: [(String, Bool)]+queueMetadataOpaqueAssertions =+  ("opaque boundary fixtures: catalog-demo.queue-metadata.json@1", validFixtureLabels cases) :+  [ ("opaque codec round-trip: catalog-demo.queue-metadata.json@1/" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False)+  | (caseLabel, value) <- NonEmpty.toList cases+  ]+  where+    cases = fixtureCases MappedBindings.queueMetadataCases++registerStateOpaqueAssertions :: [(String, Bool)]+registerStateOpaqueAssertions =+  ("opaque boundary fixtures: catalog-demo.register-state.json@1", validFixtureLabels cases) :+  [ ("opaque codec round-trip: catalog-demo.register-state.json@1/" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False)+  | (caseLabel, value) <- NonEmpty.toList cases+  ]+  where+    cases = fixtureCases MappedBindings.registerStateCases++sharedReferenceOpaqueAssertions :: [(String, Bool)]+sharedReferenceOpaqueAssertions =+  ("opaque boundary fixtures: catalog-demo.shared-reference.json@1", validFixtureLabels cases) :+  [ ("opaque codec round-trip: catalog-demo.shared-reference.json@1/" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False)+  | (caseLabel, value) <- NonEmpty.toList cases+  ]+  where+    cases = fixtureCases MappedBindings.sharedReferenceCases++unusedQualificationOpaqueAssertions :: [(String, Bool)]+unusedQualificationOpaqueAssertions =+  ("opaque boundary fixtures: catalog-demo.unused-qualification.json@1", validFixtureLabels cases) :+  [ ("opaque codec round-trip: catalog-demo.unused-qualification.json@1/" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False)+  | (caseLabel, value) <- NonEmpty.toList cases+  ]+  where+    cases = fixtureCases MappedBindings.unusedQualificationCases++coverageQualificationPayload :: Bool+coverageQualificationPayload = any (isNothing . ShapeQualificationPayload.note) shapes && any (isJust . ShapeQualificationPayload.note) shapes+  where+    shapes = map (bindingToShape MappedBindings.qualificationPayloadBinding . snd) (NonEmpty.toList (fixtureCases MappedBindings.qualificationPayloadCases))++structuralProjectionAssertions :: [(String, Bool)]+structuralProjectionAssertions =+  [ ("projection witness agreement: catalog-demo.QualificationPayload.v1/qualification_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.qualificationPayloadQualificationIdWitness (\referenceOwner -> ShapeQualificationPayload.qualificationId (bindingToShape MappedBindings.qualificationPayloadBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases MappedBindings.qualificationPayloadCases)))+  ]

+ test/conformance-projection-catalog/Generated/CatalogDemo/StructuralProjections.hs view

@@ -0,0 +1,26 @@+{-# LANGUAGE TypeFamilies #-}+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from context catalog-demo mapped structural facade; do not edit.+-- Equality witnesses are emitted for Text, Int, Bool, Natural, and UTCTime.+-- Int, Natural, and UTCTime belong to Keiki's ordered subset.+module Generated.CatalogDemo.StructuralProjections+  ( qualificationPayloadQualificationIdWitness+  ) where++import Data.Text (Text)+import Keiro.Codec.Structural (bindingToShape)+import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)+import CatalogDemo.MappedBindings qualified as MappedBindings+import CatalogDemo.MappedDomain (QualificationPayload)+import Generated.CatalogDemo.Structural.Shape.QualificationPayload qualified as ShapeQualificationPayload++data QualificationPayloadQualificationIdProjection++instance FieldProjection QualificationPayloadQualificationIdProjection where+  type FieldName QualificationPayloadQualificationIdProjection = "/qualification_id"+  type FieldOwner QualificationPayloadQualificationIdProjection = QualificationPayload+  type FieldResult QualificationPayloadQualificationIdProjection = Text+  fieldShapeId _ = "catalog-demo.QualificationPayload.v1"+  projectFieldValue _ owner = ShapeQualificationPayload.qualificationId (bindingToShape MappedBindings.qualificationPayloadBinding owner)++qualificationPayloadQualificationIdWitness :: FieldWitness QualificationPayloadQualificationIdProjection+qualificationPayloadQualificationIdWitness = fieldWitness @QualificationPayloadQualificationIdProjection

+ test/conformance-projection-catalog/Main.hs view

@@ -0,0 +1,170 @@+module Main (main) where++import CatalogDemo.MappedDomain (QualificationPayload (..), QualificationResult (..), QueryCriteria (..), QueueMetadata (..), SharedReference (..))+import Control.Monad (forM_, unless)+import Data.Aeson (Value (..), object, (.=))+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Text (Text)+import Generated.CatalogDemo.CatalogAudit.ReadModelHarness qualified as CatalogAudit+import Generated.CatalogDemo.OrderInline.QueryContract (OrderInlineQueryInput, OrderInlineQueryResult)+import Generated.CatalogDemo.OrderInline.ReadModelHarness qualified as OrderInline+import Generated.CatalogDemo.OrderTotalsLookup.ReadModelHarness qualified as OrderTotalsLookup+import Generated.CatalogDemo.Orders.Harness qualified as Orders+import Generated.CatalogDemo.ProjectionCatalog+  ( orderSummaryWriterInlineProjections+  , ordersInlineProjections+  , projectionCatalogAsyncRegistrations+  , projectionCatalogInventory+  , projectionCatalogQuerySupplies+  , projectionCatalogRegistrations+  , reportingRebuildGroupId+  , shipmentWriterInlineProjections+  , shipmentsInlineProjections+  , shippingRebuildGroupId+  )+import Generated.CatalogDemo.ShipmentLookup.ReadModelHarness qualified as ShipmentLookup+import Generated.CatalogDemo.Shipments.Harness qualified as Shipments+import Generated.CatalogDemo.QualificationJobs.Queue+import Generated.CatalogDemo.QualificationJobs.QueueCodec (qualificationJobsJobCodec)+import Generated.CatalogDemo.StructuralConformance (structuralConformanceAssertions)+import Keiro.PGMQ.Codec (JobCodec (..))+import Keiro.Projection.Catalog qualified as Catalog+import Kiroku.Store.Subscription.Types (MissingCheckpointPolicy (FromCurrentHead))++main :: IO ()+main = do+  readModelFactsPassed <- and <$> sequence [CatalogAudit.runReadModelFacts, OrderInline.runReadModelFacts, OrderTotalsLookup.runReadModelFacts, ShipmentLookup.runReadModelFacts]+  assert "generated read-model facts" readModelFactsPassed+  let perturbed = map perturbSubscriptionName projectionCatalogAsyncRegistrations+      mutated = CatalogAudit.catalogFactsAgainst projectionCatalogRegistrations perturbed projectionCatalogQuerySupplies+  assert+    "perturbed async registration identity is detected"+    (any (\(fact, expected, actual) -> fact == "asyncRegistration:audit_writer" && expected /= actual) mutated)+  let mutatedReadModelFacts factName =+        [ if fact == factName then (fact, expected, actual <> "-WRONG") else row+        | row@(fact, expected, actual) <- CatalogAudit.readModelFacts+        ]+      mutationFails factName =+        any (\(fact, expected, actual) -> fact == factName && expected /= actual) (mutatedReadModelFacts factName)+  assert "freshness fact mutation is detected" (mutationFails "freshness")+  assert "cursor fact mutation is detected" (mutationFails "cursorAuthority")+  assert "delivery fact mutation is detected" (mutationFails "projectionDelivery")+  mapM_ (uncurry assert) Orders.harnessAssertions+  mapM_ (uncurry assert) Shipments.harnessAssertions+  mapM_ (uncurry assert) structuralConformanceAssertions+  let queryInput :: OrderInlineQueryInput+      queryInput = QueryCriteria "qualification-query"+      queryResult :: OrderInlineQueryResult+      queryResult = Just (QualificationResult "qualified-result")+  assert "non-unit typed query contract" (queryCriteriaText queryInput == "qualification-query" && queryResult == Just (QualificationResult "qualified-result"))+  exerciseQualificationQueue+  let targets = Catalog.inventoryTargets projectionCatalogInventory+      groups = Catalog.inventoryGroups projectionCatalogInventory+      sourceFingerprints = map inventoryCodecFingerprint (Catalog.inventorySources projectionCatalogInventory)+  assert "four physical targets" (length targets == 4)+  assert+    "mixed clear/preserve reset policy"+    ( length (filter ((== Catalog.ClearBeforeReplay) . inventoryResetPolicy) targets) == 2+        && length (filter ((== Catalog.PreserveAndReconcile) . inventoryResetPolicy) targets) == 2+    )+  assert "one target dependency" (length (filter (not . null . inventoryDependsOn) targets) == 1)+  assert "two atomic ordered groups" (map (length . inventoryOrderedTargets) groups == [3, 1])+  assert+    "projection source fingerprints"+    ( sourceFingerprints+        == [ "aggregate:Orders/generated-codec/v1/mapped-132056a8f2ee095d",+             "aggregate:Shipments/generated-codec/v1/mapped-9456a95e380c74b5",+             "category:audit/application-decoder/v1"+           ]+    )+  assert "three generated owners" (length (Catalog.inventoryProjections projectionCatalogInventory) == 3)+  assert+    "v1/v2 projection revision bridge"+    ( map (Catalog.projectionRevisionIdText . inventoryRevisionId) (Catalog.inventoryProjectionRevisions projectionCatalogInventory)+        == ["reporting_v1", "reporting_v2"]+    )+  assert "two typed aggregate handlers" (length orderSummaryWriterInlineProjections == 1 && length shipmentWriterInlineProjections == 1)+  assert "source-selected inline handlers stay singular" (length ordersInlineProjections == 1 && length shipmentsInlineProjections == 1)+  assert "four query registrations" (length projectionCatalogRegistrations == 4)+  assert+    "one owner supplies both order queries"+    ( map (Catalog.projectionIdText . Catalog.resolvedProjectionId) projectionCatalogQuerySupplies+        == ["audit_writer", "order_summary_writer", "order_summary_writer", "shipment_writer"]+    )+  assert "one async registration" (length projectionCatalogAsyncRegistrations == 1)+  assert "generated missing-checkpoint policy" (map inventoryCheckpointPolicy (Catalog.inventorySubscriptions projectionCatalogInventory) == [FromCurrentHead])+  assert "catalog-scoped rebuild group" (Catalog.rebuildGroupIdText reportingRebuildGroupId == "reporting")+  assert "disjoint catalog rebuild group" (Catalog.rebuildGroupIdText shippingRebuildGroupId == "shipping")+  putStrLn "projection catalog conformance: PASS"++perturbSubscriptionName :: Catalog.AsyncProjectionRegistration -> Catalog.AsyncProjectionRegistration+perturbSubscriptionName (Catalog.AsyncProjectionRegistration projectionId projectionName subscriptionId _ checkpointOnMissing dedupKeyId dedupName) =+  Catalog.AsyncProjectionRegistration projectionId projectionName subscriptionId "catalog-demo-audit-WRONG" checkpointOnMissing dedupKeyId dedupName++inventoryRevisionId :: Catalog.InventoryProjectionRevision -> Catalog.ProjectionRevisionId+inventoryRevisionId (Catalog.InventoryProjectionRevision revisionId _ _ _ _ _ _) = revisionId++exerciseQualificationQueue :: IO ()+exerciseQualificationQueue = do+  let payload =+        QualificationJob+          (SharedReference "shared-queue")+          (QualificationPayload "qualification-7" Nothing)+          (QueueMetadata "metadata-7")+          Nothing+          2+          (object ["trace_id" .= ("trace-7" :: Text)])+      encoded = encodeQualificationJob payload+      expected =+        object+          [ "shared_reference" .= SharedReference "shared-queue",+            "payload"+              .= object+                [ "qualification_id" .= ("qualification-7" :: Text),+                  "note" .= Null+                ],+            "metadata" .= QueueMetadata "metadata-7",+            "maybe_metadata" .= Null,+            "attempt" .= (2 :: Int),+            "trace" .= object ["trace_id" .= ("trace-7" :: Text)]+          ]+      envelope =+        object+          [ "v" .= (1 :: Int),+            "t" .= ("QualificationJob" :: Text),+            "data" .= expected+          ]+      missingRequired = case encoded of+        Object fields -> parseQualificationJob (Object (KeyMap.delete "payload" fields))+        _ -> error "qualification queue encoder did not produce an object"+      checks =+        [ ("qualification queue exact payload", encoded == expected),+          ("qualification queue structural and opaque round-trip", parseQualificationJob encoded == Right payload),+          ("qualification queue required key rejects omission", isLeft missingRequired),+          ("qualification queue present null admits Optional", (maybeMetadata <$> parseQualificationJob encoded) == Right Nothing),+          ("qualification queue schema-v1 envelope", encodeJob qualificationJobsJobCodec payload == envelope && decodeJob qualificationJobsJobCodec envelope == Right payload),+          ("qualification queue physical identity", queuePhysical == "catalog_demo_qualification_jobs")+        ]+  forM_ checks (uncurry assert)++assert :: String -> Bool -> IO ()+assert label condition = unless condition (error ("projection catalog conformance failed: " <> label))++isLeft :: Either problem value -> Bool+isLeft (Left _) = True+isLeft (Right _) = False++inventoryResetPolicy :: Catalog.InventoryTarget -> Catalog.TargetResetPolicy+inventoryResetPolicy Catalog.InventoryTarget {resetPolicy = policy} = policy++inventoryDependsOn :: Catalog.InventoryTarget -> [Catalog.TargetId]+inventoryDependsOn Catalog.InventoryTarget {dependsOn = dependencies} = dependencies++inventoryOrderedTargets :: Catalog.InventoryGroup -> [Catalog.TargetId]+inventoryOrderedTargets Catalog.InventoryGroup {orderedTargets = targets} = targets++inventoryCodecFingerprint :: Catalog.InventorySource -> Text+inventoryCodecFingerprint (Catalog.InventorySource _ _ fingerprint) = fingerprint++inventoryCheckpointPolicy :: Catalog.InventorySubscription -> MissingCheckpointPolicy+inventoryCheckpointPolicy (Catalog.InventorySubscription _ _ _ policy) = policy

test/conformance-publisher-runtime/Generated/HospitalCapacity/HospitalPublisher/Publisher.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from publisher hospitalPublisher; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from publisher hospitalPublisher; do not edit. module Generated.HospitalCapacity.HospitalPublisher.Publisher   ( publisherOrdering   , publisherBackoff

test/conformance-queue-runtime/Generated/HospitalCapacity/ReservationWork/Queue.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit. module Generated.HospitalCapacity.ReservationWork.Queue   ( ReservationWorkItem (..)   , encodeReservationWorkItem

test/conformance-queue-runtime/Generated/HospitalCapacity/ReservationWork/QueueCodec.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit. -- | Versioned job payload envelope: @{\"v\",\"t\",\"data\"}@. -- -- Deploy workers before producers when raising its schema version. Do not

test/conformance-queue-runtime/Generated/HospitalCapacity/ReservationWork/QueuePolicy.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit. module Generated.HospitalCapacity.ReservationWork.QueuePolicy   ( ReservationWorkOutcome (..)   , retryPolicy, jobOutcomeFor

test/conformance-queue/Generated/HospitalCapacity/ReservationWork/Queue.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit. module Generated.HospitalCapacity.ReservationWork.Queue   ( ReservationWorkItem (..)   , encodeReservationWorkItem

test/conformance-queue/Generated/HospitalCapacity/ReservationWork/QueueCodec.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit. -- | Versioned job payload envelope: @{\"v\",\"t\",\"data\"}@. -- -- Deploy workers before producers when raising its schema version. Do not

test/conformance-readmodel-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModel.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from readmodel transfer_decisions; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from readmodel transfer_decisions; do not edit. module Generated.HospitalCapacity.TransferDecisions.ReadModel   ( transferDecisionsReadModel   , transferDecisionsQualifiedTable

test/conformance-readmodel-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from readmodel transfer_decisions; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from readmodel transfer_decisions; do not edit. module Generated.HospitalCapacity.TransferDecisions.ReadModelHarness (readModelFacts, readModelFactResults, runReadModelFacts) where  import Generated.HospitalCapacity.TransferDecisions.ReadModel (transferDecisionsReadModel, transferDecisionsAsyncProjection)

test/conformance-readmodel-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from readmodel transfer_decisions; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from readmodel transfer_decisions; do not edit. module Generated.HospitalCapacity.TransferDecisions.ReadModelTable (transferDecisionsQualifiedTable) where  import Data.Text (Text)

+ test/conformance-replay/Generated/ReplayDivergence/BehaviorSourceMap.hs view

@@ -0,0 +1,30 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context replay-divergence behavior source map; do not edit.+module Generated.ReplayDivergence.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-248e9c1b1eb3e5bc" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/replay-divergence.keiro" 12 3)+  "behavior-v1-7c36eda198514110" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/replay-divergence.keiro" 7 16)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-replay/Generated/ReplayDivergence/Note/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Note; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Note; do not edit. module Generated.ReplayDivergence.Note.Codec (     noteCodec,     parseNoteEvent,

test/conformance-replay/Generated/ReplayDivergence/Note/Domain.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Note; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Note; do not edit. module Generated.ReplayDivergence.Note.Domain where  import Data.Proxy (Proxy (..))

test/conformance-replay/Generated/ReplayDivergence/Note/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Note; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Note; do not edit. module Generated.ReplayDivergence.Note.EventStream   ( noteCategory   , noteCommandCategory

test/conformance-replay/Generated/ReplayDivergence/Note/Harness.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Note; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Note; do not edit. module Generated.ReplayDivergence.Note.Harness (harnessAssertions) where  import Generated.ReplayDivergence.Note.Domain

test/conformance-replay/Generated/ReplayDivergence/Note/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Note; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Note; do not edit. module Generated.ReplayDivergence.Note.Projection () where  -- No projection declarations are present; this module keeps the generated manifest inventory total.

test/conformance-replay/Generated/ReplayDivergence/Note/Transducer.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Note; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Note; do not edit. module Generated.ReplayDivergence.Note.Transducer   ( noteTransducer   , noteFoldFingerprint

test/conformance-replay/Generated/ReplayDivergence/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context replay-divergence replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context replay-divergence replay-audit assembly; do not edit. -- -- Deployment contract: --   * replay-neutral diff: no data audit is required;

+ test/conformance-router-full/Generated/IncidentPaging/BehaviorSourceMap.hs view

@@ -0,0 +1,30 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context incident-paging behavior source map; do not edit.+module Generated.IncidentPaging.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-4cc963adc6662c5e" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/incident-paging/incident-paging.keiro" 33 18)+  "behavior-v1-d0a1ec215dcca5f8" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/incident-paging/incident-paging.keiro" 38 3)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-router-full/Generated/IncidentPaging/Page/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Page; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Page; do not edit. module Generated.IncidentPaging.Page.Codec (     pageCodec,     parsePageEvent,

test/conformance-router-full/Generated/IncidentPaging/Page/Domain.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Page; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Page; do not edit. module Generated.IncidentPaging.Page.Domain where  import Data.Text (Text)

test/conformance-router-full/Generated/IncidentPaging/Page/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Page; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Page; do not edit. module Generated.IncidentPaging.Page.EventStream   ( pageCategory   , pageCommandCategory

test/conformance-router-full/Generated/IncidentPaging/Page/Transducer.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Page; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Page; do not edit. module Generated.IncidentPaging.Page.Transducer   ( pageTransducer   , pageFoldFingerprint

test/conformance-router-full/Generated/IncidentPaging/PagingRouter/Router.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from router PagingRouter; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from router PagingRouter; do not edit. module Generated.IncidentPaging.PagingRouter.Router   ( pagingRouterName   , pagingRouterWorkerOptions

test/conformance-router-full/Generated/IncidentPaging/PagingRouter/RouterHarness.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from router PagingRouter; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from router PagingRouter; do not edit. module Generated.IncidentPaging.PagingRouter.RouterHarness (routerHarnessValues) where  routerHarnessValues :: [(String, String)]

test/conformance-router-full/Generated/IncidentPaging/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context incident-paging replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context incident-paging replay-audit assembly; do not edit. -- -- Deployment contract: --   * replay-neutral diff: no data audit is required;

+ test/conformance-router-runtime/Generated/IncidentPaging/BehaviorSourceMap.hs view

@@ -0,0 +1,30 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context incident-paging behavior source map; do not edit.+module Generated.IncidentPaging.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-4cc963adc6662c5e" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/incident-paging/incident-paging.keiro" 33 18)+  "behavior-v1-d0a1ec215dcca5f8" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/incident-paging/incident-paging.keiro" 38 3)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-router-runtime/Generated/IncidentPaging/PagingRouter/Router.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from router PagingRouter; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from router PagingRouter; do not edit. module Generated.IncidentPaging.PagingRouter.Router   ( pagingRouterName   , pagingRouterWorkerOptions

test/conformance-router-runtime/Generated/IncidentPaging/PagingRouter/RouterHarness.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from router PagingRouter; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from router PagingRouter; do not edit. module Generated.IncidentPaging.PagingRouter.RouterHarness (routerHarnessValues) where  routerHarnessValues :: [(String, String)]

+ test/conformance-router/Generated/IncidentPaging/BehaviorSourceMap.hs view

@@ -0,0 +1,30 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context incident-paging behavior source map; do not edit.+module Generated.IncidentPaging.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-4cc963adc6662c5e" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/incident-paging/incident-paging.keiro" 33 18)+  "behavior-v1-d0a1ec215dcca5f8" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/incident-paging/incident-paging.keiro" 38 3)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-router/Generated/IncidentPaging/PagingRouter/RouterHarness.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from router PagingRouter; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from router PagingRouter; do not edit. module Generated.IncidentPaging.PagingRouter.RouterHarness (routerHarnessValues) where  routerHarnessValues :: [(String, String)]

+ test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/BehaviorSourceMap.hs view

@@ -0,0 +1,34 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context aggregate-scalar-expressions behavior source map; do not edit.+module Generated.AggregateScalarExpressions.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-1de91883b9e3f8bc" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/aggregate-scalar-expressions-v2.keiro" 32 10)+  "behavior-v1-5c58e0aafeb5f400" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/aggregate-scalar-expressions-v2.keiro" 32 15)+  "behavior-v1-a19a8e94d935493f" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/aggregate-scalar-expressions-v2.keiro" 32 24)+  "behavior-v1-b7db52f28632d8da" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/aggregate-scalar-expressions-v2.keiro" 62 3)+  "behavior-v1-dbf483c868dd6d34" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/aggregate-scalar-expressions-v2.keiro" 32 24)+  "behavior-v1-e9c863d5daf20011" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/aggregate-scalar-expressions-v2.keiro" 42 3)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Nominals.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context aggregate-scalar-expressions generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context aggregate-scalar-expressions generated nominal declarations; do not edit. module Generated.AggregateScalarExpressions.Nominals   ( AccountMode (..)   , accountModeText

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Nominals/Internal.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context aggregate-scalar-expressions generated nominal ID internals; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context aggregate-scalar-expressions generated nominal ID internals; do not edit. module Generated.AggregateScalarExpressions.Nominals.Internal   ( RequestId   , parseRequestId

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context aggregate-scalar-expressions replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context aggregate-scalar-expressions replay-audit assembly; do not edit. -- -- Deployment contract: --   * replay-neutral diff: no data audit is required;

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/BehaviorContract.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ScalarAccount; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ScalarAccount; do not edit. module Generated.AggregateScalarExpressions.ScalarAccount.BehaviorContract   ( BehaviorKey (..)   , ObligationKind (..)@@ -21,6 +21,7 @@ import Generated.AggregateScalarExpressions.ScalarAccount.Codec (encodeScalarAccountEvent, parseScalarAccountEvent, scalarAccountCodec) import Generated.AggregateScalarExpressions.ScalarAccount.Domain import Generated.AggregateScalarExpressions.ScalarAccount.Transducer (scalarAccountTransducer)+import Generated.AggregateScalarExpressions.BehaviorSourceMap qualified as BehaviorSourceMap import Data.Aeson (ToJSON (..), object, (.=)) import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty)@@ -53,7 +54,6 @@   , requirementExpectedEdge :: !(Maybe (K.EdgeRef ScalarAccountVertex))   , requirementTarget :: !(Maybe ScalarAccountVertex)   , requirementEventKinds :: ![Text]-  , requirementLine :: !Int   }   deriving stock (Eq, Show) @@ -126,7 +126,7 @@  behaviorRequirements :: [BehaviorRequirement] behaviorRequirements =-  [ -- ScalarAccountOpen x Close: required rejection (spec line 32)+  [ -- ScalarAccountOpen x Close: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-1de91883b9e3f8bc"       , requirementKind = RequiredRejection@@ -137,9 +137,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 32       }-  , -- ScalarAccountReviewed x Adjust: required rejection (spec line 32)+  , -- ScalarAccountReviewed x Adjust: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-5c58e0aafeb5f400"       , requirementKind = RequiredRejection@@ -150,9 +149,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 32       }-  , -- ScalarAccountClosed x Adjust: required rejection (spec line 32)+  , -- ScalarAccountClosed x Adjust: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-a19a8e94d935493f"       , requirementKind = RequiredRejection@@ -163,9 +161,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 32       }-  , -- ScalarAccountReviewed x Close: live transition (spec line 62)+  , -- ScalarAccountReviewed x Close: live transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-b7db52f28632d8da"       , requirementKind = LiveTransition@@ -176,9 +173,8 @@       , requirementExpectedEdge = (Just (K.EdgeRef ScalarAccountReviewed 0))       , requirementTarget = Just ScalarAccountClosed       , requirementEventKinds = ["ClosedEvent"]-      , requirementLine = 62       }-  , -- ScalarAccountClosed x Close: required rejection (spec line 32)+  , -- ScalarAccountClosed x Close: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-dbf483c868dd6d34"       , requirementKind = RequiredRejection@@ -189,9 +185,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 32       }-  , -- ScalarAccountOpen x Adjust: live transition (spec line 42)+  , -- ScalarAccountOpen x Adjust: live transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-e9c863d5daf20011"       , requirementKind = LiveTransition@@ -202,7 +197,6 @@       , requirementExpectedEdge = (Just (K.EdgeRef ScalarAccountOpen 0))       , requirementTarget = Just ScalarAccountReviewed       , requirementEventKinds = ["Adjusted"]-      , requirementLine = 42       }   ] @@ -382,7 +376,7 @@   Left     ( BehaviorFailure         (requirementKey requirement)-        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (spec line " <> tshow (requirementLine requirement) <> ")")+        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey requirement)) <> ")")         code         detail     )

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ScalarAccount; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ScalarAccount; do not edit. module Generated.AggregateScalarExpressions.ScalarAccount.Codec (     scalarAccountCodec,     parseScalarAccountEvent,

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Domain.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ScalarAccount; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ScalarAccount; do not edit. module Generated.AggregateScalarExpressions.ScalarAccount.Domain where  import Data.Aeson (FromJSON, ToJSON)

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ScalarAccount; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ScalarAccount; do not edit. module Generated.AggregateScalarExpressions.ScalarAccount.EventStream   ( scalarAccountCategory   , scalarAccountCommandCategory

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Harness.hs view

@@ -1,29 +1,23 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ScalarAccount; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ScalarAccount; do not edit. module Generated.AggregateScalarExpressions.ScalarAccount.Harness (harnessAssertions) where  import Generated.AggregateScalarExpressions.ScalarAccount.Domain import Generated.AggregateScalarExpressions.ScalarAccount.Codec (encodeScalarAccountEvent, parseScalarAccountEvent, scalarAccountCodec, encodeLimitsMapped, decodeLimitsMapped) import Generated.AggregateScalarExpressions.ScalarAccount.Transducer (scalarAccountTransducer)-import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, fieldWitnessAgrees, (!))+import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!)) import Keiro.Codec (eventType) import Generated.AggregateScalarExpressions.Nominals (AccountMode (..), RequestId, parseRequestId) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as AesonKey import Data.Aeson.KeyMap qualified as AesonKeyMap import Data.Either (isLeft)-import Data.List (nub) import Data.List.NonEmpty qualified as NonEmpty-import Data.Proxy (Proxy (..)) import Data.Text qualified as T-import Keiki.Shape (CanonicalTypeName (..))-import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape)-import Generated.AggregateScalarExpressions.StructuralProjections qualified as StructuralProjections+import Keiro.Codec.Structural (FixtureCases (..)) import Data.Time.Calendar (fromGregorian) import Data.Time.Clock (UTCTime (..), picosecondsToDiffTime)-import Generated.AggregateScalarExpressions.Structural.Shape.Limits qualified as ShapeLimits import ScalarExpressions.Bindings qualified as Bindings-import ScalarExpressions.Domain (Limits)  -- | (label, passed). A driver runs these and exits non-zero on any False, -- naming the failing assertion. Filling a hole wrongly turns a specific@@ -94,35 +88,10 @@ mappedConformanceAssertions :: [(String, Bool)] mappedConformanceAssertions =   concat-    [ limitsBindingAssertions-    , [("fixture coverage: scalar-expressions.Limits.v1", coverageLimits)]-    , adjustedLimitsAssertions+    [ adjustedLimitsAssertions     , structuralWirePolicyAssertions-    , structuralProjectionAssertions     ] -validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool-validFixtureLabels cases =-  all (not . T.null) labels && length labels == length (nub labels)-  where-    labels = map fst (NonEmpty.toList cases)--limitsBindingAssertions :: [(String, Bool)]-limitsBindingAssertions =-  ("fixture labels: scalar-expressions.Limits.v1", validFixtureLabels cases) :-  ("canonical identity: scalar-expressions.Limits.v1", canonicalTypeName (Proxy @Limits) == "scalar-expressions.Limits.v1") :-  concat-    [ [ ("binding domain round-trip: scalar-expressions.Limits.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.limitsBinding value)-      , ("binding shape round-trip: scalar-expressions.Limits.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.limitsBinding (bindingToShape Bindings.limitsBinding value))-      ]-    | (label, value) <- NonEmpty.toList cases-    ]-  where-    cases = fixtureCases Bindings.limitsCases--coverageLimits :: Bool-coverageLimits = True- adjustedLimitsAssertions :: [(String, Bool)] adjustedLimitsAssertions =   [ ("mapped codec round-trip: Adjusted/limits/" <> T.unpack label, roundTrips (Adjusted (AdjustedData 0 0 0 "sample-label" False Normal sampleRequestId sampleObservedAt mappedValue)))@@ -132,12 +101,6 @@ structuralWirePolicyAssertions :: [(String, Bool)] structuralWirePolicyAssertions =   [ ("wire policy unknown fields: scalar-expressions.Limits.v1", all (\(_, value) -> isLeft (decodeLimitsMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeLimitsMapped value)))) (NonEmpty.toList (fixtureCases Bindings.limitsCases)))-  ]--structuralProjectionAssertions :: [(String, Bool)]-structuralProjectionAssertions =-  [ ("projection witness agreement: scalar-expressions.Limits.v1/ceiling", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.limitsCeilingWitness (\referenceOwner -> ShapeLimits.ceiling (bindingToShape Bindings.limitsBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.limitsCases)))-  , ("projection witness agreement: scalar-expressions.Limits.v1/minimum", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.limitsMinimumWitness (\referenceOwner -> ShapeLimits.minimum (bindingToShape Bindings.limitsBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.limitsCases)))   ]  insertObjectField :: T.Text -> Aeson.Value -> Aeson.Value -> Aeson.Value

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ScalarAccount; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ScalarAccount; do not edit. module Generated.AggregateScalarExpressions.ScalarAccount.Projection () where  -- No projection declarations are present; this module keeps the generated manifest inventory total.

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Transducer.hs view

@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ScalarAccount; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ScalarAccount; do not edit. module Generated.AggregateScalarExpressions.ScalarAccount.Transducer   ( scalarAccountTransducer   , scalarAccountFoldFingerprint

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Structural/Shape/Limits.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from mapped structural Limits; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from mapped structural Limits; do not edit. module Generated.AggregateScalarExpressions.Structural.Shape.Limits (LimitsShape (..)) where  import GHC.Generics (Generic)

+ test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/StructuralConformance.hs view

@@ -0,0 +1,52 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context aggregate-scalar-expressions structural conformance; do not edit.+module Generated.AggregateScalarExpressions.StructuralConformance+  ( structuralConformanceAssertions+  ) where++import Data.List (nub)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Proxy (Proxy (..))+import Data.Text qualified as T+import Keiki.Core (fieldWitnessAgrees)+import Keiki.Shape (CanonicalTypeName (..))+import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape)+import Generated.AggregateScalarExpressions.StructuralProjections qualified as StructuralProjections+import Generated.AggregateScalarExpressions.Structural.Shape.Limits qualified as ShapeLimits+import ScalarExpressions.Bindings qualified as Bindings+import ScalarExpressions.Domain (Limits)++structuralConformanceAssertions :: [(String, Bool)]+structuralConformanceAssertions =+  concat+    [ limitsBindingAssertions+    , [("fixture coverage: scalar-expressions.Limits.v1", coverageLimits)]+    , structuralProjectionAssertions+    ]++validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool+validFixtureLabels cases =+  all (not . T.null) labels && length labels == length (nub labels)+  where+    labels = map fst (NonEmpty.toList cases)++limitsBindingAssertions :: [(String, Bool)]+limitsBindingAssertions =+  ("fixture labels: scalar-expressions.Limits.v1", validFixtureLabels cases) :+  ("canonical identity: scalar-expressions.Limits.v1", canonicalTypeName (Proxy @Limits) == "scalar-expressions.Limits.v1") :+  concat+    [ [ ("binding domain round-trip: scalar-expressions.Limits.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.limitsBinding value)+      , ("binding shape round-trip: scalar-expressions.Limits.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.limitsBinding (bindingToShape Bindings.limitsBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.limitsCases++coverageLimits :: Bool+coverageLimits = True++structuralProjectionAssertions :: [(String, Bool)]+structuralProjectionAssertions =+  [ ("projection witness agreement: scalar-expressions.Limits.v1/ceiling", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.limitsCeilingWitness (\referenceOwner -> ShapeLimits.ceiling (bindingToShape Bindings.limitsBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.limitsCases)))+  , ("projection witness agreement: scalar-expressions.Limits.v1/minimum", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.limitsMinimumWitness (\referenceOwner -> ShapeLimits.minimum (bindingToShape Bindings.limitsBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.limitsCases)))+  ]

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/StructuralProjections.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context aggregate-scalar-expressions mapped structural facade; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context aggregate-scalar-expressions mapped structural facade; do not edit. -- Equality witnesses are emitted for Text, Int, Bool, Natural, and UTCTime. -- Int, Natural, and UTCTime belong to Keiki's ordered subset. module Generated.AggregateScalarExpressions.StructuralProjections

test/conformance-scalar-expressions/Main.hs view

@@ -17,6 +17,7 @@ import Generated.AggregateScalarExpressions.ScalarAccount.EventStream (scalarAccountEventStreamDef) import Generated.AggregateScalarExpressions.ScalarAccount.Harness (harnessAssertions) import Generated.AggregateScalarExpressions.ScalarAccount.Transducer+import Generated.AggregateScalarExpressions.StructuralConformance (structuralConformanceAssertions) import Generated.AggregateScalarExpressions.StructuralProjections qualified as StructuralProjections import Keiki.Core qualified as K import Keiki.Generics (RegFieldsOf)@@ -38,7 +39,8 @@   conservativeIdProof <- conservativeGeneratedIdProjection   let behaviorReport = Behavior.behaviorCoverageReport behaviorWitnesses   let checks =-        harnessAssertions+        [("structural/" <> label, passed) | (label, passed) <- structuralConformanceAssertions]+          <> harnessAssertions           <> [ ("finite scalar oracle agrees with generated execution", finiteOracleAgreement)              , ("Natural 2 - 5 is total monus zero", naturalMonusExample)              , ("Integer/Natural oracle, concrete terms, and symbolic formulas agree", arithmeticAgreement)

test/conformance-skeletons/SkelRouter/MyService/Page/Holes.hs view

@@ -12,9 +12,8 @@     -- (no projection) ) where -import Keiki.Builder ((=:)) import Keiki.Builder qualified as B-import Keiki.Core (HsPred, RegFile, SymTransducer, lit, (./=), (.==), (.||))+import Keiki.Core (HsPred, SymTransducer) import SkelRouter.Generated.MyService.Page.Domain  -- HOLE: the transducer body. Reproduce the structure below, replacing each@@ -29,7 +28,7 @@ pageTransducer =     B.buildTransducer PagePending initialPageRegs isTerminal do         B.from PagePending do-            B.onCmd inCtorSendPage $ \d -> B.do+            B.onCmd inCtorSendPage $ \_ -> B.do                 -- HOLE emit PageSent (B.emit wirePageSent ...)                 B.goto PageDelivered   where

test/conformance-skeletons/SkelWorkflow/Generated/MyService/HospitalTransferReservation/WorkflowRuntime.hs view

@@ -1,27 +1,40 @@ -- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from workflow HospitalTransferReservation; do not edit. module SkelWorkflow.Generated.MyService.HospitalTransferReservation.WorkflowRuntime   ( workflowName-  , awaitAwakeableId+  , AwaitBinding+  , allocateDeclaredAwait+  , reservationConfirmationAwait   , awaitLabels   , declaredPatches   , declaredPatchStepNames   , withDeclaredPatches   ) where +import Data.Aeson (FromJSON) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text)-import Keiro.Workflow (WorkflowRunOptions (..))-import Keiro.Workflow.Awakeable (AwakeableId, deterministicAwakeableId)-import Keiro.Workflow.Types (PatchId (..), WorkflowId, WorkflowName (..), patchStepName)+import Effectful (Eff, IOE, (:>))+import Keiro.Workflow (StepName (..), Workflow, WorkflowRunOptions (..))+import Keiro.Workflow.Awakeable (AwakeableId, awakeableNamed)+import Keiro.Workflow.Types (PatchId (..), WorkflowName (..), patchStepName)+import Kiroku.Store.Effect (Store)  workflowName :: WorkflowName workflowName = WorkflowName "hospital-transfer-reservation" --- The awakeable id an await allocates — the real deterministicAwakeableId.--- A signal op deriving the same (name, id, label) gets the same id.-awaitAwakeableId :: WorkflowId -> Text -> AwakeableId-awaitAwakeableId wid label = deterministicAwakeableId workflowName wid label+-- | A declared await label. The constructor stays private so consumers+-- can allocate only labels that exist in the source workflow.+data AwaitBinding = AwaitBinding StepName++allocateDeclaredAwait+  :: (Workflow :> es, Store :> es, IOE :> es, FromJSON a)+  => AwaitBinding+  -> Eff es (AwakeableId, Eff es a)+allocateDeclaredAwait (AwaitBinding label) = awakeableNamed label++reservationConfirmationAwait :: AwaitBinding+reservationConfirmationAwait = AwaitBinding (StepName "reservation-confirmation")  awaitLabels :: [Text] awaitLabels = ["reservation-confirmation"]

+ test/conformance-snapshot/Generated/HospitalCapacity/BehaviorSourceMap.hs view

@@ -0,0 +1,34 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity behavior source map; do not edit.+module Generated.HospitalCapacity.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-a544566ac00664fb" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation-snapshot.keiro" 20 22)+  "behavior-v1-bf9ebe70beb18440" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation-snapshot.keiro" 32 3)+  "behavior-v1-cf40a84edc844a41" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation-snapshot.keiro" 20 27)+  "behavior-v1-dff0853d3cd55550" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation-snapshot.keiro" 28 3)+  "behavior-v1-e53a65263ad89283" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation-snapshot.keiro" 20 27)+  "behavior-v1-e7378f31cfa93bbf" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation-snapshot.keiro" 20 10)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-snapshot/Generated/HospitalCapacity/Nominals.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal declarations; do not edit. module Generated.HospitalCapacity.Nominals   ( BedType (..)   , bedTypeText

test/conformance-snapshot/Generated/HospitalCapacity/Nominals/Internal.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal ID internals; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal ID internals; do not edit. module Generated.HospitalCapacity.Nominals.Internal   ( CommandId   , parseCommandId

test/conformance-snapshot/Generated/HospitalCapacity/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context hospital-capacity replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity replay-audit assembly; do not edit. -- -- Deployment contract: --   * replay-neutral diff: no data audit is required;

test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.Codec (     reservationCodec,     parseReservationEvent,

test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Domain.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.Domain where  import Data.Aeson (FromJSON, ToJSON)

test/conformance-snapshot/Generated/HospitalCapacity/Reservation/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.EventStream   ( reservationCategory   , reservationCommandCategory

test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Transducer.hs view

@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.Transducer   ( reservationTransducer   , reservationFoldFingerprint

test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/BehaviorContract.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ArtifactCatalog; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ArtifactCatalog; do not edit. module Generated.StructuralConformance.ArtifactCatalog.BehaviorContract   ( BehaviorKey (..)   , ObligationKind (..)@@ -21,6 +21,7 @@ import Generated.StructuralConformance.ArtifactCatalog.Codec (encodeArtifactCatalogEvent, parseArtifactCatalogEvent, artifactCatalogCodec) import Generated.StructuralConformance.ArtifactCatalog.Domain import Generated.StructuralConformance.ArtifactCatalog.Transducer (artifactCatalogTransducer)+import Generated.StructuralConformance.BehaviorSourceMap qualified as BehaviorSourceMap import Data.Aeson (ToJSON (..), object, (.=)) import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty)@@ -53,7 +54,6 @@   , requirementExpectedEdge :: !(Maybe (K.EdgeRef ArtifactCatalogVertex))   , requirementTarget :: !(Maybe ArtifactCatalogVertex)   , requirementEventKinds :: ![Text]-  , requirementLine :: !Int   }   deriving stock (Eq, Show) @@ -126,7 +126,7 @@  behaviorRequirements :: [BehaviorRequirement] behaviorRequirements =-  [ -- ArtifactCatalogEmpty x ObserveArtifact: live transition (spec line 80)+  [ -- ArtifactCatalogEmpty x ObserveArtifact: live transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-5ef17e70af0d6ff7"       , requirementKind = LiveTransition@@ -137,9 +137,8 @@       , requirementExpectedEdge = (Just (K.EdgeRef ArtifactCatalogEmpty 0))       , requirementTarget = Just ArtifactCatalogObserved       , requirementEventKinds = ["ArtifactRecorded", "ArtifactAccepted"]-      , requirementLine = 80       }-  , -- ArtifactCatalogObserved x ObserveArtifact: required rejection (spec line 74)+  , -- ArtifactCatalogObserved x ObserveArtifact: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-c20f0b92a1f17333"       , requirementKind = RequiredRejection@@ -150,7 +149,6 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 74       }   ] @@ -329,7 +327,7 @@   Left     ( BehaviorFailure         (requirementKey requirement)-        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (spec line " <> tshow (requirementLine requirement) <> ")")+        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey requirement)) <> ")")         code         detail     )

test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ArtifactCatalog; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ArtifactCatalog; do not edit. module Generated.StructuralConformance.ArtifactCatalog.Codec (     artifactCatalogCodec,     parseArtifactCatalogEvent,

test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Domain.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ArtifactCatalog; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ArtifactCatalog; do not edit. module Generated.StructuralConformance.ArtifactCatalog.Domain where  import Data.Proxy (Proxy (..))

test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ArtifactCatalog; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ArtifactCatalog; do not edit. module Generated.StructuralConformance.ArtifactCatalog.EventStream   ( artifactCatalogCategory   , artifactCatalogCommandCategory

test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Harness.hs view

@@ -1,30 +1,20 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ArtifactCatalog; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ArtifactCatalog; do not edit. module Generated.StructuralConformance.ArtifactCatalog.Harness (harnessAssertions) where  import Generated.StructuralConformance.ArtifactCatalog.Domain import Generated.StructuralConformance.ArtifactCatalog.Codec (encodeArtifactCatalogEvent, parseArtifactCatalogEvent, artifactCatalogCodec, encodeArtifactInfoMapped, decodeArtifactInfoMapped, encodeArtifactKindMapped, decodeArtifactKindMapped, encodeArtifactLocationMapped, decodeArtifactLocationMapped, encodeArtifactMetadataMapped, decodeArtifactMetadataMapped) import Generated.StructuralConformance.ArtifactCatalog.Transducer (artifactCatalogTransducer)-import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, fieldWitnessAgrees, (!))+import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!)) import Keiro.Codec (eventType) 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 Generated.StructuralConformance.StructuralProjections qualified as StructuralProjections+import Keiro.Codec.Structural (FixtureCases (..)) import Conformance.Structural.Bindings qualified as Bindings-import Conformance.Structural.Domain (ArtifactInfo, ArtifactKind, ArtifactLocation, ArtifactMetadata)-import Generated.StructuralConformance.Structural.Shape.ArtifactInfo qualified as ShapeArtifactInfo-import Generated.StructuralConformance.Structural.Shape.ArtifactKind qualified as ShapeArtifactKind-import Generated.StructuralConformance.Structural.Shape.ArtifactLocation qualified as ShapeArtifactLocation-import Generated.StructuralConformance.Structural.Shape.ArtifactMetadata qualified as ShapeArtifactMetadata  -- | (label, passed). A driver runs these and exits non-zero on any False, -- naming the failing assertion. Filling a hole wrongly turns a specific@@ -79,108 +69,11 @@ mappedConformanceAssertions :: [(String, Bool)] mappedConformanceAssertions =   concat-    [ artifactInfoBindingAssertions-    , artifactKindBindingAssertions-    , artifactLocationBindingAssertions-    , artifactMetadataBindingAssertions-    , vendorGeometryOpaqueAssertions-    , [("fixture coverage: conformance.structural.ArtifactInfo.v1", coverageArtifactInfo)]-    , [("fixture coverage: conformance.structural.ArtifactKind.v1", coverageArtifactKind)]-    , [("fixture coverage: conformance.structural.ArtifactLocation.v1", coverageArtifactLocation)]-    , [("fixture coverage: conformance.structural.ArtifactMetadata.v1", coverageArtifactMetadata)]-    , artifactRecordedArtifactAssertions+    [ artifactRecordedArtifactAssertions     , artifactRecordedGeometryAssertions     , structuralWirePolicyAssertions-    , structuralProjectionAssertions     ] -validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool-validFixtureLabels cases =-  all (not . T.null) labels && length labels == length (nub labels)-  where-    labels = map fst (NonEmpty.toList cases)--artifactInfoBindingAssertions :: [(String, Bool)]-artifactInfoBindingAssertions =-  ("fixture labels: conformance.structural.ArtifactInfo.v1", validFixtureLabels cases) :-  ("canonical identity: conformance.structural.ArtifactInfo.v1", canonicalTypeName (Proxy @ArtifactInfo) == "conformance.structural.ArtifactInfo.v1") :-  concat-    [ [ ("binding domain round-trip: conformance.structural.ArtifactInfo.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.artifactInfoBinding value)-      , ("binding shape round-trip: conformance.structural.ArtifactInfo.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.artifactInfoBinding (bindingToShape Bindings.artifactInfoBinding value))-      ]-    | (label, value) <- NonEmpty.toList cases-    ]-  where-    cases = fixtureCases Bindings.artifactInfoCases--artifactKindBindingAssertions :: [(String, Bool)]-artifactKindBindingAssertions =-  ("fixture labels: conformance.structural.ArtifactKind.v1", validFixtureLabels cases) :-  ("canonical identity: conformance.structural.ArtifactKind.v1", canonicalTypeName (Proxy @ArtifactKind) == "conformance.structural.ArtifactKind.v1") :-  concat-    [ [ ("binding domain round-trip: conformance.structural.ArtifactKind.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.artifactKindBinding value)-      , ("binding shape round-trip: conformance.structural.ArtifactKind.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.artifactKindBinding (bindingToShape Bindings.artifactKindBinding value))-      ]-    | (label, value) <- NonEmpty.toList cases-    ]-  where-    cases = fixtureCases Bindings.artifactKindCases--artifactLocationBindingAssertions :: [(String, Bool)]-artifactLocationBindingAssertions =-  ("fixture labels: conformance.structural.ArtifactLocation.v1", validFixtureLabels cases) :-  ("canonical identity: conformance.structural.ArtifactLocation.v1", canonicalTypeName (Proxy @ArtifactLocation) == "conformance.structural.ArtifactLocation.v1") :-  concat-    [ [ ("binding domain round-trip: conformance.structural.ArtifactLocation.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.artifactLocationBinding value)-      , ("binding shape round-trip: conformance.structural.ArtifactLocation.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.artifactLocationBinding (bindingToShape Bindings.artifactLocationBinding value))-      ]-    | (label, value) <- NonEmpty.toList cases-    ]-  where-    cases = fixtureCases Bindings.artifactLocationCases--artifactMetadataBindingAssertions :: [(String, Bool)]-artifactMetadataBindingAssertions =-  ("fixture labels: conformance.structural.ArtifactMetadata.v1", validFixtureLabels cases) :-  ("canonical identity: conformance.structural.ArtifactMetadata.v1", canonicalTypeName (Proxy @ArtifactMetadata) == "conformance.structural.ArtifactMetadata.v1") :-  concat-    [ [ ("binding domain round-trip: conformance.structural.ArtifactMetadata.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.artifactMetadataBinding value)-      , ("binding shape round-trip: conformance.structural.ArtifactMetadata.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.artifactMetadataBinding (bindingToShape Bindings.artifactMetadataBinding value))-      ]-    | (label, value) <- NonEmpty.toList cases-    ]-  where-    cases = fixtureCases Bindings.artifactMetadataCases--vendorGeometryOpaqueAssertions :: [(String, Bool)]-vendorGeometryOpaqueAssertions =-  ("opaque boundary fixtures: vendor.geometry.json@3", validFixtureLabels cases) :-  [ ("opaque codec round-trip: vendor.geometry.json@3/" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False)-  | (caseLabel, value) <- NonEmpty.toList cases-  ]-  where-    cases = fixtureCases Bindings.geometryCases--coverageArtifactInfo :: Bool-coverageArtifactInfo = any (isNothing . ShapeArtifactInfo.artifactHash) shapes && any (isJust . ShapeArtifactInfo.artifactHash) shapes-  where-    shapes = map (bindingToShape Bindings.artifactInfoBinding . snd) (NonEmpty.toList (fixtureCases Bindings.artifactInfoCases))--coverageArtifactKind :: Bool-coverageArtifactKind = any (\case ShapeArtifactKind.Guide -> True; _ -> False) shapes && any (\case ShapeArtifactKind.Reference -> True; _ -> False) shapes-  where-    shapes = map (bindingToShape Bindings.artifactKindBinding . snd) (NonEmpty.toList (fixtureCases Bindings.artifactKindCases))--coverageArtifactLocation :: Bool-coverageArtifactLocation = any (\case ShapeArtifactLocation.LocalFile{} -> True; _ -> False) shapes && any (\case ShapeArtifactLocation.LocalDir{} -> True; _ -> False) shapes && any (\case ShapeArtifactLocation.RepoPath{} -> True; _ -> False) shapes && any (\case ShapeArtifactLocation.LocUrl{} -> True; _ -> False) shapes && any (\case ShapeArtifactLocation.Canonical -> True; _ -> False) shapes-  where-    shapes = map (bindingToShape Bindings.artifactLocationBinding . snd) (NonEmpty.toList (fixtureCases Bindings.artifactLocationCases))--coverageArtifactMetadata :: Bool-coverageArtifactMetadata = any (isNothing . ShapeArtifactMetadata.note) shapes && any (isJust . ShapeArtifactMetadata.note) shapes-  where-    shapes = map (bindingToShape Bindings.artifactMetadataBinding . snd) (NonEmpty.toList (fixtureCases Bindings.artifactMetadataCases))- artifactRecordedArtifactAssertions :: [(String, Bool)] artifactRecordedArtifactAssertions =   [ ("mapped codec round-trip: ArtifactRecorded/artifact/" <> T.unpack label, roundTrips (ArtifactRecorded (ArtifactRecordedData mappedValue (snd (NonEmpty.head (fixtureCases Bindings.geometryCases))) False)))@@ -214,12 +107,6 @@   , ("wire union arm: conformance.structural.ArtifactLocation.v1/canonical", any (\(_, value) -> objectField "tag" (encodeArtifactLocationMapped value) == Just (Aeson.String "canonical") && decodeArtifactLocationMapped (encodeArtifactLocationMapped value) == Right value) (NonEmpty.toList (fixtureCases Bindings.artifactLocationCases)))   , ("wire policy unknown fields: conformance.structural.ArtifactLocation.v1", all (\(_, value) -> isLeft (decodeArtifactLocationMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeArtifactLocationMapped value)))) (NonEmpty.toList (fixtureCases Bindings.artifactLocationCases)))   , ("wire policy unknown fields: conformance.structural.ArtifactMetadata.v1", all (\(_, value) -> isRight (decodeArtifactMetadataMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeArtifactMetadataMapped value)))) (NonEmpty.toList (fixtureCases Bindings.artifactMetadataCases)))-  ]--structuralProjectionAssertions :: [(String, Bool)]-structuralProjectionAssertions =-  [ ("projection witness agreement: conformance.structural.ArtifactInfo.v1/artifact_key", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.artifactInfoArtifactKeyWitness (\referenceOwner -> ShapeArtifactInfo.artifactKey (bindingToShape Bindings.artifactInfoBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.artifactInfoCases)))-  , ("projection witness agreement: conformance.structural.ArtifactInfo.v1/display_name", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.artifactInfoDisplayNameWitness (\referenceOwner -> ShapeArtifactInfo.displayName (bindingToShape Bindings.artifactInfoBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.artifactInfoCases)))   ]  deleteObjectField :: T.Text -> Aeson.Value -> Aeson.Value

test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ArtifactCatalog; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ArtifactCatalog; do not edit. module Generated.StructuralConformance.ArtifactCatalog.Projection () where  -- No projection declarations are present; this module keeps the generated manifest inventory total.

test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Transducer.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ArtifactCatalog; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ArtifactCatalog; do not edit. module Generated.StructuralConformance.ArtifactCatalog.Transducer   ( artifactCatalogTransducer   , artifactCatalogFoldFingerprint

+ test/conformance-structural/Generated/StructuralConformance/BehaviorSourceMap.hs view

@@ -0,0 +1,30 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context structural-conformance behavior source map; do not edit.+module Generated.StructuralConformance.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-5ef17e70af0d6ff7" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/structural-conformance.keiro" 80 3)+  "behavior-v1-c20f0b92a1f17333" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/structural-conformance.keiro" 74 16)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-structural/Generated/StructuralConformance/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context structural-conformance replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context structural-conformance replay-audit assembly; do not edit. -- -- Deployment contract: --   * replay-neutral diff: no data audit is required;

test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactInfo.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from mapped structural ArtifactInfo; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from mapped structural ArtifactInfo; do not edit. module Generated.StructuralConformance.Structural.Shape.ArtifactInfo (ArtifactInfoShape (..)) where  import Data.Text (Text)

test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactKind.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from mapped structural ArtifactKind; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from mapped structural ArtifactKind; do not edit. module Generated.StructuralConformance.Structural.Shape.ArtifactKind (ArtifactKindShape (..)) where  import GHC.Generics (Generic)

test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactLocation.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from mapped structural ArtifactLocation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from mapped structural ArtifactLocation; do not edit. module Generated.StructuralConformance.Structural.Shape.ArtifactLocation (ArtifactLocationShape (..)) where  import Data.Text (Text)

test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactMetadata.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from mapped structural ArtifactMetadata; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from mapped structural ArtifactMetadata; do not edit. module Generated.StructuralConformance.Structural.Shape.ArtifactMetadata (ArtifactMetadataShape (..)) where  import Data.Text (Text)

+ test/conformance-structural/Generated/StructuralConformance/StructuralConformance.hs view

@@ -0,0 +1,129 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context structural-conformance structural conformance; do not edit.+module Generated.StructuralConformance.StructuralConformance+  ( structuralConformanceAssertions+  ) where++import Data.Aeson qualified as Aeson+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.Core (fieldWitnessAgrees)+import Keiki.Shape (CanonicalTypeName (..))+import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape)+import Generated.StructuralConformance.StructuralProjections qualified as StructuralProjections+import Conformance.Structural.Bindings qualified as Bindings+import Conformance.Structural.Domain (ArtifactInfo, ArtifactKind, ArtifactLocation, ArtifactMetadata)+import Generated.StructuralConformance.Structural.Shape.ArtifactInfo qualified as ShapeArtifactInfo+import Generated.StructuralConformance.Structural.Shape.ArtifactKind qualified as ShapeArtifactKind+import Generated.StructuralConformance.Structural.Shape.ArtifactLocation qualified as ShapeArtifactLocation+import Generated.StructuralConformance.Structural.Shape.ArtifactMetadata qualified as ShapeArtifactMetadata++structuralConformanceAssertions :: [(String, Bool)]+structuralConformanceAssertions =+  concat+    [ artifactInfoBindingAssertions+    , artifactKindBindingAssertions+    , artifactLocationBindingAssertions+    , artifactMetadataBindingAssertions+    , vendorGeometryOpaqueAssertions+    , [("fixture coverage: conformance.structural.ArtifactInfo.v1", coverageArtifactInfo)]+    , [("fixture coverage: conformance.structural.ArtifactKind.v1", coverageArtifactKind)]+    , [("fixture coverage: conformance.structural.ArtifactLocation.v1", coverageArtifactLocation)]+    , [("fixture coverage: conformance.structural.ArtifactMetadata.v1", coverageArtifactMetadata)]+    , structuralProjectionAssertions+    ]++validFixtureLabels :: NonEmpty.NonEmpty (T.Text, value) -> Bool+validFixtureLabels cases =+  all (not . T.null) labels && length labels == length (nub labels)+  where+    labels = map fst (NonEmpty.toList cases)++artifactInfoBindingAssertions :: [(String, Bool)]+artifactInfoBindingAssertions =+  ("fixture labels: conformance.structural.ArtifactInfo.v1", validFixtureLabels cases) :+  ("canonical identity: conformance.structural.ArtifactInfo.v1", canonicalTypeName (Proxy @ArtifactInfo) == "conformance.structural.ArtifactInfo.v1") :+  concat+    [ [ ("binding domain round-trip: conformance.structural.ArtifactInfo.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.artifactInfoBinding value)+      , ("binding shape round-trip: conformance.structural.ArtifactInfo.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.artifactInfoBinding (bindingToShape Bindings.artifactInfoBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.artifactInfoCases++artifactKindBindingAssertions :: [(String, Bool)]+artifactKindBindingAssertions =+  ("fixture labels: conformance.structural.ArtifactKind.v1", validFixtureLabels cases) :+  ("canonical identity: conformance.structural.ArtifactKind.v1", canonicalTypeName (Proxy @ArtifactKind) == "conformance.structural.ArtifactKind.v1") :+  concat+    [ [ ("binding domain round-trip: conformance.structural.ArtifactKind.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.artifactKindBinding value)+      , ("binding shape round-trip: conformance.structural.ArtifactKind.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.artifactKindBinding (bindingToShape Bindings.artifactKindBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.artifactKindCases++artifactLocationBindingAssertions :: [(String, Bool)]+artifactLocationBindingAssertions =+  ("fixture labels: conformance.structural.ArtifactLocation.v1", validFixtureLabels cases) :+  ("canonical identity: conformance.structural.ArtifactLocation.v1", canonicalTypeName (Proxy @ArtifactLocation) == "conformance.structural.ArtifactLocation.v1") :+  concat+    [ [ ("binding domain round-trip: conformance.structural.ArtifactLocation.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.artifactLocationBinding value)+      , ("binding shape round-trip: conformance.structural.ArtifactLocation.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.artifactLocationBinding (bindingToShape Bindings.artifactLocationBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.artifactLocationCases++artifactMetadataBindingAssertions :: [(String, Bool)]+artifactMetadataBindingAssertions =+  ("fixture labels: conformance.structural.ArtifactMetadata.v1", validFixtureLabels cases) :+  ("canonical identity: conformance.structural.ArtifactMetadata.v1", canonicalTypeName (Proxy @ArtifactMetadata) == "conformance.structural.ArtifactMetadata.v1") :+  concat+    [ [ ("binding domain round-trip: conformance.structural.ArtifactMetadata.v1/" <> T.unpack label, bindingDomainRoundTrip Bindings.artifactMetadataBinding value)+      , ("binding shape round-trip: conformance.structural.ArtifactMetadata.v1/" <> T.unpack label, bindingShapeRoundTrip Bindings.artifactMetadataBinding (bindingToShape Bindings.artifactMetadataBinding value))+      ]+    | (label, value) <- NonEmpty.toList cases+    ]+  where+    cases = fixtureCases Bindings.artifactMetadataCases++vendorGeometryOpaqueAssertions :: [(String, Bool)]+vendorGeometryOpaqueAssertions =+  ("opaque boundary fixtures: vendor.geometry.json@3", validFixtureLabels cases) :+  [ ("opaque codec round-trip: vendor.geometry.json@3/" <> T.unpack caseLabel, case Aeson.fromJSON (Aeson.toJSON value) of Aeson.Success decoded -> decoded == value; Aeson.Error _ -> False)+  | (caseLabel, value) <- NonEmpty.toList cases+  ]+  where+    cases = fixtureCases Bindings.geometryCases++coverageArtifactInfo :: Bool+coverageArtifactInfo = any (isNothing . ShapeArtifactInfo.artifactHash) shapes && any (isJust . ShapeArtifactInfo.artifactHash) shapes+  where+    shapes = map (bindingToShape Bindings.artifactInfoBinding . snd) (NonEmpty.toList (fixtureCases Bindings.artifactInfoCases))++coverageArtifactKind :: Bool+coverageArtifactKind = any (\case ShapeArtifactKind.Guide -> True; _ -> False) shapes && any (\case ShapeArtifactKind.Reference -> True; _ -> False) shapes+  where+    shapes = map (bindingToShape Bindings.artifactKindBinding . snd) (NonEmpty.toList (fixtureCases Bindings.artifactKindCases))++coverageArtifactLocation :: Bool+coverageArtifactLocation = any (\case ShapeArtifactLocation.LocalFile{} -> True; _ -> False) shapes && any (\case ShapeArtifactLocation.LocalDir{} -> True; _ -> False) shapes && any (\case ShapeArtifactLocation.RepoPath{} -> True; _ -> False) shapes && any (\case ShapeArtifactLocation.LocUrl{} -> True; _ -> False) shapes && any (\case ShapeArtifactLocation.Canonical -> True; _ -> False) shapes+  where+    shapes = map (bindingToShape Bindings.artifactLocationBinding . snd) (NonEmpty.toList (fixtureCases Bindings.artifactLocationCases))++coverageArtifactMetadata :: Bool+coverageArtifactMetadata = any (isNothing . ShapeArtifactMetadata.note) shapes && any (isJust . ShapeArtifactMetadata.note) shapes+  where+    shapes = map (bindingToShape Bindings.artifactMetadataBinding . snd) (NonEmpty.toList (fixtureCases Bindings.artifactMetadataCases))++structuralProjectionAssertions :: [(String, Bool)]+structuralProjectionAssertions =+  [ ("projection witness agreement: conformance.structural.ArtifactInfo.v1/artifact_key", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.artifactInfoArtifactKeyWitness (\referenceOwner -> ShapeArtifactInfo.artifactKey (bindingToShape Bindings.artifactInfoBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.artifactInfoCases)))+  , ("projection witness agreement: conformance.structural.ArtifactInfo.v1/display_name", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.artifactInfoDisplayNameWitness (\referenceOwner -> ShapeArtifactInfo.displayName (bindingToShape Bindings.artifactInfoBinding referenceOwner)) owner) (NonEmpty.toList (fixtureCases Bindings.artifactInfoCases)))+  ]

test/conformance-structural/Generated/StructuralConformance/StructuralProjections.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context structural-conformance mapped structural facade; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context structural-conformance mapped structural facade; do not edit. -- Equality witnesses are emitted for Text, Int, Bool, Natural, and UTCTime. -- Int, Natural, and UTCTime belong to Keiki's ordered subset. module Generated.StructuralConformance.StructuralProjections

test/conformance-structural/Main.hs view

@@ -15,6 +15,7 @@ import Generated.StructuralConformance.ArtifactCatalog.Codec (decodeArtifactInfoMapped, decodeArtifactKindMapped, decodeArtifactLocationMapped, encodeArtifactCatalogEvent, encodeArtifactInfoMapped) import Generated.StructuralConformance.ArtifactCatalog.Domain (ArtifactCatalogCommand, ArtifactCatalogEvent (..), ArtifactCatalogRegs, ArtifactRecordedData (..), inCtorObserveArtifact) import Generated.StructuralConformance.ArtifactCatalog.Harness (harnessAssertions)+import Generated.StructuralConformance.StructuralConformance (structuralConformanceAssertions) import Generated.StructuralConformance.StructuralProjections qualified as StructuralProjections import Keiki.Core (HsPred, inpProj, (./=)) import Keiki.Symbolic (symIsBot)@@ -24,7 +25,12 @@ main :: IO () main = do     goldenAssertions <- loadGoldenAssertions-    let assertions = harnessAssertions <> projectionAssertions <> decodeDiagnosticAssertions <> goldenAssertions+    let assertions =+            [("structural/" <> label, passed) | (label, passed) <- structuralConformanceAssertions]+                <> harnessAssertions+                <> projectionAssertions+                <> decodeDiagnosticAssertions+                <> goldenAssertions     forM_ assertions $ \(label, ok) ->         putStrLn ((if ok then "PASS  " else "FAIL  ") <> label)     let failed = [label | (label, ok) <- assertions, not ok]

+ test/conformance-v2/Generated/HospitalCapacity/BehaviorSourceMap.hs view

@@ -0,0 +1,34 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity behavior source map; do not edit.+module Generated.HospitalCapacity.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-25971c9701fc5660" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation-v2.keiro" 29 3)+  "behavior-v1-a544566ac00664fb" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation-v2.keiro" 20 22)+  "behavior-v1-bf9ebe70beb18440" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation-v2.keiro" 33 3)+  "behavior-v1-cf40a84edc844a41" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation-v2.keiro" 20 27)+  "behavior-v1-e53a65263ad89283" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation-v2.keiro" 20 27)+  "behavior-v1-e7378f31cfa93bbf" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation-v2.keiro" 20 10)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-v2/Generated/HospitalCapacity/Nominals.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal declarations; do not edit. module Generated.HospitalCapacity.Nominals   ( BedType (..)   , bedTypeText

test/conformance-v2/Generated/HospitalCapacity/Nominals/Internal.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal ID internals; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal ID internals; do not edit. module Generated.HospitalCapacity.Nominals.Internal   ( CommandId   , parseCommandId

test/conformance-v2/Generated/HospitalCapacity/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context hospital-capacity replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity replay-audit assembly; do not edit. -- -- Deployment contract: --   * replay-neutral diff: no data audit is required;

test/conformance-v2/Generated/HospitalCapacity/Reservation/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.Codec (     reservationCodec,     parseReservationEvent,

test/conformance-v2/Generated/HospitalCapacity/Reservation/Domain.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.Domain where  import Data.Proxy (Proxy (..))

test/conformance-v2/Generated/HospitalCapacity/Reservation/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.EventStream   ( reservationCategory   , reservationCommandCategory

test/conformance-v2/Generated/HospitalCapacity/Reservation/Harness.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.Harness (harnessAssertions) where  import Generated.HospitalCapacity.Reservation.Domain

test/conformance-v2/Generated/HospitalCapacity/Reservation/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.Projection   ( transferDecisionsProjection   , transferDecisionsStatusFor

test/conformance-v2/Generated/HospitalCapacity/Reservation/Transducer.hs view

@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.Transducer   ( reservationTransducer   , reservationFoldFingerprint

test/conformance-workflow-full/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs view

@@ -1,27 +1,40 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from workflow HospitalTransferReservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from workflow HospitalTransferReservation; do not edit. module Generated.HospitalCapacity.HospitalTransferReservation.WorkflowRuntime   ( workflowName-  , awaitAwakeableId+  , AwaitBinding+  , allocateDeclaredAwait+  , reservationConfirmationAwait   , awaitLabels   , declaredPatches   , declaredPatchStepNames   , withDeclaredPatches   ) where +import Data.Aeson (FromJSON) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text)-import Keiro.Workflow (WorkflowRunOptions (..))-import Keiro.Workflow.Awakeable (AwakeableId, deterministicAwakeableId)-import Keiro.Workflow.Types (PatchId (..), WorkflowId, WorkflowName (..), patchStepName)+import Effectful (Eff, IOE, (:>))+import Keiro.Workflow (StepName (..), Workflow, WorkflowRunOptions (..))+import Keiro.Workflow.Awakeable (AwakeableId, awakeableNamed)+import Keiro.Workflow.Types (PatchId (..), WorkflowName (..), patchStepName)+import Kiroku.Store.Effect (Store)  workflowName :: WorkflowName workflowName = WorkflowName "hospital-transfer-reservation" --- The awakeable id an await allocates — the real deterministicAwakeableId.--- A signal op deriving the same (name, id, label) gets the same id.-awaitAwakeableId :: WorkflowId -> Text -> AwakeableId-awaitAwakeableId wid label = deterministicAwakeableId workflowName wid label+-- | A declared await label. The constructor stays private so consumers+-- can allocate only labels that exist in the source workflow.+data AwaitBinding = AwaitBinding StepName++allocateDeclaredAwait+  :: (Workflow :> es, Store :> es, IOE :> es, FromJSON a)+  => AwaitBinding+  -> Eff es (AwakeableId, Eff es a)+allocateDeclaredAwait (AwaitBinding label) = awakeableNamed label++reservationConfirmationAwait :: AwaitBinding+reservationConfirmationAwait = AwaitBinding (StepName "reservation-confirmation")  awaitLabels :: [Text] awaitLabels = ["reservation-confirmation"]

test/conformance-workflow-runtime/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs view

@@ -1,27 +1,40 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from workflow HospitalTransferReservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from workflow HospitalTransferReservation; do not edit. module Generated.HospitalCapacity.HospitalTransferReservation.WorkflowRuntime   ( workflowName-  , awaitAwakeableId+  , AwaitBinding+  , allocateDeclaredAwait+  , reservationConfirmationAwait   , awaitLabels   , declaredPatches   , declaredPatchStepNames   , withDeclaredPatches   ) where +import Data.Aeson (FromJSON) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text)-import Keiro.Workflow (WorkflowRunOptions (..))-import Keiro.Workflow.Awakeable (AwakeableId, deterministicAwakeableId)-import Keiro.Workflow.Types (PatchId (..), WorkflowId, WorkflowName (..), patchStepName)+import Effectful (Eff, IOE, (:>))+import Keiro.Workflow (StepName (..), Workflow, WorkflowRunOptions (..))+import Keiro.Workflow.Awakeable (AwakeableId, awakeableNamed)+import Keiro.Workflow.Types (PatchId (..), WorkflowName (..), patchStepName)+import Kiroku.Store.Effect (Store)  workflowName :: WorkflowName workflowName = WorkflowName "hospital-transfer-reservation" --- The awakeable id an await allocates — the real deterministicAwakeableId.--- A signal op deriving the same (name, id, label) gets the same id.-awaitAwakeableId :: WorkflowId -> Text -> AwakeableId-awaitAwakeableId wid label = deterministicAwakeableId workflowName wid label+-- | A declared await label. The constructor stays private so consumers+-- can allocate only labels that exist in the source workflow.+data AwaitBinding = AwaitBinding StepName++allocateDeclaredAwait+  :: (Workflow :> es, Store :> es, IOE :> es, FromJSON a)+  => AwaitBinding+  -> Eff es (AwakeableId, Eff es a)+allocateDeclaredAwait (AwaitBinding label) = awakeableNamed label++reservationConfirmationAwait :: AwaitBinding+reservationConfirmationAwait = AwaitBinding (StepName "reservation-confirmation")  awaitLabels :: [Text] awaitLabels = ["reservation-confirmation"]

test/conformance-workflow-runtime/Main.hs view

@@ -1,42 +1,74 @@--{- | EP-6 workflow runtime conformance: the scaffolded @WorkflowRuntime@ — the-WorkflowName and the awakeable-id derivation — compiled against the LIVE-@Keiro.Workflow@. The headline check: the id an `await` allocates equals the-id the partner `signal` operation derives from the same (name, id, label),-computed by the REAL deterministicAwakeableId. A label mismatch diverges.--}+-- | Live conformance for generated declared-await bindings. The first workflow+-- run publishes the id returned by the generated allocation wrapper and+-- suspends. Signalling that exact id must transition the PostgreSQL row, and a+-- second run must complete with the delivered payload. module Main (main) where -import Control.Monad (unless)-import Generated.HospitalCapacity.HospitalTransferReservation.WorkflowRuntime (-    awaitAwakeableId,+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Text (Text)+import Effectful (Eff, IOE, liftIO, (:>))+import Generated.HospitalCapacity.HospitalTransferReservation.WorkflowRuntime+  ( allocateDeclaredAwait,     awaitLabels,     declaredPatchStepNames,     declaredPatches,+    reservationConfirmationAwait,     withDeclaredPatches,     workflowName,- )-import Keiro.Workflow (WorkflowRunOptions (activePatches), defaultWorkflowRunOptions)-import Keiro.Workflow.Awakeable (deterministicAwakeableId)+  )+import Keiro.Test.Postgres (StoreRunner (..), withFreshResourceStore, withMigratedSuite)+import Keiro.Workflow+  ( Workflow,+    WorkflowOutcome (..),+    WorkflowRunOptions (activePatches),+    defaultWorkflowRunOptions,+    runWorkflow,+  )+import Keiro.Workflow.Awakeable (AwakeableId, signalAwakeable) import Keiro.Workflow.Types (WorkflowId (..))-import System.Exit (exitFailure)+import Kiroku.Store.Effect (Store)  main :: IO ()-main = do-    let wid = WorkflowId "rsv-1"-        label = "reservation-confirmation"-        -- the signal operation derives the id the SAME way (same name, id, label).-        signalSide = deterministicAwakeableId workflowName wid label-        awaitSide = awaitAwakeableId wid label-        matchOk = awaitSide == signalSide-        -- a non-matching label must NOT collide.-        mismatchOk = awaitAwakeableId wid "reservation-confirmed" /= awaitSide-        labelsOk = label `elem` awaitLabels-        patchKeysOk = declaredPatchStepNames == ["patch:fraud-check-v2"]-        activePatchesOk = activePatches (withDeclaredPatches defaultWorkflowRunOptions) == declaredPatches-    putStrLn ("await<->signal awakeable id match (real deterministicAwakeableId): " <> show matchOk)-    putStrLn ("mismatched label diverges: " <> show mismatchOk)-    putStrLn ("await label declared: " <> show labelsOk)-    putStrLn ("declared patch journal key uses live patchStepName: " <> show patchKeysOk)-    putStrLn ("run options activate exactly declared patches: " <> show activePatchesOk)-    unless (matchOk && mismatchOk && labelsOk && patchKeysOk && activePatchesOk) exitFailure+main =+  withMigratedSuite $ \fixture ->+    withFreshResourceStore fixture $ \(_storeHandle, StoreRunner runStore) -> do+      allocatedId <- newIORef Nothing+      let workflowId = WorkflowId "opaque-await-1"++      first <- expectRight =<< runStore (runWorkflow workflowName workflowId (reservationWorkflow allocatedId))+      assert "generated await allocated an opaque id" (first == Suspended)++      awakeableId <- readRequiredId allocatedId+      signalled <- expectRight =<< runStore (signalAwakeable awakeableId ("confirmed" :: Text))+      assert "signal of allocated id transitioned the row" signalled++      second <- expectRight =<< runStore (runWorkflow workflowName workflowId (reservationWorkflow allocatedId))+      assert "workflow resumed with the payload" (second == Completed "confirmed")++      let labelsOk = "reservation-confirmation" `elem` awaitLabels+          patchKeysOk = declaredPatchStepNames == ["patch:fraud-check-v2"]+          activePatchesOk = activePatches (withDeclaredPatches defaultWorkflowRunOptions) == declaredPatches+      assert "workflow runtime conformance" (labelsOk && patchKeysOk && activePatchesOk)++reservationWorkflow ::+  (Workflow :> es, Store :> es, IOE :> es) =>+  IORef (Maybe AwakeableId) ->+  Eff es Text+reservationWorkflow allocatedId = do+  (awakeableId, awaitConfirmation) <- allocateDeclaredAwait reservationConfirmationAwait+  liftIO (writeIORef allocatedId (Just awakeableId))+  awaitConfirmation++readRequiredId :: IORef (Maybe AwakeableId) -> IO AwakeableId+readRequiredId ref =+  readIORef ref >>= \case+    Just awakeableId -> pure awakeableId+    Nothing -> error "workflow suspended before publishing the generated allocation id"++expectRight :: (Show problem) => Either problem value -> IO value+expectRight = either (error . show) pure++assert :: String -> Bool -> IO ()+assert label condition+  | condition = putStrLn (label <> ": PASS")+  | otherwise = error ("workflow runtime conformance failed: " <> label)

test/conformance-workflow/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowFacts.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from workflow HospitalTransferReservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 5) from workflow HospitalTransferReservation; do not edit. module Generated.HospitalCapacity.HospitalTransferReservation.WorkflowFacts (WorkflowFacts (..), workflowFacts, workflowFactValues) where  -- | The workflow's deterministic decisions, pinned as typed pure facts.

+ test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/BehaviorSourceMap.hs view

@@ -0,0 +1,36 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context workspace-nominal-proof behavior source map; do not edit.+module Generated.WorkspaceNominalProof.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-11da0fd14ad66aa0" -> Just (BehaviorSourceLocation "domain/project-artifact.keiro" 8 16)+  "behavior-v1-3de05f6aced1fbd8" -> Just (BehaviorSourceLocation "domain/project.keiro" 8 21)+  "behavior-v1-3ef04b25c79aa821" -> Just (BehaviorSourceLocation "domain/project.keiro" 15 3)+  "behavior-v1-44c09c629d21fd17" -> Just (BehaviorSourceLocation "domain/project.keiro" 8 21)+  "behavior-v1-6134478c9aaa78cb" -> Just (BehaviorSourceLocation "domain/project.keiro" 8 16)+  "behavior-v1-c4b406a5be4a0d0b" -> Just (BehaviorSourceLocation "domain/project.keiro" 8 10)+  "behavior-v1-c6d79387e567590e" -> Just (BehaviorSourceLocation "domain/project-artifact.keiro" 13 3)+  "behavior-v1-ea703ecdfbda1e70" -> Just (BehaviorSourceLocation "domain/project.keiro" 22 3)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Nominals.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context workspace-nominal-proof generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context workspace-nominal-proof generated nominal declarations; do not edit. module Generated.WorkspaceNominalProof.Nominals   ( ProjectId   , parseProjectId

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Nominals/Internal.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context workspace-nominal-proof generated nominal ID internals; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context workspace-nominal-proof generated nominal ID internals; do not edit. module Generated.WorkspaceNominalProof.Nominals.Internal   ( ProjectId   , parseProjectId

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/BehaviorContract.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Project; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Project; do not edit. module Generated.WorkspaceNominalProof.Project.BehaviorContract   ( BehaviorKey (..)   , ObligationKind (..)@@ -21,6 +21,7 @@ import Generated.WorkspaceNominalProof.Project.Codec (encodeProjectEvent, parseProjectEvent, projectCodec) import Generated.WorkspaceNominalProof.Project.Domain import Generated.WorkspaceNominalProof.Project.Transducer (projectTransducer)+import Generated.WorkspaceNominalProof.BehaviorSourceMap qualified as BehaviorSourceMap import Data.Aeson (ToJSON (..), object, (.=)) import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty)@@ -53,7 +54,6 @@   , requirementExpectedEdge :: !(Maybe (K.EdgeRef ProjectVertex))   , requirementTarget :: !(Maybe ProjectVertex)   , requirementEventKinds :: ![Text]-  , requirementLine :: !Int   }   deriving stock (Eq, Show) @@ -126,7 +126,7 @@  behaviorRequirements :: [BehaviorRequirement] behaviorRequirements =-  [ -- ProjectArchived x ArchiveProject: required rejection (spec line 28)+  [ -- ProjectArchived x ArchiveProject: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-3de05f6aced1fbd8"       , requirementKind = RequiredRejection@@ -137,9 +137,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 28       }-  , -- ProjectEmpty x RegisterProject: live transition (spec line 35)+  , -- ProjectEmpty x RegisterProject: live transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-3ef04b25c79aa821"       , requirementKind = LiveTransition@@ -150,9 +149,8 @@       , requirementExpectedEdge = (Just (K.EdgeRef ProjectEmpty 0))       , requirementTarget = Just ProjectLive       , requirementEventKinds = ["ProjectRegistered"]-      , requirementLine = 35       }-  , -- ProjectArchived x RegisterProject: required rejection (spec line 28)+  , -- ProjectArchived x RegisterProject: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-44c09c629d21fd17"       , requirementKind = RequiredRejection@@ -163,9 +161,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 28       }-  , -- ProjectLive x RegisterProject: required rejection (spec line 28)+  , -- ProjectLive x RegisterProject: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-6134478c9aaa78cb"       , requirementKind = RequiredRejection@@ -176,9 +173,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 28       }-  , -- ProjectEmpty x ArchiveProject: required rejection (spec line 28)+  , -- ProjectEmpty x ArchiveProject: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-c4b406a5be4a0d0b"       , requirementKind = RequiredRejection@@ -189,9 +185,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 28       }-  , -- ProjectLive x ArchiveProject: live transition (spec line 42)+  , -- ProjectLive x ArchiveProject: live transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-ea703ecdfbda1e70"       , requirementKind = LiveTransition@@ -202,7 +197,6 @@       , requirementExpectedEdge = (Just (K.EdgeRef ProjectLive 0))       , requirementTarget = Just ProjectArchived       , requirementEventKinds = ["ArchivalRecorded"]-      , requirementLine = 42       }   ] @@ -382,7 +376,7 @@   Left     ( BehaviorFailure         (requirementKey requirement)-        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (spec line " <> tshow (requirementLine requirement) <> ")")+        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey requirement)) <> ")")         code         detail     )

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Project; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Project; do not edit. module Generated.WorkspaceNominalProof.Project.Codec (     projectCodec,     parseProjectEvent,

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Domain.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Project; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Project; do not edit. module Generated.WorkspaceNominalProof.Project.Domain where  import Data.Proxy (Proxy (..))

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Project; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Project; do not edit. module Generated.WorkspaceNominalProof.Project.EventStream   ( projectCategory   , projectCommandCategory

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Harness.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Project; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Project; do not edit. module Generated.WorkspaceNominalProof.Project.Harness (harnessAssertions) where  import Generated.WorkspaceNominalProof.Project.Domain

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Project; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Project; do not edit. module Generated.WorkspaceNominalProof.Project.Projection () where  -- No projection declarations are present; this module keeps the generated manifest inventory total.

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Transducer.hs view

@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Project; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Project; do not edit. module Generated.WorkspaceNominalProof.Project.Transducer   ( projectTransducer   , projectFoldFingerprint

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/BehaviorContract.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ProjectArtifact; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ProjectArtifact; do not edit. module Generated.WorkspaceNominalProof.ProjectArtifact.BehaviorContract   ( BehaviorKey (..)   , ObligationKind (..)@@ -21,6 +21,7 @@ import Generated.WorkspaceNominalProof.ProjectArtifact.Codec (encodeProjectArtifactEvent, parseProjectArtifactEvent, projectArtifactCodec) import Generated.WorkspaceNominalProof.ProjectArtifact.Domain import Generated.WorkspaceNominalProof.ProjectArtifact.Transducer (projectArtifactTransducer)+import Generated.WorkspaceNominalProof.BehaviorSourceMap qualified as BehaviorSourceMap import Data.Aeson (ToJSON (..), object, (.=)) import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty)@@ -53,7 +54,6 @@   , requirementExpectedEdge :: !(Maybe (K.EdgeRef ProjectArtifactVertex))   , requirementTarget :: !(Maybe ProjectArtifactVertex)   , requirementEventKinds :: ![Text]-  , requirementLine :: !Int   }   deriving stock (Eq, Show) @@ -126,7 +126,7 @@  behaviorRequirements :: [BehaviorRequirement] behaviorRequirements =-  [ -- ProjectArtifactRecorded x RecordArtifact: required rejection (spec line 8)+  [ -- ProjectArtifactRecorded x RecordArtifact: required rejection     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-11da0fd14ad66aa0"       , requirementKind = RequiredRejection@@ -137,9 +137,8 @@       , requirementExpectedEdge = Nothing       , requirementTarget = Nothing       , requirementEventKinds = []-      , requirementLine = 8       }-  , -- ProjectArtifactEmpty x RecordArtifact: live transition (spec line 13)+  , -- ProjectArtifactEmpty x RecordArtifact: live transition     BehaviorRequirement       { requirementKey = BehaviorKey "behavior-v1-c6d79387e567590e"       , requirementKind = LiveTransition@@ -150,7 +149,6 @@       , requirementExpectedEdge = (Just (K.EdgeRef ProjectArtifactEmpty 0))       , requirementTarget = Just ProjectArtifactRecorded       , requirementEventKinds = ["ArtifactRecorded"]-      , requirementLine = 13       }   ] @@ -329,7 +327,7 @@   Left     ( BehaviorFailure         (requirementKey requirement)-        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (spec line " <> tshow (requirementLine requirement) <> ")")+        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey requirement)) <> ")")         code         detail     )

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ProjectArtifact; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ProjectArtifact; do not edit. module Generated.WorkspaceNominalProof.ProjectArtifact.Codec (     projectArtifactCodec,     parseProjectArtifactEvent,

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Domain.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ProjectArtifact; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ProjectArtifact; do not edit. module Generated.WorkspaceNominalProof.ProjectArtifact.Domain where  import Data.Proxy (Proxy (..))

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ProjectArtifact; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ProjectArtifact; do not edit. module Generated.WorkspaceNominalProof.ProjectArtifact.EventStream   ( projectArtifactCategory   , projectArtifactCommandCategory

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Harness.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ProjectArtifact; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ProjectArtifact; do not edit. module Generated.WorkspaceNominalProof.ProjectArtifact.Harness (harnessAssertions) where  import Generated.WorkspaceNominalProof.ProjectArtifact.Domain

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ProjectArtifact; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ProjectArtifact; do not edit. module Generated.WorkspaceNominalProof.ProjectArtifact.Projection () where  -- No projection declarations are present; this module keeps the generated manifest inventory total.

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Transducer.hs view

@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate ProjectArtifact; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate ProjectArtifact; do not edit. module Generated.WorkspaceNominalProof.ProjectArtifact.Transducer   ( projectArtifactTransducer   , projectArtifactFoldFingerprint

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context workspace-nominal-proof replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context workspace-nominal-proof replay-audit assembly; do not edit. -- -- Deployment contract: --   * replay-neutral diff: no data audit is required;

+ test/conformance/Generated/HospitalCapacity/BehaviorSourceMap.hs view

@@ -0,0 +1,34 @@+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity behavior source map; do not edit.+module Generated.HospitalCapacity.BehaviorSourceMap+  ( BehaviorSourceLocation (..)+  , behaviorSourceLocation+  , renderBehaviorSourceLocation+  ) where++import Data.Text (Text)+import Data.Text qualified as T++data BehaviorSourceLocation = BehaviorSourceLocation+  { sourceFile :: !FilePath+  , sourceLine :: !Int+  , sourceColumn :: !Int+  }+  deriving stock (Eq, Ord, Show)++behaviorSourceLocation :: Text -> Maybe BehaviorSourceLocation+behaviorSourceLocation key = case key of+  "behavior-v1-a544566ac00664fb" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation.keiro" 20 22)+  "behavior-v1-bf9ebe70beb18440" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation.keiro" 32 3)+  "behavior-v1-cf40a84edc844a41" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation.keiro" 20 27)+  "behavior-v1-dff0853d3cd55550" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation.keiro" 28 3)+  "behavior-v1-e53a65263ad89283" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation.keiro" 20 27)+  "behavior-v1-e7378f31cfa93bbf" -> Just (BehaviorSourceLocation "keiro-dsl/test/fixtures/reservation.keiro" 20 10)+  _ -> Nothing++renderBehaviorSourceLocation :: Text -> Text+renderBehaviorSourceLocation key = case behaviorSourceLocation key of+  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"++tshow :: Show value => value -> Text+tshow = T.pack . show

test/conformance/Generated/HospitalCapacity/Nominals.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal declarations; do not edit. module Generated.HospitalCapacity.Nominals   ( BedType (..)   , bedTypeText

test/conformance/Generated/HospitalCapacity/Nominals/Internal.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal ID internals; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal ID internals; do not edit. module Generated.HospitalCapacity.Nominals.Internal   ( CommandId   , parseCommandId

test/conformance/Generated/HospitalCapacity/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from context hospital-capacity replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from context hospital-capacity replay-audit assembly; do not edit. -- -- Deployment contract: --   * replay-neutral diff: no data audit is required;

test/conformance/Generated/HospitalCapacity/Reservation/Codec.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.Codec (     reservationCodec,     parseReservationEvent,

test/conformance/Generated/HospitalCapacity/Reservation/Domain.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.Domain where  import Data.Proxy (Proxy (..))

test/conformance/Generated/HospitalCapacity/Reservation/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.EventStream   ( reservationCategory   , reservationCommandCategory

test/conformance/Generated/HospitalCapacity/Reservation/Harness.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.Harness (harnessAssertions) where  import Generated.HospitalCapacity.Reservation.Domain

test/conformance/Generated/HospitalCapacity/Reservation/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.Projection   ( transferDecisionsProjection   , transferDecisionsStatusFor

test/conformance/Generated/HospitalCapacity/Reservation/Transducer.hs view

@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.11.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Reservation; do not edit. module Generated.HospitalCapacity.Reservation.Transducer   ( reservationTransducer   , reservationFoldFingerprint

test/runtime-vocabulary/Main.hs view

@@ -12,6 +12,7 @@ import Data.Text qualified as T import Keiro.Dsl.Validate (runtimeTimerStatuses) import Keiro.Timer.Schema (TimerStatus)+import Shibuya import System.Exit (exitFailure)  main :: IO ()@@ -30,3 +31,48 @@       putStrLn ("  Keiro.Dsl.Validate.runtimeTimerStatuses: " <> show runtimeTimerStatuses)       putStrLn "  Update runtimeTimerStatuses to match the runtime, then rerun."       exitFailure+  mapM_ verifySelectionReason selectionReasonCodes+  putStrLn+    ( "runtime vocabulary: router selection dead-letter codes agree ("+        <> show (length selectionReasonCodes)+        <> " codes)"+    )++selectionReasonCodes :: [T.Text]+selectionReasonCodes =+  [ "keiro.router.selection.empty",+    "keiro.router.selection.query_failed",+    "keiro.router.selection.evaluation_failed",+    "keiro.router.selection.target_conflict",+    "keiro.router.selection.recipient_overflow"+  ]++verifySelectionReason :: T.Text -> IO ()+verifySelectionReason expectedCode =+  case mkDeadLetterCode expectedCode of+    Left err -> do+      putStrLn ("runtime vocabulary: valid router selection code was rejected: " <> show err)+      exitFailure+    Right code -> do+      let detail = "bounded public API proof"+          reason = ApplicationFailure code detail+          expectedRendering = expectedCode <> ": " <> detail+          actualCode = deadLetterCodeText (deadLetterReasonCode reason)+          actualDetail = deadLetterReasonDetail reason+          actualRendering = renderDeadLetterReason reason+      ensureEqual "code" expectedCode actualCode+      ensureEqual "detail" (Just detail) actualDetail+      ensureEqual "rendering" expectedRendering actualRendering++ensureEqual :: (Eq a, Show a) => String -> a -> a -> IO ()+ensureEqual field expected actual =+  if expected == actual+    then pure ()+    else mismatch field expected actual++mismatch :: (Show a) => String -> a -> a -> IO ()+mismatch field expected actual = do+  putStrLn ("runtime vocabulary: router selection " <> field <> " DIVERGED")+  putStrLn ("  expected: " <> show expected)+  putStrLn ("  actual:   " <> show actual)+  exitFailure