keiro-dsl 0.14.0.0 → 0.15.0.0

raw patch · 1050 files changed

+72570/−39876 lines, 1050 filesdep ~bytestringdep ~keiro-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: bytestring, keiro-core

API changes (from Hackage documentation)

- Keiro.Dsl.AggregateType: [aggregateTypeErrorLoc] :: AggregateTypeError -> !Loc

- Keiro.Dsl.AggregateType: [aggregateTypeErrorReason] :: AggregateTypeError -> !AggregateTypeErrorReason

- Keiro.Dsl.AggregateType: [aggregateTypeErrorUseSite] :: AggregateTypeError -> !AggregateUseSite

- Keiro.Dsl.BehaviorCoverage: [behaviorRecordAggregate] :: BehaviorRecordRow -> !Name

- Keiro.Dsl.BehaviorCoverage: [behaviorRecordCommand] :: BehaviorRecordRow -> !Name

- Keiro.Dsl.BehaviorCoverage: [behaviorRecordEvidence] :: BehaviorRecordRow -> !EvidenceLevel

- Keiro.Dsl.BehaviorCoverage: [behaviorRecordKey] :: BehaviorRecordRow -> !BehaviorKey

- Keiro.Dsl.BehaviorCoverage: [behaviorRecordKind] :: BehaviorRecordRow -> !ObligationKind

- Keiro.Dsl.BehaviorCoverage: [behaviorRecordOutputs] :: BehaviorRecordRow -> ![OutputEvidence]

- Keiro.Dsl.BehaviorCoverage: [behaviorRecordOwner] :: BehaviorRecordRow -> !Maybe FilePath

- Keiro.Dsl.BehaviorCoverage: [behaviorRecordSource] :: BehaviorRecordRow -> !Name

- Keiro.Dsl.BehaviorCoverage: [behaviorRequirements] :: BehaviorObligationsReport -> ![BehaviorRequirement]

- Keiro.Dsl.BehaviorCoverage: [behaviorSubject] :: BehaviorObligationsReport -> !FilePath

- Keiro.Dsl.BehaviorCoverage: [behaviorWorkspaceService] :: BehaviorObligationsReport -> !Maybe Text

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

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

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

- Keiro.Dsl.BehaviorCoverage: [requirementAggregate] :: BehaviorRequirement -> !Name

- Keiro.Dsl.BehaviorCoverage: [requirementCanonical] :: BehaviorRequirement -> !Text

- Keiro.Dsl.BehaviorCoverage: [requirementCommand] :: BehaviorRequirement -> !Name

- Keiro.Dsl.BehaviorCoverage: [requirementContext] :: BehaviorRequirement -> !Name

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

- Keiro.Dsl.BehaviorCoverage: [requirementEvents] :: BehaviorRequirement -> ![Name]

- Keiro.Dsl.BehaviorCoverage: [requirementEvidence] :: BehaviorRequirement -> !EvidenceLevel

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

- Keiro.Dsl.BehaviorCoverage: [requirementGuardCoverage] :: BehaviorRequirement -> !GuardCoverage

- Keiro.Dsl.BehaviorCoverage: [requirementKey] :: BehaviorRequirement -> !BehaviorKey

- Keiro.Dsl.BehaviorCoverage: [requirementKind] :: BehaviorRequirement -> !ObligationKind

- Keiro.Dsl.BehaviorCoverage: [requirementLocation] :: BehaviorRequirement -> !Loc

- Keiro.Dsl.BehaviorCoverage: [requirementMode] :: BehaviorRequirement -> !Maybe TransitionMode

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

- Keiro.Dsl.BehaviorCoverage: [requirementOutputs] :: BehaviorRequirement -> ![OutputEvidence]

- Keiro.Dsl.BehaviorCoverage: [requirementOwner] :: BehaviorRequirement -> !Maybe FilePath

- Keiro.Dsl.BehaviorCoverage: [requirementSource] :: BehaviorRequirement -> !Name

- Keiro.Dsl.BehaviorCoverage: [requirementTarget] :: BehaviorRequirement -> !Maybe Name

- 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.CheckReport: [entryCode] :: CheckReportEntry -> !DiagnosticCode

- Keiro.Dsl.CheckReport: [entryDenied] :: CheckReportEntry -> !Bool

- Keiro.Dsl.CheckReport: [entryFile] :: CheckReportEntry -> !FilePath

- Keiro.Dsl.CheckReport: [entryLine] :: CheckReportEntry -> !Int

- Keiro.Dsl.CheckReport: [entryMessage] :: CheckReportEntry -> !Text

- Keiro.Dsl.CheckReport: [entryRelated] :: CheckReportEntry -> ![CheckReportRelated]

- Keiro.Dsl.CheckReport: [entrySeverity] :: CheckReportEntry -> !Severity

- Keiro.Dsl.CheckReport: [memberDeclaredLanguageVersion] :: CheckReportMember -> !Maybe LanguageVersion

- Keiro.Dsl.CheckReport: [memberPath] :: CheckReportMember -> !FilePath

- Keiro.Dsl.CheckReport: [memberSourceForm] :: CheckReportMember -> !Text

- Keiro.Dsl.CheckReport: [relatedFile] :: CheckReportRelated -> !FilePath

- Keiro.Dsl.CheckReport: [relatedLine] :: CheckReportRelated -> !Int

- Keiro.Dsl.CheckReport: [relatedNote] :: CheckReportRelated -> !Text

- Keiro.Dsl.CheckReport: [reportDeclaredLanguageVersion] :: CheckReportLanguage -> !Maybe LanguageVersion

- Keiro.Dsl.CheckReport: [reportDenyCodes] :: CheckReportEnforcement -> ![DiagnosticCode]

- Keiro.Dsl.CheckReport: [reportDenyWarnings] :: CheckReportEnforcement -> !Bool

- Keiro.Dsl.CheckReport: [reportEffectiveLanguageVersion] :: CheckReportLanguage -> !LanguageVersion

- Keiro.Dsl.CheckReport: [reportLanguageSupport] :: CheckReportLanguage -> !LanguageSupport

- Keiro.Dsl.CheckReport: [reportMinLanguage] :: CheckReportEnforcement -> !Maybe LanguageVersion

- Keiro.Dsl.CheckReport: [reportRuntimeSemantics] :: CheckReportLanguage -> !Text

- Keiro.Dsl.CheckReport: [reportSourceForm] :: CheckReportLanguage -> !Text

- Keiro.Dsl.CheckReport: [reportStable] :: CheckReportLanguage -> !Bool

- Keiro.Dsl.CheckReport: [summaryDeniedWarnings] :: CheckReportSummary -> !Int

- Keiro.Dsl.CheckReport: [summaryErrors] :: CheckReportSummary -> !Int

- Keiro.Dsl.CheckReport: [summaryWarnings] :: CheckReportSummary -> !Int

- Keiro.Dsl.CodecCompare: [baPayloadSchema] :: BranchArm -> !Maybe BranchSchema

- Keiro.Dsl.CodecCompare: [baWireTag] :: BranchArm -> !Text

- Keiro.Dsl.CodecCompare: [bfPresenceOptional] :: BranchField -> !Bool

- Keiro.Dsl.CodecCompare: [bfSchema] :: BranchField -> !BranchSchema

- Keiro.Dsl.CodecCompare: [bfWireKey] :: BranchField -> !Text

- Keiro.Dsl.CodecCompare: [cgKind] :: CoverageGap -> !BranchKind

- Keiro.Dsl.CodecCompare: [cgOrigin] :: CoverageGap -> !FixtureOrigin

- Keiro.Dsl.CodecCompare: [cgPointer] :: CoverageGap -> !JsonPointer

- Keiro.Dsl.CodecCompare: [classifiedName] :: ClassifiedObservation -> !Text

- Keiro.Dsl.CodecCompare: [classifiedOrigin] :: ClassifiedObservation -> !FixtureOrigin

- Keiro.Dsl.CodecCompare: [classifiedVerdict] :: ClassifiedObservation -> !FixtureVerdict

- Keiro.Dsl.CodecCompare: [coCaseName] :: CompareObservation -> !Text

- Keiro.Dsl.CodecCompare: [coFixturePath] :: CompareObservation -> !FilePath

- Keiro.Dsl.CodecCompare: [coGeneratedDecode] :: CompareObservation -> !DecodeOutcome

- Keiro.Dsl.CodecCompare: [coGeneratedValue] :: CompareObservation -> !Value

- Keiro.Dsl.CodecCompare: [coHistoricalDecode] :: CompareObservation -> !DecodeOutcome

- Keiro.Dsl.CodecCompare: [coHistoricalValue] :: CompareObservation -> !Value

- Keiro.Dsl.CodecCompare: [coInputValue] :: CompareObservation -> !Value

- Keiro.Dsl.CodecCompare: [cpBindingSymbol] :: CompareProvenance -> !QualifiedValueName

- Keiro.Dsl.CodecCompare: [cpBindingVersion] :: CompareProvenance -> !BindingVersion

- Keiro.Dsl.CodecCompare: [cpCanonicalType] :: CompareProvenance -> !CanonicalTypeId

- Keiro.Dsl.CodecCompare: [cpHistoricalCodecIdentity] :: CompareProvenance -> !Text

- Keiro.Dsl.CodecCompare: [cpHistoricalCodecVersion] :: CompareProvenance -> !Text

- Keiro.Dsl.CodecCompare: [cpWireFingerprint] :: CompareProvenance -> !Text

- Keiro.Dsl.CodecCompare: [crAuthority] :: CompareReport -> !Text

- Keiro.Dsl.CodecCompare: [crCoverageGaps] :: CompareReport -> ![CoverageGap]

- Keiro.Dsl.CodecCompare: [crInputIssues] :: CompareReport -> ![CompareInputIssue]

- Keiro.Dsl.CodecCompare: [crObservations] :: CompareReport -> ![ClassifiedObservation]

- Keiro.Dsl.CodecCompare: [crProvenance] :: CompareReport -> !CompareProvenance

- Keiro.Dsl.CodecCompare: [dbKind] :: DeclaredBranch -> !BranchKind

- Keiro.Dsl.CodecCompare: [dbOrigin] :: DeclaredBranch -> !FixtureOrigin

- Keiro.Dsl.CodecCompare: [dbPointer] :: DeclaredBranch -> !JsonPointer

- Keiro.Dsl.CodecCompare: [hcDecode] :: HistoricalCodec a -> !Value -> Either Text a

- Keiro.Dsl.CodecCompare: [hcEncode] :: HistoricalCodec a -> !a -> Value

- Keiro.Dsl.CodecCompare: [hcIdentity] :: HistoricalCodec a -> !Text

- Keiro.Dsl.CodecCompare: [hcVersion] :: HistoricalCodec a -> !Text

- Keiro.Dsl.CodecCompare: [obKind] :: ObservedBranch -> !BranchKind

- Keiro.Dsl.CodecCompare: [obOrigin] :: ObservedBranch -> !FixtureOrigin

- Keiro.Dsl.CodecCompare: [obPointer] :: ObservedBranch -> !JsonPointer

- Keiro.Dsl.CodecCompare: [reportWriteMessage] :: ReportWriteError -> !Text

- Keiro.Dsl.CodecCompare: [reportWritePath] :: ReportWriteError -> !FilePath

- Keiro.Dsl.ConformancePackage: [conformanceFileKind] :: ConformanceFile -> !ModuleKind

- Keiro.Dsl.ConformancePackage: [conformanceFilePath] :: ConformanceFile -> !FilePath

- Keiro.Dsl.ConformancePackage: [conformanceFileText] :: ConformanceFile -> !Text

- Keiro.Dsl.ConformancePackage: [conformanceReportDispositions] :: ConformancePackageReport -> ![(ConformanceFile, ConformanceWriteDisposition)]

- Keiro.Dsl.ConformancePackage: [conformanceReportPlan] :: ConformancePackageReport -> !ConformancePackagePlan

- Keiro.Dsl.ConformancePackage: [conformanceReportRoot] :: ConformancePackageReport -> !FilePath

- Keiro.Dsl.ConformancePackage: [conformanceReportStale] :: ConformancePackageReport -> ![ConformanceStaleFile]

- Keiro.Dsl.ConformancePackage: [conformanceStaleBannerPresent] :: ConformanceStaleFile -> !Maybe Bool

- Keiro.Dsl.ConformancePackage: [conformanceStaleKind] :: ConformanceStaleFile -> !ModuleKind

- Keiro.Dsl.ConformancePackage: [conformanceStalePath] :: ConformanceStaleFile -> !FilePath

- Keiro.Dsl.ConformancePackage: [cppDirectory] :: ConformancePackagePlan -> !FilePath

- Keiro.Dsl.ConformancePackage: [cppFacadeModule] :: ConformancePackagePlan -> !Text

- Keiro.Dsl.ConformancePackage: [cppFiles] :: ConformancePackagePlan -> ![ConformanceFile]

- Keiro.Dsl.ConformancePackage: [cppPackageName] :: ConformancePackagePlan -> !Text

- Keiro.Dsl.ConformancePackage: [cppRuntimePackage] :: ConformancePackagePlan -> !RuntimePackageName

- Keiro.Dsl.ConformancePackage: [cppServiceKey] :: ConformancePackagePlan -> !ConformanceServiceKey

- Keiro.Dsl.ConformancePackage: [cprFacadeModule] :: ConformancePackageRecord -> !Text

- Keiro.Dsl.ConformancePackage: [cprFiles] :: ConformancePackageRecord -> ![(ModuleKind, FilePath)]

- Keiro.Dsl.ConformancePackage: [cprRuntimePackage] :: ConformancePackageRecord -> !RuntimePackageName

- Keiro.Dsl.ConformancePackage: [cprSchema] :: ConformancePackageRecord -> !Int

- Keiro.Dsl.ConformancePackage: [cprServiceKey] :: ConformancePackageRecord -> !ConformanceServiceKey

- Keiro.Dsl.ConformancePackage: [duplicateFactKey] :: DuplicateFactKey -> !String

- Keiro.Dsl.ConformancePackage: [duplicateFactSide] :: DuplicateFactKey -> !ConformanceFactSide

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

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

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

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

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

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

- 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.Coverage: [coverageDelta] :: CoverageReport -> !Maybe CoverageDelta

- Keiro.Dsl.Coverage: [coverageFindings] :: CoverageReport -> ![CoverageFinding]

- Keiro.Dsl.Coverage: [coverageJsonBoundaries] :: CoverageReport -> ![JsonBoundary]

- Keiro.Dsl.Coverage: [coverageOpaqueBoundaries] :: CoverageReport -> ![OpaqueBoundary]

- Keiro.Dsl.Coverage: [coveragePrevious] :: CoverageReport -> !Maybe CoveragePrevious

- Keiro.Dsl.Coverage: [coverageRoots] :: CoverageReport -> ![CoverageRoot]

- Keiro.Dsl.Coverage: [coverageSnapshotBoundaries] :: CoverageReport -> ![SnapshotBoundary]

- Keiro.Dsl.Coverage: [coverageSpec] :: CoverageReport -> !FilePath

- Keiro.Dsl.Coverage: [coverageStructuralBoundaries] :: CoverageReport -> ![StructuralBoundary]

- Keiro.Dsl.Coverage: [coverageSummary] :: CoverageReport -> !CoverageSummary

- Keiro.Dsl.Coverage: [coverageUnsupportedSurfaces] :: CoverageReport -> ![UnsupportedSurface]

- Keiro.Dsl.Coverage: [findingCode] :: CoverageFinding -> !DiagnosticCode

- Keiro.Dsl.Coverage: [findingMessage] :: CoverageFinding -> !Text

- Keiro.Dsl.Coverage: [findingRoots] :: CoverageFinding -> ![Text]

- Keiro.Dsl.Coverage: [findingSeverity] :: CoverageFinding -> !Severity

- Keiro.Dsl.Coverage: [jsonPath] :: JsonBoundary -> !Text

- Keiro.Dsl.Coverage: [jsonRoot] :: JsonBoundary -> !Text

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

- Keiro.Dsl.Coverage: [opaqueCodecIdentity] :: OpaqueBoundary -> !Text

- Keiro.Dsl.Coverage: [opaqueCodecVersion] :: OpaqueBoundary -> !Text

- Keiro.Dsl.Coverage: [opaqueMappedType] :: OpaqueBoundary -> !Text

- Keiro.Dsl.Coverage: [opaquePath] :: OpaqueBoundary -> !Text

- Keiro.Dsl.Coverage: [opaqueRoot] :: OpaqueBoundary -> !Text

- Keiro.Dsl.Coverage: [previousOpaqueBoundaries] :: CoveragePrevious -> ![OpaqueBoundary]

- Keiro.Dsl.Coverage: [previousReference] :: CoveragePrevious -> !Text

- Keiro.Dsl.Coverage: [previousSummary] :: CoveragePrevious -> !CoverageSummary

- Keiro.Dsl.Coverage: [rootCanonicalType] :: CoverageRoot -> !Maybe Text

- Keiro.Dsl.Coverage: [rootCodecIdentity] :: CoverageRoot -> !Maybe Text

- Keiro.Dsl.Coverage: [rootCodecVersion] :: CoverageRoot -> !Maybe Text

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

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

- Keiro.Dsl.Coverage: [rootMode] :: CoverageRoot -> !CoverageMode

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

- Keiro.Dsl.Coverage: [rootSurface] :: CoverageRoot -> !CoverageSurface

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

- Keiro.Dsl.Coverage: [snapshotAggregate] :: SnapshotBoundary -> !Text

- Keiro.Dsl.Coverage: [snapshotEnabled] :: SnapshotBoundary -> !Bool

- Keiro.Dsl.Coverage: [snapshotEncoding] :: SnapshotBoundary -> !Text

- Keiro.Dsl.Coverage: [snapshotInvalidation] :: SnapshotBoundary -> !Text

- Keiro.Dsl.Coverage: [snapshotMappedType] :: SnapshotBoundary -> !Text

- Keiro.Dsl.Coverage: [snapshotMode] :: SnapshotBoundary -> !CoverageMode

- Keiro.Dsl.Coverage: [snapshotRegister] :: SnapshotBoundary -> !Text

- Keiro.Dsl.Coverage: [snapshotRoot] :: SnapshotBoundary -> !Text

- Keiro.Dsl.Coverage: [snapshotWireFingerprint] :: SnapshotBoundary -> !Text

- Keiro.Dsl.Coverage: [structuralCanonicalType] :: StructuralBoundary -> !Text

- Keiro.Dsl.Coverage: [structuralMappedType] :: StructuralBoundary -> !Text

- Keiro.Dsl.Coverage: [structuralPath] :: StructuralBoundary -> !Text

- Keiro.Dsl.Coverage: [structuralRoot] :: StructuralBoundary -> !Text

- Keiro.Dsl.Coverage: [structuralWireFingerprint] :: StructuralBoundary -> !Text

- Keiro.Dsl.Coverage: [unsupportedReason] :: UnsupportedSurface -> !Text

- Keiro.Dsl.Coverage: [unsupportedSupport] :: UnsupportedSurface -> !Text

- Keiro.Dsl.Coverage: [unsupportedSurface] :: UnsupportedSurface -> !Text

- Keiro.Dsl.Diff: [ckCode] :: ChangeKind -> !DiagnosticCode

- Keiro.Dsl.Diff: [ckContext] :: ChangeKind -> !ChangeContext

- Keiro.Dsl.Diff: [ckDetail] :: ChangeKind -> !Text

- Keiro.Dsl.Diff: [ckFacet] :: ChangeKind -> !Text

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

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

- Keiro.Dsl.Diff: [ckNode] :: ChangeKind -> !Name

- Keiro.Dsl.Diff: [ckPaths] :: ChangeKind -> ![Text]

- Keiro.Dsl.Diff: [ckSubject] :: ChangeKind -> !Text

- Keiro.Dsl.Diff: [ckVector] :: ChangeKind -> !CompatibilityVector

- Keiro.Dsl.Diff: [cvConsumerBuild] :: CompatibilityVector -> !SurfaceVerdict

- Keiro.Dsl.Diff: [cvOldBinaryReadNewEvents] :: CompatibilityVector -> !SurfaceVerdict

- Keiro.Dsl.Diff: [cvPersistedIdentity] :: CompatibilityVector -> !SurfaceVerdict

- Keiro.Dsl.Diff: [cvPrivateHistoryRead] :: CompatibilityVector -> !SurfaceVerdict

- Keiro.Dsl.Diff: [cvPublicConsumer] :: CompatibilityVector -> !SurfaceVerdict

- Keiro.Dsl.Diff: [cvRollout] :: CompatibilityVector -> !Set RolloutConstraint

- Keiro.Dsl.Diff: [cvSnapshotHydration] :: CompatibilityVector -> !SurfaceVerdict

- Keiro.Dsl.Diff: [deNew] :: DiffEnv -> !Spec

- Keiro.Dsl.Diff: [deOld] :: DiffEnv -> !Spec

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

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

- Keiro.Dsl.Diff: [prAdded] :: Paired n -> ![n]

- Keiro.Dsl.Diff: [prMatched] :: Paired n -> ![(n, n)]

- Keiro.Dsl.Diff: [prRemoved] :: Paired n -> ![n]

- Keiro.Dsl.DiffReport: [osFile] :: OwnedSite -> !FilePath

- Keiro.Dsl.DiffReport: [osLine] :: OwnedSite -> !Int

- Keiro.Dsl.DiffReport: [wcChange] :: WorkspaceChange -> !Change

- Keiro.Dsl.DiffReport: [wcDeclarationSite] :: WorkspaceChange -> !Maybe OwnedSite

- Keiro.Dsl.DiffReport: [wcUseSites] :: WorkspaceChange -> ![(Text, Maybe OwnedSite)]

- Keiro.Dsl.DiffReport: [wmAdoptionBaseline] :: WorkspaceMeta -> !Bool

- Keiro.Dsl.DiffReport: [wmIdentity] :: WorkspaceMeta -> !Text

- Keiro.Dsl.DiffReport: [wmManifest] :: WorkspaceMeta -> !FilePath

- Keiro.Dsl.DiffReport: [wmMembersNew] :: WorkspaceMeta -> ![FilePath]

- Keiro.Dsl.DiffReport: [wmMembersOld] :: WorkspaceMeta -> ![FilePath]

- Keiro.Dsl.DiffReport: [wmSince] :: WorkspaceMeta -> !Text

- Keiro.Dsl.EventOutput: [outputFields] :: EventOutputMapping -> ![CheckedFieldCopy]

- Keiro.Dsl.EventOutput: [outputObligation] :: EventOutputMapping -> !OutputObligationKey

- Keiro.Dsl.EventOutput: [outputSourceCommand] :: EventOutputMapping -> !Name

- Keiro.Dsl.ExplainBindings: [holeKind] :: BindingHole -> !BindingObligationKind

- Keiro.Dsl.ExplainBindings: [holeMappedName] :: BindingHole -> !Name

- Keiro.Dsl.ExplainBindings: [holeModule] :: BindingHole -> !Text

- Keiro.Dsl.ExplainBindings: [holePath] :: BindingHole -> !Maybe Text

- Keiro.Dsl.ExplainBindings: [holeSignature] :: BindingHole -> !Text

- Keiro.Dsl.ExplainBindings: [holeSymbol] :: BindingHole -> !Text

- Keiro.Dsl.ExplainBindings: [obligationBindingVersion] :: BindingObligation -> !Maybe Text

- Keiro.Dsl.ExplainBindings: [obligationCanonicalType] :: BindingObligation -> !Maybe Text

- Keiro.Dsl.ExplainBindings: [obligationCategory] :: BindingObligation -> !Text

- Keiro.Dsl.ExplainBindings: [obligationEqualityContract] :: BindingObligation -> !Maybe Text

- Keiro.Dsl.ExplainBindings: [obligationIdDomainContract] :: BindingObligation -> !Maybe Text

- Keiro.Dsl.ExplainBindings: [obligationKind] :: BindingObligation -> !BindingObligationKind

- Keiro.Dsl.ExplainBindings: [obligationMappedName] :: BindingObligation -> !Name

- Keiro.Dsl.ExplainBindings: [obligationModule] :: BindingObligation -> !Text

- Keiro.Dsl.ExplainBindings: [obligationPackage] :: BindingObligation -> !Text

- Keiro.Dsl.ExplainBindings: [obligationSignature] :: BindingObligation -> !Text

- Keiro.Dsl.ExplainBindings: [obligationSymbol] :: BindingObligation -> !Text

- Keiro.Dsl.ExplainBindings: [obligationUseSites] :: BindingObligation -> ![Text]

- Keiro.Dsl.Expression: [expressionDiagnosticCode] :: ExpressionDiagnostic -> !ExpressionDiagnosticCode

- Keiro.Dsl.Expression: [expressionDiagnosticLoc] :: ExpressionDiagnostic -> !Loc

- Keiro.Dsl.Expression: [expressionDiagnosticMessage] :: ExpressionDiagnostic -> !Text

- Keiro.Dsl.Expression: [scalarProjectionFields] :: ResolvedScalarProjection -> ![Name]

- Keiro.Dsl.Expression: [scalarProjectionOwner] :: ResolvedScalarProjection -> !MappedKey

- Keiro.Dsl.Expression: [scalarProjectionPointer] :: ResolvedScalarProjection -> !Text

- Keiro.Dsl.Expression: [typedScalarLoc] :: TypedScalarExpr -> !Loc

- Keiro.Dsl.Expression: [typedScalarNode] :: TypedScalarExpr -> !TypedScalarNode

- Keiro.Dsl.Expression: [typedScalarType] :: TypedScalarExpr -> !ResolvedAggregateType

- Keiro.Dsl.Goldens: [goldenAggregate] :: GoldenPayload -> !Text

- Keiro.Dsl.Goldens: [goldenContext] :: GoldenPayload -> !Text

- Keiro.Dsl.Goldens: [goldenEvent] :: GoldenPayload -> !Text

- Keiro.Dsl.Goldens: [goldenEvidence] :: GoldenPayload -> !GoldenEvidence

- Keiro.Dsl.Goldens: [goldenJson] :: GoldenPayload -> !Text

- Keiro.Dsl.Goldens: [goldenVersion] :: GoldenPayload -> !Int

- Keiro.Dsl.Grammar: [aggCommands] :: Aggregate -> ![Command]

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

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

- Keiro.Dsl.Grammar: [aggEvents] :: Aggregate -> ![Event]

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

- Keiro.Dsl.Grammar: [aggName] :: Aggregate -> !Name

- Keiro.Dsl.Grammar: [aggProjection] :: Aggregate -> !Maybe ProjectionSpec

- Keiro.Dsl.Grammar: [aggRegs] :: Aggregate -> ![RegDecl]

- Keiro.Dsl.Grammar: [aggSnapshot] :: Aggregate -> !Maybe SnapshotSpec

- Keiro.Dsl.Grammar: [aggStates] :: Aggregate -> ![StateDecl]

- Keiro.Dsl.Grammar: [aggTransitions] :: Aggregate -> ![Transition]

- Keiro.Dsl.Grammar: [aggWire] :: Aggregate -> !Maybe WireSpec

- Keiro.Dsl.Grammar: [aggregateFieldLoc] :: AggregateField -> !Loc

- Keiro.Dsl.Grammar: [aggregateFieldName] :: AggregateField -> !Name

- Keiro.Dsl.Grammar: [aggregateFieldSelector] :: AggregateField -> !Maybe Name

- Keiro.Dsl.Grammar: [aggregateFieldType] :: AggregateField -> !Maybe TypeExpr

- Keiro.Dsl.Grammar: [aggregateFieldWireKey] :: AggregateField -> !Maybe Text

- Keiro.Dsl.Grammar: [boKind] :: BackoffSpec -> !Name

- Keiro.Dsl.Grammar: [boMax] :: BackoffSpec -> !Maybe Text

- Keiro.Dsl.Grammar: [boMultiplier] :: BackoffSpec -> !Maybe Text

- Keiro.Dsl.Grammar: [boWindow] :: BackoffSpec -> !Text

- Keiro.Dsl.Grammar: [brCrossCheck] :: BindRow -> !Bool

- Keiro.Dsl.Grammar: [brField] :: BindRow -> !Name

- Keiro.Dsl.Grammar: [brRequired] :: BindRow -> !Bool

- Keiro.Dsl.Grammar: [brSource] :: BindRow -> !WireSource

- Keiro.Dsl.Grammar: [ceFields] :: ContractEvent -> ![ContractField]

- Keiro.Dsl.Grammar: [ceName] :: ContractEvent -> !Name

- Keiro.Dsl.Grammar: [ceTopic] :: ContractEvent -> !Name

- Keiro.Dsl.Grammar: [cfLoc] :: ContractField -> !Loc

- Keiro.Dsl.Grammar: [cfName] :: ContractField -> !Name

- Keiro.Dsl.Grammar: [cfSelector] :: ContractField -> !Maybe Name

- Keiro.Dsl.Grammar: [cfType] :: ContractField -> !ContractType

- Keiro.Dsl.Grammar: [cfWireKey] :: ContractField -> !Maybe Text

- Keiro.Dsl.Grammar: [cmdFields] :: Command -> ![AggregateField]

- Keiro.Dsl.Grammar: [cmdLoc] :: Command -> !Loc

- Keiro.Dsl.Grammar: [cmdName] :: Command -> !Name

- Keiro.Dsl.Grammar: [corrField] :: CorrelateDecl -> !Name

- Keiro.Dsl.Grammar: [corrVia] :: CorrelateDecl -> !Name

- Keiro.Dsl.Grammar: [ctrDiscriminator] :: ContractNode -> !Name

- Keiro.Dsl.Grammar: [ctrEvents] :: ContractNode -> ![ContractEvent]

- Keiro.Dsl.Grammar: [ctrLoc] :: ContractNode -> !Loc

- Keiro.Dsl.Grammar: [ctrName] :: ContractNode -> !Name

- Keiro.Dsl.Grammar: [ctrSchemaVersion] :: ContractNode -> !Int

- Keiro.Dsl.Grammar: [ctrTopics] :: ContractNode -> ![(Name, Text)]

- Keiro.Dsl.Grammar: [decBodySchemaVersion] :: DecodeSpec -> !Int

- Keiro.Dsl.Grammar: [decBodyStrict] :: DecodeSpec -> !Bool

- Keiro.Dsl.Grammar: [decEnvelope] :: DecodeSpec -> !Text

- Keiro.Dsl.Grammar: [dispCommand] :: DispatchNode -> !Name

- Keiro.Dsl.Grammar: [dispDisposition] :: DispatchNode -> !DispatchDisposition

- Keiro.Dsl.Grammar: [dispFields] :: DispatchNode -> ![FieldBinding]

- Keiro.Dsl.Grammar: [dispKey] :: DispatchNode -> !Text

- Keiro.Dsl.Grammar: [dispLoc] :: DispatchNode -> !Loc

- Keiro.Dsl.Grammar: [dispTarget] :: DispatchNode -> !Name

- Keiro.Dsl.Grammar: [drAction] :: DispositionRow -> !InboxAction

- Keiro.Dsl.Grammar: [drLoc] :: DispositionRow -> !Loc

- Keiro.Dsl.Grammar: [drOutcome] :: DispositionRow -> !Name

- Keiro.Dsl.Grammar: [emContract] :: EmitNode -> !Name

- Keiro.Dsl.Grammar: [emDiscriminant] :: EmitNode -> !Name

- Keiro.Dsl.Grammar: [emIdempotencyKey] :: EmitNode -> !DeriveSpec

- Keiro.Dsl.Grammar: [emKey] :: EmitNode -> !Name

- Keiro.Dsl.Grammar: [emLoc] :: EmitNode -> !Loc

- Keiro.Dsl.Grammar: [emMap] :: EmitNode -> ![EmitMapRow]

- Keiro.Dsl.Grammar: [emMessageId] :: EmitNode -> !DeriveSpec

- Keiro.Dsl.Grammar: [emName] :: EmitNode -> !Name

- Keiro.Dsl.Grammar: [emSkip] :: EmitNode -> !Bool

- Keiro.Dsl.Grammar: [emSource] :: EmitNode -> !Text

- Keiro.Dsl.Grammar: [emTopic] :: EmitNode -> !Name

- Keiro.Dsl.Grammar: [emrEvent] :: EmitMapRow -> !Name

- Keiro.Dsl.Grammar: [emrLoc] :: EmitMapRow -> !Loc

- Keiro.Dsl.Grammar: [emrValue] :: EmitMapRow -> !Text

- Keiro.Dsl.Grammar: [enumBinding] :: EnumDecl -> !Maybe NominalBindingDecl

- Keiro.Dsl.Grammar: [enumCtors] :: EnumDecl -> ![(Name, Text)]

- Keiro.Dsl.Grammar: [enumLoc] :: EnumDecl -> !Loc

- Keiro.Dsl.Grammar: [enumName] :: EnumDecl -> !Name

- 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: [evBody] :: Event -> !EventBody

- Keiro.Dsl.Grammar: [evDeprecated] :: Event -> !Bool

- Keiro.Dsl.Grammar: [evLoc] :: Event -> !Loc

- Keiro.Dsl.Grammar: [evName] :: Event -> !Name

- Keiro.Dsl.Grammar: [evRetiring] :: Event -> !Bool

- Keiro.Dsl.Grammar: [evUpcastFrom] :: Event -> !Maybe (Int, Hole)

- Keiro.Dsl.Grammar: [evVersion] :: Event -> !Int

- Keiro.Dsl.Grammar: [faField] :: FireAtExpr -> !Name

- Keiro.Dsl.Grammar: [faWindow] :: FireAtExpr -> !Text

- Keiro.Dsl.Grammar: [fbName] :: FieldBinding -> !Name

- Keiro.Dsl.Grammar: [fbValue] :: FieldBinding -> !Maybe Text

- Keiro.Dsl.Grammar: [fieldName] :: Field -> !Name

- Keiro.Dsl.Grammar: [fieldType] :: Field -> !Maybe Name

- Keiro.Dsl.Grammar: [fireCommand] :: FireNode -> !Name

- Keiro.Dsl.Grammar: [fireDisposition] :: FireNode -> !FireDisposition

- Keiro.Dsl.Grammar: [fireFields] :: FireNode -> ![FieldBinding]

- Keiro.Dsl.Grammar: [fireFiredEventId] :: FireNode -> !IdExpr

- Keiro.Dsl.Grammar: [fireKey] :: FireNode -> !Text

- Keiro.Dsl.Grammar: [fireTarget] :: FireNode -> !Name

- Keiro.Dsl.Grammar: [gkField] :: WqGroupKey -> !Name

- Keiro.Dsl.Grammar: [gkFixture] :: WqGroupKey -> !Maybe Text

- Keiro.Dsl.Grammar: [gkVia] :: WqGroupKey -> !Name

- Keiro.Dsl.Grammar: [hAdvance] :: HandleNode -> !AdvanceNode

- Keiro.Dsl.Grammar: [hDispatch] :: HandleNode -> ![DispatchNode]

- Keiro.Dsl.Grammar: [hOn] :: HandleNode -> !Name

- Keiro.Dsl.Grammar: [hSchedule] :: HandleNode -> !Name

- Keiro.Dsl.Grammar: [hsModule] :: HaskellSource -> !Text

- Keiro.Dsl.Grammar: [hsPackage] :: HaskellSource -> !Text

- Keiro.Dsl.Grammar: [hsType] :: HaskellSource -> !Name

- Keiro.Dsl.Grammar: [idBinding] :: IdDecl -> !Maybe NominalBindingDecl

- Keiro.Dsl.Grammar: [idLoc] :: IdDecl -> !Loc

- Keiro.Dsl.Grammar: [idName] :: IdDecl -> !Name

- Keiro.Dsl.Grammar: [idPrefix] :: IdDecl -> !Text

- Keiro.Dsl.Grammar: [ideField] :: IdExpr -> !Name

- Keiro.Dsl.Grammar: [idePrefix] :: IdExpr -> !Text

- Keiro.Dsl.Grammar: [ideStrategy] :: IdExpr -> !IdStrategy

- Keiro.Dsl.Grammar: [inFields] :: InputDecl -> ![Field]

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

- Keiro.Dsl.Grammar: [inName] :: InputDecl -> !Name

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

- Keiro.Dsl.Grammar: [inkAccept] :: IntakeNode -> ![Name]

- Keiro.Dsl.Grammar: [inkBinds] :: IntakeNode -> ![BindRow]

- Keiro.Dsl.Grammar: [inkContract] :: IntakeNode -> !Name

- Keiro.Dsl.Grammar: [inkDecode] :: IntakeNode -> !DecodeSpec

- Keiro.Dsl.Grammar: [inkDedupeKey] :: IntakeNode -> !Name

- Keiro.Dsl.Grammar: [inkDedupePolicy] :: IntakeNode -> !Name

- Keiro.Dsl.Grammar: [inkDisposition] :: IntakeNode -> ![DispositionRow]

- Keiro.Dsl.Grammar: [inkLoc] :: IntakeNode -> !Loc

- Keiro.Dsl.Grammar: [inkName] :: IntakeNode -> !Name

- Keiro.Dsl.Grammar: [inkPersist] :: IntakeNode -> !InkPersist

- Keiro.Dsl.Grammar: [inkTopic] :: IntakeNode -> !Name

- Keiro.Dsl.Grammar: [mapPairs] :: Mapping -> ![(Name, Name)]

- Keiro.Dsl.Grammar: [mapPartial] :: Mapping -> !Bool

- Keiro.Dsl.Grammar: [nominalBindingVersion] :: NominalBindingDecl -> !Maybe Text

- Keiro.Dsl.Grammar: [nominalBinding] :: NominalBindingDecl -> !Maybe Text

- Keiro.Dsl.Grammar: [nominalCanonicalType] :: NominalBindingDecl -> !Maybe Text

- Keiro.Dsl.Grammar: [nominalFixtures] :: NominalBindingDecl -> !Maybe Text

- Keiro.Dsl.Grammar: [nominalHaskell] :: NominalBindingDecl -> !Maybe HaskellSource

- Keiro.Dsl.Grammar: [nominalInitial] :: NominalBindingDecl -> !Maybe Text

- Keiro.Dsl.Grammar: [nominalLoc] :: NominalBindingDecl -> !Loc

- Keiro.Dsl.Grammar: [nominalScalarBinding] :: NominalScalarDecl -> !NominalBindingDecl

- Keiro.Dsl.Grammar: [nominalScalarLoc] :: NominalScalarDecl -> !Loc

- Keiro.Dsl.Grammar: [nominalScalarName] :: NominalScalarDecl -> !Name

- Keiro.Dsl.Grammar: [nominalScalarRepresentation] :: NominalScalarDecl -> !Name

- Keiro.Dsl.Grammar: [opLoc] :: OperationNode -> !Loc

- Keiro.Dsl.Grammar: [opName] :: OperationNode -> !Name

- Keiro.Dsl.Grammar: [opShape] :: OperationNode -> !OperationShape

- Keiro.Dsl.Grammar: [pdDedupKey] :: PgmqDispatchNode -> !Name

- Keiro.Dsl.Grammar: [pdDedupQueueField] :: PgmqDispatchNode -> !Text

- Keiro.Dsl.Grammar: [pdDedupQueue] :: PgmqDispatchNode -> !Name

- Keiro.Dsl.Grammar: [pdDedupReadModelField] :: PgmqDispatchNode -> !Text

- Keiro.Dsl.Grammar: [pdDedupReadModel] :: PgmqDispatchNode -> !Name

- Keiro.Dsl.Grammar: [pdEnqueueTo] :: PgmqDispatchNode -> !Name

- Keiro.Dsl.Grammar: [pdFanoutBody] :: PgmqDispatchNode -> !Name

- Keiro.Dsl.Grammar: [pdLoc] :: PgmqDispatchNode -> !Loc

- Keiro.Dsl.Grammar: [pdName] :: PgmqDispatchNode -> !Name

- Keiro.Dsl.Grammar: [pdSourceKey] :: PgmqDispatchNode -> !Name

- Keiro.Dsl.Grammar: [pdSourceReadModel] :: PgmqDispatchNode -> !Name

- 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: [procCorrelate] :: ProcessNode -> !CorrelateDecl

- Keiro.Dsl.Grammar: [procHandle] :: ProcessNode -> !HandleNode

- Keiro.Dsl.Grammar: [procId] :: ProcessNode -> !Name

- Keiro.Dsl.Grammar: [procInput] :: ProcessNode -> !InputDecl

- Keiro.Dsl.Grammar: [procLoc] :: ProcessNode -> !Loc

- Keiro.Dsl.Grammar: [procName] :: ProcessNode -> !Text

- Keiro.Dsl.Grammar: [procPoison] :: ProcessNode -> !PolicyChoice

- Keiro.Dsl.Grammar: [procProjections] :: ProcessNode -> ![Name]

- Keiro.Dsl.Grammar: [procRejected] :: ProcessNode -> !PolicyChoice

- Keiro.Dsl.Grammar: [procSaga] :: ProcessNode -> !SagaRef

- Keiro.Dsl.Grammar: [procTarget] :: ProcessNode -> !Name

- Keiro.Dsl.Grammar: [procTimer] :: ProcessNode -> !TimerNode

- Keiro.Dsl.Grammar: [projConsistency] :: ProjectionSpec -> !Maybe Consistency

- Keiro.Dsl.Grammar: [projKey] :: ProjectionSpec -> !Name

- Keiro.Dsl.Grammar: [projLoc] :: ProjectionSpec -> !Loc

- Keiro.Dsl.Grammar: [projStatusMap] :: ProjectionSpec -> !Maybe Mapping

- Keiro.Dsl.Grammar: [projTable] :: ProjectionSpec -> !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: [pubBackoff] :: PublisherNode -> !BackoffSpec

- Keiro.Dsl.Grammar: [pubEmit] :: PublisherNode -> !Name

- Keiro.Dsl.Grammar: [pubLoc] :: PublisherNode -> !Loc

- Keiro.Dsl.Grammar: [pubMaxAttempts] :: PublisherNode -> !Int

- Keiro.Dsl.Grammar: [pubName] :: PublisherNode -> !Name

- Keiro.Dsl.Grammar: [pubOrdering] :: PublisherNode -> !Name

- Keiro.Dsl.Grammar: [pubOutboxField] :: PublisherNode -> !Name

- Keiro.Dsl.Grammar: [rdCommand] :: RouterDispatchNode -> !Name

- Keiro.Dsl.Grammar: [rdDisposition] :: RouterDispatchNode -> !DispatchDisposition

- Keiro.Dsl.Grammar: [rdFields] :: RouterDispatchNode -> ![FieldBinding]

- Keiro.Dsl.Grammar: [rdLoc] :: RouterDispatchNode -> !Loc

- Keiro.Dsl.Grammar: [regInitial] :: RegDecl -> !RegInitial

- Keiro.Dsl.Grammar: [regLoc] :: RegDecl -> !Loc

- Keiro.Dsl.Grammar: [regName] :: RegDecl -> !Name

- Keiro.Dsl.Grammar: [regType] :: RegDecl -> !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: [rmColumns] :: ReadModelNode -> ![RmColumn]

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

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

- Keiro.Dsl.Grammar: [rmLoc] :: ReadModelNode -> !Loc

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

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

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

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

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

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

- Keiro.Dsl.Grammar: [rmVersion] :: ReadModelNode -> !Int

- 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: [rtDispatch] :: RouterNode -> !RouterDispatchNode

- Keiro.Dsl.Grammar: [rtId] :: RouterNode -> !Name

- Keiro.Dsl.Grammar: [rtInput] :: RouterNode -> !InputDecl

- Keiro.Dsl.Grammar: [rtKey] :: RouterNode -> !CorrelateDecl

- Keiro.Dsl.Grammar: [rtLoc] :: RouterNode -> !Loc

- Keiro.Dsl.Grammar: [rtName] :: RouterNode -> !Text

- Keiro.Dsl.Grammar: [rtPoison] :: RouterNode -> !PolicyChoice

- Keiro.Dsl.Grammar: [rtProjections] :: RouterNode -> ![Name]

- Keiro.Dsl.Grammar: [rtRejected] :: RouterNode -> !PolicyChoice

- Keiro.Dsl.Grammar: [rtResolve] :: RouterNode -> !ResolveDecl

- Keiro.Dsl.Grammar: [rtTarget] :: RouterNode -> !Name

- Keiro.Dsl.Grammar: [ruleCases] :: RuleDecl -> ![(Name, Expr)]

- Keiro.Dsl.Grammar: [ruleCodomain] :: RuleDecl -> !Name

- Keiro.Dsl.Grammar: [ruleDomain] :: RuleDecl -> !Name

- Keiro.Dsl.Grammar: [ruleLoc] :: RuleDecl -> !Loc

- Keiro.Dsl.Grammar: [ruleName] :: RuleDecl -> !Name

- Keiro.Dsl.Grammar: [rvLoc] :: ResolveDecl -> !Loc

- Keiro.Dsl.Grammar: [rvRow] :: ResolveDecl -> ![Name]

- Keiro.Dsl.Grammar: [rvSource] :: ResolveDecl -> !ResolveSource

- Keiro.Dsl.Grammar: [sagaAgg] :: SagaRef -> !Name

- Keiro.Dsl.Grammar: [sagaCategory] :: SagaRef -> !Text

- Keiro.Dsl.Grammar: [snapCodecVersion] :: SnapshotSpec -> !Int

- Keiro.Dsl.Grammar: [snapLoc] :: SnapshotSpec -> !Loc

- Keiro.Dsl.Grammar: [snapPolicy] :: SnapshotSpec -> !SnapPolicy

- Keiro.Dsl.Grammar: [snapShapeHash] :: SnapshotSpec -> !Text

- Keiro.Dsl.Grammar: [specContext] :: Spec -> !Name

- Keiro.Dsl.Grammar: [specEnums] :: Spec -> ![EnumDecl]

- Keiro.Dsl.Grammar: [specIds] :: Spec -> ![IdDecl]

- Keiro.Dsl.Grammar: [specLayout] :: Spec -> !Maybe Placement

- Keiro.Dsl.Grammar: [specMapped] :: Spec -> ![MappedDecl]

- Keiro.Dsl.Grammar: [specModuleRoot] :: Spec -> !Maybe Text

- Keiro.Dsl.Grammar: [specNodes] :: Spec -> ![Node]

- Keiro.Dsl.Grammar: [specNominalScalars] :: Spec -> ![NominalScalarDecl]

- Keiro.Dsl.Grammar: [specRules] :: Spec -> ![RuleDecl]

- Keiro.Dsl.Grammar: [stLoc] :: StateDecl -> !Loc

- Keiro.Dsl.Grammar: [stName] :: StateDecl -> !Name

- Keiro.Dsl.Grammar: [stTerminal] :: StateDecl -> !Bool

- Keiro.Dsl.Grammar: [tCommand] :: Transition -> !Name

- Keiro.Dsl.Grammar: [tEmits] :: Transition -> ![Name]

- Keiro.Dsl.Grammar: [tGoto] :: Transition -> !Name

- Keiro.Dsl.Grammar: [tGuard] :: Transition -> !Maybe Expr

- Keiro.Dsl.Grammar: [tImplementation] :: Transition -> !TransitionImplementation

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

- Keiro.Dsl.Grammar: [tMode] :: Transition -> !TransitionMode

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

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

- Keiro.Dsl.Grammar: [tSource] :: Transition -> !Name

- Keiro.Dsl.Grammar: [tWrites] :: Transition -> ![(Name, Expr)]

- Keiro.Dsl.Grammar: [tmDeadLetter] :: TimerNode -> !Text

- Keiro.Dsl.Grammar: [tmDecodeUnknown] :: TimerNode -> !Name

- Keiro.Dsl.Grammar: [tmFireAt] :: TimerNode -> !FireAtExpr

- Keiro.Dsl.Grammar: [tmFire] :: TimerNode -> !FireNode

- Keiro.Dsl.Grammar: [tmId] :: TimerNode -> !IdExpr

- Keiro.Dsl.Grammar: [tmLoc] :: TimerNode -> !Loc

- Keiro.Dsl.Grammar: [tmMaxAttempts] :: TimerNode -> !Int

- Keiro.Dsl.Grammar: [tmName] :: TimerNode -> !Name

- Keiro.Dsl.Grammar: [tmPayload] :: TimerNode -> ![FieldBinding]

- Keiro.Dsl.Grammar: [ueContentsField] :: UnionEncoding -> !Text

- Keiro.Dsl.Grammar: [ueTagField] :: UnionEncoding -> !Text

- Keiro.Dsl.Grammar: [ueUnknownFields] :: UnionEncoding -> !UnknownFields

- Keiro.Dsl.Grammar: [waCtor] :: WireArm -> !Name

- Keiro.Dsl.Grammar: [waLoc] :: WireArm -> !Loc

- Keiro.Dsl.Grammar: [waPayload] :: WireArm -> !Maybe TypeExpr

- Keiro.Dsl.Grammar: [waTag] :: WireArm -> !Text

- Keiro.Dsl.Grammar: [weCtor] :: WireEnum -> !Name

- Keiro.Dsl.Grammar: [weLoc] :: WireEnum -> !Loc

- Keiro.Dsl.Grammar: [weTag] :: WireEnum -> !Text

- Keiro.Dsl.Grammar: [wfBody] :: WorkflowNode -> ![WfBodyItem]

- Keiro.Dsl.Grammar: [wfHaskell] :: WireField -> !Name

- Keiro.Dsl.Grammar: [wfIdField] :: WorkflowNode -> !Maybe Name

- Keiro.Dsl.Grammar: [wfIdVia] :: WorkflowNode -> !Name

- Keiro.Dsl.Grammar: [wfId] :: WorkflowNode -> !Name

- Keiro.Dsl.Grammar: [wfInputFields] :: WorkflowNode -> ![Field]

- Keiro.Dsl.Grammar: [wfInput] :: WorkflowNode -> !Name

- Keiro.Dsl.Grammar: [wfKey] :: WireField -> !Text

- Keiro.Dsl.Grammar: [wfLoc] :: WorkflowNode -> !Loc

- Keiro.Dsl.Grammar: [wfOnMissing] :: WireField -> !Maybe OnMissing

- Keiro.Dsl.Grammar: [wfOutput] :: WorkflowNode -> !Name

- Keiro.Dsl.Grammar: [wfPresence] :: WireField -> !Presence

- Keiro.Dsl.Grammar: [wfStable] :: WorkflowNode -> !Text

- Keiro.Dsl.Grammar: [wfType] :: WireField -> !TypeExpr

- Keiro.Dsl.Grammar: [wireFields] :: WireSpec -> !Text

- Keiro.Dsl.Grammar: [wireKind] :: WireSpec -> !Text

- Keiro.Dsl.Grammar: [wireSchemaVersion] :: WireSpec -> !Int

- Keiro.Dsl.Grammar: [wqDelay] :: WorkqueueNode -> !Text

- Keiro.Dsl.Grammar: [wqDisposition] :: WorkqueueNode -> ![WqDispRow]

- Keiro.Dsl.Grammar: [wqDlqOn] :: WorkqueueNode -> !Bool

- Keiro.Dsl.Grammar: [wqDlq] :: WorkqueueNode -> !Text

- Keiro.Dsl.Grammar: [wqGroupKey] :: WorkqueueNode -> !Maybe WqGroupKey

- Keiro.Dsl.Grammar: [wqLoc] :: WorkqueueNode -> !Loc

- Keiro.Dsl.Grammar: [wqLogical] :: WorkqueueNode -> !Text

- Keiro.Dsl.Grammar: [wqMaxRetries] :: WorkqueueNode -> !Int

- Keiro.Dsl.Grammar: [wqName] :: WorkqueueNode -> !Name

- Keiro.Dsl.Grammar: [wqOrdering] :: WorkqueueNode -> !WqOrdering

- Keiro.Dsl.Grammar: [wqPayloadName] :: WorkqueueNode -> !Name

- Keiro.Dsl.Grammar: [wqPayload] :: WorkqueueNode -> ![WqField]

- Keiro.Dsl.Grammar: [wqPhysical] :: WorkqueueNode -> !Text

- Keiro.Dsl.Grammar: [wqProvision] :: WorkqueueNode -> !WqProvision

- Keiro.Dsl.Grammar: [wqTable] :: WorkqueueNode -> !Text

- Keiro.Dsl.Grammar: [wqdAction] :: WqDispRow -> !InboxAction

- Keiro.Dsl.Grammar: [wqdLoc] :: WqDispRow -> !Loc

- Keiro.Dsl.Grammar: [wqdOutcome] :: WqDispRow -> !Name

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

- Keiro.Dsl.Grammar: [wqfName] :: WqField -> !Name

- Keiro.Dsl.Grammar: [wqfType] :: WqField -> !QueuePayloadType

- Keiro.Dsl.Grammar: [wqfWire] :: WqField -> !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.HaskellSourceMove: [moveBackupPath] :: SourceMove -> !FilePath

- Keiro.Dsl.HaskellSourceMove: [moveContentDigest] :: SourceMove -> !Maybe Text

- Keiro.Dsl.HaskellSourceMove: [moveKind] :: SourceMove -> !ModuleKind

- Keiro.Dsl.HaskellSourceMove: [moveNewModule] :: SourceMove -> !Text

- Keiro.Dsl.HaskellSourceMove: [moveNewPath] :: SourceMove -> !FilePath

- Keiro.Dsl.HaskellSourceMove: [moveOldModule] :: SourceMove -> !Text

- Keiro.Dsl.HaskellSourceMove: [moveOldPath] :: SourceMove -> !FilePath

- Keiro.Dsl.HaskellSourceMove: [moveRole] :: SourceMove -> !ModuleRole

- Keiro.Dsl.HaskellSourceMove: [moveTransformedDigest] :: SourceMove -> !Maybe Text

- Keiro.Dsl.LanguageVersion: [definitionBodyParser] :: LanguageDefinition -> !LanguageBodyParser

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

- Keiro.Dsl.LanguageVersion: [definitionPredecessor] :: LanguageDefinition -> !Maybe LanguageVersion

- Keiro.Dsl.LanguageVersion: [definitionRuntimeSemanticsProfile] :: LanguageDefinition -> !RuntimeSemanticsProfile

- Keiro.Dsl.LanguageVersion: [definitionSupport] :: LanguageDefinition -> !LanguageSupport

- Keiro.Dsl.LanguageVersion: [definitionSyntaxProfile] :: LanguageDefinition -> !SyntaxProfile

- Keiro.Dsl.LanguageVersion: [definitionVersion] :: LanguageDefinition -> !LanguageVersion

- Keiro.Dsl.LanguageVersion: [parsedSourceLanguage] :: ParsedSource -> !SourceLanguage

- Keiro.Dsl.LanguageVersion: [parsedSpec] :: ParsedSource -> !Spec

- Keiro.Dsl.LanguageVersion: [sourceLanguageDeclaredVersion] :: SourceLanguageDiagnostic -> !Maybe LanguageVersion

- Keiro.Dsl.LanguageVersion: [sourceLanguageErrorCode] :: SourceLanguageDiagnostic -> !SourceLanguageErrorCode

- Keiro.Dsl.LanguageVersion: [sourceLanguageLoc] :: SourceLanguageDiagnostic -> !Loc

- Keiro.Dsl.LanguageVersion: [sourceLanguageSource] :: SourceLanguageDiagnostic -> !FilePath

- Keiro.Dsl.LanguageVersion: [sourceLanguageSupportedVersions] :: SourceLanguageDiagnostic -> !NonEmpty LanguageVersion

- Keiro.Dsl.LanguageVersion: [sourceLanguageToken] :: SourceLanguageDiagnostic -> !Maybe Text

- Keiro.Dsl.MappedConsumer: [consumerMappings] :: ConsumerPlan -> ![MappingIdentity]

- Keiro.Dsl.MappedConsumer: [consumerModules] :: ConsumerPlan -> ![Text]

- Keiro.Dsl.MappedConsumer: [consumerPackages] :: ConsumerPlan -> ![Text]

- Keiro.Dsl.MappedConsumer: [mappingBindingSymbol] :: MappingIdentity -> !Text

- Keiro.Dsl.MappedConsumer: [mappingBindingVersion] :: MappingIdentity -> !Text

- Keiro.Dsl.MappedConsumer: [mappingCanonicalType] :: MappingIdentity -> !Text

- Keiro.Dsl.MappedConsumer: [mappingCodecIdentity] :: MappingIdentity -> !Text

- Keiro.Dsl.MappedConsumer: [mappingCodecVersion] :: MappingIdentity -> !Text

- Keiro.Dsl.MappedConsumer: [mappingFixtureSymbol] :: MappingIdentity -> !Text

- Keiro.Dsl.MappedConsumer: [mappingInitialSymbol] :: MappingIdentity -> !Maybe Text

- Keiro.Dsl.MappedConsumer: [mappingModule] :: MappingIdentity -> !Text

- Keiro.Dsl.MappedConsumer: [mappingNominalCategory] :: MappingIdentity -> !Text

- Keiro.Dsl.MappedConsumer: [mappingNominalRepresentation] :: MappingIdentity -> !Text

- Keiro.Dsl.MappedConsumer: [mappingPackage] :: MappingIdentity -> !Text

- Keiro.Dsl.MappedConsumer: [mappingSpecName] :: MappingIdentity -> !Text

- Keiro.Dsl.MappedConsumer: [mappingType] :: MappingIdentity -> !Text

- Keiro.Dsl.MappedDiff: [mfCode] :: MappedFinding -> !DiagnosticCode

- Keiro.Dsl.MappedDiff: [mfDeclaration] :: MappedFinding -> !Name

- Keiro.Dsl.MappedDiff: [mfDetail] :: MappedFinding -> !Text

- Keiro.Dsl.MappedDiff: [mfLeaf] :: MappedFinding -> !Text

- Keiro.Dsl.MappedDiff: [mfOldUnknownFields] :: MappedFinding -> !Maybe UnknownFields

- Keiro.Dsl.MappedDiff: [mfUsePaths] :: MappedFinding -> ![UsePath]

- Keiro.Dsl.NominalType: [consumerNominalBindingVersion] :: ConsumerNominalBinding -> !BindingVersion

- Keiro.Dsl.NominalType: [consumerNominalBinding] :: ConsumerNominalBinding -> !QualifiedValueName

- Keiro.Dsl.NominalType: [consumerNominalCanonical] :: ConsumerNominalBinding -> !CanonicalTypeId

- Keiro.Dsl.NominalType: [consumerNominalFixtures] :: ConsumerNominalBinding -> !QualifiedValueName

- Keiro.Dsl.NominalType: [consumerNominalHaskell] :: ConsumerNominalBinding -> !HaskellSource

- Keiro.Dsl.NominalType: [consumerNominalInitial] :: ConsumerNominalBinding -> !Maybe QualifiedValueName

- Keiro.Dsl.NominalType: [equalityContractVersion] :: CheckedNominalEquality -> !Text

- Keiro.Dsl.NominalType: [equalityDomain] :: CheckedNominalEquality -> !NominalEqualityDomain

- Keiro.Dsl.NominalType: [equalityKeyRepresentation] :: CheckedNominalEquality -> !NominalEqualityKey

- Keiro.Dsl.NominalType: [resolvedNominalLoc] :: ResolvedNominalType -> !Loc

- Keiro.Dsl.NominalType: [resolvedNominalName] :: ResolvedNominalType -> !Name

- Keiro.Dsl.NominalType: [resolvedNominalOwnership] :: ResolvedNominalType -> !NominalOwnership

- Keiro.Dsl.NominalType: [resolvedNominalRepresentation] :: ResolvedNominalType -> !NominalRepresentation

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

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

- Keiro.Dsl.Parser: [parsedSourceLanguage] :: ParsedSource -> !SourceLanguage

- Keiro.Dsl.Parser: [parsedSpec] :: ParsedSource -> !Spec

- 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.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.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.Scaffold: [aAggregate] :: Agg -> !Aggregate

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

- Keiro.Dsl.Scaffold: [aCommands] :: Agg -> ![ResolvedCtor]

- Keiro.Dsl.Scaffold: [aContext] :: Agg -> !Context

- Keiro.Dsl.Scaffold: [aCtxPascal] :: Agg -> !Text

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

- Keiro.Dsl.Scaffold: [aEnums] :: Agg -> ![EnumDecl]

- Keiro.Dsl.Scaffold: [aEvents] :: Agg -> ![ResolvedCtor]

- Keiro.Dsl.Scaffold: [aFoldFingerprint] :: Agg -> !Text

- Keiro.Dsl.Scaffold: [aGenPrefix] :: Agg -> !Text

- Keiro.Dsl.Scaffold: [aGeneratedNominals] :: Agg -> ![ResolvedNominalType]

- Keiro.Dsl.Scaffold: [aHolePrefix] :: Agg -> !Text

- Keiro.Dsl.Scaffold: [aIds] :: Agg -> ![IdDecl]

- Keiro.Dsl.Scaffold: [aLanguageContract] :: Agg -> !EffectiveLanguageContract

- Keiro.Dsl.Scaffold: [aLoc] :: Agg -> !Loc

- Keiro.Dsl.Scaffold: [aName] :: Agg -> !Text

- Keiro.Dsl.Scaffold: [aOutputMappings] :: Agg -> !Map (Int, Int) EventOutputMapping

- Keiro.Dsl.Scaffold: [aProjection] :: Agg -> !Maybe ProjectionSpec

- Keiro.Dsl.Scaffold: [aReadModels] :: Agg -> ![ReadModelNode]

- Keiro.Dsl.Scaffold: [aRegs] :: Agg -> ![ResolvedRegister]

- Keiro.Dsl.Scaffold: [aSnapshot] :: Agg -> !Maybe SnapshotSpec

- Keiro.Dsl.Scaffold: [aSpec] :: Agg -> !Spec

- Keiro.Dsl.Scaffold: [aStates] :: Agg -> ![StateDecl]

- Keiro.Dsl.Scaffold: [aSymbols] :: Agg -> !AggregateSymbols

- Keiro.Dsl.Scaffold: [aTransitions] :: Agg -> ![Transition]

- Keiro.Dsl.Scaffold: [aTypeGraph] :: Agg -> !Maybe TypeGraph

- Keiro.Dsl.Scaffold: [aVertexType] :: Agg -> !Text

- Keiro.Dsl.Scaffold: [aWire] :: Agg -> !WireSpec

- Keiro.Dsl.Scaffold: [contextName] :: Context -> !Text

- Keiro.Dsl.Scaffold: [modulePath] :: ScaffoldModule -> !FilePath

- Keiro.Dsl.Scaffold: [moduleText] :: ScaffoldModule -> !Text

- Keiro.Dsl.Scaffold: [nominalDeclaration] :: NominalGenerationOwner -> !ResolvedNominalType

- Keiro.Dsl.Scaffold: [nominalEqualityUsed] :: NominalGenerationOwner -> !Bool

- Keiro.Dsl.Scaffold: [nominalModule] :: NominalGenerationOwner -> !Text

- Keiro.Dsl.Scaffold: [nominalUseAggregate] :: NominalUseSite -> !Name

- Keiro.Dsl.Scaffold: [nominalUseKind] :: NominalUseSite -> !AggregateUseSite

- Keiro.Dsl.Scaffold: [nominalUseSites] :: NominalGenerationOwner -> !Set NominalUseSite

- Keiro.Dsl.Scaffold: [rcFields] :: ResolvedCtor -> ![(ResolvedFieldIdentity, ResolvedAggregateType)]

- Keiro.Dsl.Scaffold: [rcName] :: ResolvedCtor -> !Text

- Keiro.Dsl.Scaffold: [rcUpcastFrom] :: ResolvedCtor -> !Maybe Int

- Keiro.Dsl.Scaffold: [rcVersion] :: ResolvedCtor -> !Int

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

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

- Keiro.Dsl.Scaffold: [roleFamily] :: ModuleRole -> !Text

- Keiro.Dsl.Scaffold: [roleOwnerKind] :: ModuleRole -> !Text

- Keiro.Dsl.Scaffold: [roleOwnerName] :: ModuleRole -> !Text

- Keiro.Dsl.Scaffold: [rrInitial] :: ResolvedRegister -> !ResolvedRegisterInitial

- Keiro.Dsl.Scaffold: [rrLoc] :: ResolvedRegister -> !Loc

- Keiro.Dsl.Scaffold: [rrName] :: ResolvedRegister -> !Name

- Keiro.Dsl.Scaffold: [rrType] :: ResolvedRegister -> !ResolvedAggregateType

- Keiro.Dsl.Scaffold: [spBinding] :: StructuralProjection -> !QualifiedValueName

- Keiro.Dsl.Scaffold: [spCanonical] :: StructuralProjection -> !CanonicalTypeId

- Keiro.Dsl.Scaffold: [spOwner] :: StructuralProjection -> !HaskellSource

- Keiro.Dsl.Scaffold: [spPointer] :: StructuralProjection -> !Text

- Keiro.Dsl.Scaffold: [spResult] :: StructuralProjection -> !Text

- Keiro.Dsl.Scaffold: [spSelectors] :: StructuralProjection -> ![(Text, Text)]

- Keiro.Dsl.Scaffold: [spTag] :: StructuralProjection -> !Text

- Keiro.Dsl.Scaffold: [spWitness] :: StructuralProjection -> !Text

- Keiro.Dsl.ScaffoldRecord: [recBehaviorRequirements] :: ScaffoldRecord -> ![BehaviorRecordRow]

- Keiro.Dsl.ScaffoldRecord: [recBindingObligations] :: ScaffoldRecord -> ![BindingHole]

- Keiro.Dsl.ScaffoldRecord: [recFiles] :: ScaffoldRecord -> ![(ModuleKind, FilePath)]

- Keiro.Dsl.ScaffoldRecord: [recIdDomains] :: ScaffoldRecord -> ![Text]

- Keiro.Dsl.ScaffoldRecord: [recLanguageContract] :: ScaffoldRecord -> !EffectiveLanguageContract

- Keiro.Dsl.ScaffoldRecord: [recLayout] :: ScaffoldRecord -> !Text

- Keiro.Dsl.ScaffoldRecord: [recMappings] :: ScaffoldRecord -> ![MappingIdentity]

- Keiro.Dsl.ScaffoldRecord: [recModuleRoles] :: ScaffoldRecord -> ![ScaffoldModuleRoleRow]

- Keiro.Dsl.ScaffoldRecord: [recModuleRoot] :: ScaffoldRecord -> !Text

- Keiro.Dsl.ScaffoldRecord: [recNamingEdition] :: ScaffoldRecord -> !GeneratedHaskellNamingEdition

- Keiro.Dsl.ScaffoldRecord: [recNominalEqualities] :: ScaffoldRecord -> ![Text]

- 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: [recSourceLanguage] :: ScaffoldRecord -> !SourceLanguage

- Keiro.Dsl.ScaffoldRecord: [recSpecPath] :: ScaffoldRecord -> !Text

- Keiro.Dsl.ScaffoldRecord: [srrKind] :: ScaffoldModuleRoleRow -> !ModuleKind

- Keiro.Dsl.ScaffoldRecord: [srrPath] :: ScaffoldModuleRoleRow -> !FilePath

- Keiro.Dsl.ScaffoldRecord: [srrRole] :: ScaffoldModuleRoleRow -> !ModuleRole

- 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: [driftCurrent] :: MappingDrift -> !Maybe MappingIdentity

- Keiro.Dsl.ScaffoldRun: [driftPrevious] :: MappingDrift -> !Maybe MappingIdentity

- Keiro.Dsl.ScaffoldRun: [driftSpecName] :: MappingDrift -> !Text

- Keiro.Dsl.ScaffoldRun: [languageDriftCurrent] :: SourceLanguageDrift -> !SourceLanguage

- Keiro.Dsl.ScaffoldRun: [languageDriftPrevious] :: SourceLanguageDrift -> !SourceLanguage

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

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

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

- Keiro.Dsl.ScaffoldRun: [reportAddedBehavior] :: ScaffoldReport -> ![BehaviorRecordRow]

- Keiro.Dsl.ScaffoldRun: [reportConformancePackage] :: ScaffoldReport -> !Maybe ConformancePackageReport

- Keiro.Dsl.ScaffoldRun: [reportConstraintPlan] :: ScaffoldReport -> ![Text]

- Keiro.Dsl.ScaffoldRun: [reportConsumerPlan] :: ScaffoldReport -> !ConsumerPlan

- Keiro.Dsl.ScaffoldRun: [reportContext] :: ScaffoldReport -> !Context

- Keiro.Dsl.ScaffoldRun: [reportDispositions] :: ScaffoldReport -> ![(ScaffoldModule, WriteDisposition)]

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

- Keiro.Dsl.ScaffoldRun: [reportInertNodes] :: ScaffoldReport -> ![(Text, Text)]

- Keiro.Dsl.ScaffoldRun: [reportManifestPath] :: ScaffoldReport -> !FilePath

- Keiro.Dsl.ScaffoldRun: [reportMappingDrift] :: ScaffoldReport -> ![MappingDrift]

- Keiro.Dsl.ScaffoldRun: [reportNameMoves] :: ScaffoldReport -> ![SourceMove]

- Keiro.Dsl.ScaffoldRun: [reportNewHoles] :: ScaffoldReport -> ![BindingHole]

- Keiro.Dsl.ScaffoldRun: [reportObsoleteOutputHooks] :: ScaffoldReport -> ![(Text, Text)]

- Keiro.Dsl.ScaffoldRun: [reportOutDir] :: ScaffoldReport -> !FilePath

- Keiro.Dsl.ScaffoldRun: [reportPreviousSpecPath] :: ScaffoldReport -> !Maybe Text

- 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: [reportRecordPath] :: ScaffoldReport -> !FilePath

- Keiro.Dsl.ScaffoldRun: [reportRemovedBehavior] :: ScaffoldReport -> ![BehaviorRecordRow]

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

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

- Keiro.Dsl.ScaffoldRun: [reportSidecarMoves] :: ScaffoldReport -> ![SidecarMove]

- Keiro.Dsl.ScaffoldRun: [reportSourceLanguageDrift] :: ScaffoldReport -> !Maybe SourceLanguageDrift

- Keiro.Dsl.ScaffoldRun: [reportSpecPath] :: ScaffoldReport -> !FilePath

- Keiro.Dsl.ScaffoldRun: [reportStale] :: ScaffoldReport -> ![StaleModule]

- Keiro.Dsl.ScaffoldRun: [staleGeneratedEvidence] :: StaleModule -> !Maybe StaleGeneratedEvidence

- Keiro.Dsl.ScaffoldRun: [staleKind] :: StaleModule -> !ModuleKind

- Keiro.Dsl.ScaffoldRun: [stalePath] :: StaleModule -> !FilePath

- Keiro.Dsl.SemanticContract: effectiveContractLanguageVersion :: EffectiveLanguageContract -> LanguageVersion

- Keiro.Dsl.SemanticContract: effectiveRuntimeProfile :: EffectiveLanguageContract -> RuntimeSemanticsProfile

- 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.SidecarMigration: [sidecarBackupPath] :: SidecarMove -> !Maybe FilePath

- Keiro.Dsl.SidecarMigration: [sidecarMoveDisposition] :: SidecarMove -> !SidecarMoveDisposition

- Keiro.Dsl.SidecarMigration: [sidecarNewPath] :: SidecarMove -> !FilePath

- Keiro.Dsl.SidecarMigration: [sidecarOldPath] :: SidecarMove -> !FilePath

- 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.TypeGraph: [odCodecIdentity] :: OpaqueDecl -> !CodecIdentity

- Keiro.Dsl.TypeGraph: [odCodecVersion] :: OpaqueDecl -> !CodecVersion

- Keiro.Dsl.TypeGraph: [odFixtures] :: OpaqueDecl -> !QualifiedValueName

- Keiro.Dsl.TypeGraph: [odHaskell] :: OpaqueDecl -> !HaskellSource

- Keiro.Dsl.TypeGraph: [odInitial] :: OpaqueDecl -> !Maybe QualifiedValueName

- Keiro.Dsl.TypeGraph: [odLoc] :: OpaqueDecl -> !Loc

- Keiro.Dsl.TypeGraph: [odName] :: OpaqueDecl -> !Name

- Keiro.Dsl.TypeGraph: [rwaCtor] :: ResolvedWireArm -> !Name

- Keiro.Dsl.TypeGraph: [rwaLoc] :: ResolvedWireArm -> !Loc

- Keiro.Dsl.TypeGraph: [rwaPayload] :: ResolvedWireArm -> !Maybe ResolvedTypeExpr

- Keiro.Dsl.TypeGraph: [rwaTag] :: ResolvedWireArm -> !Text

- Keiro.Dsl.TypeGraph: [rwfHaskell] :: ResolvedWireField -> !Name

- Keiro.Dsl.TypeGraph: [rwfKey] :: ResolvedWireField -> !Text

- Keiro.Dsl.TypeGraph: [rwfLoc] :: ResolvedWireField -> !Loc

- Keiro.Dsl.TypeGraph: [rwfOnMissing] :: ResolvedWireField -> !Maybe OnMissing

- Keiro.Dsl.TypeGraph: [rwfPresence] :: ResolvedWireField -> !Presence

- Keiro.Dsl.TypeGraph: [rwfType] :: ResolvedWireField -> !ResolvedTypeExpr

- Keiro.Dsl.TypeGraph: [sdBindingVersion] :: StructuralDecl -> !BindingVersion

- Keiro.Dsl.TypeGraph: [sdBinding] :: StructuralDecl -> !QualifiedValueName

- Keiro.Dsl.TypeGraph: [sdCanonical] :: StructuralDecl -> !CanonicalTypeId

- Keiro.Dsl.TypeGraph: [sdFixtures] :: StructuralDecl -> !QualifiedValueName

- Keiro.Dsl.TypeGraph: [sdHaskell] :: StructuralDecl -> !HaskellSource

- Keiro.Dsl.TypeGraph: [sdInitial] :: StructuralDecl -> !Maybe QualifiedValueName

- Keiro.Dsl.TypeGraph: [sdLoc] :: StructuralDecl -> !Loc

- Keiro.Dsl.TypeGraph: [sdName] :: StructuralDecl -> !Name

- Keiro.Dsl.TypeGraph: [tgDeclarations] :: TypeGraph -> !Map MappedKey ResolvedMappedDecl

- Keiro.Dsl.TypeGraph: [tgDerivedMappedConsumers] :: TypeGraph -> ![DerivedMappedConsumer]

- Keiro.Dsl.TypeGraph: [tgProjectionOperationalIdentities] :: TypeGraph -> !Map DerivedMappedConsumer Text

- Keiro.Dsl.TypeGraph: [tgReachability] :: TypeGraph -> !Map MappedKey (Set MappedKey)

- 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: [tgUseSites] :: TypeGraph -> ![UseSite]

- Keiro.Dsl.TypeGraph: [upRoot] :: UsePath -> !UseSite

- Keiro.Dsl.TypeGraph: [upSegments] :: UsePath -> ![PathSeg]

- Keiro.Dsl.Workspace: [oiDeclarations] :: OwnershipIndex -> !Map (Text, Name) (FilePath, Loc)

- Keiro.Dsl.Workspace: [oiNodes] :: OwnershipIndex -> !Map (Text, Name) (FilePath, Loc)

- Keiro.Dsl.Workspace: [wdCode] :: WorkspaceDiagnostic -> !DiagnosticCode

- Keiro.Dsl.Workspace: [wdLocations] :: WorkspaceDiagnostic -> !NonEmpty WorkspaceLocation

- Keiro.Dsl.Workspace: [wdMessage] :: WorkspaceDiagnostic -> !Text

- Keiro.Dsl.Workspace: [wdSeverity] :: WorkspaceDiagnostic -> !Severity

- Keiro.Dsl.Workspace: [wdSourceLanguageCause] :: WorkspaceDiagnostic -> !Maybe SourceLanguageDiagnostic

- Keiro.Dsl.Workspace: [wlFile] :: WorkspaceLocation -> !WorkspaceFile

- Keiro.Dsl.Workspace: [wlLine] :: WorkspaceLocation -> !Int

- Keiro.Dsl.Workspace: [wlRole] :: WorkspaceLocation -> !Text

- Keiro.Dsl.Workspace: [wmLineBase] :: WorkspaceMember -> !Int

- Keiro.Dsl.Workspace: [wmLineCount] :: WorkspaceMember -> !Int

- Keiro.Dsl.Workspace: [wmPath] :: WorkspaceMember -> !FilePath

- Keiro.Dsl.Workspace: [wmSourceIndex] :: WorkspaceMember -> !SemanticSourceIndex

- Keiro.Dsl.Workspace: [wmSourceLanguage] :: WorkspaceMember -> !SourceLanguage

- Keiro.Dsl.Workspace: [wmSpec] :: WorkspaceMember -> !Spec

- Keiro.Dsl.Workspace: [wmfLayoutLoc] :: WorkspaceManifest -> !Loc

- Keiro.Dsl.Workspace: [wmfLayout] :: WorkspaceManifest -> !Maybe Placement

- Keiro.Dsl.Workspace: [wmfMembers] :: WorkspaceManifest -> !NonEmpty WorkspaceMemberRef

- Keiro.Dsl.Workspace: [wmfModuleRootLoc] :: WorkspaceManifest -> !Loc

- Keiro.Dsl.Workspace: [wmfModuleRoot] :: WorkspaceManifest -> !Maybe Text

- Keiro.Dsl.Workspace: [wmfRuntimePackageLoc] :: WorkspaceManifest -> !Loc

- Keiro.Dsl.Workspace: [wmfRuntimePackage] :: WorkspaceManifest -> !Maybe RuntimePackageName

- Keiro.Dsl.Workspace: [wmfServiceLoc] :: WorkspaceManifest -> !Loc

- Keiro.Dsl.Workspace: [wmfService] :: WorkspaceManifest -> !Text

- Keiro.Dsl.Workspace: [wmrLoc] :: WorkspaceMemberRef -> !Loc

- Keiro.Dsl.Workspace: [wmrPath] :: WorkspaceMemberRef -> !FilePath

- Keiro.Dsl.Workspace: [wsContext] :: WorkspaceSpec -> !Name

- Keiro.Dsl.Workspace: [wsLanguageContract] :: WorkspaceSpec -> !EffectiveLanguageContract

- Keiro.Dsl.Workspace: [wsLayout] :: WorkspaceSpec -> !Maybe Placement

- Keiro.Dsl.Workspace: [wsLineMap] :: WorkspaceSpec -> !LineMap

- Keiro.Dsl.Workspace: [wsManifestPath] :: WorkspaceSpec -> !FilePath

- Keiro.Dsl.Workspace: [wsMembers] :: WorkspaceSpec -> ![WorkspaceMember]

- Keiro.Dsl.Workspace: [wsMergedSpec] :: WorkspaceSpec -> !Spec

- Keiro.Dsl.Workspace: [wsModuleRoot] :: WorkspaceSpec -> !Maybe Text

- Keiro.Dsl.Workspace: [wsOwnership] :: WorkspaceSpec -> !OwnershipIndex

- Keiro.Dsl.Workspace: [wsRuntimePackage] :: WorkspaceSpec -> !Maybe RuntimePackageName

- Keiro.Dsl.Workspace: [wsService] :: WorkspaceSpec -> !Text

- Keiro.Dsl.Workspace: [wsSourceIndex] :: WorkspaceSpec -> !SemanticSourceIndex

- Keiro.Dsl.WorkspaceAdoption: [cfEvidence] :: ClaimedFile -> !ClaimEvidence

- Keiro.Dsl.WorkspaceAdoption: [cfPath] :: ClaimedFile -> !FilePath

- Keiro.Dsl.WorkspaceAdoption: [cfSource] :: ClaimedFile -> !Maybe Text

- Keiro.Dsl.WorkspaceAdoption: [cfSpec] :: ClaimedFile -> !Maybe Text

- Keiro.Dsl.WorkspaceAdoption: [mrClaimed] :: MigrationReport -> ![ClaimedFile]

- Keiro.Dsl.WorkspaceAdoption: [mrLegacyRecord] :: MigrationReport -> !Maybe (FilePath, Text)

- Keiro.Dsl.WorkspaceAdoption: [mrLikelyStale] :: MigrationReport -> ![StaleModule]

- Keiro.Dsl.WorkspaceAdoption: [mrService] :: MigrationReport -> !Text

- Keiro.Dsl.WorkspaceAdoption: [mrUnclaimed] :: MigrationReport -> ![FilePath]

- Keiro.Dsl.WorkspaceDiff: [osFile] :: OwnedSite -> !FilePath

- Keiro.Dsl.WorkspaceDiff: [osLine] :: OwnedSite -> !Int

- Keiro.Dsl.WorkspaceDiff: [wcChange] :: WorkspaceChange -> !Change

- Keiro.Dsl.WorkspaceDiff: [wcDeclarationSite] :: WorkspaceChange -> !Maybe OwnedSite

- Keiro.Dsl.WorkspaceDiff: [wcUseSites] :: WorkspaceChange -> ![(Text, Maybe OwnedSite)]

- Keiro.Dsl.WorkspaceDiff: [wmAdoptionBaseline] :: WorkspaceMeta -> !Bool

- Keiro.Dsl.WorkspaceDiff: [wmIdentity] :: WorkspaceMeta -> !Text

- Keiro.Dsl.WorkspaceDiff: [wmManifest] :: WorkspaceMeta -> !FilePath

- Keiro.Dsl.WorkspaceDiff: [wmMembersNew] :: WorkspaceMeta -> ![FilePath]

- Keiro.Dsl.WorkspaceDiff: [wmMembersOld] :: WorkspaceMeta -> ![FilePath]

- Keiro.Dsl.WorkspaceDiff: [wmSince] :: WorkspaceMeta -> !Text

- Keiro.Dsl.WorkspaceRecord: [adEvidence] :: AdoptedRow -> !Text

- Keiro.Dsl.WorkspaceRecord: [adPath] :: AdoptedRow -> !FilePath

- Keiro.Dsl.WorkspaceRecord: [adSource] :: AdoptedRow -> !Maybe Text

- Keiro.Dsl.WorkspaceRecord: [adSpec] :: AdoptedRow -> !Maybe Text

- Keiro.Dsl.WorkspaceRecord: [wrAdopted] :: WorkspaceRecord -> ![AdoptedRow]

- Keiro.Dsl.WorkspaceRecord: [wrBehaviorRequirements] :: WorkspaceRecord -> ![BehaviorRecordRow]

- Keiro.Dsl.WorkspaceRecord: [wrBindingObligations] :: WorkspaceRecord -> ![BindingHole]

- Keiro.Dsl.WorkspaceRecord: [wrContext] :: WorkspaceRecord -> !Text

- Keiro.Dsl.WorkspaceRecord: [wrIdDomains] :: WorkspaceRecord -> ![Text]

- Keiro.Dsl.WorkspaceRecord: [wrLanguageContract] :: WorkspaceRecord -> !EffectiveLanguageContract

- Keiro.Dsl.WorkspaceRecord: [wrLayout] :: WorkspaceRecord -> !Text

- Keiro.Dsl.WorkspaceRecord: [wrManifest] :: WorkspaceRecord -> !Text

- Keiro.Dsl.WorkspaceRecord: [wrMappings] :: WorkspaceRecord -> ![MappingIdentity]

- Keiro.Dsl.WorkspaceRecord: [wrMembers] :: WorkspaceRecord -> ![FilePath]

- Keiro.Dsl.WorkspaceRecord: [wrModuleRoot] :: WorkspaceRecord -> !Text

- Keiro.Dsl.WorkspaceRecord: [wrModules] :: WorkspaceRecord -> ![WorkspaceModuleRow]

- Keiro.Dsl.WorkspaceRecord: [wrNamingEdition] :: WorkspaceRecord -> !GeneratedHaskellNamingEdition

- Keiro.Dsl.WorkspaceRecord: [wrNominalEqualities] :: WorkspaceRecord -> ![Text]

- 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.WorkspaceRecord: [wrService] :: WorkspaceRecord -> !Text

- Keiro.Dsl.WorkspaceRecord: [wrSourceLanguages] :: WorkspaceRecord -> ![WorkspaceSourceLanguageRow]

- Keiro.Dsl.WorkspaceRecord: [wrmKind] :: WorkspaceModuleRow -> !ModuleKind

- Keiro.Dsl.WorkspaceRecord: [wrmOwner] :: WorkspaceModuleRow -> !Maybe FilePath

- Keiro.Dsl.WorkspaceRecord: [wrmPath] :: WorkspaceModuleRow -> !FilePath

- Keiro.Dsl.WorkspaceRecord: [wrmRole] :: WorkspaceModuleRow -> !Maybe ModuleRole

- Keiro.Dsl.WorkspaceRecord: [wrslPath] :: WorkspaceSourceLanguageRow -> !FilePath

- Keiro.Dsl.WorkspaceRecord: [wrslSourceLanguage] :: WorkspaceSourceLanguageRow -> !SourceLanguage

- Keiro.Dsl.WorkspaceScaffold: [omCurrent] :: OwnershipMove -> !Maybe FilePath

- Keiro.Dsl.WorkspaceScaffold: [omPath] :: OwnershipMove -> !FilePath

- Keiro.Dsl.WorkspaceScaffold: [omPrevious] :: OwnershipMove -> !Maybe FilePath

- Keiro.Dsl.WorkspaceScaffold: [wpCheckedService] :: WorkspacePlan -> !CheckedService

- Keiro.Dsl.WorkspaceScaffold: [wpConformancePackage] :: WorkspacePlan -> !Maybe ConformancePackagePlan

- Keiro.Dsl.WorkspaceScaffold: [wpContext] :: WorkspacePlan -> !Context

- Keiro.Dsl.WorkspaceScaffold: [wpGoldenRoot] :: WorkspacePlan -> !FilePath

- Keiro.Dsl.WorkspaceScaffold: [wpModules] :: WorkspacePlan -> ![(ScaffoldModule, ModuleProvenance)]

- Keiro.Dsl.WorkspaceScaffold: [wpRuntimePackage] :: WorkspacePlan -> !Maybe RuntimePackageName

- Keiro.Dsl.WorkspaceScaffold: [wpWorkspace] :: WorkspacePlan -> !WorkspaceSpec

- Keiro.Dsl.WorkspaceScaffold: [wsldCurrent] :: WorkspaceSourceLanguageDrift -> !SourceLanguage

- Keiro.Dsl.WorkspaceScaffold: [wsldPath] :: WorkspaceSourceLanguageDrift -> !FilePath

- Keiro.Dsl.WorkspaceScaffold: [wsldPrevious] :: WorkspaceSourceLanguageDrift -> !SourceLanguage

- Keiro.Dsl.WorkspaceScaffold: [wsrAddedBehavior] :: WorkspaceScaffoldReport -> ![BehaviorRecordRow]

- Keiro.Dsl.WorkspaceScaffold: [wsrBuildManifestPath] :: WorkspaceScaffoldReport -> !FilePath

- Keiro.Dsl.WorkspaceScaffold: [wsrConformancePackage] :: WorkspaceScaffoldReport -> !Maybe ConformancePackageReport

- Keiro.Dsl.WorkspaceScaffold: [wsrConstraintPlan] :: WorkspaceScaffoldReport -> ![Text]

- Keiro.Dsl.WorkspaceScaffold: [wsrConsumerPlan] :: WorkspaceScaffoldReport -> !ConsumerPlan

- Keiro.Dsl.WorkspaceScaffold: [wsrContext] :: WorkspaceScaffoldReport -> !Context

- Keiro.Dsl.WorkspaceScaffold: [wsrDispositions] :: WorkspaceScaffoldReport -> ![(ScaffoldModule, ModuleProvenance, WriteDisposition)]

- Keiro.Dsl.WorkspaceScaffold: [wsrGeneratedArtifactImpact] :: WorkspaceScaffoldReport -> ![GeneratedArtifactImpact]

- Keiro.Dsl.WorkspaceScaffold: [wsrInertNodes] :: WorkspaceScaffoldReport -> ![(Text, Text)]

- Keiro.Dsl.WorkspaceScaffold: [wsrManifestPath] :: WorkspaceScaffoldReport -> !FilePath

- Keiro.Dsl.WorkspaceScaffold: [wsrMappingDrift] :: WorkspaceScaffoldReport -> ![MappingDrift]

- Keiro.Dsl.WorkspaceScaffold: [wsrMembers] :: WorkspaceScaffoldReport -> ![FilePath]

- Keiro.Dsl.WorkspaceScaffold: [wsrMigration] :: WorkspaceScaffoldReport -> !Maybe MigrationReport

- Keiro.Dsl.WorkspaceScaffold: [wsrNameMoves] :: WorkspaceScaffoldReport -> ![SourceMove]

- Keiro.Dsl.WorkspaceScaffold: [wsrNewHoles] :: WorkspaceScaffoldReport -> ![BindingHole]

- Keiro.Dsl.WorkspaceScaffold: [wsrObsoleteOutputHooks] :: WorkspaceScaffoldReport -> ![(Text, Text)]

- Keiro.Dsl.WorkspaceScaffold: [wsrOutDir] :: WorkspaceScaffoldReport -> !FilePath

- Keiro.Dsl.WorkspaceScaffold: [wsrOwnershipMoves] :: WorkspaceScaffoldReport -> ![OwnershipMove]

- Keiro.Dsl.WorkspaceScaffold: [wsrPreviousManifest] :: WorkspaceScaffoldReport -> !Maybe Text

- 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: [wsrRecordPath] :: WorkspaceScaffoldReport -> !FilePath

- Keiro.Dsl.WorkspaceScaffold: [wsrRemovedBehavior] :: WorkspaceScaffoldReport -> ![BehaviorRecordRow]

- Keiro.Dsl.WorkspaceScaffold: [wsrRouterSelectionDrift] :: WorkspaceScaffoldReport -> ![RouterSelectionDrift]

- Keiro.Dsl.WorkspaceScaffold: [wsrSemanticImpact] :: WorkspaceScaffoldReport -> !SemanticImpactReport

- Keiro.Dsl.WorkspaceScaffold: [wsrService] :: WorkspaceScaffoldReport -> !Text

- Keiro.Dsl.WorkspaceScaffold: [wsrSidecarMoves] :: WorkspaceScaffoldReport -> ![SidecarMove]

- Keiro.Dsl.WorkspaceScaffold: [wsrSourceLanguageDrift] :: WorkspaceScaffoldReport -> ![WorkspaceSourceLanguageDrift]

- Keiro.Dsl.WorkspaceScaffold: [wsrStale] :: WorkspaceScaffoldReport -> ![StaleModule]

+ Keiro.Dsl.AggregateType: [loc] :: AggregateTypeError -> !Loc

+ Keiro.Dsl.AggregateType: [reason] :: AggregateTypeError -> !AggregateTypeErrorReason

+ Keiro.Dsl.AggregateType: [useSite] :: AggregateTypeError -> !AggregateUseSite

+ Keiro.Dsl.BehaviorCoverage: [aggregate] :: BehaviorRecordRow -> !Name

+ Keiro.Dsl.BehaviorCoverage: [canonical] :: BehaviorRequirement -> !Text

+ Keiro.Dsl.BehaviorCoverage: [command] :: BehaviorRecordRow -> !Name

+ Keiro.Dsl.BehaviorCoverage: [context] :: BehaviorRequirement -> !Name

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

+ Keiro.Dsl.BehaviorCoverage: [events] :: BehaviorRequirement -> ![Name]

+ Keiro.Dsl.BehaviorCoverage: [evidence] :: BehaviorRecordRow -> !EvidenceLevel

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

+ Keiro.Dsl.BehaviorCoverage: [guardCoverage] :: BehaviorRequirement -> !GuardCoverage

+ Keiro.Dsl.BehaviorCoverage: [key] :: BehaviorRecordRow -> !BehaviorKey

+ Keiro.Dsl.BehaviorCoverage: [kind] :: BehaviorRecordRow -> !ObligationKind

+ Keiro.Dsl.BehaviorCoverage: [location] :: BehaviorRequirement -> !Loc

+ Keiro.Dsl.BehaviorCoverage: [mode] :: BehaviorRequirement -> !Maybe TransitionMode

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

+ Keiro.Dsl.BehaviorCoverage: [outputs] :: BehaviorRecordRow -> ![OutputEvidence]

+ Keiro.Dsl.BehaviorCoverage: [owner] :: BehaviorRecordRow -> !Maybe FilePath

+ Keiro.Dsl.BehaviorCoverage: [requirements] :: BehaviorObligationsReport -> ![BehaviorRequirement]

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

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

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

+ Keiro.Dsl.BehaviorCoverage: [source] :: BehaviorRecordRow -> !Name

+ Keiro.Dsl.BehaviorCoverage: [subject] :: BehaviorObligationsReport -> !FilePath

+ Keiro.Dsl.BehaviorCoverage: [target] :: BehaviorRequirement -> !Maybe Name

+ Keiro.Dsl.BehaviorCoverage: [workspaceService] :: BehaviorObligationsReport -> !Maybe Text

+ Keiro.Dsl.BehaviorCoverage: unBehaviorKey :: BehaviorKey -> Text

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

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

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

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

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

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

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

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

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

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

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

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

+ Keiro.Dsl.CheckReport: [code] :: CheckReportEntry -> !DiagnosticCode

+ Keiro.Dsl.CheckReport: [declaredLanguageVersion] :: CheckReportMember -> !Maybe LanguageVersion

+ Keiro.Dsl.CheckReport: [deniedWarnings] :: CheckReportSummary -> !Int

+ Keiro.Dsl.CheckReport: [denied] :: CheckReportEntry -> !Bool

+ Keiro.Dsl.CheckReport: [denyCodes] :: CheckReportEnforcement -> ![DiagnosticCode]

+ Keiro.Dsl.CheckReport: [denyWarnings] :: CheckReportEnforcement -> !Bool

+ Keiro.Dsl.CheckReport: [effectiveLanguageVersion] :: CheckReportLanguage -> !LanguageVersion

+ Keiro.Dsl.CheckReport: [errors] :: CheckReportSummary -> !Int

+ Keiro.Dsl.CheckReport: [file] :: CheckReportEntry -> !FilePath

+ Keiro.Dsl.CheckReport: [languageSupport] :: CheckReportLanguage -> !LanguageSupport

+ Keiro.Dsl.CheckReport: [line] :: CheckReportEntry -> !Int

+ Keiro.Dsl.CheckReport: [message] :: CheckReportEntry -> !Text

+ Keiro.Dsl.CheckReport: [minLanguage] :: CheckReportEnforcement -> !Maybe LanguageVersion

+ Keiro.Dsl.CheckReport: [note] :: CheckReportRelated -> !Text

+ Keiro.Dsl.CheckReport: [path] :: CheckReportMember -> !FilePath

+ Keiro.Dsl.CheckReport: [related] :: CheckReportEntry -> ![CheckReportRelated]

+ Keiro.Dsl.CheckReport: [runtimeSemantics] :: CheckReportLanguage -> !Text

+ Keiro.Dsl.CheckReport: [severity] :: CheckReportEntry -> !Severity

+ Keiro.Dsl.CheckReport: [sourceForm] :: CheckReportMember -> !Text

+ Keiro.Dsl.CheckReport: [stable] :: CheckReportLanguage -> !Bool

+ Keiro.Dsl.CheckReport: [warnings] :: CheckReportSummary -> !Int

+ Keiro.Dsl.CodecCompare: [authority] :: CompareReport -> !Text

+ Keiro.Dsl.CodecCompare: [bindingSymbol] :: CompareProvenance -> !QualifiedValueName

+ Keiro.Dsl.CodecCompare: [bindingVersion] :: CompareProvenance -> !BindingVersion

+ Keiro.Dsl.CodecCompare: [canonicalType] :: CompareProvenance -> !CanonicalTypeId

+ Keiro.Dsl.CodecCompare: [caseName] :: CompareObservation -> !Text

+ Keiro.Dsl.CodecCompare: [coverageGaps] :: CompareReport -> ![CoverageGap]

+ Keiro.Dsl.CodecCompare: [decode] :: HistoricalCodec a -> !Value -> Either Text a

+ Keiro.Dsl.CodecCompare: [encode] :: HistoricalCodec a -> !a -> Value

+ Keiro.Dsl.CodecCompare: [fixturePath] :: CompareObservation -> !FilePath

+ Keiro.Dsl.CodecCompare: [generatedDecode] :: CompareObservation -> !DecodeOutcome

+ Keiro.Dsl.CodecCompare: [generatedValue] :: CompareObservation -> !Value

+ Keiro.Dsl.CodecCompare: [historicalCodecIdentity] :: CompareProvenance -> !Text

+ Keiro.Dsl.CodecCompare: [historicalCodecVersion] :: CompareProvenance -> !Text

+ Keiro.Dsl.CodecCompare: [historicalDecode] :: CompareObservation -> !DecodeOutcome

+ Keiro.Dsl.CodecCompare: [historicalValue] :: CompareObservation -> !Value

+ Keiro.Dsl.CodecCompare: [identity] :: HistoricalCodec a -> !Text

+ Keiro.Dsl.CodecCompare: [inputIssues] :: CompareReport -> ![CompareInputIssue]

+ Keiro.Dsl.CodecCompare: [inputValue] :: CompareObservation -> !Value

+ Keiro.Dsl.CodecCompare: [kind] :: CoverageGap -> !BranchKind

+ Keiro.Dsl.CodecCompare: [message] :: ReportWriteError -> !Text

+ Keiro.Dsl.CodecCompare: [name] :: ClassifiedObservation -> !Text

+ Keiro.Dsl.CodecCompare: [observations] :: CompareReport -> ![ClassifiedObservation]

+ Keiro.Dsl.CodecCompare: [origin] :: ClassifiedObservation -> !FixtureOrigin

+ Keiro.Dsl.CodecCompare: [path] :: ReportWriteError -> !FilePath

+ Keiro.Dsl.CodecCompare: [payloadSchema] :: BranchArm -> !Maybe BranchSchema

+ Keiro.Dsl.CodecCompare: [pointer] :: CoverageGap -> !JsonPointer

+ Keiro.Dsl.CodecCompare: [presenceOptional] :: BranchField -> !Bool

+ Keiro.Dsl.CodecCompare: [provenance] :: CompareReport -> !CompareProvenance

+ Keiro.Dsl.CodecCompare: [schema] :: BranchField -> !BranchSchema

+ Keiro.Dsl.CodecCompare: [verdict] :: ClassifiedObservation -> !FixtureVerdict

+ Keiro.Dsl.CodecCompare: [version] :: HistoricalCodec a -> !Text

+ Keiro.Dsl.CodecCompare: [wireFingerprint] :: CompareProvenance -> !Text

+ Keiro.Dsl.CodecCompare: [wireKey] :: BranchField -> !Text

+ Keiro.Dsl.CodecCompare: [wireTag] :: BranchArm -> !Text

+ Keiro.Dsl.CodecCompare: unJsonPointer :: JsonPointer -> Text

+ Keiro.Dsl.ConformancePackage: [bannerPresent] :: ConformanceStaleFile -> !Maybe Bool

+ Keiro.Dsl.ConformancePackage: [directory] :: ConformancePackagePlan -> !FilePath

+ Keiro.Dsl.ConformancePackage: [dispositions] :: ConformancePackageReport -> ![(ConformanceFile, ConformanceWriteDisposition)]

+ Keiro.Dsl.ConformancePackage: [facadeModule] :: ConformancePackageRecord -> !Text

+ Keiro.Dsl.ConformancePackage: [files] :: ConformancePackageRecord -> ![(ModuleKind, FilePath)]

+ Keiro.Dsl.ConformancePackage: [key] :: DuplicateFactKey -> !String

+ Keiro.Dsl.ConformancePackage: [kind] :: ConformanceStaleFile -> !ModuleKind

+ Keiro.Dsl.ConformancePackage: [packageName] :: ConformancePackagePlan -> !Text

+ Keiro.Dsl.ConformancePackage: [path] :: ConformanceStaleFile -> !FilePath

+ Keiro.Dsl.ConformancePackage: [plan] :: ConformancePackageReport -> !ConformancePackagePlan

+ Keiro.Dsl.ConformancePackage: [root] :: ConformancePackageReport -> !FilePath

+ Keiro.Dsl.ConformancePackage: [runtimePackage] :: ConformancePackageRecord -> !RuntimePackageName

+ Keiro.Dsl.ConformancePackage: [schema] :: ConformancePackageRecord -> !Int

+ Keiro.Dsl.ConformancePackage: [serviceKey] :: ConformancePackageRecord -> !ConformanceServiceKey

+ Keiro.Dsl.ConformancePackage: [side] :: DuplicateFactKey -> !ConformanceFactSide

+ Keiro.Dsl.ConformancePackage: [stale] :: ConformancePackageReport -> ![ConformanceStaleFile]

+ Keiro.Dsl.ConformancePackage: [text] :: ConformanceFile -> !Text

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

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

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

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

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

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

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

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

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

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

+ Keiro.Dsl.Coverage: [aggregate] :: SnapshotBoundary -> !Text

+ Keiro.Dsl.Coverage: [canonicalType] :: StructuralBoundary -> !Text

+ Keiro.Dsl.Coverage: [code] :: CoverageFinding -> !DiagnosticCode

+ Keiro.Dsl.Coverage: [codecIdentity] :: OpaqueBoundary -> !Text

+ Keiro.Dsl.Coverage: [codecVersion] :: OpaqueBoundary -> !Text

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

+ Keiro.Dsl.Coverage: [delta] :: CoverageReport -> !Maybe CoverageDelta

+ Keiro.Dsl.Coverage: [enabled] :: SnapshotBoundary -> !Bool

+ Keiro.Dsl.Coverage: [encoding] :: SnapshotBoundary -> !Text

+ Keiro.Dsl.Coverage: [findings] :: CoverageReport -> ![CoverageFinding]

+ Keiro.Dsl.Coverage: [invalidation] :: SnapshotBoundary -> !Text

+ Keiro.Dsl.Coverage: [mappedType] :: SnapshotBoundary -> !Text

+ Keiro.Dsl.Coverage: [message] :: CoverageFinding -> !Text

+ Keiro.Dsl.Coverage: [mode] :: SnapshotBoundary -> !CoverageMode

+ Keiro.Dsl.Coverage: [opaqueBoundaries] :: CoverageReport -> ![OpaqueBoundary]

+ Keiro.Dsl.Coverage: [path] :: JsonBoundary -> !Text

+ Keiro.Dsl.Coverage: [previous] :: CoverageReport -> !Maybe CoveragePrevious

+ Keiro.Dsl.Coverage: [reason] :: UnsupportedSurface -> !Text

+ Keiro.Dsl.Coverage: [reference] :: CoveragePrevious -> !Text

+ Keiro.Dsl.Coverage: [register] :: SnapshotBoundary -> !Text

+ Keiro.Dsl.Coverage: [root] :: SnapshotBoundary -> !Text

+ Keiro.Dsl.Coverage: [roots] :: CoverageReport -> ![CoverageRoot]

+ Keiro.Dsl.Coverage: [severity] :: CoverageFinding -> !Severity

+ Keiro.Dsl.Coverage: [snapshotBoundaries] :: CoverageReport -> ![SnapshotBoundary]

+ Keiro.Dsl.Coverage: [spec] :: CoverageReport -> !FilePath

+ Keiro.Dsl.Coverage: [structuralBoundaries] :: CoverageReport -> ![StructuralBoundary]

+ Keiro.Dsl.Coverage: [summary] :: CoverageReport -> !CoverageSummary

+ Keiro.Dsl.Coverage: [support] :: UnsupportedSurface -> !Text

+ Keiro.Dsl.Coverage: [surface] :: UnsupportedSurface -> !Text

+ Keiro.Dsl.Coverage: [unsupportedSurfaces] :: CoverageReport -> ![UnsupportedSurface]

+ Keiro.Dsl.Coverage: [wireFingerprint] :: SnapshotBoundary -> !Text

+ Keiro.Dsl.Diff: [added] :: Paired n -> ![n]

+ Keiro.Dsl.Diff: [code] :: ChangeKind -> !DiagnosticCode

+ Keiro.Dsl.Diff: [consumerBuild] :: CompatibilityVector -> !SurfaceVerdict

+ Keiro.Dsl.Diff: [context] :: ChangeKind -> !ChangeContext

+ Keiro.Dsl.Diff: [detail] :: ChangeKind -> !Text

+ Keiro.Dsl.Diff: [facet] :: ChangeKind -> !Text

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

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

+ Keiro.Dsl.Diff: [matched] :: Paired n -> ![(n, n)]

+ Keiro.Dsl.Diff: [new] :: DiffEnv -> !Spec

+ Keiro.Dsl.Diff: [node] :: ChangeKind -> !Name

+ Keiro.Dsl.Diff: [oldBinaryReadNewEvents] :: CompatibilityVector -> !SurfaceVerdict

+ Keiro.Dsl.Diff: [old] :: DiffEnv -> !Spec

+ Keiro.Dsl.Diff: [paths] :: ChangeKind -> ![Text]

+ Keiro.Dsl.Diff: [persistedIdentity] :: CompatibilityVector -> !SurfaceVerdict

+ Keiro.Dsl.Diff: [privateHistoryRead] :: CompatibilityVector -> !SurfaceVerdict

+ Keiro.Dsl.Diff: [publicConsumer] :: CompatibilityVector -> !SurfaceVerdict

+ Keiro.Dsl.Diff: [removed] :: Paired n -> ![n]

+ Keiro.Dsl.Diff: [rollout] :: CompatibilityVector -> !Set RolloutConstraint

+ Keiro.Dsl.Diff: [snapshotHydration] :: CompatibilityVector -> !SurfaceVerdict

+ Keiro.Dsl.Diff: [subject] :: ChangeKind -> !Text

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

+ Keiro.Dsl.Diff: [vector] :: ChangeKind -> !CompatibilityVector

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

+ Keiro.Dsl.DiffReport: [adoptionBaseline] :: WorkspaceMeta -> !Bool

+ Keiro.Dsl.DiffReport: [change] :: WorkspaceChange -> !Change

+ Keiro.Dsl.DiffReport: [declarationSite] :: WorkspaceChange -> !Maybe OwnedSite

+ Keiro.Dsl.DiffReport: [file] :: OwnedSite -> !FilePath

+ Keiro.Dsl.DiffReport: [identity] :: WorkspaceMeta -> !Text

+ Keiro.Dsl.DiffReport: [line] :: OwnedSite -> !Int

+ Keiro.Dsl.DiffReport: [manifest] :: WorkspaceMeta -> !FilePath

+ Keiro.Dsl.DiffReport: [membersNew] :: WorkspaceMeta -> ![FilePath]

+ Keiro.Dsl.DiffReport: [membersOld] :: WorkspaceMeta -> ![FilePath]

+ Keiro.Dsl.DiffReport: [since] :: WorkspaceMeta -> !Text

+ Keiro.Dsl.DiffReport: [useSites] :: WorkspaceChange -> ![(Text, Maybe OwnedSite)]

+ Keiro.Dsl.EventOutput: [fields] :: EventOutputMapping -> ![CheckedFieldCopy]

+ Keiro.Dsl.EventOutput: [obligation] :: EventOutputMapping -> !OutputObligationKey

+ Keiro.Dsl.EventOutput: [sourceCommand] :: EventOutputMapping -> !Name

+ Keiro.Dsl.EventOutput: unOutputObligationKey :: OutputObligationKey -> Text

+ Keiro.Dsl.ExplainBindings: [bindingVersion] :: BindingObligation -> !Maybe Text

+ Keiro.Dsl.ExplainBindings: [canonicalType] :: BindingObligation -> !Maybe Text

+ Keiro.Dsl.ExplainBindings: [category] :: BindingObligation -> !Text

+ Keiro.Dsl.ExplainBindings: [equalityContract] :: BindingObligation -> !Maybe Text

+ Keiro.Dsl.ExplainBindings: [idDomainContract] :: BindingObligation -> !Maybe Text

+ Keiro.Dsl.ExplainBindings: [kind] :: BindingHole -> !BindingObligationKind

+ Keiro.Dsl.ExplainBindings: [mappedName] :: BindingHole -> !Name

+ Keiro.Dsl.ExplainBindings: [moduleName] :: BindingHole -> !Text

+ Keiro.Dsl.ExplainBindings: [package] :: BindingObligation -> !Text

+ Keiro.Dsl.ExplainBindings: [path] :: BindingHole -> !Maybe Text

+ Keiro.Dsl.ExplainBindings: [signature] :: BindingHole -> !Text

+ Keiro.Dsl.ExplainBindings: [symbol] :: BindingHole -> !Text

+ Keiro.Dsl.ExplainBindings: [useSites] :: BindingObligation -> ![Text]

+ Keiro.Dsl.Expression: [code] :: ExpressionDiagnostic -> !ExpressionDiagnosticCode

+ Keiro.Dsl.Expression: [fields] :: ResolvedScalarProjection -> ![Name]

+ Keiro.Dsl.Expression: [loc] :: ExpressionDiagnostic -> !Loc

+ Keiro.Dsl.Expression: [message] :: ExpressionDiagnostic -> !Text

+ Keiro.Dsl.Expression: [node] :: TypedScalarExpr -> !TypedScalarNode

+ Keiro.Dsl.Expression: [owner] :: ResolvedScalarProjection -> !MappedKey

+ Keiro.Dsl.Expression: [pointer] :: ResolvedScalarProjection -> !Text

+ Keiro.Dsl.Expression: [valueType] :: TypedScalarExpr -> !ResolvedAggregateType

+ Keiro.Dsl.Goldens: [aggregate] :: GoldenPayload -> !Text

+ Keiro.Dsl.Goldens: [context] :: GoldenPayload -> !Text

+ Keiro.Dsl.Goldens: [event] :: GoldenPayload -> !Text

+ Keiro.Dsl.Goldens: [evidence] :: GoldenPayload -> !GoldenEvidence

+ Keiro.Dsl.Goldens: [json] :: GoldenPayload -> !Text

+ Keiro.Dsl.Goldens: [version] :: GoldenPayload -> !Int

+ Keiro.Dsl.Grammar: [accept] :: IntakeNode -> ![Name]

+ Keiro.Dsl.Grammar: [action] :: WqDispRow -> !InboxAction

+ Keiro.Dsl.Grammar: [advance] :: HandleNode -> !AdvanceNode

+ Keiro.Dsl.Grammar: [agg] :: SagaRef -> !Name

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

+ Keiro.Dsl.Grammar: [backoff] :: PublisherNode -> !BackoffSpec

+ Keiro.Dsl.Grammar: [bindingVersion] :: NominalBindingDecl -> !Maybe Text

+ Keiro.Dsl.Grammar: [binding] :: NominalScalarDecl -> !NominalBindingDecl

+ Keiro.Dsl.Grammar: [binds] :: IntakeNode -> ![BindRow]

+ Keiro.Dsl.Grammar: [bodySchemaVersion] :: DecodeSpec -> !Int

+ Keiro.Dsl.Grammar: [bodyStrict] :: DecodeSpec -> !Bool

+ Keiro.Dsl.Grammar: [body] :: WorkflowNode -> ![WfBodyItem]

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

+ Keiro.Dsl.Grammar: [canonicalType] :: NominalBindingDecl -> !Maybe Text

+ Keiro.Dsl.Grammar: [cases] :: RuleDecl -> ![(Name, Expr)]

+ Keiro.Dsl.Grammar: [category] :: SagaRef -> !Text

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

+ Keiro.Dsl.Grammar: [codecVersion] :: SnapshotSpec -> !Int

+ Keiro.Dsl.Grammar: [codomain] :: RuleDecl -> !Name

+ Keiro.Dsl.Grammar: [columns] :: ReadModelNode -> ![RmColumn]

+ Keiro.Dsl.Grammar: [command] :: RouterDispatchNode -> !Name

+ Keiro.Dsl.Grammar: [commands] :: Aggregate -> ![Command]

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

+ Keiro.Dsl.Grammar: [consistency] :: ProjectionSpec -> !Maybe Consistency

+ Keiro.Dsl.Grammar: [contentsField] :: UnionEncoding -> !Text

+ Keiro.Dsl.Grammar: [context] :: Spec -> !Name

+ Keiro.Dsl.Grammar: [contract] :: EmitNode -> !Name

+ Keiro.Dsl.Grammar: [correlate] :: ProcessNode -> !CorrelateDecl

+ Keiro.Dsl.Grammar: [crossCheck] :: BindRow -> !Bool

+ Keiro.Dsl.Grammar: [ctor] :: WireArm -> !Name

+ Keiro.Dsl.Grammar: [ctors] :: EnumDecl -> ![(Name, Text)]

+ Keiro.Dsl.Grammar: [deadLetter] :: TimerNode -> !Text

+ Keiro.Dsl.Grammar: [decodeUnknown] :: TimerNode -> !Name

+ Keiro.Dsl.Grammar: [decode] :: IntakeNode -> !DecodeSpec

+ Keiro.Dsl.Grammar: [dedupKey] :: PgmqDispatchNode -> !Name

+ Keiro.Dsl.Grammar: [dedupQueueField] :: PgmqDispatchNode -> !Text

+ Keiro.Dsl.Grammar: [dedupQueue] :: PgmqDispatchNode -> !Name

+ Keiro.Dsl.Grammar: [dedupReadModelField] :: PgmqDispatchNode -> !Text

+ Keiro.Dsl.Grammar: [dedupReadModel] :: PgmqDispatchNode -> !Name

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

+ Keiro.Dsl.Grammar: [dedupeKey] :: IntakeNode -> !Name

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

+ Keiro.Dsl.Grammar: [dedupePolicy] :: IntakeNode -> !Name

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

+ Keiro.Dsl.Grammar: [delay] :: WorkqueueNode -> !Text

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

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

+ Keiro.Dsl.Grammar: [deprecated] :: Event -> !Bool

+ Keiro.Dsl.Grammar: [discriminant] :: EmitNode -> !Name

+ Keiro.Dsl.Grammar: [discriminator] :: ContractNode -> !Name

+ Keiro.Dsl.Grammar: [dispatch] :: RouterNode -> !RouterDispatchNode

+ Keiro.Dsl.Grammar: [disposition] :: WorkqueueNode -> ![WqDispRow]

+ Keiro.Dsl.Grammar: [dlqOn] :: WorkqueueNode -> !Bool

+ Keiro.Dsl.Grammar: [dlq] :: WorkqueueNode -> !Text

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

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

+ Keiro.Dsl.Grammar: [domain] :: RuleDecl -> !Name

+ Keiro.Dsl.Grammar: [emit] :: PublisherNode -> !Name

+ Keiro.Dsl.Grammar: [emits] :: Transition -> ![Name]

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

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

+ Keiro.Dsl.Grammar: [enqueueTo] :: PgmqDispatchNode -> !Name

+ Keiro.Dsl.Grammar: [enums] :: Spec -> ![EnumDecl]

+ Keiro.Dsl.Grammar: [envelope] :: DecodeSpec -> !Text

+ Keiro.Dsl.Grammar: [event] :: EmitMapRow -> !Name

+ Keiro.Dsl.Grammar: [events] :: ContractNode -> ![ContractEvent]

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

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

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

+ Keiro.Dsl.Grammar: [fanoutBody] :: PgmqDispatchNode -> !Name

+ Keiro.Dsl.Grammar: [field] :: WqGroupKey -> !Name

+ Keiro.Dsl.Grammar: [fields] :: ContractEvent -> ![ContractField]

+ Keiro.Dsl.Grammar: [fireAt] :: TimerNode -> !FireAtExpr

+ Keiro.Dsl.Grammar: [fire] :: TimerNode -> !FireNode

+ Keiro.Dsl.Grammar: [firedEventId] :: FireNode -> !IdExpr

+ Keiro.Dsl.Grammar: [fixture] :: WqGroupKey -> !Maybe Text

+ Keiro.Dsl.Grammar: [fixtures] :: NominalBindingDecl -> !Maybe Text

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

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

+ Keiro.Dsl.Grammar: [goto] :: Transition -> !Name

+ Keiro.Dsl.Grammar: [groupKey] :: WorkqueueNode -> !Maybe WqGroupKey

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

+ Keiro.Dsl.Grammar: [guard] :: Transition -> !Maybe Expr

+ Keiro.Dsl.Grammar: [handle] :: ProcessNode -> !HandleNode

+ Keiro.Dsl.Grammar: [haskell] :: NominalBindingDecl -> !Maybe HaskellSource

+ Keiro.Dsl.Grammar: [idField] :: WorkflowNode -> !Maybe Name

+ Keiro.Dsl.Grammar: [idVia] :: WorkflowNode -> !Name

+ Keiro.Dsl.Grammar: [id] :: WorkflowNode -> !Name

+ Keiro.Dsl.Grammar: [idempotencyKey] :: EmitNode -> !DeriveSpec

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

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

+ Keiro.Dsl.Grammar: [ids] :: Spec -> ![IdDecl]

+ Keiro.Dsl.Grammar: [implementation] :: Transition -> !TransitionImplementation

+ Keiro.Dsl.Grammar: [initial] :: RegDecl -> !RegInitial

+ Keiro.Dsl.Grammar: [inputFields] :: WorkflowNode -> ![Field]

+ Keiro.Dsl.Grammar: [key] :: EmitNode -> !Name

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

+ Keiro.Dsl.Grammar: [layout] :: Spec -> !Maybe Placement

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

+ Keiro.Dsl.Grammar: [loc] :: OperationNode -> !Loc

+ Keiro.Dsl.Grammar: [logical] :: WorkqueueNode -> !Text

+ Keiro.Dsl.Grammar: [map] :: EmitNode -> ![EmitMapRow]

+ Keiro.Dsl.Grammar: [mapped] :: Spec -> ![MappedDecl]

+ Keiro.Dsl.Grammar: [maxAttempts] :: PublisherNode -> !Int

+ Keiro.Dsl.Grammar: [maxRetries] :: WorkqueueNode -> !Int

+ Keiro.Dsl.Grammar: [max] :: BackoffSpec -> !Maybe Text

+ Keiro.Dsl.Grammar: [messageId] :: EmitNode -> !DeriveSpec

+ Keiro.Dsl.Grammar: [mode] :: Transition -> !TransitionMode

+ Keiro.Dsl.Grammar: [moduleName] :: HaskellSource -> !Text

+ Keiro.Dsl.Grammar: [moduleRoot] :: Spec -> !Maybe Text

+ Keiro.Dsl.Grammar: [multiplier] :: BackoffSpec -> !Maybe Text

+ Keiro.Dsl.Grammar: [name] :: OperationNode -> !Name

+ Keiro.Dsl.Grammar: [nodes] :: Spec -> ![Node]

+ Keiro.Dsl.Grammar: [nominalScalars] :: Spec -> ![NominalScalarDecl]

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

+ Keiro.Dsl.Grammar: [onMissing] :: WireField -> !Maybe OnMissing

+ Keiro.Dsl.Grammar: [on] :: HandleNode -> !Name

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

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

+ Keiro.Dsl.Grammar: [ordering] :: WorkqueueNode -> !WqOrdering

+ Keiro.Dsl.Grammar: [outboxField] :: PublisherNode -> !Name

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

+ Keiro.Dsl.Grammar: [outcome] :: WqDispRow -> !Name

+ Keiro.Dsl.Grammar: [output] :: WorkflowNode -> !Name

+ Keiro.Dsl.Grammar: [package] :: HaskellSource -> !Text

+ Keiro.Dsl.Grammar: [pairs] :: Mapping -> ![(Name, Name)]

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

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

+ Keiro.Dsl.Grammar: [payloadName] :: WorkqueueNode -> !Name

+ Keiro.Dsl.Grammar: [payload] :: WorkqueueNode -> ![WqField]

+ Keiro.Dsl.Grammar: [persist] :: IntakeNode -> !InkPersist

+ Keiro.Dsl.Grammar: [physical] :: WorkqueueNode -> !Text

+ Keiro.Dsl.Grammar: [poison] :: RouterNode -> !PolicyChoice

+ Keiro.Dsl.Grammar: [policy] :: SnapshotSpec -> !SnapPolicy

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

+ Keiro.Dsl.Grammar: [prefix] :: IdExpr -> !Text

+ Keiro.Dsl.Grammar: [presence] :: WireField -> !Presence

+ Keiro.Dsl.Grammar: [projection] :: Aggregate -> !Maybe ProjectionSpec

+ Keiro.Dsl.Grammar: [projections] :: RouterNode -> ![Name]

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

+ Keiro.Dsl.Grammar: [provision] :: WorkqueueNode -> !WqProvision

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

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

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

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

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

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

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

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

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

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

+ Keiro.Dsl.Grammar: [regs] :: Aggregate -> ![RegDecl]

+ Keiro.Dsl.Grammar: [rejected] :: RouterNode -> !PolicyChoice

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

+ Keiro.Dsl.Grammar: [representation] :: NominalScalarDecl -> !Name

+ Keiro.Dsl.Grammar: [required] :: BindRow -> !Bool

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

+ Keiro.Dsl.Grammar: [resolve] :: RouterNode -> !ResolveDecl

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

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

+ Keiro.Dsl.Grammar: [retiring] :: Event -> !Bool

+ Keiro.Dsl.Grammar: [row] :: ResolveDecl -> ![Name]

+ Keiro.Dsl.Grammar: [rules] :: Spec -> ![RuleDecl]

+ Keiro.Dsl.Grammar: [saga] :: ProcessNode -> !SagaRef

+ Keiro.Dsl.Grammar: [schedule] :: HandleNode -> !Name

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

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

+ Keiro.Dsl.Grammar: [selector] :: ContractField -> !Maybe Name

+ Keiro.Dsl.Grammar: [shapeHash] :: SnapshotSpec -> !Text

+ Keiro.Dsl.Grammar: [shape] :: OperationNode -> !OperationShape

+ Keiro.Dsl.Grammar: [skip] :: EmitNode -> !Bool

+ Keiro.Dsl.Grammar: [snapshot] :: Aggregate -> !Maybe SnapshotSpec

+ Keiro.Dsl.Grammar: [sourceKey] :: PgmqDispatchNode -> !Name

+ Keiro.Dsl.Grammar: [sourceReadModel] :: PgmqDispatchNode -> !Name

+ Keiro.Dsl.Grammar: [source] :: EmitNode -> !Text

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

+ Keiro.Dsl.Grammar: [stable] :: WorkflowNode -> !Text

+ Keiro.Dsl.Grammar: [states] :: Aggregate -> ![StateDecl]

+ Keiro.Dsl.Grammar: [statusMap] :: ProjectionSpec -> !Maybe Mapping

+ Keiro.Dsl.Grammar: [strategy] :: IdExpr -> !IdStrategy

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

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

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

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

+ Keiro.Dsl.Grammar: [tagField] :: UnionEncoding -> !Text

+ Keiro.Dsl.Grammar: [tag] :: WireArm -> !Text

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

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

+ Keiro.Dsl.Grammar: [terminal] :: StateDecl -> !Bool

+ Keiro.Dsl.Grammar: [timer] :: ProcessNode -> !TimerNode

+ Keiro.Dsl.Grammar: [topic] :: EmitNode -> !Name

+ Keiro.Dsl.Grammar: [topics] :: ContractNode -> ![(Name, Text)]

+ Keiro.Dsl.Grammar: [transitions] :: Aggregate -> ![Transition]

+ Keiro.Dsl.Grammar: [unknownFields] :: UnionEncoding -> !UnknownFields

+ Keiro.Dsl.Grammar: [upcastFrom] :: Event -> !Maybe (Int, Hole)

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

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

+ Keiro.Dsl.Grammar: [valueType] :: WqField -> !QueuePayloadType

+ Keiro.Dsl.Grammar: [value] :: EmitMapRow -> !Text

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

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

+ Keiro.Dsl.Grammar: [via] :: WqGroupKey -> !Name

+ Keiro.Dsl.Grammar: [window] :: BackoffSpec -> !Text

+ Keiro.Dsl.Grammar: [wireKey] :: ContractField -> !Maybe Text

+ Keiro.Dsl.Grammar: [wire] :: WqField -> !Text

+ Keiro.Dsl.Grammar: [writes] :: Transition -> ![(Name, Expr)]

+ Keiro.Dsl.Grammar: unLoc :: Loc -> Int

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

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

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

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

+ Keiro.Dsl.HaskellSourceMove: [backupPath] :: SourceMove -> !FilePath

+ Keiro.Dsl.HaskellSourceMove: [contentDigest] :: SourceMove -> !Maybe Text

+ Keiro.Dsl.HaskellSourceMove: [kind] :: SourceMove -> !ModuleKind

+ Keiro.Dsl.HaskellSourceMove: [newModule] :: SourceMove -> !Text

+ Keiro.Dsl.HaskellSourceMove: [newPath] :: SourceMove -> !FilePath

+ Keiro.Dsl.HaskellSourceMove: [oldModule] :: SourceMove -> !Text

+ Keiro.Dsl.HaskellSourceMove: [oldPath] :: SourceMove -> !FilePath

+ Keiro.Dsl.HaskellSourceMove: [role] :: SourceMove -> !ModuleRole

+ Keiro.Dsl.HaskellSourceMove: [transformedDigest] :: SourceMove -> !Maybe Text

+ Keiro.Dsl.LanguageVersion: [bodyParser] :: LanguageDefinition -> !LanguageBodyParser

+ Keiro.Dsl.LanguageVersion: [declaredVersion] :: SourceLanguageDiagnostic -> !Maybe LanguageVersion

+ Keiro.Dsl.LanguageVersion: [errorCode] :: SourceLanguageDiagnostic -> !SourceLanguageErrorCode

+ Keiro.Dsl.LanguageVersion: [loc] :: SourceLanguageDiagnostic -> !Loc

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

+ Keiro.Dsl.LanguageVersion: [predecessor] :: LanguageDefinition -> !Maybe LanguageVersion

+ Keiro.Dsl.LanguageVersion: [runtimeSemanticsProfile] :: LanguageDefinition -> !RuntimeSemanticsProfile

+ Keiro.Dsl.LanguageVersion: [sourceLanguage] :: ParsedSource -> !SourceLanguage

+ Keiro.Dsl.LanguageVersion: [source] :: SourceLanguageDiagnostic -> !FilePath

+ Keiro.Dsl.LanguageVersion: [spec] :: ParsedSource -> !Spec

+ Keiro.Dsl.LanguageVersion: [support] :: LanguageDefinition -> !LanguageSupport

+ Keiro.Dsl.LanguageVersion: [supportedVersions] :: SourceLanguageDiagnostic -> !NonEmpty LanguageVersion

+ Keiro.Dsl.LanguageVersion: [syntaxProfile] :: LanguageDefinition -> !SyntaxProfile

+ Keiro.Dsl.LanguageVersion: [token] :: SourceLanguageDiagnostic -> !Maybe Text

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

+ Keiro.Dsl.MappedConsumer: [bindingSymbol] :: MappingIdentity -> !Text

+ Keiro.Dsl.MappedConsumer: [bindingVersion] :: MappingIdentity -> !Text

+ Keiro.Dsl.MappedConsumer: [canonicalType] :: MappingIdentity -> !Text

+ Keiro.Dsl.MappedConsumer: [codecIdentity] :: MappingIdentity -> !Text

+ Keiro.Dsl.MappedConsumer: [codecVersion] :: MappingIdentity -> !Text

+ Keiro.Dsl.MappedConsumer: [fixtureSymbol] :: MappingIdentity -> !Text

+ Keiro.Dsl.MappedConsumer: [initialSymbol] :: MappingIdentity -> !Maybe Text

+ Keiro.Dsl.MappedConsumer: [mappings] :: ConsumerPlan -> ![MappingIdentity]

+ Keiro.Dsl.MappedConsumer: [moduleName] :: MappingIdentity -> !Text

+ Keiro.Dsl.MappedConsumer: [modules] :: ConsumerPlan -> ![Text]

+ Keiro.Dsl.MappedConsumer: [nominalCategory] :: MappingIdentity -> !Text

+ Keiro.Dsl.MappedConsumer: [nominalRepresentation] :: MappingIdentity -> !Text

+ Keiro.Dsl.MappedConsumer: [package] :: MappingIdentity -> !Text

+ Keiro.Dsl.MappedConsumer: [packages] :: ConsumerPlan -> ![Text]

+ Keiro.Dsl.MappedConsumer: [specName] :: MappingIdentity -> !Text

+ Keiro.Dsl.MappedConsumer: [valueType] :: MappingIdentity -> !Text

+ Keiro.Dsl.MappedDiff: [code] :: MappedFinding -> !DiagnosticCode

+ Keiro.Dsl.MappedDiff: [declaration] :: MappedFinding -> !Name

+ Keiro.Dsl.MappedDiff: [detail] :: MappedFinding -> !Text

+ Keiro.Dsl.MappedDiff: [leaf] :: MappedFinding -> !Text

+ Keiro.Dsl.MappedDiff: [oldUnknownFields] :: MappedFinding -> !Maybe UnknownFields

+ Keiro.Dsl.MappedDiff: [usePaths] :: MappedFinding -> ![UsePath]

+ Keiro.Dsl.NominalType: [bindingVersion] :: ConsumerNominalBinding -> !BindingVersion

+ Keiro.Dsl.NominalType: [binding] :: ConsumerNominalBinding -> !QualifiedValueName

+ Keiro.Dsl.NominalType: [canonical] :: ConsumerNominalBinding -> !CanonicalTypeId

+ Keiro.Dsl.NominalType: [contractVersion] :: CheckedNominalEquality -> !Text

+ Keiro.Dsl.NominalType: [domain] :: CheckedNominalEquality -> !NominalEqualityDomain

+ Keiro.Dsl.NominalType: [fixtures] :: ConsumerNominalBinding -> !QualifiedValueName

+ Keiro.Dsl.NominalType: [haskell] :: ConsumerNominalBinding -> !HaskellSource

+ Keiro.Dsl.NominalType: [initial] :: ConsumerNominalBinding -> !Maybe QualifiedValueName

+ Keiro.Dsl.NominalType: [keyRepresentation] :: CheckedNominalEquality -> !NominalEqualityKey

+ Keiro.Dsl.NominalType: [loc] :: ResolvedNominalType -> !Loc

+ Keiro.Dsl.NominalType: [name] :: ResolvedNominalType -> !Name

+ Keiro.Dsl.NominalType: [ownership] :: ResolvedNominalType -> !NominalOwnership

+ Keiro.Dsl.NominalType: [representation] :: ResolvedNominalType -> !NominalRepresentation

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

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

+ Keiro.Dsl.Parser: [sourceLanguage] :: ParsedSource -> !SourceLanguage

+ Keiro.Dsl.Parser: [spec] :: ParsedSource -> !Spec

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

+ Keiro.Dsl.RuntimePackage: unRuntimePackageName :: RuntimePackageName -> Text

+ Keiro.Dsl.Scaffold: [aggregate] :: Agg -> !Aggregate

+ Keiro.Dsl.Scaffold: [binding] :: StructuralProjection -> !QualifiedValueName

+ Keiro.Dsl.Scaffold: [canonical] :: StructuralProjection -> !CanonicalTypeId

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

+ Keiro.Dsl.Scaffold: [commands] :: Agg -> ![ResolvedCtor]

+ Keiro.Dsl.Scaffold: [context] :: Agg -> !Context

+ Keiro.Dsl.Scaffold: [ctxPascal] :: Agg -> !Text

+ Keiro.Dsl.Scaffold: [declaration] :: NominalGenerationOwner -> !ResolvedNominalType

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

+ Keiro.Dsl.Scaffold: [enums] :: Agg -> ![EnumDecl]

+ Keiro.Dsl.Scaffold: [equalityUsed] :: NominalGenerationOwner -> !Bool

+ Keiro.Dsl.Scaffold: [events] :: Agg -> ![ResolvedCtor]

+ Keiro.Dsl.Scaffold: [family] :: ModuleRole -> !Text

+ Keiro.Dsl.Scaffold: [fields] :: ResolvedCtor -> ![(ResolvedFieldIdentity, ResolvedAggregateType)]

+ Keiro.Dsl.Scaffold: [foldFingerprint] :: Agg -> !Text

+ Keiro.Dsl.Scaffold: [genPrefix] :: Agg -> !Text

+ Keiro.Dsl.Scaffold: [generatedNominals] :: Agg -> ![ResolvedNominalType]

+ Keiro.Dsl.Scaffold: [holePrefix] :: Agg -> !Text

+ Keiro.Dsl.Scaffold: [ids] :: Agg -> ![IdDecl]

+ Keiro.Dsl.Scaffold: [initial] :: ResolvedRegister -> !ResolvedRegisterInitial

+ Keiro.Dsl.Scaffold: [languageContract] :: Agg -> !EffectiveLanguageContract

+ Keiro.Dsl.Scaffold: [loc] :: ResolvedRegister -> !Loc

+ Keiro.Dsl.Scaffold: [moduleName] :: NominalGenerationOwner -> !Text

+ Keiro.Dsl.Scaffold: [name] :: ResolvedCtor -> !Text

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

+ Keiro.Dsl.Scaffold: [outputMappings] :: Agg -> !Map (Int, Int) EventOutputMapping

+ Keiro.Dsl.Scaffold: [ownerKind] :: ModuleRole -> !Text

+ Keiro.Dsl.Scaffold: [ownerName] :: ModuleRole -> !Text

+ Keiro.Dsl.Scaffold: [owner] :: StructuralProjection -> !HaskellSource

+ Keiro.Dsl.Scaffold: [path] :: ScaffoldModule -> !FilePath

+ Keiro.Dsl.Scaffold: [pointer] :: StructuralProjection -> !Text

+ Keiro.Dsl.Scaffold: [projection] :: Agg -> !Maybe ProjectionSpec

+ Keiro.Dsl.Scaffold: [readModels] :: Agg -> ![ReadModelNode]

+ Keiro.Dsl.Scaffold: [regs] :: Agg -> ![ResolvedRegister]

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

+ Keiro.Dsl.Scaffold: [result] :: StructuralProjection -> !Text

+ Keiro.Dsl.Scaffold: [selectors] :: StructuralProjection -> ![(Text, Text)]

+ Keiro.Dsl.Scaffold: [snapshot] :: Agg -> !Maybe SnapshotSpec

+ Keiro.Dsl.Scaffold: [spec] :: Agg -> !Spec

+ Keiro.Dsl.Scaffold: [states] :: Agg -> ![StateDecl]

+ Keiro.Dsl.Scaffold: [symbols] :: Agg -> !AggregateSymbols

+ Keiro.Dsl.Scaffold: [tag] :: StructuralProjection -> !Text

+ Keiro.Dsl.Scaffold: [text] :: ScaffoldModule -> !Text

+ Keiro.Dsl.Scaffold: [transitions] :: Agg -> ![Transition]

+ Keiro.Dsl.Scaffold: [typeGraph] :: Agg -> !Maybe TypeGraph

+ Keiro.Dsl.Scaffold: [upcastFrom] :: ResolvedCtor -> !Maybe Int

+ Keiro.Dsl.Scaffold: [useSites] :: NominalGenerationOwner -> !Set NominalUseSite

+ Keiro.Dsl.Scaffold: [valueType] :: ResolvedRegister -> !ResolvedAggregateType

+ Keiro.Dsl.Scaffold: [version] :: ResolvedCtor -> !Int

+ Keiro.Dsl.Scaffold: [vertexType] :: Agg -> !Text

+ Keiro.Dsl.Scaffold: [wire] :: Agg -> !WireSpec

+ Keiro.Dsl.Scaffold: [witness] :: StructuralProjection -> !Text

+ Keiro.Dsl.Scaffold: modernizeScaffoldModule :: ScaffoldModule -> ScaffoldModule

+ Keiro.Dsl.ScaffoldRecord: IdiomaticNamingV2 :: GeneratedHaskellNamingEdition

+ Keiro.Dsl.ScaffoldRecord: [behaviorRequirements] :: ScaffoldRecord -> ![BehaviorRecordRow]

+ Keiro.Dsl.ScaffoldRecord: [bindingObligations] :: ScaffoldRecord -> ![BindingHole]

+ Keiro.Dsl.ScaffoldRecord: [files] :: ScaffoldRecord -> ![(ModuleKind, FilePath)]

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

+ Keiro.Dsl.ScaffoldRecord: [kind] :: ScaffoldModuleRoleRow -> !ModuleKind

+ Keiro.Dsl.ScaffoldRecord: [languageContract] :: ScaffoldRecord -> !EffectiveLanguageContract

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

+ Keiro.Dsl.ScaffoldRecord: [mappings] :: ScaffoldRecord -> ![MappingIdentity]

+ Keiro.Dsl.ScaffoldRecord: [moduleRoles] :: ScaffoldRecord -> ![ScaffoldModuleRoleRow]

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

+ Keiro.Dsl.ScaffoldRecord: [namingEdition] :: ScaffoldRecord -> !GeneratedHaskellNamingEdition

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

+ Keiro.Dsl.ScaffoldRecord: [path] :: ScaffoldModuleRoleRow -> !FilePath

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

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

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

+ Keiro.Dsl.ScaffoldRecord: [role] :: ScaffoldModuleRoleRow -> !ModuleRole

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

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

+ Keiro.Dsl.ScaffoldRecord: [sourceLanguage] :: ScaffoldRecord -> !SourceLanguage

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

+ Keiro.Dsl.ScaffoldRun: GeneratedHaskellEditionImpact :: !GeneratedHaskellNamingEdition -> ![FilePath] -> ![FilePath] -> ![GeneratedHaskellEditionUse] -> GeneratedHaskellEditionImpact

+ Keiro.Dsl.ScaffoldRun: GeneratedHaskellEditionRefusal :: ![Text] -> Refusal

+ Keiro.Dsl.ScaffoldRun: GeneratedHaskellEditionRequired :: !GeneratedHaskellEditionImpact -> Refusal

+ Keiro.Dsl.ScaffoldRun: GeneratedHaskellEditionUse :: !FilePath -> !Int -> !Text -> !Text -> !HoleUseForm -> GeneratedHaskellEditionUse

+ Keiro.Dsl.ScaffoldRun: LedgerAbsent :: LedgerRead a

+ Keiro.Dsl.ScaffoldRun: LedgerParsed :: !a -> LedgerRead a

+ Keiro.Dsl.ScaffoldRun: LedgerReadUnreadable :: !FilePath -> LedgerRead a

+ Keiro.Dsl.ScaffoldRun: LedgerUnreadable :: !FilePath -> Refusal

+ Keiro.Dsl.ScaffoldRun: OperatorOperand :: HoleUseForm

+ Keiro.Dsl.ScaffoldRun: PrefixApplication :: HoleUseForm

+ Keiro.Dsl.ScaffoldRun: QualifiedApplication :: HoleUseForm

+ Keiro.Dsl.ScaffoldRun: RecordDotRenamed :: HoleUseForm

+ Keiro.Dsl.ScaffoldRun: RecordFieldBinding :: HoleUseForm

+ Keiro.Dsl.ScaffoldRun: [addedBehavior] :: ScaffoldReport -> ![BehaviorRecordRow]

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

+ Keiro.Dsl.ScaffoldRun: [conformancePackage] :: ScaffoldReport -> !Maybe ConformancePackageReport

+ Keiro.Dsl.ScaffoldRun: [constraintPlan] :: ScaffoldReport -> ![Text]

+ Keiro.Dsl.ScaffoldRun: [consumerPlan] :: ScaffoldReport -> !ConsumerPlan

+ Keiro.Dsl.ScaffoldRun: [context] :: ScaffoldReport -> !Context

+ Keiro.Dsl.ScaffoldRun: [current] :: SourceLanguageDrift -> !SourceLanguage

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

+ Keiro.Dsl.ScaffoldRun: [dispositions] :: ScaffoldReport -> ![(ScaffoldModule, WriteDisposition)]

+ Keiro.Dsl.ScaffoldRun: [form] :: GeneratedHaskellEditionUse -> !HoleUseForm

+ Keiro.Dsl.ScaffoldRun: [fromEdition] :: GeneratedHaskellEditionImpact -> !GeneratedHaskellNamingEdition

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

+ Keiro.Dsl.ScaffoldRun: [generatedEvidence] :: StaleModule -> !Maybe StaleGeneratedEvidence

+ Keiro.Dsl.ScaffoldRun: [generatedPaths] :: GeneratedHaskellEditionImpact -> ![FilePath]

+ Keiro.Dsl.ScaffoldRun: [handOwnedUses] :: GeneratedHaskellEditionImpact -> ![GeneratedHaskellEditionUse]

+ Keiro.Dsl.ScaffoldRun: [inertNodes] :: ScaffoldReport -> ![(Text, Text)]

+ Keiro.Dsl.ScaffoldRun: [kind] :: StaleModule -> !ModuleKind

+ Keiro.Dsl.ScaffoldRun: [line] :: GeneratedHaskellEditionUse -> !Int

+ Keiro.Dsl.ScaffoldRun: [manifestPath] :: ScaffoldReport -> !FilePath

+ Keiro.Dsl.ScaffoldRun: [mappingDrift] :: ScaffoldReport -> ![MappingDrift]

+ Keiro.Dsl.ScaffoldRun: [nameMoves] :: ScaffoldReport -> ![SourceMove]

+ Keiro.Dsl.ScaffoldRun: [newHoles] :: ScaffoldReport -> ![BindingHole]

+ Keiro.Dsl.ScaffoldRun: [obsoleteOutputHooks] :: ScaffoldReport -> ![(Text, Text)]

+ Keiro.Dsl.ScaffoldRun: [outDir] :: ScaffoldReport -> !FilePath

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

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

+ Keiro.Dsl.ScaffoldRun: [previousSpecPath] :: ScaffoldReport -> !Maybe Text

+ Keiro.Dsl.ScaffoldRun: [previous] :: SourceLanguageDrift -> !SourceLanguage

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

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

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

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

+ Keiro.Dsl.ScaffoldRun: [recordPath] :: ScaffoldReport -> !FilePath

+ Keiro.Dsl.ScaffoldRun: [removedBehavior] :: ScaffoldReport -> ![BehaviorRecordRow]

+ Keiro.Dsl.ScaffoldRun: [replacement] :: GeneratedHaskellEditionUse -> !Text

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

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

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

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

+ Keiro.Dsl.ScaffoldRun: [sidecarMoves] :: ScaffoldReport -> ![SidecarMove]

+ Keiro.Dsl.ScaffoldRun: [sidecarPaths] :: GeneratedHaskellEditionImpact -> ![FilePath]

+ Keiro.Dsl.ScaffoldRun: [sourceLanguageDrift] :: ScaffoldReport -> !Maybe SourceLanguageDrift

+ Keiro.Dsl.ScaffoldRun: [specName] :: MappingDrift -> !Text

+ Keiro.Dsl.ScaffoldRun: [specPath] :: ScaffoldReport -> !FilePath

+ Keiro.Dsl.ScaffoldRun: [stale] :: ScaffoldReport -> ![StaleModule]

+ Keiro.Dsl.ScaffoldRun: applyPreparedGeneratedHaskellEditionMigration :: FilePath -> Maybe PreparedGeneratedHaskellEditionMigration -> IO ()

+ Keiro.Dsl.ScaffoldRun: data GeneratedHaskellEditionImpact

+ Keiro.Dsl.ScaffoldRun: data GeneratedHaskellEditionUse

+ Keiro.Dsl.ScaffoldRun: data HoleUseForm

+ Keiro.Dsl.ScaffoldRun: data LedgerRead a

+ Keiro.Dsl.ScaffoldRun: data PreparedGeneratedHaskellEditionMigration

+ Keiro.Dsl.ScaffoldRun: executeServiceScaffoldWithRuntimePackageAndMigrations :: Maybe RuntimePackageName -> Bool -> Bool -> FilePath -> Bool -> FilePath -> SourceLanguage -> Context -> CheckedService -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport)

+ Keiro.Dsl.ScaffoldRun: generatedHaskellEditionBackupRoot :: GeneratedHaskellNamingEdition -> FilePath

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

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

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

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

+ Keiro.Dsl.ScaffoldRun: instance GHC.Classes.Eq a => GHC.Classes.Eq (Keiro.Dsl.ScaffoldRun.LedgerRead a)

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

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

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

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

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

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

+ Keiro.Dsl.ScaffoldRun: instance GHC.Internal.Show.Show a => GHC.Internal.Show.Show (Keiro.Dsl.ScaffoldRun.LedgerRead a)

+ Keiro.Dsl.ScaffoldRun: ledgerToMaybe :: LedgerRead a -> Maybe a

+ Keiro.Dsl.ScaffoldRun: preflightGeneratedHaskellEditionMigration :: FilePath -> Maybe GeneratedHaskellNamingEdition -> [(ModuleKind, FilePath)] -> [FilePath] -> IO (Either [Text] (Maybe PreparedGeneratedHaskellEditionMigration))

+ Keiro.Dsl.ScaffoldRun: preparedGeneratedHaskellEditionImpact :: PreparedGeneratedHaskellEditionMigration -> GeneratedHaskellEditionImpact

+ Keiro.Dsl.ScaffoldRun: readRecord :: FilePath -> IO (LedgerRead ScaffoldRecord)

+ Keiro.Dsl.ScaffoldRun: withGeneratedHaskellEditionSourceMoves :: [SourceMove] -> Maybe PreparedGeneratedHaskellEditionMigration -> Maybe PreparedGeneratedHaskellEditionMigration

+ Keiro.Dsl.SemanticContract: EffectiveLanguageContract :: !LanguageVersion -> !RuntimeSemanticsProfile -> EffectiveLanguageContract

+ Keiro.Dsl.SemanticContract: [contractLanguageVersion] :: EffectiveLanguageContract -> !LanguageVersion

+ Keiro.Dsl.SemanticContract: [runtimeProfile] :: EffectiveLanguageContract -> !RuntimeSemanticsProfile

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

+ Keiro.Dsl.SidecarMigration: [backupPath] :: SidecarMove -> !Maybe FilePath

+ Keiro.Dsl.SidecarMigration: [moveDisposition] :: SidecarMove -> !SidecarMoveDisposition

+ Keiro.Dsl.SidecarMigration: [newPath] :: SidecarMove -> !FilePath

+ Keiro.Dsl.SidecarMigration: [oldPath] :: SidecarMove -> !FilePath

+ Keiro.Dsl.SourceIndex: [code] :: SourceIndexFailure -> !SourceIndexFailureCode

+ Keiro.Dsl.SourceIndex: [message] :: SourceIndexFailure -> !Text

+ Keiro.Dsl.SourceIndex: [parsedSource] :: ParsedSourceDocument -> !ParsedSource

+ Keiro.Dsl.SourceIndex: [sourceIndex] :: ParsedSourceDocument -> !SemanticSourceIndex

+ Keiro.Dsl.SourceIndex: [span] :: SourceIndexFailure -> !Maybe SourceSpan

+ Keiro.Dsl.SourceIndex: [subject] :: SourceIndexFailure -> !Maybe SourceSubject

+ Keiro.Dsl.TypeGraph: [bindingVersion] :: StructuralDecl -> !BindingVersion

+ Keiro.Dsl.TypeGraph: [binding] :: StructuralDecl -> !QualifiedValueName

+ Keiro.Dsl.TypeGraph: [canonical] :: StructuralDecl -> !CanonicalTypeId

+ Keiro.Dsl.TypeGraph: [codecIdentity] :: OpaqueDecl -> !CodecIdentity

+ Keiro.Dsl.TypeGraph: [codecVersion] :: OpaqueDecl -> !CodecVersion

+ Keiro.Dsl.TypeGraph: [ctor] :: ResolvedWireArm -> !Name

+ Keiro.Dsl.TypeGraph: [declarations] :: TypeGraph -> !Map MappedKey ResolvedMappedDecl

+ Keiro.Dsl.TypeGraph: [derivedMappedConsumers] :: TypeGraph -> ![DerivedMappedConsumer]

+ Keiro.Dsl.TypeGraph: [fixtures] :: OpaqueDecl -> !QualifiedValueName

+ Keiro.Dsl.TypeGraph: [haskell] :: ResolvedWireField -> !Name

+ Keiro.Dsl.TypeGraph: [initial] :: OpaqueDecl -> !Maybe QualifiedValueName

+ Keiro.Dsl.TypeGraph: [key] :: ResolvedWireField -> !Text

+ Keiro.Dsl.TypeGraph: [loc] :: ResolvedWireArm -> !Loc

+ Keiro.Dsl.TypeGraph: [name] :: OpaqueDecl -> !Name

+ Keiro.Dsl.TypeGraph: [onMissing] :: ResolvedWireField -> !Maybe OnMissing

+ Keiro.Dsl.TypeGraph: [payload] :: ResolvedWireArm -> !Maybe ResolvedTypeExpr

+ Keiro.Dsl.TypeGraph: [presence] :: ResolvedWireField -> !Presence

+ Keiro.Dsl.TypeGraph: [projectionOperationalIdentities] :: TypeGraph -> !Map DerivedMappedConsumer Text

+ Keiro.Dsl.TypeGraph: [reachability] :: TypeGraph -> !Map MappedKey (Set MappedKey)

+ Keiro.Dsl.TypeGraph: [replayableProjectionGroups] :: TypeGraph -> !Map DerivedMappedConsumer Name

+ Keiro.Dsl.TypeGraph: [rootSegments] :: TypeGraph -> !Map UseSite [PathSeg]

+ Keiro.Dsl.TypeGraph: [root] :: UsePath -> !UseSite

+ Keiro.Dsl.TypeGraph: [segments] :: UsePath -> ![PathSeg]

+ Keiro.Dsl.TypeGraph: [tag] :: ResolvedWireArm -> !Text

+ Keiro.Dsl.TypeGraph: [unsupportedProjectionSources] :: TypeGraph -> ![UnsupportedProjectionSource]

+ Keiro.Dsl.TypeGraph: [useSites] :: TypeGraph -> ![UseSite]

+ Keiro.Dsl.TypeGraph: [valueType] :: ResolvedWireField -> !ResolvedTypeExpr

+ Keiro.Dsl.TypeGraph: unBindingVersion :: BindingVersion -> Text

+ Keiro.Dsl.TypeGraph: unCanonicalTypeId :: CanonicalTypeId -> Text

+ Keiro.Dsl.TypeGraph: unCodecIdentity :: CodecIdentity -> Text

+ Keiro.Dsl.TypeGraph: unCodecVersion :: CodecVersion -> Text

+ Keiro.Dsl.TypeGraph: unMappedKey :: MappedKey -> Name

+ Keiro.Dsl.TypeGraph: unQualifiedValueName :: QualifiedValueName -> Text

+ Keiro.Dsl.Workspace: [code] :: WorkspaceDiagnostic -> !DiagnosticCode

+ Keiro.Dsl.Workspace: [context] :: WorkspaceSpec -> !Name

+ Keiro.Dsl.Workspace: [declarations] :: OwnershipIndex -> !Map (Text, Name) (FilePath, Loc)

+ Keiro.Dsl.Workspace: [file] :: WorkspaceLocation -> !WorkspaceFile

+ Keiro.Dsl.Workspace: [languageContract] :: WorkspaceSpec -> !EffectiveLanguageContract

+ Keiro.Dsl.Workspace: [layoutLoc] :: WorkspaceManifest -> !Loc

+ Keiro.Dsl.Workspace: [layout] :: WorkspaceSpec -> !Maybe Placement

+ Keiro.Dsl.Workspace: [lineBase] :: WorkspaceMember -> !Int

+ Keiro.Dsl.Workspace: [lineCount] :: WorkspaceMember -> !Int

+ Keiro.Dsl.Workspace: [lineMap] :: WorkspaceSpec -> !LineMap

+ Keiro.Dsl.Workspace: [line] :: WorkspaceLocation -> !Int

+ Keiro.Dsl.Workspace: [loc] :: WorkspaceMemberRef -> !Loc

+ Keiro.Dsl.Workspace: [locations] :: WorkspaceDiagnostic -> !NonEmpty WorkspaceLocation

+ Keiro.Dsl.Workspace: [manifestPath] :: WorkspaceSpec -> !FilePath

+ Keiro.Dsl.Workspace: [members] :: WorkspaceSpec -> ![WorkspaceMember]

+ Keiro.Dsl.Workspace: [mergedSpec] :: WorkspaceSpec -> !Spec

+ Keiro.Dsl.Workspace: [message] :: WorkspaceDiagnostic -> !Text

+ Keiro.Dsl.Workspace: [moduleRootLoc] :: WorkspaceManifest -> !Loc

+ Keiro.Dsl.Workspace: [moduleRoot] :: WorkspaceSpec -> !Maybe Text

+ Keiro.Dsl.Workspace: [nodes] :: OwnershipIndex -> !Map (Text, Name) (FilePath, Loc)

+ Keiro.Dsl.Workspace: [ownership] :: WorkspaceSpec -> !OwnershipIndex

+ Keiro.Dsl.Workspace: [path] :: WorkspaceMember -> !FilePath

+ Keiro.Dsl.Workspace: [role] :: WorkspaceLocation -> !Text

+ Keiro.Dsl.Workspace: [runtimePackageLoc] :: WorkspaceManifest -> !Loc

+ Keiro.Dsl.Workspace: [runtimePackage] :: WorkspaceSpec -> !Maybe RuntimePackageName

+ Keiro.Dsl.Workspace: [serviceLoc] :: WorkspaceManifest -> !Loc

+ Keiro.Dsl.Workspace: [service] :: WorkspaceSpec -> !Text

+ Keiro.Dsl.Workspace: [severity] :: WorkspaceDiagnostic -> !Severity

+ Keiro.Dsl.Workspace: [sourceIndex] :: WorkspaceMember -> !SemanticSourceIndex

+ Keiro.Dsl.Workspace: [sourceLanguageCause] :: WorkspaceDiagnostic -> !Maybe SourceLanguageDiagnostic

+ Keiro.Dsl.Workspace: [sourceLanguage] :: WorkspaceMember -> !SourceLanguage

+ Keiro.Dsl.Workspace: [spec] :: WorkspaceMember -> !Spec

+ Keiro.Dsl.WorkspaceAdoption: [claimed] :: MigrationReport -> ![ClaimedFile]

+ Keiro.Dsl.WorkspaceAdoption: [evidence] :: ClaimedFile -> !ClaimEvidence

+ Keiro.Dsl.WorkspaceAdoption: [legacyRecord] :: MigrationReport -> !Maybe (FilePath, Text)

+ Keiro.Dsl.WorkspaceAdoption: [likelyStale] :: MigrationReport -> ![StaleModule]

+ Keiro.Dsl.WorkspaceAdoption: [path] :: ClaimedFile -> !FilePath

+ Keiro.Dsl.WorkspaceAdoption: [service] :: MigrationReport -> !Text

+ Keiro.Dsl.WorkspaceAdoption: [source] :: ClaimedFile -> !Maybe Text

+ Keiro.Dsl.WorkspaceAdoption: [spec] :: ClaimedFile -> !Maybe Text

+ Keiro.Dsl.WorkspaceAdoption: [unclaimed] :: MigrationReport -> ![FilePath]

+ Keiro.Dsl.WorkspaceDiff: [adoptionBaseline] :: WorkspaceMeta -> !Bool

+ Keiro.Dsl.WorkspaceDiff: [change] :: WorkspaceChange -> !Change

+ Keiro.Dsl.WorkspaceDiff: [declarationSite] :: WorkspaceChange -> !Maybe OwnedSite

+ Keiro.Dsl.WorkspaceDiff: [file] :: OwnedSite -> !FilePath

+ Keiro.Dsl.WorkspaceDiff: [identity] :: WorkspaceMeta -> !Text

+ Keiro.Dsl.WorkspaceDiff: [line] :: OwnedSite -> !Int

+ Keiro.Dsl.WorkspaceDiff: [manifest] :: WorkspaceMeta -> !FilePath

+ Keiro.Dsl.WorkspaceDiff: [membersNew] :: WorkspaceMeta -> ![FilePath]

+ Keiro.Dsl.WorkspaceDiff: [membersOld] :: WorkspaceMeta -> ![FilePath]

+ Keiro.Dsl.WorkspaceDiff: [since] :: WorkspaceMeta -> !Text

+ Keiro.Dsl.WorkspaceDiff: [useSites] :: WorkspaceChange -> ![(Text, Maybe OwnedSite)]

+ Keiro.Dsl.WorkspaceRecord: [adopted] :: WorkspaceRecord -> ![AdoptedRow]

+ Keiro.Dsl.WorkspaceRecord: [bindingObligations] :: WorkspaceRecord -> ![BindingHole]

+ Keiro.Dsl.WorkspaceRecord: [context] :: WorkspaceRecord -> !Text

+ Keiro.Dsl.WorkspaceRecord: [evidence] :: AdoptedRow -> !Text

+ Keiro.Dsl.WorkspaceRecord: [idDomains] :: WorkspaceRecord -> ![Text]

+ Keiro.Dsl.WorkspaceRecord: [kind] :: WorkspaceModuleRow -> !ModuleKind

+ Keiro.Dsl.WorkspaceRecord: [languageContract] :: WorkspaceRecord -> !EffectiveLanguageContract

+ Keiro.Dsl.WorkspaceRecord: [layout] :: WorkspaceRecord -> !Text

+ Keiro.Dsl.WorkspaceRecord: [manifest] :: WorkspaceRecord -> !Text

+ Keiro.Dsl.WorkspaceRecord: [mappings] :: WorkspaceRecord -> ![MappingIdentity]

+ Keiro.Dsl.WorkspaceRecord: [members] :: WorkspaceRecord -> ![FilePath]

+ Keiro.Dsl.WorkspaceRecord: [moduleRoot] :: WorkspaceRecord -> !Text

+ Keiro.Dsl.WorkspaceRecord: [modules] :: WorkspaceRecord -> ![WorkspaceModuleRow]

+ Keiro.Dsl.WorkspaceRecord: [namingEdition] :: WorkspaceRecord -> !GeneratedHaskellNamingEdition

+ Keiro.Dsl.WorkspaceRecord: [nominalEqualities] :: WorkspaceRecord -> ![Text]

+ Keiro.Dsl.WorkspaceRecord: [owner] :: WorkspaceModuleRow -> !Maybe FilePath

+ Keiro.Dsl.WorkspaceRecord: [path] :: AdoptedRow -> !FilePath

+ Keiro.Dsl.WorkspaceRecord: [projectionCatalogFacts] :: WorkspaceRecord -> ![Text]

+ Keiro.Dsl.WorkspaceRecord: [queryContractBaseline] :: WorkspaceRecord -> !Bool

+ Keiro.Dsl.WorkspaceRecord: [queryContracts] :: WorkspaceRecord -> ![QueryContractIdentity]

+ Keiro.Dsl.WorkspaceRecord: [requirements] :: WorkspaceRecord -> ![BehaviorRecordRow]

+ Keiro.Dsl.WorkspaceRecord: [role] :: WorkspaceModuleRow -> !Maybe ModuleRole

+ Keiro.Dsl.WorkspaceRecord: [routerSelections] :: WorkspaceRecord -> ![RouterSelectionSnapshot]

+ Keiro.Dsl.WorkspaceRecord: [semanticImpact] :: WorkspaceRecord -> !Maybe SemanticImpactSnapshot

+ Keiro.Dsl.WorkspaceRecord: [service] :: WorkspaceRecord -> !Text

+ Keiro.Dsl.WorkspaceRecord: [sourceLanguage] :: WorkspaceSourceLanguageRow -> !SourceLanguage

+ Keiro.Dsl.WorkspaceRecord: [sourceLanguages] :: WorkspaceRecord -> ![WorkspaceSourceLanguageRow]

+ Keiro.Dsl.WorkspaceRecord: [source] :: AdoptedRow -> !Maybe Text

+ Keiro.Dsl.WorkspaceRecord: [spec] :: AdoptedRow -> !Maybe Text

+ Keiro.Dsl.WorkspaceScaffold: [addedBehavior] :: WorkspaceScaffoldReport -> ![BehaviorRecordRow]

+ Keiro.Dsl.WorkspaceScaffold: [buildManifestPath] :: WorkspaceScaffoldReport -> !FilePath

+ Keiro.Dsl.WorkspaceScaffold: [checkedService] :: WorkspacePlan -> !CheckedService

+ Keiro.Dsl.WorkspaceScaffold: [conformancePackage] :: WorkspaceScaffoldReport -> !Maybe ConformancePackageReport

+ Keiro.Dsl.WorkspaceScaffold: [constraintPlan] :: WorkspaceScaffoldReport -> ![Text]

+ Keiro.Dsl.WorkspaceScaffold: [consumerPlan] :: WorkspaceScaffoldReport -> !ConsumerPlan

+ Keiro.Dsl.WorkspaceScaffold: [context] :: WorkspaceScaffoldReport -> !Context

+ Keiro.Dsl.WorkspaceScaffold: [current] :: WorkspaceSourceLanguageDrift -> !SourceLanguage

+ Keiro.Dsl.WorkspaceScaffold: [dispositions] :: WorkspaceScaffoldReport -> ![(ScaffoldModule, ModuleProvenance, WriteDisposition)]

+ Keiro.Dsl.WorkspaceScaffold: [generatedArtifactImpact] :: WorkspaceScaffoldReport -> ![GeneratedArtifactImpact]

+ Keiro.Dsl.WorkspaceScaffold: [goldenRoot] :: WorkspacePlan -> !FilePath

+ Keiro.Dsl.WorkspaceScaffold: [inertNodes] :: WorkspaceScaffoldReport -> ![(Text, Text)]

+ Keiro.Dsl.WorkspaceScaffold: [manifestPath] :: WorkspaceScaffoldReport -> !FilePath

+ Keiro.Dsl.WorkspaceScaffold: [mappingDrift] :: WorkspaceScaffoldReport -> ![MappingDrift]

+ Keiro.Dsl.WorkspaceScaffold: [members] :: WorkspaceScaffoldReport -> ![FilePath]

+ Keiro.Dsl.WorkspaceScaffold: [migration] :: WorkspaceScaffoldReport -> !Maybe MigrationReport

+ Keiro.Dsl.WorkspaceScaffold: [modules] :: WorkspacePlan -> ![(ScaffoldModule, ModuleProvenance)]

+ Keiro.Dsl.WorkspaceScaffold: [nameMoves] :: WorkspaceScaffoldReport -> ![SourceMove]

+ Keiro.Dsl.WorkspaceScaffold: [newHoles] :: WorkspaceScaffoldReport -> ![BindingHole]

+ Keiro.Dsl.WorkspaceScaffold: [obsoleteOutputHooks] :: WorkspaceScaffoldReport -> ![(Text, Text)]

+ Keiro.Dsl.WorkspaceScaffold: [outDir] :: WorkspaceScaffoldReport -> !FilePath

+ Keiro.Dsl.WorkspaceScaffold: [ownershipMoves] :: WorkspaceScaffoldReport -> ![OwnershipMove]

+ Keiro.Dsl.WorkspaceScaffold: [path] :: WorkspaceSourceLanguageDrift -> !FilePath

+ Keiro.Dsl.WorkspaceScaffold: [previousManifest] :: WorkspaceScaffoldReport -> !Maybe Text

+ Keiro.Dsl.WorkspaceScaffold: [previous] :: WorkspaceSourceLanguageDrift -> !SourceLanguage

+ Keiro.Dsl.WorkspaceScaffold: [projectionMappedImpact] :: WorkspaceScaffoldReport -> !Maybe ProjectionMappedImpact

+ Keiro.Dsl.WorkspaceScaffold: [queryContractBaselineUnavailable] :: WorkspaceScaffoldReport -> !Bool

+ Keiro.Dsl.WorkspaceScaffold: [queryContractDrift] :: WorkspaceScaffoldReport -> ![QueryContractDrift]

+ Keiro.Dsl.WorkspaceScaffold: [queryContractMigrations] :: WorkspaceScaffoldReport -> ![QueryContractMigration]

+ Keiro.Dsl.WorkspaceScaffold: [recordPath] :: WorkspaceScaffoldReport -> !FilePath

+ Keiro.Dsl.WorkspaceScaffold: [removedBehavior] :: WorkspaceScaffoldReport -> ![BehaviorRecordRow]

+ Keiro.Dsl.WorkspaceScaffold: [routerSelectionDrift] :: WorkspaceScaffoldReport -> ![RouterSelectionDrift]

+ Keiro.Dsl.WorkspaceScaffold: [runtimePackage] :: WorkspacePlan -> !Maybe RuntimePackageName

+ Keiro.Dsl.WorkspaceScaffold: [semanticImpact] :: WorkspaceScaffoldReport -> !SemanticImpactReport

+ Keiro.Dsl.WorkspaceScaffold: [service] :: WorkspaceScaffoldReport -> !Text

+ Keiro.Dsl.WorkspaceScaffold: [sidecarMoves] :: WorkspaceScaffoldReport -> ![SidecarMove]

+ Keiro.Dsl.WorkspaceScaffold: [sourceLanguageDrift] :: WorkspaceScaffoldReport -> ![WorkspaceSourceLanguageDrift]

+ Keiro.Dsl.WorkspaceScaffold: [stale] :: WorkspaceScaffoldReport -> ![StaleModule]

+ Keiro.Dsl.WorkspaceScaffold: [workspace] :: WorkspacePlan -> !WorkspaceSpec

+ Keiro.Dsl.WorkspaceScaffold: executeWorkspaceScaffoldWithMigrations :: FilePath -> Bool -> Bool -> Bool -> WorkspacePlan -> IO (Either [Refusal] WorkspaceScaffoldReport)

+ Keiro.Dsl.WorkspaceScaffold: readWorkspaceRecord :: FilePath -> IO (LedgerRead WorkspaceRecord)

- Keiro.Dsl.Coverage: [jsonBoundaries] :: CoverageCounts -> !Int

+ Keiro.Dsl.Coverage: [jsonBoundaries] :: CoverageReport -> ![JsonBoundary]

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

+ Keiro.Dsl.Grammar: [input] :: WorkflowNode -> !Name

- Keiro.Dsl.Scaffold: [kind] :: ScaffoldModule -> !ModuleKind

+ Keiro.Dsl.Scaffold: [kind] :: NominalUseSite -> !AggregateUseSite

This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.

Files

CHANGELOG.md +36/−0
app/Main.hs +160/−133
bench/structural-codec/Main.hs +0/−2
generated-haskell-edition-idiomatic-v2.md too large to diff
internal/Keiro/Dsl/GeneratedHaskellLanguage.hs +174/−0
keiro-dsl.cabal +78/−42
record-field-migration-0.15.md +1433/−0
src/Keiro/Dsl/AggregateGenerationPlan.hs +6/−6
src/Keiro/Dsl/AggregateType.hs +76/−73
src/Keiro/Dsl/BehaviorCoverage.hs +194/−171
src/Keiro/Dsl/BehaviorSourceMap.hs +89/−74
src/Keiro/Dsl/CanonicalEncoding.hs +8/−8
src/Keiro/Dsl/CheckReport.hs +110/−110
src/Keiro/Dsl/CodecCompare.hs +123/−119
src/Keiro/Dsl/ConformancePackage.hs +96/−96
src/Keiro/Dsl/ConsumerTypePlan.hs +49/−43
src/Keiro/Dsl/CoordinationImpact.hs +92/−92
src/Keiro/Dsl/Coverage.hs +294/−276
src/Keiro/Dsl/Diff.hs +3092/−3018
src/Keiro/Dsl/DiffReport.hs +105/−105
src/Keiro/Dsl/EventOutput.hs +30/−26
src/Keiro/Dsl/ExplainBindings.hs +149/−149
src/Keiro/Dsl/Expression.hs +104/−96
src/Keiro/Dsl/FieldIdentity.hs +12/−12
src/Keiro/Dsl/FoldFingerprint.hs +71/−71
src/Keiro/Dsl/Frontend/Internal.hs +75/−69
src/Keiro/Dsl/GeneratedHaskellLanguage.hs +0/−48
src/Keiro/Dsl/Goldens.hs +65/−55
src/Keiro/Dsl/Grammar.hs +382/−378
src/Keiro/Dsl/Harness.hs +301/−301
src/Keiro/Dsl/HaskellImport.hs +35/−35
src/Keiro/Dsl/HaskellName.hs +25/−22
src/Keiro/Dsl/HaskellSourceMove.hs +30/−30
src/Keiro/Dsl/IdDomain.hs +11/−11
src/Keiro/Dsl/LanguageVersion.hs +53/−53
src/Keiro/Dsl/Manifest.hs +19/−19
src/Keiro/Dsl/MappedCodecPlan.hs +7/−7
src/Keiro/Dsl/MappedConsumer.hs +102/−102
src/Keiro/Dsl/MappedDiff.hs +76/−76
src/Keiro/Dsl/NominalType.hs +100/−99
src/Keiro/Dsl/Parser.hs +1/−1
src/Keiro/Dsl/Parser/Aggregate.hs +49/−49
src/Keiro/Dsl/Parser/Coordination.hs +72/−72
src/Keiro/Dsl/Parser/Core.hs +9/−9
src/Keiro/Dsl/Parser/Declaration.hs +7/−7
src/Keiro/Dsl/Parser/Document.hs +2/−2
src/Keiro/Dsl/Parser/Integration.hs +41/−41
src/Keiro/Dsl/Parser/Mapped.hs +21/−21
src/Keiro/Dsl/Parser/Preamble.hs +20/−20
src/Keiro/Dsl/Parser/ProjectionCatalog.hs +30/−30
src/Keiro/Dsl/Parser/Queue.hs +29/−29
src/Keiro/Dsl/Parser/ReadModel.hs +12/−12
src/Keiro/Dsl/Parser/Workflow.hs +11/−11
src/Keiro/Dsl/PrettyPrint.hs +304/−304
src/Keiro/Dsl/ProjectionMappedImpact.hs +25/−25
src/Keiro/Dsl/ProjectionSupply.hs +40/−40
src/Keiro/Dsl/ReadModelQueryContract.hs +23/−23
src/Keiro/Dsl/ReadModelShape.hs +10/−10
src/Keiro/Dsl/ReplayImpact.hs +107/−74
src/Keiro/Dsl/RouterSelection.hs +174/−150
src/Keiro/Dsl/RuntimePackage.hs +4/−0
src/Keiro/Dsl/Scaffold.hs +8754/−8725
src/Keiro/Dsl/ScaffoldRecord.hs +146/−139
src/Keiro/Dsl/ScaffoldRun.hs +2047/−1713
src/Keiro/Dsl/SemanticContract.hs +25/−27
src/Keiro/Dsl/SemanticImpact.hs +230/−226
src/Keiro/Dsl/ServiceHarness.hs +13/−13
src/Keiro/Dsl/SidecarMigration.hs +58/−63
src/Keiro/Dsl/Source.hs +0/−2
src/Keiro/Dsl/SourceIndex.hs +41/−40
src/Keiro/Dsl/StructuralConformance.hs +98/−84
src/Keiro/Dsl/Syntax.hs +0/−2
src/Keiro/Dsl/TypeGraph.hs +192/−168
src/Keiro/Dsl/Validate.hs +4783/−4783
src/Keiro/Dsl/Workspace.hs +228/−228
src/Keiro/Dsl/WorkspaceAdoption.hs +42/−42
src/Keiro/Dsl/WorkspaceDiff.hs +34/−34
src/Keiro/Dsl/WorkspaceRecord.hs +133/−114
src/Keiro/Dsl/WorkspaceScaffold.hs +353/−285
test/Keiro/Dsl/ConformanceBaseline.hs +53/−52
test/Keiro/Dsl/FrontendCompatibility.hs +45/−45
test/Keiro/Dsl/FrontendProfiles.hs +13/−15
test/Keiro/Dsl/FrontendPublicApiProbe.hs +9/−9
test/Keiro/Dsl/FrontendSurface.hs +16/−18
test/Main.hs +15034/−13923
test/README.md +78/−0
test/aggregate-scalar-expression-mutation-test.sh +128/−0
test/aggregate-scalars-mutation-test.sh +51/−0
test/behavior-complete-mutation-test.sh +171/−0
test/conformance-aggregate-scalars/AggregateScalars/ScalarLedger/BehaviorHoles.hs +10/−0
test/conformance-aggregate-scalars/Generated/AggregateScalars/BehaviorSourceMap.hs +5/−5
test/conformance-aggregate-scalars/Generated/AggregateScalars/ReplayAudit.hs +1/−1
test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/BehaviorContract.hs +350/−0
test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Codec.hs +1/−2
test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Domain.hs +1/−2
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/−2
test/conformance-aggregate-scalars/keiro-dsl-cabal-fragment.context.aggregate-scalars.txt +32/−0
test/conformance-aggregate-scalars/keiro-dsl-ledger.context.aggregate-scalars.txt +32/−0
test/conformance-baseline.json +63/−0
test/conformance-behavior-complete/Generated/BehaviorComplete/BehaviorSourceMap.hs +5/−5
test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/BehaviorContract.hs +263/−259
test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Codec.hs +3/−4
test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Domain.hs +1/−2
test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/EventStream.hs +1/−1
test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Harness.hs +1/−1
test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Projection.hs +1/−1
test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Transducer.hs +1/−2
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 +4/−4
test/conformance-behavior-complete/Generated/BehaviorComplete/StructuralProjections.hs +3/−3
test/conformance-behavior-complete/behavior-complete-report.cabal +42/−0
test/conformance-behavior-complete/keiro-dsl-cabal-fragment.context.behavior-complete.txt +45/−0
test/conformance-behavior-complete/keiro-dsl-ledger.context.behavior-complete.txt +65/−0
test/conformance-codec-compare/Conformance/CodecCompare/Historical.hs +8/−8
test/conformance-codec-compare/Main.hs +6/−6
test/conformance-codec-compare/RunnerMain.hs +25/−0
test/conformance-codec-compare/fixtures/artifact-info/canonical.json +10/−0
test/conformance-codec-compare/fixtures/artifact-info/local-dir-null.json +10/−0
test/conformance-codec-compare/fixtures/artifact-info/local-file-missing.json +6/−0
test/conformance-codec-compare/fixtures/artifact-info/repo-path.json +10/−0
test/conformance-codec-compare/fixtures/artifact-info/url.json +10/−0
test/conformance-codec-compare/fixtures/generated-parity/canonical.json +10/−0
test/conformance-codec-compare/fixtures/generated-parity/local-dir-null.json +10/−0
test/conformance-codec-compare/fixtures/generated-parity/local-file-missing.json +6/−0
test/conformance-codec-compare/fixtures/generated-parity/repo-path.json +10/−0
test/conformance-codec-compare/fixtures/generated-parity/url.json +10/−0
test/conformance-codec-compare/fixtures/missing-arm/local-file.json +6/−0
test/conformance-coldstart/Billing/Subscription/BehaviorHoles.hs +14/−0
test/conformance-coldstart/Generated/Billing/BehaviorSourceMap.hs +5/−5
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/BehaviorContract.hs +399/−0
test/conformance-coldstart/Generated/Billing/Subscription/Codec.hs +1/−2
test/conformance-coldstart/Generated/Billing/Subscription/Domain.hs +1/−2
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/−2
test/conformance-coldstart/keiro-dsl-cabal-fragment.context.billing.txt +33/−0
test/conformance-coldstart/keiro-dsl-ledger.context.billing.txt +45/−0
test/conformance-contract-v1-compat/Generated/HospitalCapacity/Emergency/Contract.hs +1/−3
test/conformance-contract-v1-compat/keiro-dsl-cabal-fragment.context.hospital-capacity.txt +19/−0
test/conformance-contract-v1-compat/keiro-dsl-ledger.context.hospital-capacity.txt +10/−0
test/conformance-contract/Generated/HospitalCapacity/Emergency/Contract.hs +1/−3
test/conformance-contract/Main.hs +3/−3
test/conformance-contract/keiro-dsl-cabal-fragment.context.hospital-capacity.txt +21/−0
test/conformance-contract/keiro-dsl-ledger.context.hospital-capacity.txt +14/−0
test/conformance-corpus-manifest.txt +127/−0
test/conformance-declarative-router/Generated/TransferRouting/BehaviorSourceMap.hs +5/−5
test/conformance-declarative-router/Generated/TransferRouting/Hospital/BehaviorContract.hs +110/−106
test/conformance-declarative-router/Generated/TransferRouting/Hospital/Codec.hs +1/−2
test/conformance-declarative-router/Generated/TransferRouting/Hospital/Domain.hs +1/−2
test/conformance-declarative-router/Generated/TransferRouting/Hospital/EventStream.hs +1/−1
test/conformance-declarative-router/Generated/TransferRouting/Hospital/Harness.hs +1/−1
test/conformance-declarative-router/Generated/TransferRouting/Hospital/Projection.hs +1/−1
test/conformance-declarative-router/Generated/TransferRouting/Hospital/Transducer.hs +1/−2
test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/QueryContract.hs +1/−1
test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/ReadModel.hs +1/−1
test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/ReadModelHarness.hs +1/−2
test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/ReadModelTable.hs +1/−1
test/conformance-declarative-router/Generated/TransferRouting/HospitalTransferRouter/Router.hs +1/−1
test/conformance-declarative-router/Generated/TransferRouting/HospitalTransferRouter/RouterHarness.hs +1/−1
test/conformance-declarative-router/Generated/TransferRouting/ProjectionCatalog.hs +1/−1
test/conformance-declarative-router/Generated/TransferRouting/ReplayAudit.hs +1/−1
test/conformance-declarative-router/Generated/TransferRouting/Structural/Shape/HospitalLoadRow.hs +1/−1
test/conformance-declarative-router/Generated/TransferRouting/Structural/Shape/TransferRouteInput.hs +1/−1
test/conformance-declarative-router/Generated/TransferRouting/StructuralConformance.hs +8/−8
test/conformance-declarative-router/Generated/TransferRouting/StructuralProjections.hs +8/−8
test/conformance-declarative-router/README.md +23/−0
test/conformance-declarative-router/keiro-dsl-cabal-fragment.context.transfer-routing.txt +56/−0
test/conformance-declarative-router/keiro-dsl-ledger.context.transfer-routing.txt +79/−0
test/conformance-dispatch-full/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModel.hs +60/−0
test/conformance-dispatch-full/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelHarness.hs +32/−0
test/conformance-dispatch-full/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelTable.hs +9/−0
test/conformance-dispatch-full/Generated/HospitalCapacity/ReservationWork/Queue.hs +1/−2
test/conformance-dispatch-full/Generated/HospitalCapacity/ReservationWork/QueueCodec.hs +1/−1
test/conformance-dispatch-full/Generated/HospitalCapacity/ReservationWork/QueuePolicy.hs +1/−1
test/conformance-dispatch-full/Generated/HospitalCapacity/TransferDecisions/ReadModel.hs +60/−0
test/conformance-dispatch-full/Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs +32/−0
test/conformance-dispatch-full/Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs +9/−0
test/conformance-dispatch-full/HospitalCapacity/AcceptedTransferNeeds/ReadModelHoles.hs +26/−0
test/conformance-dispatch-full/HospitalCapacity/TransferDecisions/ReadModelHoles.hs +25/−0
test/conformance-dispatch-full/keiro-dsl-cabal-fragment.context.hospital-capacity.txt +35/−0
test/conformance-dispatch-full/keiro-dsl-ledger.context.hospital-capacity.txt +30/−0
test/conformance-domain-outcomes/Generated/DomainOutcomes/BehaviorSourceMap.hs +5/−5
test/conformance-domain-outcomes/Generated/DomainOutcomes/Nominals.hs +1/−1
test/conformance-domain-outcomes/Generated/DomainOutcomes/ReplayAudit.hs +1/−1
test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/BehaviorContract.hs +119/−115
test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Codec.hs +1/−2
test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Domain.hs +1/−2
test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/EventStream.hs +1/−1
test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Harness.hs +1/−1
test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Projection.hs +1/−1
test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Transducer.hs +1/−2
test/conformance-domain-outcomes/keiro-dsl-cabal-fragment.context.domain-outcomes.txt +31/−0
test/conformance-domain-outcomes/keiro-dsl-ledger.context.domain-outcomes.txt +35/−0
test/conformance-id-domain-migration/Generated/IdDomainMigration/BehaviorSourceMap.hs +5/−5
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/BehaviorContract.hs +350/−0
test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Codec.hs +1/−2
test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Domain.hs +1/−2
test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/EventStream.hs +63/−0
test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Harness.hs +59/−0
test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Projection.hs +4/−0
test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Transducer.hs +57/−0
test/conformance-id-domain-migration/Generated/IdDomainMigration/ReplayAudit.hs +23/−0
test/conformance-id-domain-migration/IdDomainMigration/OrderBook/BehaviorHoles.hs +10/−0
test/conformance-id-domain-migration/Main.hs +1/−1
test/conformance-id-domain-migration/keiro-dsl-cabal-fragment.context.id-domain-migration.txt +32/−0
test/conformance-id-domain-migration/keiro-dsl-ledger.context.id-domain-migration.txt +36/−0
test/conformance-import-planning/Generated/ImportPlanningCollisions/BehaviorSourceMap.hs +5/−5
test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/BehaviorContract.hs +110/−106
test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Codec.hs +2/−3
test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Domain.hs +1/−2
test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/EventStream.hs +1/−1
test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Harness.hs +1/−1
test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Projection.hs +1/−1
test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Transducer.hs +1/−2
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 +3/−3
test/conformance-import-planning/Generated/ImportPlanningCollisions/StructuralProjections.hs +3/−3
test/conformance-import-planning/keiro-dsl-cabal-fragment.context.import-planning-collisions.txt +46/−0
test/conformance-import-planning/keiro-dsl-ledger.context.import-planning-collisions.txt +52/−0
test/conformance-intake-full/Generated/HospitalCapacity/Emergency/Contract.hs +64/−0
test/conformance-intake-full/Generated/HospitalCapacity/IncidentInbox/Inbox.hs +3/−3
test/conformance-intake-full/keiro-dsl-cabal-fragment.context.hospital-capacity.txt +26/−0
test/conformance-intake-full/keiro-dsl-ledger.context.hospital-capacity.txt +13/−0
test/conformance-intake-runtime/Generated/HospitalCapacity/Emergency/Contract.hs +64/−0
test/conformance-intake-runtime/Generated/HospitalCapacity/IncidentInbox/Inbox.hs +3/−3
test/conformance-intake-runtime/keiro-dsl-cabal-fragment.context.hospital-capacity.txt +26/−0
test/conformance-intake-runtime/keiro-dsl-ledger.context.hospital-capacity.txt +13/−0
test/conformance-mapped-queue/Generated/MappedQueue/MappedJobs/Queue.hs +6/−7
test/conformance-mapped-queue/Generated/MappedQueue/MappedJobs/QueueCodec.hs +1/−1
test/conformance-mapped-queue/Generated/MappedQueue/MappedJobs/QueuePolicy.hs +1/−1
test/conformance-mapped-queue/Generated/MappedQueue/Structural/Shape/JobMetadata.hs +1/−1
test/conformance-mapped-queue/Generated/MappedQueue/Structural/Shape/JobPayload.hs +1/−1
test/conformance-mapped-queue/Generated/MappedQueue/StructuralConformance.hs +7/−7
test/conformance-mapped-queue/Generated/MappedQueue/StructuralProjections.hs +4/−4
test/conformance-mapped-queue/Main.hs +1/−1
test/conformance-mapped-queue/keiro-dsl-cabal-fragment.context.mapped-queue.txt +36/−0
test/conformance-mapped-queue/keiro-dsl-ledger.context.mapped-queue.txt +34/−0
test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/QueryContract.hs +1/−1
test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/ReadModel.hs +1/−1
test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/ReadModelHarness.hs +1/−2
test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/ReadModelTable.hs +1/−1
test/conformance-mapped-readmodel/Generated/MappedReadmodel/ProjectionCatalog.hs +1/−1
test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/AccountLookup.hs +1/−1
test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/AccountProfile.hs +1/−1
test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/AccountSummary.hs +1/−1
test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/TenantKey.hs +1/−1
test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/UnusedFilter.hs +1/−1
test/conformance-mapped-readmodel/Generated/MappedReadmodel/StructuralConformance.hs +14/−14
test/conformance-mapped-readmodel/Generated/MappedReadmodel/StructuralProjections.hs +13/−13
test/conformance-mapped-readmodel/keiro-dsl-cabal-fragment.context.mapped-readmodel.txt +44/−0
test/conformance-mapped-readmodel/keiro-dsl-ledger.context.mapped-readmodel.txt +67/−0
test/conformance-newsurface/Generated/TransferRouting/BehaviorSourceMap.hs +5/−5
test/conformance-newsurface/Generated/TransferRouting/Hospital/BehaviorContract.hs +337/−0
test/conformance-newsurface/Generated/TransferRouting/Hospital/Codec.hs +1/−2
test/conformance-newsurface/Generated/TransferRouting/Hospital/Domain.hs +1/−2
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/−2
test/conformance-newsurface/Generated/TransferRouting/HospitalLoad/ReadModel.hs +1/−2
test/conformance-newsurface/Generated/TransferRouting/HospitalLoad/ReadModelHarness.hs +1/−2
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-newsurface/TransferRouting/Hospital/BehaviorHoles.hs +9/−0
test/conformance-newsurface/keiro-dsl-cabal-fragment.context.transfer-routing.txt +41/−0
test/conformance-newsurface/keiro-dsl-ledger.context.transfer-routing.txt +44/−0
test/conformance-nominal-scalars/Generated/NominalScalars/BehaviorSourceMap.hs +5/−5
test/conformance-nominal-scalars/Generated/NominalScalars/Nominal/Shape/OrderStatus.hs +1/−1
test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/BehaviorContract.hs +110/−106
test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Codec.hs +1/−2
test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Domain.hs +1/−2
test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/EventStream.hs +1/−1
test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Harness.hs +1/−1
test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Projection.hs +1/−1
test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Transducer.hs +1/−2
test/conformance-nominal-scalars/Generated/NominalScalars/NominalProjections.hs +1/−1
test/conformance-nominal-scalars/Generated/NominalScalars/ReplayAudit.hs +1/−1
test/conformance-nominal-scalars/NominalConformance/Domain.hs +18/−0
test/conformance-nominal-scalars/compile-fail/PartialInverse.hs +12/−0
test/conformance-nominal-scalars/compile-fail/check-partial-inverse.sh +4/−0
test/conformance-nominal-scalars/keiro-dsl-cabal-fragment.context.nominal-scalars.txt +42/−0
test/conformance-nominal-scalars/keiro-dsl-ledger.context.nominal-scalars.txt +67/−0
test/conformance-nominal-scalars/mutations/dishonest-exact.sh +4/−0
test/conformance-nominal-scalars/mutations/enum-transpose.sh +4/−0
test/conformance-nominal-scalars/mutations/id-one-direction.sh +4/−0
test/conformance-nominal-scalars/mutations/scalar-wire.sh +4/−0
test/conformance-process-full/Generated/SurgeDemo/BehaviorSourceMap.hs +5/−5
test/conformance-process-full/Generated/SurgeDemo/Hospital/BehaviorContract.hs +349/−0
test/conformance-process-full/Generated/SurgeDemo/Hospital/Codec.hs +1/−2
test/conformance-process-full/Generated/SurgeDemo/Hospital/Domain.hs +1/−2
test/conformance-process-full/Generated/SurgeDemo/Hospital/EventStream.hs +1/−1
test/conformance-process-full/Generated/SurgeDemo/Hospital/Harness.hs +57/−0
test/conformance-process-full/Generated/SurgeDemo/Hospital/Projection.hs +1/−1
test/conformance-process-full/Generated/SurgeDemo/Hospital/Transducer.hs +1/−2
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/BehaviorContract.hs +398/−0
test/conformance-process-full/Generated/SurgeDemo/Surge/Codec.hs +1/−2
test/conformance-process-full/Generated/SurgeDemo/Surge/Domain.hs +1/−2
test/conformance-process-full/Generated/SurgeDemo/Surge/EventStream.hs +1/−1
test/conformance-process-full/Generated/SurgeDemo/Surge/Harness.hs +61/−0
test/conformance-process-full/Generated/SurgeDemo/Surge/Projection.hs +1/−1
test/conformance-process-full/Generated/SurgeDemo/Surge/Transducer.hs +1/−2
test/conformance-process-full/Generated/SurgeDemo/SurgeFlow/Process.hs +1/−1
test/conformance-process-full/Generated/SurgeDemo/SurgeFlow/ProcessHarness.hs +22/−0
test/conformance-process-full/SurgeDemo/Hospital/BehaviorHoles.hs +10/−0
test/conformance-process-full/SurgeDemo/Surge/BehaviorHoles.hs +14/−0
test/conformance-process-full/SurgeDemo/SurgeFlow/Manager.hs +4/−4
test/conformance-process-full/SurgeDemo/SurgeFlow/ProcessHoles.hs +11/−0
test/conformance-process-full/keiro-dsl-cabal-fragment.context.surge-demo.txt +48/−0
test/conformance-process-full/keiro-dsl-ledger.context.surge-demo.txt +68/−0
test/conformance-process-runtime/Generated/HospitalCapacity/BehaviorSourceMap.hs +5/−5
test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/BehaviorContract.hs +337/−0
test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/Codec.hs +66/−0
test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/Domain.hs +40/−0
test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/EventStream.hs +49/−0
test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/Harness.hs +57/−0
test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/Projection.hs +4/−0
test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/Transducer.hs +54/−0
test/conformance-process-runtime/Generated/HospitalCapacity/HospitalSurge/Process.hs +1/−1
test/conformance-process-runtime/Generated/HospitalCapacity/HospitalSurge/ProcessHarness.hs +22/−0
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/ReplayAudit.hs +30/−0
test/conformance-process-runtime/Generated/HospitalCapacity/Surge/BehaviorContract.hs +350/−0
test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Codec.hs +1/−2
test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Domain.hs +1/−2
test/conformance-process-runtime/Generated/HospitalCapacity/Surge/EventStream.hs +1/−1
test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Harness.hs +87/−0
test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Projection.hs +4/−0
test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Transducer.hs +1/−2
test/conformance-process-runtime/HospitalCapacity/Hospital/BehaviorHoles.hs +9/−0
test/conformance-process-runtime/HospitalCapacity/Hospital/Holes.hs +33/−0
test/conformance-process-runtime/HospitalCapacity/HospitalSurge/ProcessHoles.hs +11/−0
test/conformance-process-runtime/HospitalCapacity/Surge/BehaviorHoles.hs +10/−0
test/conformance-process-runtime/keiro-dsl-cabal-fragment.context.hospital-capacity.txt +46/−0
test/conformance-process-runtime/keiro-dsl-ledger.context.hospital-capacity.txt +61/−0
test/conformance-process/Generated/HospitalCapacity/BehaviorSourceMap.hs +5/−5
test/conformance-process/Generated/HospitalCapacity/Hospital/BehaviorContract.hs +337/−0
test/conformance-process/Generated/HospitalCapacity/Hospital/Codec.hs +66/−0
test/conformance-process/Generated/HospitalCapacity/Hospital/Domain.hs +40/−0
test/conformance-process/Generated/HospitalCapacity/Hospital/EventStream.hs +49/−0
test/conformance-process/Generated/HospitalCapacity/Hospital/Harness.hs +57/−0
test/conformance-process/Generated/HospitalCapacity/Hospital/Projection.hs +4/−0
test/conformance-process/Generated/HospitalCapacity/Hospital/Transducer.hs +54/−0
test/conformance-process/Generated/HospitalCapacity/HospitalSurge/Process.hs +76/−0
test/conformance-process/Generated/HospitalCapacity/HospitalSurge/ProcessHarness.hs +1/−1
test/conformance-process/Generated/HospitalCapacity/Nominals.hs +13/−0
test/conformance-process/Generated/HospitalCapacity/Nominals/Internal.hs +70/−0
test/conformance-process/Generated/HospitalCapacity/ReplayAudit.hs +30/−0
test/conformance-process/Generated/HospitalCapacity/Surge/BehaviorContract.hs +350/−0
test/conformance-process/Generated/HospitalCapacity/Surge/Codec.hs +85/−0
test/conformance-process/Generated/HospitalCapacity/Surge/Domain.hs +61/−0
test/conformance-process/Generated/HospitalCapacity/Surge/EventStream.hs +49/−0
test/conformance-process/Generated/HospitalCapacity/Surge/Harness.hs +87/−0
test/conformance-process/Generated/HospitalCapacity/Surge/Projection.hs +4/−0
test/conformance-process/Generated/HospitalCapacity/Surge/Transducer.hs +64/−0
test/conformance-process/HospitalCapacity/Hospital/BehaviorHoles.hs +9/−0
test/conformance-process/HospitalCapacity/Hospital/Holes.hs +37/−0
test/conformance-process/HospitalCapacity/HospitalSurge/ProcessHoles.hs +11/−0
test/conformance-process/HospitalCapacity/Surge/BehaviorHoles.hs +10/−0
test/conformance-process/HospitalCapacity/Surge/Holes.hs +37/−0
test/conformance-process/keiro-dsl-cabal-fragment.context.hospital-capacity.txt +46/−0
test/conformance-process/keiro-dsl-ledger.context.hospital-capacity.txt +61/−0
test/conformance-projection-catalog/Generated/CatalogDemo/BehaviorSourceMap.hs +5/−5
test/conformance-projection-catalog/Generated/CatalogDemo/CatalogAudit/ReadModel.hs +1/−1
test/conformance-projection-catalog/Generated/CatalogDemo/CatalogAudit/ReadModelHarness.hs +1/−2
test/conformance-projection-catalog/Generated/CatalogDemo/CatalogAudit/ReadModelTable.hs +1/−1
test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/QueryContract.hs +1/−1
test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/ReadModel.hs +1/−1
test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/ReadModelHarness.hs +1/−2
test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/ReadModelTable.hs +1/−1
test/conformance-projection-catalog/Generated/CatalogDemo/OrderTotalsLookup/ReadModel.hs +1/−1
test/conformance-projection-catalog/Generated/CatalogDemo/OrderTotalsLookup/ReadModelHarness.hs +1/−2
test/conformance-projection-catalog/Generated/CatalogDemo/OrderTotalsLookup/ReadModelTable.hs +1/−1
test/conformance-projection-catalog/Generated/CatalogDemo/Orders/BehaviorContract.hs +110/−106
test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Codec.hs +1/−2
test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Domain.hs +1/−2
test/conformance-projection-catalog/Generated/CatalogDemo/Orders/EventStream.hs +1/−1
test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Harness.hs +1/−1
test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Projection.hs +1/−1
test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Transducer.hs +1/−2
test/conformance-projection-catalog/Generated/CatalogDemo/ProjectionCatalog.hs +1/−1
test/conformance-projection-catalog/Generated/CatalogDemo/QualificationJobs/Queue.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/QualificationJobs/QueueCodec.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/QualificationJobs/QueuePolicy.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/ReplayAudit.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/ShipmentLookup/ReadModel.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/ShipmentLookup/ReadModelHarness.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/ShipmentLookup/ReadModelTable.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/BehaviorContract.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Codec.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Domain.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/EventStream.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Harness.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Projection.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Transducer.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/Structural/Shape/QualificationPayload.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/StructuralConformance.hs too large to diff
test/conformance-projection-catalog/Generated/CatalogDemo/StructuralProjections.hs too large to diff
test/conformance-projection-catalog/Main.hs too large to diff
test/conformance-projection-catalog/keiro-dsl-cabal-fragment.context.catalog-demo.txt too large to diff
test/conformance-projection-catalog/keiro-dsl-ledger.context.catalog-demo.txt too large to diff
test/conformance-publisher-runtime/Generated/HospitalCapacity/Emergency/Contract.hs too large to diff
test/conformance-publisher-runtime/Generated/HospitalCapacity/HospitalPublisher/Publisher.hs too large to diff
test/conformance-publisher-runtime/keiro-dsl-cabal-fragment.context.hospital-capacity.txt too large to diff
test/conformance-publisher-runtime/keiro-dsl-ledger.context.hospital-capacity.txt too large to diff
test/conformance-queue-runtime/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModel.hs too large to diff
test/conformance-queue-runtime/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelHarness.hs too large to diff
test/conformance-queue-runtime/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelTable.hs too large to diff
test/conformance-queue-runtime/Generated/HospitalCapacity/ReservationWork/Queue.hs too large to diff
test/conformance-queue-runtime/Generated/HospitalCapacity/ReservationWork/QueueCodec.hs too large to diff
test/conformance-queue-runtime/Generated/HospitalCapacity/ReservationWork/QueuePolicy.hs too large to diff
test/conformance-queue-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModel.hs too large to diff
test/conformance-queue-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs too large to diff
test/conformance-queue-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs too large to diff
test/conformance-queue-runtime/HospitalCapacity/AcceptedTransferNeeds/ReadModelHoles.hs too large to diff
test/conformance-queue-runtime/HospitalCapacity/TransferDecisions/ReadModelHoles.hs too large to diff
test/conformance-queue-runtime/keiro-dsl-cabal-fragment.context.hospital-capacity.txt too large to diff
test/conformance-queue-runtime/keiro-dsl-ledger.context.hospital-capacity.txt too large to diff
test/conformance-queue/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModel.hs too large to diff
test/conformance-queue/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelHarness.hs too large to diff
test/conformance-queue/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelTable.hs too large to diff
test/conformance-queue/Generated/HospitalCapacity/ReservationWork/Queue.hs too large to diff
test/conformance-queue/Generated/HospitalCapacity/ReservationWork/QueueCodec.hs too large to diff
test/conformance-queue/Generated/HospitalCapacity/ReservationWork/QueuePolicy.hs too large to diff
test/conformance-queue/Generated/HospitalCapacity/TransferDecisions/ReadModel.hs too large to diff
test/conformance-queue/Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs too large to diff
test/conformance-queue/Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs too large to diff
test/conformance-queue/HospitalCapacity/AcceptedTransferNeeds/ReadModelHoles.hs too large to diff
test/conformance-queue/HospitalCapacity/TransferDecisions/ReadModelHoles.hs too large to diff
test/conformance-queue/keiro-dsl-cabal-fragment.context.hospital-capacity.txt too large to diff
test/conformance-queue/keiro-dsl-ledger.context.hospital-capacity.txt too large to diff
test/conformance-readmodel-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModel.hs too large to diff
test/conformance-readmodel-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs too large to diff
test/conformance-readmodel-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs too large to diff
test/conformance-readmodel-runtime/keiro-dsl-cabal-fragment.context.hospital-capacity.txt too large to diff
test/conformance-readmodel-runtime/keiro-dsl-ledger.context.hospital-capacity.txt too large to diff
test/conformance-replay/Generated/ReplayDivergence/BehaviorSourceMap.hs too large to diff
test/conformance-replay/Generated/ReplayDivergence/Note/BehaviorContract.hs too large to diff
test/conformance-replay/Generated/ReplayDivergence/Note/Codec.hs too large to diff
test/conformance-replay/Generated/ReplayDivergence/Note/Domain.hs too large to diff
test/conformance-replay/Generated/ReplayDivergence/Note/EventStream.hs too large to diff
test/conformance-replay/Generated/ReplayDivergence/Note/Harness.hs too large to diff
test/conformance-replay/Generated/ReplayDivergence/Note/Projection.hs too large to diff
test/conformance-replay/Generated/ReplayDivergence/Note/Transducer.hs too large to diff
test/conformance-replay/Generated/ReplayDivergence/ReplayAudit.hs too large to diff
test/conformance-replay/ReplayDivergence/Note/BehaviorHoles.hs too large to diff
test/conformance-replay/keiro-dsl-cabal-fragment.context.replay-divergence.txt too large to diff
test/conformance-replay/keiro-dsl-ledger.context.replay-divergence.txt too large to diff
test/conformance-router-full/Generated/IncidentPaging/BehaviorSourceMap.hs too large to diff
test/conformance-router-full/Generated/IncidentPaging/Page/BehaviorContract.hs too large to diff
test/conformance-router-full/Generated/IncidentPaging/Page/Codec.hs too large to diff
test/conformance-router-full/Generated/IncidentPaging/Page/Domain.hs too large to diff
test/conformance-router-full/Generated/IncidentPaging/Page/EventStream.hs too large to diff
test/conformance-router-full/Generated/IncidentPaging/Page/Harness.hs too large to diff
test/conformance-router-full/Generated/IncidentPaging/Page/Projection.hs too large to diff
test/conformance-router-full/Generated/IncidentPaging/Page/Transducer.hs too large to diff
test/conformance-router-full/Generated/IncidentPaging/PagingRouter/Router.hs too large to diff
test/conformance-router-full/Generated/IncidentPaging/PagingRouter/RouterHarness.hs too large to diff
test/conformance-router-full/Generated/IncidentPaging/ReplayAudit.hs too large to diff
test/conformance-router-full/Generated/IncidentPaging/ServiceOncall/ReadModel.hs too large to diff
test/conformance-router-full/Generated/IncidentPaging/ServiceOncall/ReadModelHarness.hs too large to diff
test/conformance-router-full/Generated/IncidentPaging/ServiceOncall/ReadModelTable.hs too large to diff
test/conformance-router-full/IncidentPaging/Page/BehaviorHoles.hs too large to diff
test/conformance-router-full/IncidentPaging/PagingRouter/RouterHoles.hs too large to diff
test/conformance-router-full/IncidentPaging/ServiceOncall/ReadModelHoles.hs too large to diff
test/conformance-router-full/keiro-dsl-cabal-fragment.context.incident-paging.txt too large to diff
test/conformance-router-full/keiro-dsl-ledger.context.incident-paging.txt too large to diff
test/conformance-router-runtime/Generated/IncidentPaging/BehaviorSourceMap.hs too large to diff
test/conformance-router-runtime/Generated/IncidentPaging/Page/BehaviorContract.hs too large to diff
test/conformance-router-runtime/Generated/IncidentPaging/Page/Codec.hs too large to diff
test/conformance-router-runtime/Generated/IncidentPaging/Page/Domain.hs too large to diff
test/conformance-router-runtime/Generated/IncidentPaging/Page/EventStream.hs too large to diff
test/conformance-router-runtime/Generated/IncidentPaging/Page/Harness.hs too large to diff
test/conformance-router-runtime/Generated/IncidentPaging/Page/Projection.hs too large to diff
test/conformance-router-runtime/Generated/IncidentPaging/Page/Transducer.hs too large to diff
test/conformance-router-runtime/Generated/IncidentPaging/PagingRouter/Router.hs too large to diff
test/conformance-router-runtime/Generated/IncidentPaging/PagingRouter/RouterHarness.hs too large to diff
test/conformance-router-runtime/Generated/IncidentPaging/ReplayAudit.hs too large to diff
test/conformance-router-runtime/Generated/IncidentPaging/ServiceOncall/ReadModel.hs too large to diff
test/conformance-router-runtime/Generated/IncidentPaging/ServiceOncall/ReadModelHarness.hs too large to diff
test/conformance-router-runtime/Generated/IncidentPaging/ServiceOncall/ReadModelTable.hs too large to diff
test/conformance-router-runtime/IncidentPaging/Page/BehaviorHoles.hs too large to diff
test/conformance-router-runtime/IncidentPaging/Page/Holes.hs too large to diff
test/conformance-router-runtime/IncidentPaging/PagingRouter/RouterHoles.hs too large to diff
test/conformance-router-runtime/IncidentPaging/ServiceOncall/ReadModelHoles.hs too large to diff
test/conformance-router-runtime/keiro-dsl-cabal-fragment.context.incident-paging.txt too large to diff
test/conformance-router-runtime/keiro-dsl-ledger.context.incident-paging.txt too large to diff
test/conformance-router/Generated/IncidentPaging/BehaviorSourceMap.hs too large to diff
test/conformance-router/Generated/IncidentPaging/Page/BehaviorContract.hs too large to diff
test/conformance-router/Generated/IncidentPaging/Page/Codec.hs too large to diff
test/conformance-router/Generated/IncidentPaging/Page/Domain.hs too large to diff
test/conformance-router/Generated/IncidentPaging/Page/EventStream.hs too large to diff
test/conformance-router/Generated/IncidentPaging/Page/Harness.hs too large to diff
test/conformance-router/Generated/IncidentPaging/Page/Projection.hs too large to diff
test/conformance-router/Generated/IncidentPaging/Page/Transducer.hs too large to diff
test/conformance-router/Generated/IncidentPaging/PagingRouter/Router.hs too large to diff
test/conformance-router/Generated/IncidentPaging/PagingRouter/RouterHarness.hs too large to diff
test/conformance-router/Generated/IncidentPaging/ReplayAudit.hs too large to diff
test/conformance-router/Generated/IncidentPaging/ServiceOncall/ReadModel.hs too large to diff
test/conformance-router/Generated/IncidentPaging/ServiceOncall/ReadModelHarness.hs too large to diff
test/conformance-router/Generated/IncidentPaging/ServiceOncall/ReadModelTable.hs too large to diff
test/conformance-router/IncidentPaging/Page/BehaviorHoles.hs too large to diff
test/conformance-router/IncidentPaging/Page/Holes.hs too large to diff
test/conformance-router/IncidentPaging/PagingRouter/RouterHoles.hs too large to diff
test/conformance-router/IncidentPaging/ServiceOncall/ReadModelHoles.hs too large to diff
test/conformance-router/keiro-dsl-cabal-fragment.context.incident-paging.txt too large to diff
test/conformance-router/keiro-dsl-ledger.context.incident-paging.txt too large to diff
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/BehaviorSourceMap.hs too large to diff
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Nominals.hs too large to diff
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Nominals/Internal.hs too large to diff
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ReplayAudit.hs too large to diff
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/BehaviorContract.hs too large to diff
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Codec.hs too large to diff
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Domain.hs too large to diff
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/EventStream.hs too large to diff
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Harness.hs too large to diff
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Projection.hs too large to diff
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Transducer.hs too large to diff
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Structural/Shape/Limits.hs too large to diff
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/StructuralConformance.hs too large to diff
test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/StructuralProjections.hs too large to diff
test/conformance-scalar-expressions/Main.hs too large to diff
test/conformance-scalar-expressions/keiro-dsl-cabal-fragment.context.aggregate-scalar-expressions.txt too large to diff
test/conformance-scalar-expressions/keiro-dsl-ledger.context.aggregate-scalar-expressions.txt too large to diff
test/conformance-service-package/domain/alpha.keiro too large to diff
test/conformance-service-package/domain/beta.keiro too large to diff
test/conformance-service-package/domain/evidence.keiro too large to diff
test/conformance-service-package/domain/shared.keiro too large to diff
test/conformance-service-package/runtime/keiro-dsl-conformance-service-runtime.cabal too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/BehaviorHoles.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/Generated/BehaviorContract.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/Generated/Codec.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/Generated/Domain.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/Generated/EventStream.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/Generated/Harness.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/Generated/Projection.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/Generated/Transducer.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/AlphaView/Generated/ReadModel.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/AlphaView/Generated/ReadModelHarness.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/AlphaView/Generated/ReadModelTable.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/AlphaView/ReadModelHoles.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/BehaviorHoles.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/Generated/BehaviorContract.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/Generated/Codec.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/Generated/Domain.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/Generated/EventStream.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/Generated/Harness.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/Generated/Projection.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/Generated/Transducer.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/BetaView/Generated/ReadModel.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/BetaView/Generated/ReadModelHarness.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/BetaView/Generated/ReadModelTable.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/BetaView/ReadModelHoles.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Generated/BehaviorSourceMap.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Generated/Conformance.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Generated/Nominals.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Generated/Nominals/Internal.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Generated/ReplayAudit.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/WorkspaceProofWorkflow/Generated/WorkflowFacts.hs too large to diff
test/conformance-service-package/runtime/src/Proof/WorkspaceProof/WorkspaceProofWorkflow/Generated/WorkflowRuntime.hs too large to diff
test/conformance-service-package/runtime/src/keiro-dsl-cabal-fragment.workspace.workspace-proof.txt too large to diff
test/conformance-service-package/runtime/src/keiro-dsl-conformance.workspace.workspace-proof/keiro-dsl-conformance-ledger.txt too large to diff
test/conformance-service-package/runtime/src/keiro-dsl-conformance.workspace.workspace-proof/keiro-workspace-proof-conformance.cabal too large to diff
test/conformance-service-package/runtime/src/keiro-dsl-conformance.workspace.workspace-proof/src/KeiroConformance/Expectations.hs too large to diff
test/conformance-service-package/runtime/src/keiro-dsl-conformance.workspace.workspace-proof/src/Main.hs too large to diff
test/conformance-service-package/runtime/src/keiro-dsl-ledger.workspace.workspace-proof.txt too large to diff
test/conformance-service-package/service.keiro-workspace too large to diff
test/conformance-skeletons/Main.hs too large to diff
test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/BehaviorContract.hs too large to diff
test/conformance-skeletons/SkelAggregate/keiro-dsl-manifest.my-service.txt too large to diff
test/conformance-skeletons/SkelAggregate/keiro-dsl-scaffold-record.my-service.txt too large to diff
test/conformance-skeletons/SkelIntake/Generated/MyService/ThingInbox/Inbox.hs too large to diff
test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/BehaviorContract.hs too large to diff
test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/BehaviorContract.hs too large to diff
test/conformance-skeletons/SkelProcess/MyService/Hospital/BehaviorHoles.hs too large to diff
test/conformance-skeletons/SkelProcess/MyService/Surge/BehaviorHoles.hs too large to diff
test/conformance-skeletons/SkelRouter/Generated/MyService/Page/BehaviorContract.hs too large to diff
test/conformance-skeletons/SkelRouter/MyService/Page/BehaviorHoles.hs too large to diff
test/conformance-skeletons/SkelWorkflow/Generated/MyService/HospitalTransferReservation/WorkflowFacts.hs too large to diff
test/conformance-skeletons/keiro-dsl-cabal-fragment.context.my-service.txt too large to diff
test/conformance-skeletons/keiro-dsl-ledger.context.my-service.txt too large to diff
test/conformance-snapshot/Generated/HospitalCapacity/BehaviorSourceMap.hs too large to diff
test/conformance-snapshot/Generated/HospitalCapacity/Nominals.hs too large to diff
test/conformance-snapshot/Generated/HospitalCapacity/Nominals/Internal.hs too large to diff
test/conformance-snapshot/Generated/HospitalCapacity/ReplayAudit.hs too large to diff
test/conformance-snapshot/Generated/HospitalCapacity/Reservation/BehaviorContract.hs too large to diff
test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Codec.hs too large to diff
test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Domain.hs too large to diff
test/conformance-snapshot/Generated/HospitalCapacity/Reservation/EventStream.hs too large to diff
test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Harness.hs too large to diff
test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Projection.hs too large to diff
test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Transducer.hs too large to diff
test/conformance-snapshot/HospitalCapacity/Reservation/BehaviorHoles.hs too large to diff
test/conformance-snapshot/keiro-dsl-cabal-fragment.context.hospital-capacity.txt too large to diff
test/conformance-snapshot/keiro-dsl-ledger.context.hospital-capacity.txt too large to diff
test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/BehaviorContract.hs too large to diff
test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Codec.hs too large to diff
test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Domain.hs too large to diff
test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/EventStream.hs too large to diff
test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Harness.hs too large to diff
test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Projection.hs too large to diff
test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Transducer.hs too large to diff
test/conformance-structural/Generated/StructuralConformance/BehaviorSourceMap.hs too large to diff
test/conformance-structural/Generated/StructuralConformance/ReplayAudit.hs too large to diff
test/conformance-structural/Generated/StructuralConformance/Structural/CodecCompare/ArtifactInfo.hs too large to diff
test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactInfo.hs too large to diff
test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactKind.hs too large to diff
test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactLocation.hs too large to diff
test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactMetadata.hs too large to diff
test/conformance-structural/Generated/StructuralConformance/StructuralConformance.hs too large to diff
test/conformance-structural/Generated/StructuralConformance/StructuralProjections.hs too large to diff
test/conformance-structural/StructuralConformance/ArtifactCatalog/BehaviorHoles.hs too large to diff
test/conformance-structural/keiro-dsl-cabal-fragment.context.structural-conformance.txt too large to diff
test/conformance-structural/keiro-dsl-ledger.context.structural-conformance.txt too large to diff
test/conformance-v2/Generated/HospitalCapacity/BehaviorSourceMap.hs too large to diff
test/conformance-v2/Generated/HospitalCapacity/Nominals.hs too large to diff
test/conformance-v2/Generated/HospitalCapacity/Nominals/Internal.hs too large to diff
test/conformance-v2/Generated/HospitalCapacity/ReplayAudit.hs too large to diff
test/conformance-v2/Generated/HospitalCapacity/Reservation/BehaviorContract.hs too large to diff
test/conformance-v2/Generated/HospitalCapacity/Reservation/Codec.hs too large to diff
test/conformance-v2/Generated/HospitalCapacity/Reservation/Domain.hs too large to diff
test/conformance-v2/Generated/HospitalCapacity/Reservation/EventStream.hs too large to diff
test/conformance-v2/Generated/HospitalCapacity/Reservation/Harness.hs too large to diff
test/conformance-v2/Generated/HospitalCapacity/Reservation/Projection.hs too large to diff
test/conformance-v2/Generated/HospitalCapacity/Reservation/Transducer.hs too large to diff
test/conformance-v2/HospitalCapacity/Reservation/BehaviorHoles.hs too large to diff
test/conformance-v2/keiro-dsl-cabal-fragment.context.hospital-capacity.txt too large to diff
test/conformance-v2/keiro-dsl-ledger.context.hospital-capacity.txt too large to diff
test/conformance-workflow-full/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowFacts.hs too large to diff
test/conformance-workflow-full/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs too large to diff
test/conformance-workflow-full/keiro-dsl-cabal-fragment.context.hospital-capacity.txt too large to diff
test/conformance-workflow-full/keiro-dsl-ledger.context.hospital-capacity.txt too large to diff
test/conformance-workflow-runtime/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowFacts.hs too large to diff
test/conformance-workflow-runtime/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs too large to diff
test/conformance-workflow-runtime/keiro-dsl-cabal-fragment.context.hospital-capacity.txt too large to diff
test/conformance-workflow-runtime/keiro-dsl-ledger.context.hospital-capacity.txt too large to diff
test/conformance-workflow/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowFacts.hs too large to diff
test/conformance-workflow/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs too large to diff
test/conformance-workflow/Main.hs too large to diff
test/conformance-workflow/keiro-dsl-cabal-fragment.context.hospital-capacity.txt too large to diff
test/conformance-workflow/keiro-dsl-ledger.context.hospital-capacity.txt too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/BehaviorSourceMap.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Nominals.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Nominals/Internal.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/BehaviorContract.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Codec.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Domain.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/EventStream.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Harness.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Projection.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Transducer.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/BehaviorContract.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Codec.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Domain.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/EventStream.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Harness.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Projection.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Transducer.hs too large to diff
test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ReplayAudit.hs too large to diff
test/conformance-workspace-nominals/keiro-dsl-cabal-fragment.workspace.workspace-nominal-proof.txt too large to diff
test/conformance-workspace-nominals/keiro-dsl-ledger.workspace.workspace-nominal-proof.txt too large to diff
test/conformance/Generated/HospitalCapacity/BehaviorSourceMap.hs too large to diff
test/conformance/Generated/HospitalCapacity/Nominals.hs too large to diff
test/conformance/Generated/HospitalCapacity/Nominals/Internal.hs too large to diff
test/conformance/Generated/HospitalCapacity/ReplayAudit.hs too large to diff
test/conformance/Generated/HospitalCapacity/Reservation/BehaviorContract.hs too large to diff
test/conformance/Generated/HospitalCapacity/Reservation/Codec.hs too large to diff
test/conformance/Generated/HospitalCapacity/Reservation/Domain.hs too large to diff
test/conformance/Generated/HospitalCapacity/Reservation/EventStream.hs too large to diff
test/conformance/Generated/HospitalCapacity/Reservation/Harness.hs too large to diff
test/conformance/Generated/HospitalCapacity/Reservation/Projection.hs too large to diff
test/conformance/Generated/HospitalCapacity/Reservation/Transducer.hs too large to diff
test/conformance/HospitalCapacity/Reservation/BehaviorHoles.hs too large to diff
test/conformance/keiro-dsl-cabal-fragment.context.hospital-capacity.txt too large to diff
test/conformance/keiro-dsl-ledger.context.hospital-capacity.txt too large to diff
test/diff-test.sh too large to diff
test/domain-command-outcome-mutation-test.sh too large to diff
test/fixtures/aggregate-bad-refs.keiro too large to diff
test/fixtures/aggregate-collection-expressions-v2-rejects.keiro too large to diff
test/fixtures/aggregate-field-alias.keiro too large to diff
test/fixtures/aggregate-scalar-expressions-v1-rejects.keiro too large to diff
test/fixtures/aggregate-scalar-expressions-v2.keiro too large to diff
test/fixtures/aggregate-scalars-arithmetic.keiro too large to diff
test/fixtures/aggregate-scalars-invalid-capabilities.keiro too large to diff
test/fixtures/aggregate-scalars-unsupported.keiro too large to diff
test/fixtures/aggregate-scalars-workspace/domain/scalars.keiro too large to diff
test/fixtures/aggregate-scalars-workspace/service.keiro-workspace too large to diff
test/fixtures/aggregate-scalars.keiro too large to diff
test/fixtures/behavior-complete-workspace/declarations.keiro too large to diff
test/fixtures/behavior-complete-workspace/journey.keiro too large to diff
test/fixtures/behavior-complete-workspace/service.keiro-workspace too large to diff
test/fixtures/behavior-complete.keiro too large to diff
test/fixtures/catalog-readmodel-backing-required.keiro too large to diff
test/fixtures/catalog-readmodel-backing-unobserved.keiro too large to diff
test/fixtures/catalog-readmodel-physical-override.keiro too large to diff
test/fixtures/catalog-readmodel-reorder-a.keiro too large to diff
test/fixtures/catalog-readmodel-reorder-b.keiro too large to diff
test/fixtures/check-report/legacy-min-language.golden.json too large to diff
test/fixtures/compatibility-vector-new.keiro too large to diff
test/fixtures/compatibility-vector-old.keiro too large to diff
test/fixtures/compatibility-vector.diff.golden too large to diff
test/fixtures/consumer-types-armadd.keiro too large to diff
test/fixtures/consumer-types-binding-change.keiro too large to diff
test/fixtures/consumer-types-encoding.keiro too large to diff
test/fixtures/consumer-types-enumadd.keiro too large to diff
test/fixtures/consumer-types-enumremove.keiro too large to diff
test/fixtures/consumer-types-enumspelling.keiro too large to diff
test/fixtures/consumer-types-fieldadd-default.keiro too large to diff
test/fixtures/consumer-types-fieldadd-nodefault.keiro too large to diff
test/fixtures/consumer-types-fieldremove.keiro too large to diff
test/fixtures/consumer-types-fixtures-change.keiro too large to diff
test/fixtures/consumer-types-haskell-rename.keiro too large to diff
test/fixtures/consumer-types-initial-change.keiro too large to diff
test/fixtures/consumer-types-mode-cross.keiro too large to diff
test/fixtures/consumer-types-nested-propagation.keiro too large to diff
test/fixtures/consumer-types-opaque-version.keiro too large to diff
test/fixtures/consumer-types-tagchange.keiro too large to diff
test/fixtures/consumer-types-v2.keiro too large to diff
test/fixtures/consumer-types-wirekey.keiro too large to diff
test/fixtures/consumer-types.keiro too large to diff
test/fixtures/contract-bump-fieldadd.keiro too large to diff
test/fixtures/contract-discriminator.keiro too large to diff
test/fixtures/contract-eventadd.keiro too large to diff
test/fixtures/contract-eventdrop.keiro too large to diff
test/fixtures/contract-fieldadd.keiro too large to diff
test/fixtures/contract-fieldtype.keiro too large to diff
test/fixtures/contract-reserved-family.keiro too large to diff
test/fixtures/contract-topic.keiro too large to diff
test/fixtures/contract-typeid-domain.diff.golden too large to diff
test/fixtures/contract-typeid-domain.diff.json.golden too large to diff
test/fixtures/contract-v1-compat.keiro too large to diff
test/fixtures/contract-v4.keiro too large to diff
test/fixtures/contract.keiro too large to diff
test/fixtures/declarative-router/README.md too large to diff
test/fixtures/declarative-router/unbounded.keiro too large to diff
test/fixtures/declarative-router/valid.keiro too large to diff
test/fixtures/deny-unlogged.keiro too large to diff
test/fixtures/dispatch-dedup-bad-field.keiro too large to diff
test/fixtures/dispatch-dedup-ghost-queue.keiro too large to diff
test/fixtures/domain-command-outcomes.keiro too large to diff
test/fixtures/duplicate-names.keiro too large to diff
test/fixtures/emit-badevent.keiro too large to diff
test/fixtures/emit-derive.keiro too large to diff
test/fixtures/emit-mapchange.keiro too large to diff
test/fixtures/emit-noskip.keiro too large to diff
test/fixtures/emit-ordering.keiro too large to diff
test/fixtures/emit-outboxfield.keiro too large to diff
test/fixtures/emit-topic-mismatch.keiro too large to diff
test/fixtures/emit.keiro too large to diff
test/fixtures/fold-identity-baseline.golden too large to diff
test/fixtures/fold-identity-diff-replay.golden too large to diff
test/fixtures/hospital-surge-badref.keiro too large to diff
test/fixtures/hospital-surge-clock.keiro too large to diff
test/fixtures/hospital-surge-dispatchid.keiro too large to diff
test/fixtures/hospital-surge-handle.keiro too large to diff
test/fixtures/hospital-surge-inputtype.keiro too large to diff
test/fixtures/hospital-surge-payload.keiro too large to diff
test/fixtures/hospital-surge-procname.keiro too large to diff
test/fixtures/hospital-surge-timerid.keiro too large to diff
test/fixtures/hospital-surge-window.keiro too large to diff
test/fixtures/hospital-surge.keiro too large to diff
test/fixtures/id-domain-migration-v3.keiro too large to diff
test/fixtures/import-planning-collisions.keiro too large to diff
test/fixtures/incident-paging/incident-paging-dispatch.keiro too large to diff
test/fixtures/incident-paging/incident-paging.keiro too large to diff
test/fixtures/intake-decode.keiro too large to diff
test/fixtures/intake-dedupekey.keiro too large to diff
test/fixtures/intake-dedupepolicy.keiro too large to diff
test/fixtures/intake-dup-retry.keiro too large to diff
test/fixtures/intake-dup-row.keiro too large to diff
test/fixtures/intake-incomplete.keiro too large to diff
test/fixtures/intake-pf-retry.keiro too large to diff
test/fixtures/intake-topic-mismatch.keiro too large to diff
test/fixtures/intake.keiro too large to diff
test/fixtures/language-duplicate.keiro too large to diff
test/fixtures/language-identifier-v1.keiro too large to diff
test/fixtures/language-identifier-v2.keiro too large to diff
test/fixtures/language-legacy.keiro too large to diff
test/fixtures/language-malformed.keiro too large to diff
test/fixtures/language-misplaced.keiro too large to diff
test/fixtures/language-v1.keiro too large to diff
test/fixtures/language-zero.keiro too large to diff
test/fixtures/mapped-ambiguous.keiro too large to diff
test/fixtures/mapped-bad-encoding.keiro too large to diff
test/fixtures/mapped-bad-haskell-name.keiro too large to diff
test/fixtures/mapped-dup-armname.keiro too large to diff
test/fixtures/mapped-dup-fieldname.keiro too large to diff
test/fixtures/mapped-dup-tag.keiro too large to diff
test/fixtures/mapped-dup-wirekey.keiro too large to diff
test/fixtures/mapped-empty-identity.keiro too large to diff
test/fixtures/mapped-guard-natural.keiro too large to diff
test/fixtures/mapped-guard-time.keiro too large to diff
test/fixtures/mapped-guard.keiro too large to diff
test/fixtures/mapped-illtyped-default.keiro too large to diff
test/fixtures/mapped-import-conflict.keiro too large to diff
test/fixtures/mapped-missing-binding-version.keiro too large to diff
test/fixtures/mapped-missing-binding.keiro too large to diff
test/fixtures/mapped-missing-canonical.keiro too large to diff
test/fixtures/mapped-missing-fixture.keiro too large to diff
test/fixtures/mapped-missing-initial.keiro too large to diff
test/fixtures/mapped-optional-json.keiro too large to diff
test/fixtures/mapped-optional-opaque.keiro too large to diff
test/fixtures/mapped-optional-optional.keiro too large to diff
test/fixtures/mapped-readmodel-workspace/readmodel.keiro too large to diff
test/fixtures/mapped-readmodel-workspace/service.keiro-workspace too large to diff
test/fixtures/mapped-readmodel-workspace/types.keiro too large to diff
test/fixtures/mapped-readmodel.keiro too large to diff
test/fixtures/mapped-recursive-mutual.keiro too large to diff
test/fixtures/mapped-recursive.keiro too large to diff
test/fixtures/mapped-union-key-collision.keiro too large to diff
test/fixtures/mapped-unresolved.keiro too large to diff
test/fixtures/mapped-workqueue.keiro too large to diff
test/fixtures/nominal-bad-qualified.keiro too large to diff
test/fixtures/nominal-invalid-prefix.keiro too large to diff
test/fixtures/nominal-missing-facts.keiro too large to diff
test/fixtures/nominal-missing-initial.keiro too large to diff
test/fixtures/nominal-name-collision.keiro too large to diff
test/fixtures/nominal-scalars.keiro too large to diff
test/fixtures/nominal-unsupported-representation.keiro too large to diff
test/fixtures/nominal-v1.keiro too large to diff
test/fixtures/operation-ghost-aggregate.keiro too large to diff
test/fixtures/operation-signal-value.keiro too large to diff
test/fixtures/order.keiro too large to diff
test/fixtures/outcome-identifier-legacy.keiro too large to diff
test/fixtures/outcome-identifier-positions.keiro too large to diff
test/fixtures/outcome-identifier-v5.keiro too large to diff
test/fixtures/outcome-identifier.keiro too large to diff
test/fixtures/process-bad-timer.keiro too large to diff
test/fixtures/process-ghost-refs.keiro too large to diff
test/fixtures/projection-catalog-grown.keiro-workspace too large to diff
test/fixtures/projection-catalog-unrelated.keiro too large to diff
test/fixtures/projection-catalog.keiro too large to diff
test/fixtures/projection-catalog.keiro-workspace too large to diff
test/fixtures/projection-owner-multi-query.keiro too large to diff
test/fixtures/readmodel-consistency-conflict.keiro too large to diff
test/fixtures/readmodel-dispatch-unresolved.keiro too large to diff
test/fixtures/readmodel-inline-unreferenced.keiro too large to diff
test/fixtures/readmodel-migration-l4.keiro too large to diff
test/fixtures/readmodel-query-unresolved.keiro too large to diff
test/fixtures/readmodel-runtime.keiro too large to diff
test/fixtures/readmodel-scope-eventual.keiro too large to diff
test/fixtures/readmodel-shape-drift.keiro too large to diff
test/fixtures/readmodel-strong-inline.keiro too large to diff
test/fixtures/readmodel-strong-standalone.keiro too large to diff
test/fixtures/readmodel.keiro too large to diff
test/fixtures/record-migration/behavior-obligations.exact.json.golden too large to diff
test/fixtures/record-migration/single-file-scaffold-record.ledger.golden too large to diff
test/fixtures/record-migration/workspace-scaffold-record.ledger.golden too large to diff
test/fixtures/replay-divergence.keiro too large to diff
test/fixtures/reservation-bad-command.keiro too large to diff
test/fixtures/reservation-chain-gap.keiro too large to diff
test/fixtures/reservation-clock.keiro too large to diff
test/fixtures/reservation-cmdfieldtype.keiro too large to diff
test/fixtures/reservation-deprecated-replay-only.keiro too large to diff
test/fixtures/reservation-deprecated.keiro too large to diff
test/fixtures/reservation-dup-upcast-source.keiro too large to diff
test/fixtures/reservation-enumadd.keiro too large to diff
test/fixtures/reservation-enumdrop.keiro too large to diff
test/fixtures/reservation-enumwire.keiro too large to diff
test/fixtures/reservation-fieldadd.keiro too large to diff
test/fixtures/reservation-fieldremove.keiro too large to diff
test/fixtures/reservation-fieldtype.keiro too large to diff
test/fixtures/reservation-foldchange.keiro too large to diff
test/fixtures/reservation-guard-tightened-twin.keiro too large to diff
test/fixtures/reservation-guard-tightened.keiro too large to diff
test/fixtures/reservation-idprefix.keiro too large to diff
test/fixtures/reservation-no-statusmap.keiro too large to diff
test/fixtures/reservation-projection.keiro too large to diff
test/fixtures/reservation-retiring.keiro too large to diff
test/fixtures/reservation-snapshot.keiro too large to diff
test/fixtures/reservation-v2-noupcast.keiro too large to diff
test/fixtures/reservation-v2.keiro too large to diff
test/fixtures/reservation-v3-dangling.keiro too large to diff
test/fixtures/reservation-wire.keiro too large to diff
test/fixtures/reservation-work-dedupkey.keiro too large to diff
test/fixtures/reservation-work-df-retry.keiro too large to diff
test/fixtures/reservation-work-divergent.keiro too large to diff
test/fixtures/reservation-work-fieldtype.keiro too large to diff
test/fixtures/reservation-work-fifo-nokey.keiro too large to diff
test/fixtures/reservation-work-key-unordered.keiro too large to diff
test/fixtures/reservation-work-optfield.keiro too large to diff
test/fixtures/reservation-work-partitioned-empty.keiro too large to diff
test/fixtures/reservation-work-rename.keiro too large to diff
test/fixtures/reservation-work-reqfield.keiro too large to diff
test/fixtures/reservation-work-retarget.keiro too large to diff
test/fixtures/reservation-work-sf-deadletter.keiro too large to diff
test/fixtures/reservation-work-unlogged.keiro too large to diff
test/fixtures/reservation-work-wirename.keiro too large to diff
test/fixtures/reservation-work.keiro too large to diff
test/fixtures/reservation.keiro too large to diff
test/fixtures/rule-bad-domain.keiro too large to diff
test/fixtures/rule-not-total.keiro too large to diff
test/fixtures/semantic-impact.keiro too large to diff
test/fixtures/semantic-locality/domain/alpha.keiro too large to diff
test/fixtures/semantic-locality/domain/beta.keiro too large to diff
test/fixtures/semantic-locality/service.keiro-workspace too large to diff
test/fixtures/statusmap-dangling.keiro too large to diff
test/fixtures/statusmap-dup-key.keiro too large to diff
test/fixtures/structural-conformance.keiro too large to diff
test/fixtures/structural-locality.keiro too large to diff
test/fixtures/structural-locality.keiro-workspace too large to diff
test/fixtures/subscription.keiro too large to diff
test/fixtures/surge-service.keiro too large to diff
test/fixtures/transfer-routing.keiro too large to diff
test/fixtures/workflow-body.keiro too large to diff
test/fixtures/workflow-can-mid.keiro too large to diff
test/fixtures/workflow-continue-seed-v2.keiro too large to diff
test/fixtures/workflow-continue.keiro too large to diff
test/fixtures/workflow-dup-label.keiro too large to diff
test/fixtures/workflow-evolution-diff.keiro too large to diff
test/fixtures/workflow-evolution.keiro too large to diff
test/fixtures/workflow-idfield.keiro too large to diff
test/fixtures/workflow-inputfield.keiro too large to diff
test/fixtures/workflow-output.keiro too large to diff
test/fixtures/workflow-patch-colon.keiro too large to diff
test/fixtures/workflow-patch-dup.keiro too large to diff
test/fixtures/workflow-rename.keiro too large to diff
test/fixtures/workflow-signal-mismatch.keiro too large to diff
test/fixtures/workflow-stepadd.keiro too large to diff
test/fixtures/workflow-unresolved-fields.keiro too large to diff
test/fixtures/workflow.keiro too large to diff
test/fixtures/workqueue-dlq-divergent.keiro too large to diff
test/fixtures/workqueue-dup-row.keiro too large to diff
test/fixtures/workqueue-group-key-change.keiro too large to diff
test/fixtures/workqueue-hashed-logical.keiro too large to diff
test/fixtures/workqueue-incomplete.keiro too large to diff
test/fixtures/workqueue-ordering-change.keiro too large to diff
test/fixtures/workqueue-policy-base.keiro too large to diff
test/fixtures/workqueue-provision-change.keiro too large to diff
test/fixtures/workqueue-table-divergent.keiro too large to diff
test/fixtures/workqueue-uppercase-logical.keiro too large to diff
test/fixtures/workspace-authority-conflict/domain/a.keiro too large to diff
test/fixtures/workspace-authority-conflict/domain/b.keiro too large to diff
test/fixtures/workspace-authority-conflict/service.keiro-workspace too large to diff
test/fixtures/workspace-context-mismatch/domain/a.keiro too large to diff
test/fixtures/workspace-context-mismatch/domain/b.keiro too large to diff
test/fixtures/workspace-context-mismatch/service.keiro-workspace too large to diff
test/fixtures/workspace-diff-moved/domain/order.keiro too large to diff
test/fixtures/workspace-diff-moved/domain/shared.keiro too large to diff
test/fixtures/workspace-diff-moved/service.keiro-workspace too large to diff
test/fixtures/workspace-diff-new/domain/order.keiro too large to diff
test/fixtures/workspace-diff-new/domain/shared.keiro too large to diff
test/fixtures/workspace-diff-new/domain/shipment.keiro too large to diff
test/fixtures/workspace-diff-new/service.keiro-workspace too large to diff
test/fixtures/workspace-diff-new/workspace.diff.golden too large to diff
test/fixtures/workspace-diff-old/domain/order.keiro too large to diff
test/fixtures/workspace-diff-old/domain/shared.keiro too large to diff
test/fixtures/workspace-diff-old/domain/shipment.keiro too large to diff
test/fixtures/workspace-diff-old/service.keiro-workspace too large to diff
test/fixtures/workspace-dup-decl/domain/project.keiro too large to diff
test/fixtures/workspace-dup-decl/domain/shared.keiro too large to diff
test/fixtures/workspace-dup-decl/service.keiro-workspace too large to diff
test/fixtures/workspace-dup-member/domain/a.keiro too large to diff
test/fixtures/workspace-dup-member/service.keiro-workspace too large to diff
test/fixtures/workspace-dup-node/domain/a.keiro too large to diff
test/fixtures/workspace-dup-node/domain/b.keiro too large to diff
test/fixtures/workspace-dup-node/service.keiro-workspace too large to diff
test/fixtures/workspace-invalid-member-path/service.keiro-workspace too large to diff
test/fixtures/workspace-member-parse-failed/domain/a.keiro too large to diff
test/fixtures/workspace-member-parse-failed/domain/b.keiro too large to diff
test/fixtures/workspace-member-parse-failed/service.keiro-workspace too large to diff
test/fixtures/workspace-missing-member/domain/a.keiro too large to diff
test/fixtures/workspace-missing-member/service.keiro-workspace too large to diff
test/fixtures/workspace-nominals/domain/project-artifact.keiro too large to diff
test/fixtures/workspace-nominals/domain/project.keiro too large to diff
test/fixtures/workspace-nominals/domain/shared.keiro too large to diff
test/fixtures/workspace-nominals/service.keiro-workspace too large to diff
test/fixtures/workspace-path-collision/domain/a.keiro too large to diff
test/fixtures/workspace-path-collision/domain/b.keiro too large to diff
test/fixtures/workspace-path-collision/service.keiro-workspace too large to diff
test/fixtures/workspace-unresolved/domain/project.keiro too large to diff
test/fixtures/workspace-unresolved/domain/shared.keiro too large to diff
test/fixtures/workspace-unresolved/service.keiro-workspace too large to diff
test/fixtures/workspace/domain/project-artifact.keiro too large to diff
test/fixtures/workspace/domain/project.keiro too large to diff
test/fixtures/workspace/domain/shared.keiro too large to diff
test/fixtures/workspace/service-reordered.keiro-workspace too large to diff
test/fixtures/workspace/service.keiro-workspace too large to diff
test/frontend-0.7/diagnostics/duplicate-clause.txt too large to diff
test/frontend-0.7/diagnostics/duplicate-preamble.txt too large to diff
test/frontend-0.7/diagnostics/escaped-string.txt too large to diff
test/frontend-0.7/diagnostics/expression-error.txt too large to diff
test/frontend-0.7/diagnostics/feature-explicit-implementation-v1.txt too large to diff
test/frontend-0.7/diagnostics/feature-integer-v1.txt too large to diff
test/frontend-0.7/diagnostics/feature-nominal-binding-v1.txt too large to diff
test/frontend-0.7/diagnostics/feature-typed-expression-v1.txt too large to diff
test/frontend-0.7/diagnostics/invalid-preamble.txt too large to diff
test/frontend-0.7/diagnostics/misplaced-preamble.txt too large to diff
test/frontend-0.7/diagnostics/numeric-overflow.txt too large to diff
test/frontend-0.7/diagnostics/semantic-error.txt too large to diff
test/frontend-0.7/diagnostics/workspace-member-parse-failure.txt too large to diff
test/frontend-0.7/manifest.json too large to diff
test/frontend-0.7/sources/body-grammar-invalid.keiro too large to diff
test/frontend-0.7/sources/feature-explicit-implementation-v1.keiro too large to diff
test/frontend-0.7/sources/feature-integer-v1.keiro too large to diff
test/frontend-0.7/sources/feature-nominal-binding-v1.keiro too large to diff
test/frontend-0.7/sources/feature-typed-expression-v1.keiro too large to diff
test/frontend-0.7/sources/language-duplicate.keiro too large to diff
test/frontend-0.7/sources/language-legacy.keiro too large to diff
test/frontend-0.7/sources/language-malformed.keiro too large to diff
test/frontend-0.7/sources/language-misplaced.keiro too large to diff
test/frontend-0.7/sources/language-v1.keiro too large to diff
test/frontend-0.7/sources/language-v2.keiro too large to diff
test/frontend-0.7/sources/language-v3.keiro too large to diff
test/frontend-0.7/sources/language-zero.keiro too large to diff
test/frontend-0.7/sources/semantic-invalid.keiro too large to diff
test/frontend-0.7/workspaces/member-parse-failed/domain/a.keiro too large to diff
test/frontend-0.7/workspaces/member-parse-failed/domain/b.keiro too large to diff
test/frontend-0.7/workspaces/member-parse-failed/service.keiro-workspace too large to diff
test/frontend-0.7/workspaces/valid/domain/project-artifact.keiro too large to diff
test/frontend-0.7/workspaces/valid/domain/project.keiro too large to diff
test/frontend-0.7/workspaces/valid/domain/shared.keiro too large to diff
test/frontend-0.7/workspaces/valid/service.keiro-workspace too large to diff
test/golden-payloads/hospital-capacity/Reservation/TransferReservationCreated.v1.json too large to diff
test/golden-payloads/structural-conformance/ArtifactCatalog/ArtifactRecorded.v1.json too large to diff
test/haskell-name/Main.hs too large to diff
test/id-domain-migration-mutation-test.sh too large to diff
test/import-planning/Main.hs too large to diff
test/keiro-dsl-codec-compare-artifact-info.cabal too large to diff
test/mapped-queue-mutation-test.sh too large to diff
test/mapped-readmodel-mutation-test.sh too large to diff
test/mapped-surface-locality-test.sh too large to diff
test/mapped-surface-mutation-test.sh too large to diff
test/mutation-test.sh too large to diff
test/process-mutation-test.sh too large to diff
test/projection-supply-mutation-test.sh too large to diff
test/replay-mutation-test.sh too large to diff
test/router-mutation-test.sh too large to diff
test/source-anchor-mutation-test.sh too large to diff
test/structural-mutation-test.sh too large to diff
test/workflow-mutation-test.sh too large to diff

CHANGELOG.md view

@@ -6,6 +6,42 @@  ## Unreleased +## 0.15.0.0 — 2026-08-30++### Breaking Changes++- Package-authored product records now use concise repeated labels under+  `DuplicateRecordFields`, `NoFieldSelectors`, and `OverloadedRecordDot`. Their+  generated selector functions and owner-prefixed field labels are removed from the+  public Haskell API; construction and constructor-directed matching remain supported.+  Migrate reads to record dot using the exhaustive+  [`record-field-migration-0.15.md`](src/record-field-migration-0.15.md) table. The twelve+  intentional single-field newtype unwrappers listed there remain explicit functions.+- Scaffolded Haskell advances from `idiomatic-v1` to `idiomatic-v2`. Generated product+  selectors are removed or renamed to concise labels, and the Cabal fragment now+  defaults `DuplicateRecordFields`, `NoFieldSelectors`, `OverloadedRecordDot`, and+  `OverloadedStrings`. Every existing pre-v2 ledger, including a historical ledger with+  no edition row, requires an explicit `--apply-generated-haskell-edition` run with+  durable from-edition backups; a legacy tree that also needs sidecar or module-name+  migration requires both apply flags in one run. Ordinary scaffolding refuses before+  writes. See the+  [adoption guide](https://github.com/shinzui/keiro/blob/master/docs/guides/adopting-keiro-dsl-idiomatic-v2.md).++### Other Changes++- Scaffold now refuses before writes when a ledger file exists but cannot be parsed,+  instead of treating corrupt history as absent.+- Generated-edition remediation reports attribute prefix, qualified, renamed+  record-dot, record-field, and operator-operand uses in recorded Hole files, while+  stating that compile errors remain authoritative outside that lexical inventory.+- `remediation-report.txt` is regenerated on every edition apply and no longer blocks a+  rollback, Hole edit, and retry; immutable edition backups remain the conflict evidence.+- JSON and wire keys, canonical/rendered output, diagnostics, fingerprints, `.keiro`+  language behavior, and runtime semantics are unchanged by the record migration.+- The checked package and generated-edition inventories, extension-policy gate, and+  Fourmolu parser options now enforce the record model and reject `FieldSelectors`+  escape hatches.+ ## 0.14.0.0 — 2026-08-21  ### Breaking Changes

app/Main.hs view

@@ -1,6 +1,5 @@--- | The @keiro-dsl@ command-line tool. EP-1 ships the @parse@ and @check@--- subcommands; a later milestone adds @scaffold@ to the same--- optparse-applicative command tree.+-- | The @keiro-dsl@ command-line tool, including parsing, checking, diffing,+-- scaffolding, and explicit generated-Haskell edition migration. module Main (main) where  import Control.Monad (when)@@ -30,14 +29,14 @@ import Keiro.Dsl.ReplayImpact (renderReplayImpact, replayImpactServices) import Keiro.Dsl.RuntimePackage (RuntimePackageName, mkRuntimePackageName) import Keiro.Dsl.Scaffold (Context (..), ScaffoldModule (..), codecComparisonBanner, codecComparisonModule)-import Keiro.Dsl.ScaffoldRun (checkIndexedServiceDiagnostics, executeServiceScaffoldWithRuntimePackageAndNameMigrations, planIndexedServiceScaffoldWithRuntimePackageAndGoldens, renderRefusals, renderScaffoldReport)-import Keiro.Dsl.SemanticContract (CheckedService, checkedLanguageContract, checkedSource, checkedSpec, effectiveContractLanguageVersion, languageContractNotice)+import Keiro.Dsl.ScaffoldRun (checkIndexedServiceDiagnostics, executeServiceScaffoldWithRuntimePackageAndMigrations, planIndexedServiceScaffoldWithRuntimePackageAndGoldens, renderRefusals, renderScaffoldReport)+import Keiro.Dsl.SemanticContract (CheckedService, EffectiveLanguageContract (..), checkedLanguageContract, checkedSource, checkedSpec, 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, 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 Keiro.Dsl.WorkspaceScaffold (executeWorkspaceScaffoldWithMigrations, planWorkspaceScaffoldWithRuntimePackageAndGoldens, renderWorkspaceScaffoldReport) import Numeric.Natural (Natural) import Options.Applicative import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist)@@ -53,7 +52,7 @@   | Check FilePath CheckOptions   | Inspect FilePath InspectionFormat   | BehaviorObligations FilePath BehaviorFormat-  | Scaffold FilePath FilePath (Maybe String) (Maybe RuntimePackageName) Bool Bool Bool (Maybe FilePath) (Maybe (String, FilePath))+  | Scaffold FilePath FilePath (Maybe String) (Maybe RuntimePackageName) Bool Bool Bool Bool (Maybe FilePath) (Maybe (String, FilePath))   | Diff FilePath String (Maybe FilePath) (Maybe FilePath) [CompatibilitySurface] Bool (Maybe FilePath) (Maybe DiffCoverageOptions)   | New String @@ -109,7 +108,7 @@           (info (BehaviorObligations <$> fileArg <*> behaviorFormatOpt <**> helper) (progDesc "List static aggregate behavior obligations for a .keiro file or workspace"))         <> command           "scaffold"-          (info (Scaffold <$> fileArg <*> outOpt <*> optional moduleRootOpt <*> optional runtimePackageOpt <*> collocateSwitch <*> forceGeneratedOverwriteSwitch <*> applyNameMigrationsSwitch <*> optional goldensOpt <*> codecComparisonOpts <**> helper) (progDesc "Emit the generated layer + typed holes from a .keiro file"))+          (info (Scaffold <$> fileArg <*> outOpt <*> optional moduleRootOpt <*> optional runtimePackageOpt <*> collocateSwitch <*> forceGeneratedOverwriteSwitch <*> applyNameMigrationsSwitch <*> applyGeneratedHaskellEditionSwitch <*> optional goldensOpt <*> codecComparisonOpts <**> helper) (progDesc "Emit the generated layer + typed holes from a .keiro file"))         <> command           "diff"           (info (Diff <$> fileArg <*> sinceOpt <*> optional emitGoldensOpt <*> optional replayImpactOutOpt <*> many gateOpt <*> explainSwitch <*> optional reportOutOpt <*> diffCoverageOptions <**> helper) (progDesc "Classify spec changes since a git ref as per-surface compatibility vectors; exit non-zero on any gated BREAKING surface"))@@ -142,6 +141,9 @@ applyNameMigrationsSwitch :: Parser Bool applyNameMigrationsSwitch = switch (long "apply-name-migrations" <> help "Apply reviewed generated-Haskell source and sidecar moves with recoverable backups") +applyGeneratedHaskellEditionSwitch :: Parser Bool+applyGeneratedHaskellEditionSwitch = switch (long "apply-generated-haskell-edition" <> help "Adopt idiomatic-v2 generated Haskell with durable idiomatic-v1 backups and a Hole remediation report")+ goldensOpt :: Parser FilePath goldensOpt = strOption (long "goldens" <> metavar "DIR" <> help "Golden-payload root to embed in generated aggregate harnesses") @@ -265,15 +267,15 @@ -- immediate error, and this one could only ever be a silent no-op. validateCheckDenyCodes :: CheckOptions -> IO () validateCheckDenyCodes options = do-  when (CoverageOpaqueGateExceeded `elem` checkDenyCodes options) $ do+  when (CoverageOpaqueGateExceeded `elem` (.checkDenyCodes) options) $ do     TIO.hPutStrLn       stderr       "check: --deny CoverageOpaqueGateExceeded can never match; the code is the error --fail-on-opaque itself raises, so pass --fail-on-opaque instead of denying it"     exitFailure-  case [diagnosticCode | diagnosticCode <- checkDenyCodes options, diagnosticOrigin diagnosticCode == CoverageDiagnostic, diagnosticCode /= CoverageOpaqueGateExceeded] of+  case [diagnosticCode | diagnosticCode <- (.checkDenyCodes) options, diagnosticOrigin diagnosticCode == CoverageDiagnostic, diagnosticCode /= CoverageOpaqueGateExceeded] of     [] -> pure ()     unreachable-      | Just _ <- checkCoverage options -> pure ()+      | Just _ <- (.checkCoverage) options -> pure ()       | otherwise -> do           TIO.hPutStrLn             stderr@@ -346,29 +348,29 @@     <> T.pack (show legacyCount)     <> " legacy-unversioned member(s)"   where-    legacyCount = length [() | member <- wsMembers workspace, LegacyUnversioned <- [wmSourceLanguage member]]+    legacyCount = length [() | member <- (.members) workspace, LegacyUnversioned <- [(.sourceLanguage) member]]  minimumWorkspaceLanguageDiagnostics :: LanguageVersion -> WorkspaceSpec -> [WorkspaceDiagnostic] minimumWorkspaceLanguageDiagnostics floorVersion workspace   | effectiveVersion >= floorVersion = []   | otherwise =       [ WorkspaceDiagnostic-          { wdLocations =+          { locations =               NE.fromList                 ( WorkspaceLocation WorkspaceManifestFile 1 ""                     : [ WorkspaceLocation-                          (WorkspaceMemberFile (wmPath member))-                          (sourceLanguageLine (wmSourceLanguage member))+                          (WorkspaceMemberFile ((.path) member))+                          (sourceLanguageLine ((.sourceLanguage) member))                           ( "member selects effective language version "-                              <> languageVersionText (effectiveLanguageVersion (wmSourceLanguage member))+                              <> languageVersionText (effectiveLanguageVersion ((.sourceLanguage) member))                           )-                      | member <- wsMembers workspace+                      | member <- (.members) workspace                       ]                 ),-            wdSeverity = Error,-            wdCode = LanguageVersionBelowMinimum,-            wdSourceLanguageCause = Nothing,-            wdMessage =+            severity = Error,+            code = LanguageVersionBelowMinimum,+            sourceLanguageCause = Nothing,+            message =               "effective language version "                 <> languageVersionText effectiveVersion                 <> " (workspace-composed) is below the required minimum "@@ -379,28 +381,28 @@           }       ]   where-    effectiveVersion = effectiveContractLanguageVersion (checkedLanguageContract (checkedWorkspace workspace))+    effectiveVersion = (.contractLanguageVersion) (checkedLanguageContract (checkedWorkspace workspace))     sourceLanguageLine LegacyUnversioned = 1     sourceLanguageLine DeclaredLanguage {languageVersionLoc = Loc lineNumber} = lineNumber  deniesWarningCode :: CheckOptions -> DiagnosticCode -> Bool deniesWarningCode options diagnosticCode =-  checkDenyWarnings options || diagnosticCode `elem` checkDenyCodes options+  (.checkDenyWarnings) options || diagnosticCode `elem` (.checkDenyCodes) options  deniedSourceWarningCodes :: CheckOptions -> [Diagnostic] -> [DiagnosticCode] deniedSourceWarningCodes options diagnostics =-  [ code diagnostic+  [ (.code) diagnostic   | diagnostic <- diagnostics,-    severity diagnostic == Warning,-    deniesWarningCode options (code diagnostic)+    (.severity) diagnostic == Warning,+    deniesWarningCode options ((.code) diagnostic)   ]  deniedWorkspaceWarningCodes :: CheckOptions -> [WorkspaceDiagnostic] -> [DiagnosticCode] deniedWorkspaceWarningCodes options diagnostics =-  [ wdCode diagnostic+  [ (.code) diagnostic   | diagnostic <- diagnostics,-    wdSeverity diagnostic == Warning,-    deniesWarningCode options (wdCode diagnostic)+    (.severity) diagnostic == Warning,+    deniesWarningCode options ((.code) diagnostic)   ]  emitDeniedWarningSummary :: [DiagnosticCode] -> IO ()@@ -416,9 +418,9 @@ checkReportEnforcement :: CheckOptions -> CheckReport.CheckReportEnforcement checkReportEnforcement options =   CheckReport.CheckReportEnforcement-    { CheckReport.reportMinLanguage = checkMinLanguage options,-      CheckReport.reportDenyWarnings = checkDenyWarnings options,-      CheckReport.reportDenyCodes = checkDenyCodes options+    { CheckReport.minLanguage = (.checkMinLanguage) options,+      CheckReport.denyWarnings = (.checkDenyWarnings) options,+      CheckReport.denyCodes = (.checkDenyCodes) options     }  -- | Write a check report to @--report-out@, creating any missing parent@@ -431,7 +433,7 @@         createDirectoryIfMissing True (takeDirectory path)         Aeson.encodeFile path report     )-    (checkReportOut options)+    ((.checkReportOut) options)  writeSourceCheckReport :: FilePath -> ParsedSource -> CheckedService -> CheckOptions -> [Diagnostic] -> IO () writeSourceCheckReport subject parsedSource service options diagnostics =@@ -439,7 +441,7 @@     options     ( CheckReport.checkReport         subject-        (parsedSourceLanguage parsedSource)+        ((.sourceLanguage) parsedSource)         (checkedLanguageContract service)         enforcement         diagnostics@@ -494,8 +496,8 @@   | isWorkspacePath fp = runWorkspaceInspect fp format run (BehaviorObligations fp format)   | isWorkspacePath fp = runWorkspaceBehaviorObligations fp format-run (Scaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite applyNameMigrations cliGoldens comparisonRequest)-  | isWorkspacePath fp = runWorkspaceScaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite applyNameMigrations cliGoldens comparisonRequest+run (Scaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite applyNameMigrations applyGeneratedHaskellEdition cliGoldens comparisonRequest)+  | isWorkspacePath fp = runWorkspaceScaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite applyNameMigrations applyGeneratedHaskellEdition cliGoldens comparisonRequest run (Diff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions)   | isWorkspacePath fp = runWorkspaceDiff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions run (Parse fp) = do@@ -504,27 +506,27 @@     Left failure -> do       hPutStrLn stderr (T.unpack (renderParseFailure failure))       exitFailure-    Right ParsedSourceDocument {documentParsedSource = parsedSource} -> TIO.putStrLn (renderSource parsedSource)+    Right ParsedSourceDocument {parsedSource = parsedSource} -> TIO.putStrLn (renderSource parsedSource) run (Check fp options) = do   input <- TIO.readFile fp   case parseSourceDocument fp input of     Left failure -> do       hPutStrLn stderr (T.unpack (renderParseFailure failure))       exitFailure-    Right ParsedSourceDocument {documentParsedSource = parsedSource, documentSourceIndex = sourceIndex} -> do+    Right ParsedSourceDocument {parsedSource = parsedSource, sourceIndex = sourceIndex} -> do       validateCheckDenyCodes options       let service = checkedSource parsedSource           spec = checkedSpec service-          floorDiags = maybe [] (\floorVersion -> minimumLanguageDiagnostics floorVersion (parsedSourceLanguage parsedSource)) (checkMinLanguage options)+          floorDiags = maybe [] (\floorVersion -> minimumLanguageDiagnostics floorVersion ((.sourceLanguage) parsedSource)) ((.checkMinLanguage) options)           semanticDiags = floorDiags <> checkIndexedServiceDiagnostics Nothing sourceIndex (mkContext Nothing False spec) service-          semanticFailed = any ((== Error) . severity) semanticDiags-      emitLanguageContractNotice fp (sourceFormText (parsedSourceLanguage parsedSource)) service+          semanticFailed = any ((== Error) . (.severity)) semanticDiags+      emitLanguageContractNotice fp (sourceFormText ((.sourceLanguage) parsedSource)) service       mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) semanticDiags       -- Coverage is part of this invocation's diagnostic surface, not a       -- success-path artifact: its findings must reach the deny policy, the exit       -- code, and the check report. It still runs only after semantic validation       -- passes, because an unresolvable graph has nothing to cover.-      coveragePlan <- planCheckCoverage fp service (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@@ -533,30 +535,30 @@       if semanticFailed || not coverageOk || not (null deniedWarningCodes)         then exitFailure         else do-          when (checkEmit options) (TIO.putStrLn (renderSource parsedSource))-          if checkExplainBindings options+          when ((.checkEmit) options) (TIO.putStrLn (renderSource parsedSource))+          if (.checkExplainBindings) options             then case bindingObligationsForService service of               Left graphErrors -> do                 hPutStrLn stderr ("validated spec did not resolve its mapped type graph: " <> show graphErrors)                 exitFailure-              Right obligations -> TIO.putStrLn (renderBindingObligations (specContext spec) obligations)+              Right obligations -> TIO.putStrLn (renderBindingObligations ((.context) spec) obligations)             else pure ()-          when (not (checkEmit options) && not (checkExplainBindings options)) (putStrLn "OK")-run (Scaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite applyNameMigrations cliGoldens comparisonRequest) = do+          when (not ((.checkEmit) options) && not ((.checkExplainBindings) options)) (putStrLn "OK")+run (Scaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite applyNameMigrations applyGeneratedHaskellEdition cliGoldens comparisonRequest) = do   input <- TIO.readFile fp   case parseSourceDocument fp input of     Left failure -> do       hPutStrLn stderr (T.unpack (renderParseFailure failure))       exitFailure-    Right ParsedSourceDocument {documentParsedSource = parsedSource, documentSourceIndex = sourceIndex} -> do+    Right ParsedSourceDocument {parsedSource = parsedSource, sourceIndex = sourceIndex} -> do       let service = checkedSource parsedSource           spec = checkedSpec service-      emitLanguageContractNotice fp (sourceFormText (parsedSourceLanguage parsedSource)) service+      emitLanguageContractNotice fp (sourceFormText ((.sourceLanguage) parsedSource)) service       -- Validation gate: never scaffold an invalid spec. Abort on any       -- error-severity diagnostic before writing a single module.       let diags = validateService service       mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags-      when (any ((== Error) . severity) diags) exitFailure+      when (any ((== Error) . (.severity)) diags) exitFailure       let ctx = mkContext cliRoot cliCollocate spec           goldenRoot = fromMaybe (takeDirectory fp </> "golden-payloads") cliGoldens       goldens <- loadGoldenPayloads goldenRoot spec@@ -570,7 +572,7 @@           case comparisonReady of             Left comparisonError -> TIO.hPutStrLn stderr comparisonError >> exitFailure             Right () -> do-              result <- executeServiceScaffoldWithRuntimePackageAndNameMigrations cliRuntimePackage applyNameMigrations out forceGeneratedOverwrite fp (parsedSourceLanguage parsedSource) ctx service modules+              result <- executeServiceScaffoldWithRuntimePackageAndMigrations cliRuntimePackage applyNameMigrations applyGeneratedHaskellEdition out forceGeneratedOverwrite fp ((.sourceLanguage) parsedSource) ctx service modules               case result of                 Left refusals -> do                   mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)@@ -586,19 +588,19 @@   input <- TIO.readFile fp   case parseSourceDocument fp input of     Left failure -> hPutStrLn stderr (T.unpack (renderParseFailure failure)) >> exitFailure-    Right ParsedSourceDocument {documentParsedSource = parsedSource} ->+    Right ParsedSourceDocument {parsedSource = parsedSource} ->       TLIO.putStrLn-        (AesonText.encodeToLazyText (sourceInspection fp (parsedSourceLanguage parsedSource) (checkedSource parsedSource)))+        (AesonText.encodeToLazyText (sourceInspection fp ((.sourceLanguage) parsedSource) (checkedSource parsedSource))) run (BehaviorObligations fp format) = do   input <- TIO.readFile fp   case parseSourceDocument fp input of     Left failure -> hPutStrLn stderr (T.unpack (renderParseFailure failure)) >> exitFailure-    Right ParsedSourceDocument {documentParsedSource = parsedSource, documentSourceIndex = sourceIndex} -> do+    Right ParsedSourceDocument {parsedSource = parsedSource, sourceIndex = sourceIndex} -> do       let service = checkedSource parsedSource           spec = checkedSpec service           diagnostics = validateService service       mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diagnostics-      if any ((== Error) . severity) diagnostics+      if any ((== Error) . (.severity)) diagnostics         then exitFailure         else case sourceAwareBehaviorReport fp Nothing sourceIndex spec of           Left failure -> renderBehaviorReportFailure failure@@ -621,14 +623,14 @@           case (,) <$> parseSourceDocument (ref <> ":" <> relPath) (T.pack oldText) <*> parseSourceDocument fp newText of             Left failure -> hPutStrLn stderr (T.unpack (renderParseFailure failure)) >> exitFailure             Right-              ( ParsedSourceDocument {documentParsedSource = oldSource},-                ParsedSourceDocument {documentParsedSource = newSource}+              ( ParsedSourceDocument {parsedSource = oldSource},+                ParsedSourceDocument {parsedSource = newSource}                 ) -> do                 let oldService = checkedSource oldSource                     newService = checkedSource newSource                     oldSpec = checkedSpec oldService                     newSpec = checkedSpec newService-                emitLanguageContractNotice fp (sourceFormText (parsedSourceLanguage newSource)) newService+                emitLanguageContractNotice fp (sourceFormText ((.sourceLanguage) newSource)) newService                 case (,) <$> diffSources oldSource newSource <*> replayImpactServices oldService newService of                   Left surfaceError -> TIO.hPutStrLn stderr (renderFoldSurfaceError surfaceError) >> exitFailure                   Right (changes, impact) -> do@@ -646,7 +648,7 @@                     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 ()+                    if any (gatedBreaking effectiveGate) changes || any ((== CoordinationBreaking) . (.severity)) 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).@@ -685,22 +687,22 @@                 [ "schema" .= ("keiro-dsl/source-inspection/1" :: T.Text),                   "kind" .= ("workspace" :: T.Text),                   "path" .= fp,-                  "service" .= wsService workspace,+                  "service" .= (.service) workspace,                   "effectiveSemanticContract" .= checkedLanguageContract (checkedWorkspace workspace),-                  "members" .= map memberInspection (wsMembers workspace)+                  "members" .= map memberInspection ((.members) workspace)                 ]             )         )   where     memberInspection member =       Aeson.object-        [ "path" .= wmPath member,+        [ "path" .= (.path) member,           "sourceForm" .= sourceFormText sourceLanguage,           "declaredLanguageVersion" .= declaredLanguageVersionMaybe sourceLanguage,           "effectiveLanguageVersion" .= effectiveLanguageVersion sourceLanguage         ]       where-        sourceLanguage = wmSourceLanguage member+        sourceLanguage = (.sourceLanguage) member  runWorkspaceBehaviorObligations :: FilePath -> BehaviorFormat -> IO () runWorkspaceBehaviorObligations fp format = do@@ -710,7 +712,7 @@     Right workspace -> do       let diagnostics = checkWorkspace workspace       mapM_ (TIO.hPutStrLn stderr . renderWorkspaceDiagnostic fp) diagnostics-      if any ((== Error) . wdSeverity) diagnostics+      if any ((== Error) . (.severity)) diagnostics         then exitFailure         else case workspaceBehaviorReport workspace of           Left failure -> renderBehaviorReportFailure failure@@ -719,17 +721,19 @@ workspaceBehaviorReport :: WorkspaceSpec -> Either BehaviorReportFailure Behavior.BehaviorObligationsReport workspaceBehaviorReport workspace =   sourceAwareBehaviorReport-    (wsManifestPath workspace)-    (Just (wsService workspace))-    (wsSourceIndex workspace)+    ((.manifestPath) workspace)+    (Just ((.service) workspace))+    ((.sourceIndex) workspace)     (checkedSpec (checkedWorkspace workspace))     >>= \report ->       pure-        report-          { Behavior.behaviorRequirements =+        Behavior.BehaviorObligationsReport+          { Behavior.subject = report.subject,+            Behavior.workspaceService = report.workspaceService,+            Behavior.requirements =               map-                (Behavior.attributeBehaviorOwner (fmap fst . nodeOwner (wsOwnership workspace) "aggregate"))-                (Behavior.behaviorRequirements report)+                (Behavior.attributeBehaviorOwner (fmap fst . nodeOwner workspace.ownership "aggregate"))+                report.requirements           }  data BehaviorReportFailure@@ -742,9 +746,9 @@   sourceEntries <- either (Left . BehaviorReportSourceFailed) Right (BehaviorSource.planBehaviorSourceMap requirements sourceIndex)   pure     Behavior.BehaviorObligationsReport-      { Behavior.behaviorSubject = subject,-        Behavior.behaviorWorkspaceService = workspaceService,-        Behavior.behaviorRequirements = BehaviorSource.attachBehaviorSourceLocations sourceEntries requirements+      { Behavior.subject = subject,+        Behavior.workspaceService = workspaceService,+        Behavior.requirements = BehaviorSource.attachBehaviorSourceLocations sourceEntries requirements       }  writeBehaviorReport :: BehaviorFormat -> Behavior.BehaviorObligationsReport -> IO ()@@ -765,11 +769,11 @@       ( \sourceFailure ->           hPutStrLn             stderr-            ( show (BehaviorSource.failureCode sourceFailure)+            ( show ((.code) sourceFailure)                 <> " "-                <> T.unpack (Behavior.unBehaviorKey (BehaviorSource.failureKey sourceFailure))+                <> T.unpack (Behavior.unBehaviorKey ((.key) sourceFailure))                 <> ": "-                <> T.unpack (BehaviorSource.failureMessage sourceFailure)+                <> T.unpack ((.message) sourceFailure)             )       )       errors@@ -795,15 +799,15 @@       exitFailure     Right workspace -> do       let service = checkedWorkspace workspace-          floorDiags = maybe [] (\floorVersion -> minimumWorkspaceLanguageDiagnostics floorVersion workspace) (checkMinLanguage options)+          floorDiags = maybe [] (\floorVersion -> minimumWorkspaceLanguageDiagnostics floorVersion workspace) ((.checkMinLanguage) options)           semanticDiags = floorDiags <> checkWorkspaceForService workspace service           spec = checkedSpec service-          semanticFailed = any ((== Error) . wdSeverity) semanticDiags+          semanticFailed = any ((== Error) . (.severity)) 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 service (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@@ -812,15 +816,15 @@       if semanticFailed || not coverageOk || not (null deniedWarningCodes)         then exitFailure         else do-          when (checkEmit options) (TIO.putStrLn (renderSpec spec))-          if checkExplainBindings options+          when ((.checkEmit) options) (TIO.putStrLn (renderSpec spec))+          if (.checkExplainBindings) options             then case bindingObligationsForService service of               Left graphErrors -> do                 hPutStrLn stderr ("validated workspace did not resolve its mapped type graph: " <> show graphErrors)                 exitFailure-              Right obligations -> TIO.putStrLn (renderBindingObligations (wsContext workspace) obligations)+              Right obligations -> TIO.putStrLn (renderBindingObligations ((.context) workspace) obligations)             else pure ()-          when (not (checkEmit options) && not (checkExplainBindings options)) (putStrLn "OK")+          when (not ((.checkEmit) options) && not ((.checkExplainBindings) options)) (putStrLn "OK")  -- | @scaffold@ on a workspace manifest: compose the whole service, then plan -- and emit the complete module set for every member in one invocation.@@ -842,10 +846,11 @@   Bool ->   Bool ->   Bool ->+  Bool ->   Maybe FilePath ->   Maybe (String, FilePath) ->   IO ()-runWorkspaceScaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite applyNameMigrations cliGoldens comparisonRequest = do+runWorkspaceScaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite applyNameMigrations applyGeneratedHaskellEdition cliGoldens comparisonRequest = do   loaded <- loadWorkspace (fileContentSource (takeDirectory fp)) fp   case loaded of     Left failure -> do@@ -857,12 +862,12 @@       -- error-severity diagnostic before writing a single module.       let diags = checkWorkspace workspace       mapM_ (TIO.hPutStrLn stderr . renderWorkspaceDiagnostic fp) diags-      when (any ((== Error) . wdSeverity) diags) exitFailure+      when (any ((== Error) . (.severity)) diags) exitFailure       let spec = checkedSpec (checkedWorkspace workspace)           ctx = workspaceContext cliRoot cliCollocate workspace           effectiveRuntimePackage = case cliRuntimePackage of             Just packageName -> Just packageName-            Nothing -> wsRuntimePackage workspace+            Nothing -> (.runtimePackage) workspace           goldenRoot = fromMaybe (takeDirectory fp </> "golden-payloads") cliGoldens       goldens <- loadGoldenPayloads goldenRoot spec       case ( planWorkspaceScaffoldWithRuntimePackageAndGoldens goldens effectiveRuntimePackage goldenRoot ctx workspace,@@ -877,7 +882,7 @@           case comparisonReady of             Left comparisonError -> TIO.hPutStrLn stderr comparisonError >> exitFailure             Right () -> do-              result <- executeWorkspaceScaffoldWithNameMigrations out forceGeneratedOverwrite applyNameMigrations plan+              result <- executeWorkspaceScaffoldWithMigrations out forceGeneratedOverwrite applyNameMigrations applyGeneratedHaskellEdition plan               case result of                 Left refusals -> do                   mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)@@ -963,18 +968,18 @@                         Right (workspaceChanges, impact) -> do                           written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) goldenRoot                           mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written-                          let changes = map wcChange workspaceChanges+                          let changes = map (.change) workspaceChanges                               effectiveGate = gateWith gatedSurfaces                               semanticImpact = CheckedDiff.mappedSemanticImpactForServices oldService newService                               coordination = coordinationImpact oldService newService semanticImpact                               reportMeta =                                 WorkspaceMeta-                                  { wmIdentity = wsService newWorkspace,-                                    wmManifest = fp,-                                    wmSince = T.pack ref,-                                    wmMembersOld = map wmPath (wsMembers oldWorkspace),-                                    wmMembersNew = map wmPath (wsMembers newWorkspace),-                                    wmAdoptionBaseline = adoptionBaseline+                                  { identity = (.service) newWorkspace,+                                    manifest = fp,+                                    since = T.pack ref,+                                    membersOld = map (.path) ((.members) oldWorkspace),+                                    membersNew = map (.path) ((.members) newWorkspace),+                                    adoptionBaseline = adoptionBaseline                                   }                           mapM_ (TIO.putStrLn . renderWorkspaceFinding) workspaceChanges                           mapM_ TIO.putStrLn (renderSemanticImpact semanticImpact)@@ -985,7 +990,7 @@                           mapM_ (`Aeson.encodeFile` impact) replayImpactOut                           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 || any ((== CoordinationBreaking) . coordinationSeverity) coordination || not coverageOk then exitFailure else pure ()+                          if any (gatedBreaking effectiveGate) changes || any ((== CoordinationBreaking) . (.severity)) coordination || not coverageOk then exitFailure else pure ()  -- | A @git show@ backed source rooted at a workspace manifest directory. gitContentSource :: FilePath -> String -> FilePath -> ContentSource@@ -1010,41 +1015,63 @@   WorkspaceSpec ->   IO (Either WorkspaceFailure WorkspaceSpec) loadAdoptionBaseline oldSource manifestPath currentManifest newWorkspace = do-  present <- traverse presentAtRevision (NE.toList (wmfMembers currentManifest))+  present <- traverse presentAtRevision (NE.toList ((.members) currentManifest))   case NE.nonEmpty [member | (member, True) <- present] of     Nothing -> pure (Right (emptyWorkspaceBaseline newWorkspace))     Just members ->-      let oldManifest = currentManifest {wmfMembers = members}+      let oldManifest =+            WorkspaceManifest+              { service = (.service) currentManifest,+                serviceLoc = (.serviceLoc) currentManifest,+                runtimePackage = (.runtimePackage) currentManifest,+                runtimePackageLoc = (.runtimePackageLoc) currentManifest,+                moduleRoot = (.moduleRoot) currentManifest,+                moduleRootLoc = (.moduleRootLoc) currentManifest,+                layout = (.layout) currentManifest,+                layoutLoc = (.layoutLoc) currentManifest,+                members = members+              }           manifestName = takeFileName manifestPath           baselineSource =             ContentSource               { csRead = \relative ->                   if relative == manifestName                     then pure (Right (renderWorkspaceManifest oldManifest))-                    else csRead oldSource relative+                    else (.csRead) oldSource relative               }        in loadWorkspace baselineSource manifestPath   where     presentAtRevision member = do-      result <- csRead oldSource (wmrPath member)+      result <- (.csRead) oldSource ((.path) member)       pure (member, either (const False) (const True) result)  -- | The sound old side when every current member is new at the adoption ref. emptyWorkspaceBaseline :: WorkspaceSpec -> WorkspaceSpec emptyWorkspaceBaseline workspace =-  workspace-    { wsMembers = [],-      wsMergedSpec =-        (wsMergedSpec workspace)-          { specIds = [],-            specEnums = [],-            specRules = [],-            specMapped = [],-            specNodes = []+  WorkspaceSpec+    { service = workspace.service,+      manifestPath = workspace.manifestPath,+      languageContract = workspace.languageContract,+      context = workspace.context,+      runtimePackage = workspace.runtimePackage,+      moduleRoot = workspace.moduleRoot,+      layout = workspace.layout,+      members = [],+      mergedSpec =+        Spec+          { context = workspace.mergedSpec.context,+            moduleRoot = workspace.mergedSpec.moduleRoot,+            layout = workspace.mergedSpec.layout,+            ids = [],+            enums = [],+            rules = [],+            nominalScalars = workspace.mergedSpec.nominalScalars,+            mapped = [],+            nodes = []           },-      wsSourceIndex = emptySemanticSourceIndex,-      wsLineMap = LineMap [],-      wsOwnership = OwnershipIndex mempty mempty+      sourceIndex = emptySemanticSourceIndex,+      lineMap = LineMap [],+      ownership = OwnershipIndex mempty mempty     }  workspaceGoldenRoot :: FilePath -> FilePath -> FilePath@@ -1066,12 +1093,12 @@ workspaceContext :: Maybe String -> Bool -> WorkspaceSpec -> Context workspaceContext cliRoot cliCollocate workspace =   Context-    { contextName = wsContext workspace,-      moduleRoot = maybe (fromMaybe "" (wsModuleRoot workspace)) T.pack cliRoot,+    { name = (.context) workspace,+      moduleRoot = maybe (fromMaybe "" ((.moduleRoot) workspace)) T.pack cliRoot,       placement =         if cliCollocate           then CollocatedLeaf-          else fromMaybe GeneratedPrefix (wsLayout workspace)+          else fromMaybe GeneratedPrefix ((.layout) workspace)     }  shouldExplain :: Change -> Bool@@ -1093,7 +1120,7 @@ preflightComparison :: FilePath -> Maybe (String, FilePath) -> Maybe ScaffoldModule -> IO (Either T.Text ()) preflightComparison _ Nothing Nothing = pure (Right ()) preflightComparison out (Just (_, requestedPath)) (Just comparisonModule) = do-  let expectedPath = normalise (out </> modulePath comparisonModule)+  let expectedPath = normalise (out </> (.path) comparisonModule)       actualPath = normalise requestedPath   if actualPath /= expectedPath     then@@ -1120,7 +1147,7 @@ writeComparison Nothing Nothing = pure () writeComparison (Just (_, path)) (Just comparisonModule) = do   createDirectoryIfMissing True (takeDirectory path)-  TIO.writeFile path (moduleText comparisonModule)+  TIO.writeFile path ((.text) comparisonModule)   TIO.hPutStrLn stderr ("comparison generated " <> T.pack path <> " (migration evidence only)") writeComparison _ _ = hPutStrLn stderr "internal error: incomplete codec-comparison output" >> exitFailure @@ -1141,11 +1168,11 @@     Left graphErrors -> CoverageUnresolved (show graphErrors)     Right baseReport ->       PlannedCoverage-        (checkCoveragePath options)-        (if checkFailOnOpaque options then Coverage.failOnOpaque baseReport else baseReport)+        ((.checkCoveragePath) options)+        (if (.checkFailOnOpaque) options then Coverage.failOnOpaque baseReport else baseReport)  plannedCoverageFindings :: PlannedCoverage -> [Coverage.CoverageFinding]-plannedCoverageFindings (PlannedCoverage _ report) = Coverage.coverageFindings report+plannedCoverageFindings (PlannedCoverage _ report) = (.findings) report plannedCoverageFindings _ = []  -- | Coverage findings as ordinary source diagnostics. They carry no line, which@@ -1154,8 +1181,8 @@ plannedCoverageDiagnostics plan =   [ Diagnostic       { line = 0,-        severity = Coverage.findingSeverity finding,-        code = Coverage.findingCode finding,+        severity = (.severity) finding,+        code = (.code) finding,         relatedLocations = [],         message = Coverage.coverageFindingMessage finding       }@@ -1167,11 +1194,11 @@ workspaceCoverageDiagnostic :: FilePath -> Coverage.CoverageFinding -> WorkspaceDiagnostic workspaceCoverageDiagnostic _ finding =   WorkspaceDiagnostic-    { wdLocations = NE.fromList [WorkspaceLocation WorkspaceManifestFile 0 ""],-      wdSeverity = Coverage.findingSeverity finding,-      wdCode = Coverage.findingCode finding,-      wdSourceLanguageCause = Nothing,-      wdMessage = Coverage.coverageFindingMessage finding+    { locations = NE.fromList [WorkspaceLocation WorkspaceManifestFile 0 ""],+      severity = (.severity) finding,+      code = (.code) finding,+      sourceLanguageCause = Nothing,+      message = Coverage.coverageFindingMessage finding     }  emitPlannedCoverage :: PlannedCoverage -> IO Bool@@ -1189,12 +1216,12 @@       hPutStrLn stderr ("diff specs did not resolve their mapped type graph for coverage: " <> show graphErrors)       pure False     Right baseReport -> do-      let report = if diffFailOnOpaqueIncrease options then Coverage.failOnOpaqueIncrease baseReport else baseReport-      emitCoverageReport (diffCoveragePath options) report+      let report = if (.diffFailOnOpaqueIncrease) options then Coverage.failOnOpaqueIncrease baseReport else baseReport+      emitCoverageReport ((.diffCoveragePath) options) report  emitCoverageReport :: FilePath -> Coverage.CoverageReport -> IO Bool emitCoverageReport path report = do-  mapM_ (TIO.hPutStrLn stderr . Coverage.renderCoverageFinding (Coverage.coverageSpec report)) (Coverage.coverageFindings report)+  mapM_ (TIO.hPutStrLn stderr . Coverage.renderCoverageFinding ((.spec) report)) ((.findings) report)   TIO.putStr (Coverage.renderCoverageSummary report)   Coverage.writeCoverageReport path report   putStrLn ("coverage report written to " <> path)@@ -1205,10 +1232,10 @@ mkContext :: Maybe String -> Bool -> Spec -> Context mkContext cliRoot cliCollocate spec =   Context-    { contextName = specContext spec,-      moduleRoot = maybe (fromMaybe "" (specModuleRoot spec)) T.pack cliRoot,+    { name = (.context) spec,+      moduleRoot = maybe (fromMaybe "" ((.moduleRoot) spec)) T.pack cliRoot,       placement =         if cliCollocate           then CollocatedLeaf-          else fromMaybe GeneratedPrefix (specLayout spec)+          else fromMaybe GeneratedPrefix ((.layout) spec)     }

bench/structural-codec/Main.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedRecordDot #-}- module Main (main) where  import Conformance.Structural.Bindings qualified as Bindings

+ generated-haskell-edition-idiomatic-v2.md view

file too large to diff

+ internal/Keiro/Dsl/GeneratedHaskellLanguage.hs view

@@ -0,0 +1,174 @@+-- | The Haskell language contract for overwriteable generated modules.+--+-- The manifest and conformance build profile publish the shared baseline.+-- Syntax outside that baseline must be requested through the closed extension+-- type and rendered as a module-local pragma.+module Keiro.Dsl.GeneratedHaskellLanguage+  ( GeneratedHaskellExtension (..),+    generatedHaskellDefaultLanguage,+    generatedHaskellDefaultExtensions,+    idiomaticV2LabelMigrations,+    modernizeGeneratedHaskellSource,+    modernizeGeneratedHaskellSourceWithState,+    RewriteState (..),+    renderGeneratedLanguagePragmas,+  )+where++import Data.Char (isAlphaNum)+import Data.List (nub, sort)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T++data GeneratedHaskellExtension+  = ExtBlockArguments+  | ExtDeriveAnyClass+  | ExtDuplicateRecordFields+  | ExtOverloadedLabels+  | ExtOverloadedRecordDot+  | ExtQualifiedDo+  | ExtTemplateHaskell+  | ExtTypeFamilies+  deriving (Eq, Ord, Show)++generatedHaskellDefaultLanguage :: Text+generatedHaskellDefaultLanguage = "GHC2024"++generatedHaskellDefaultExtensions :: [Text]+generatedHaskellDefaultExtensions =+  [ "DuplicateRecordFields",+    "NoFieldSelectors",+    "OverloadedRecordDot",+    "OverloadedStrings"+  ]++renderGeneratedLanguagePragmas :: [GeneratedHaskellExtension] -> [Text]+renderGeneratedLanguagePragmas =+  map renderPragma+    . filter (`notElem` generatedHaskellDefaultExtensions)+    . sort+    . nub+    . map extensionName+  where+    renderPragma name = "{-# LANGUAGE " <> name <> " #-}"++extensionName :: GeneratedHaskellExtension -> Text+extensionName extension = case extension of+  ExtBlockArguments -> "BlockArguments"+  ExtDeriveAnyClass -> "DeriveAnyClass"+  ExtDuplicateRecordFields -> "DuplicateRecordFields"+  ExtOverloadedLabels -> "OverloadedLabels"+  ExtOverloadedRecordDot -> "OverloadedRecordDot"+  ExtQualifiedDo -> "QualifiedDo"+  ExtTemplateHaskell -> "TemplateHaskell"+  ExtTypeFamilies -> "TypeFamilies"++-- | Apply the idiomatic-v2 product-label mapping to Haskell identifiers while+-- preserving comments and literals byte for byte. The emitter templates still+-- use the released idiomatic-v1 labels as their semantic vocabulary; keeping+-- the presentation rewrite here makes the edition boundary complete and keeps+-- wire strings, diagnostics, and generated comments outside that boundary.+modernizeGeneratedHaskellSource :: Text -> Text+modernizeGeneratedHaskellSource = fst . modernizeGeneratedHaskellSourceWithState++modernizeGeneratedHaskellSourceWithState :: Text -> (Text, RewriteState)+modernizeGeneratedHaskellSourceWithState source =+  let (output, finalState) = go Code (T.unpack source)+   in (T.pack output, finalState)+  where+    go Code [] = ([], Code)+    go LineComment [] = ([], Code)+    go state [] = ([], state)+    go Code input@('-' : '-' : _) =+      let (dashes, remaining) = span (== '-') input+          startsComment = case remaining of+            [] -> True+            character : _ -> not (isHaskellSymbol character)+       in emit dashes (go (if startsComment then LineComment else Code) remaining)+    go Code ('{' : '-' : rest) = emit "{-" (go (BlockComment 1) rest)+    go Code ('"' : rest) = emit "\"" (go StringLiteral rest)+    go Code ('\'' : rest)+      | startsCharacterLiteral rest = emit "'" (go CharacterLiteral rest)+      | otherwise = emit "'" (go Code rest)+    go Code sourceText@(character : rest)+      | identifierStart character =+          let (token, remaining) = span identifierCharacter sourceText+              replacement = Map.findWithDefault (T.pack token) (T.pack token) idiomaticV2Labels+           in emit (T.unpack replacement) (go Code remaining)+      | otherwise = emit [character] (go Code rest)+    go LineComment ('\n' : rest) = emit "\n" (go Code rest)+    go LineComment (character : rest) = emit [character] (go LineComment rest)+    go (BlockComment depth) ('{' : '-' : rest) = emit "{-" (go (BlockComment (depth + 1)) rest)+    go (BlockComment 1) ('-' : '}' : rest) = emit "-}" (go Code rest)+    go (BlockComment depth) ('-' : '}' : rest) = emit "-}" (go (BlockComment (depth - 1)) rest)+    go (BlockComment depth) (character : rest) = emit [character] (go (BlockComment depth) rest)+    go StringLiteral ('\\' : escaped : rest) = emit ['\\', escaped] (go StringLiteral rest)+    go StringLiteral ('"' : rest) = emit "\"" (go Code rest)+    go StringLiteral (character : rest) = emit [character] (go StringLiteral rest)+    go CharacterLiteral ('\\' : escaped : rest) = emit ['\\', escaped] (go CharacterLiteral rest)+    go CharacterLiteral ('\'' : rest) = emit "'" (go Code rest)+    go CharacterLiteral (character : rest) = emit [character] (go CharacterLiteral rest)++    emit prefix (output, state) = (prefix <> output, state)+    startsCharacterLiteral ('\\' : _) = True+    startsCharacterLiteral (_ : '\'' : _) = True+    startsCharacterLiteral _ = False+    isHaskellSymbol character = character `elem` ("!#$%&*+./<=>?@\\^|-~:" :: String)+    identifierStart character = character == '_' || character >= 'A' && character <= 'Z' || character >= 'a' && character <= 'z'+    identifierCharacter character = identifierStart character || isAlphaNum character || character == '\''++data RewriteState+  = Code+  | LineComment+  | BlockComment !Int+  | StringLiteral+  | CharacterLiteral+  deriving stock (Eq, Show)++idiomaticV2Labels :: Map.Map Text Text+idiomaticV2Labels = Map.fromList idiomaticV2LabelMigrations++idiomaticV2LabelMigrations :: [(Text, Text)]+idiomaticV2LabelMigrations =+  [ ("failureCode", "code"),+    ("failureDetail", "detail"),+    ("failureKey", "key"),+    ("failureSubject", "subject"),+    ("inboxFailureAttempt", "attempt"),+    ("inboxFailureReason", "reason"),+    ("reportDuplicate", "duplicate"),+    ("reportFailed", "failed"),+    ("reportFilled", "filled"),+    ("reportMissing", "missing"),+    ("reportPending", "pending"),+    ("reportRequired", "required"),+    ("reportStale", "stale"),+    ("reportUnverified", "unverified"),+    ("reportVerified", "verified"),+    ("requirementCommandName", "commandName"),+    ("requirementEventKinds", "eventKinds"),+    ("requirementEvidence", "evidence"),+    ("requirementExpectedEdge", "expectedEdge"),+    ("requirementGuardCoverage", "guardCoverage"),+    ("requirementKey", "key"),+    ("requirementKind", "kind"),+    ("requirementLine", "line"),+    ("requirementSource", "source"),+    ("requirementTarget", "target"),+    ("sourceColumn", "column"),+    ("sourceFile", "file"),+    ("sourceLine", "line"),+    ("witnessCommand", "command"),+    ("witnessExpected", "expected"),+    ("witnessHistory", "history"),+    ("witnessHistoryPrefix", "historyPrefix"),+    ("witnessKey", "key"),+    ("witnessObservedChunk", "observedChunk"),+    ("workflowFactAwaitLabels", "awaitLabels"),+    ("workflowFactBody", "body"),+    ("workflowFactIdField", "idField"),+    ("workflowFactIdVia", "idVia"),+    ("workflowFactName", "name"),+    ("workflowFactPatchIds", "patchIds")+  ]

keiro-dsl.cabal view

@@ -1,23 +1,41 @@-cabal-version:   3.0-name:            keiro-dsl-version:         0.14.0.0-synopsis:        Typed specification toolchain for keiro services+cabal-version:      3.0+name:               keiro-dsl+version:            0.15.0.0+synopsis:           Typed specification toolchain for keiro services description:   keiro-dsl is the toolchain over a typed `.keiro` specification of a keiro   service: a parser + checker + scaffolder + harness emitter. It emits the   symbol-free deterministic layer plus typed holes, never a keiki symbolic   operator (the firewall invariant). -license:         BSD-3-Clause-license-file:    LICENSE-author:          Nadeem Bitar-maintainer:      nadeem@gmail.com-copyright:       2026 Nadeem Bitar-category:        Development-build-type:      Simple-tested-with:     GHC >=9.12 && <9.13-extra-doc-files: CHANGELOG.md+license:            BSD-3-Clause+license-file:       LICENSE+author:             Nadeem Bitar+maintainer:         nadeem@gmail.com+copyright:          2026 Nadeem Bitar+category:           Development+build-type:         Simple+tested-with:        GHC >=9.12 && <9.13+extra-doc-files:+  CHANGELOG.md+  generated-haskell-edition-idiomatic-v2.md+  record-field-migration-0.15.md +-- The main package test is intentionally runnable from an unpacked source+-- distribution. Include its fixtures, compatibility manifests, mutation+-- scripts, and committed conformance corpus instead of relying on the+-- repository checkout surrounding this package.+extra-source-files:+  test/**/*.cabal+  test/**/*.golden+  test/**/*.hs+  test/**/*.json+  test/**/*.keiro+  test/**/*.keiro-workspace+  test/**/*.md+  test/**/*.sh+  test/**/*.txt+ common warnings   ghc-options: -Wall -Werror=missing-fields @@ -27,7 +45,9 @@     DuplicateRecordFields     ImportQualifiedPost     LambdaCase+    NoFieldSelectors     OverloadedLabels+    OverloadedRecordDot     OverloadedStrings  -- Every component importing this stanza compiles only `keiro-dsl scaffold`@@ -46,7 +66,11 @@  common generated-output   default-language:   GHC2024-  default-extensions: OverloadedStrings+  default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings    -- Published Languages 1-4 intentionally retain the frozen 0.11 ReadModel   -- spelling during the 0.12 migration window. Those generated bytes are not@@ -58,6 +82,16 @@   if flag(werror-generated)     ghc-options: -Werror +library generated-haskell-language-internal+  import:          warnings, shared+  visibility:      private+  hs-source-dirs:  internal+  exposed-modules: Keiro.Dsl.GeneratedHaskellLanguage+  build-depends:+    , base        >=4.21 && <5+    , containers  >=0.6  && <0.8+    , text        >=2.1  && <2.2+ library   import:          warnings, shared   hs-source-dirs:  src@@ -126,7 +160,6 @@     Keiro.Dsl.AggregateGenerationPlan     Keiro.Dsl.FieldIdentity     Keiro.Dsl.Frontend.Internal-    Keiro.Dsl.GeneratedHaskellLanguage     Keiro.Dsl.HaskellName     Keiro.Dsl.Parser.Aggregate     Keiro.Dsl.Parser.Coordination@@ -144,21 +177,22 @@     Paths_keiro_dsl    build-depends:-    , aeson               >=2.2.1     && <2.3-    , 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.14.0.0-    , megaparsec          >=9.6       && <9.9-    , mmzk-typeid         >=0.7       && <0.8-    , parser-combinators  >=1.3       && <1.4-    , prettyprinter       >=1.7       && <1.8-    , text                >=2.1       && <2.2-    , time                >=1.12      && <1.15+    , aeson                                          >=2.2.1     && <2.3+    , 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.15.0.0+    , keiro-dsl:generated-haskell-language-internal+    , megaparsec                                     >=9.6       && <9.9+    , mmzk-typeid                                    >=0.7       && <0.8+    , parser-combinators                             >=1.3       && <1.4+    , prettyprinter                                  >=1.7       && <1.8+    , text                                           >=2.1       && <2.2+    , time                                           >=1.12      && <1.15  executable keiro-dsl   import:         warnings, shared@@ -190,19 +224,21 @@     Paths_keiro_dsl    build-depends:-    , aeson        >=2.2       && <2.3-    , base         >=4.21      && <5-    , containers   >=0.6       && <0.8-    , directory    >=1.3       && <1.4-    , filepath     >=1.4       && <1.6-    , hspec        >=2.11-    , keiki        >=0.9       && <0.10-    , keiro-core   ^>=0.14.0.0+    , aeson                                          >=2.2       && <2.3+    , base                                           >=4.21      && <5+    , bytestring                                     >=0.12      && <0.13+    , containers                                     >=0.6       && <0.8+    , directory                                      >=1.3       && <1.4+    , filepath                                       >=1.4       && <1.6+    , hspec                                          >=2.11+    , keiki                                          >=0.9       && <0.10+    , keiro-core                                     ^>=0.15.0.0     , keiro-dsl-    , mmzk-typeid  >=0.7       && <0.8-    , process      >=1.6       && <1.7-    , QuickCheck   >=2.14-    , text         >=2.1       && <2.2+    , keiro-dsl:generated-haskell-language-internal+    , mmzk-typeid                                    >=0.7       && <0.8+    , process                                        >=1.6       && <1.7+    , QuickCheck                                     >=2.14+    , text                                           >=2.1       && <2.2  test-suite keiro-dsl-import-planning-test   import:         warnings, shared

+ record-field-migration-0.15.md view

@@ -0,0 +1,1433 @@+# keiro-dsl record-field migration for 0.15++This checked inventory is the package-authored record migration contract for ExecPlan 177.+It validates every tracked Haskell source compiled through the `shared` Cabal stanza.+The current column preserves the released 0.14 spelling; the target column and all other+facts are derived from the live 0.15 source. Unchanged rows are intentional.+Product reads become record-dot projections, while single-field newtype unwrappers remain+explicit positional functions. The review-risk column is an omission detector: it flags+serialized, rendered, CLI, and runtime surfaces for review but does not prove byte+compatibility. Exact byte claims live in named package-test goldens.++Inventory: 286 record-owning declarations, 1412 fields, 1375 strict fields, and 1281 fields exported through a public `Type (..)`.++| Location | Owner | Kind | Public | Current | Target | Type/strictness | Selection replacement | Review risk / observable surface | Deriving |+| --- | --- | --- | --- | --- | --- | --- | --- | --- | --- |+| `keiro-dsl/src/Keiro/Dsl/AggregateGenerationPlan.hs:14` | `TransitionLayoutEntry` | data | no | `layoutDeclarationIndex` | `declarationIndex` | `!Int` | `(.declarationIndex)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/AggregateGenerationPlan.hs:15` | `TransitionLayoutEntry` | data | no | `layoutOutgoingIndex` | `outgoingIndex` | `!Int` | `(.outgoingIndex)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/AggregateGenerationPlan.hs:16` | `TransitionLayoutEntry` | data | no | `layoutTransition` | `transition` | `!Transition` | `(.transition)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/AggregateType.hs:85` | `AggregateSymbols` | data | no | `symbolNominals` | `nominals` | `!(Map Name ResolvedNominalType)` | `(.nominals)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/AggregateType.hs:86` | `AggregateSymbols` | data | no | `symbolVertices` | `vertices` | `!(Map Name [Name])` | `(.vertices)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/AggregateType.hs:87` | `AggregateSymbols` | data | no | `symbolMapped` | `mapped` | `!(Map MappedKey ResolvedMappedDecl)` | `(.mapped)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/AggregateType.hs:121` | `AggregateTypeError` | data | yes | `aggregateTypeErrorLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/AggregateType.hs:122` | `AggregateTypeError` | data | yes | `aggregateTypeErrorUseSite` | `useSite` | `!AggregateUseSite` | `(.useSite)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/AggregateType.hs:123` | `AggregateTypeError` | data | yes | `aggregateTypeErrorReason` | `reason` | `!AggregateTypeErrorReason` | `(.reason)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/AggregateType.hs:251` | `AggregateHaskellSource` | data | no | `aggregateSourceBuiltin` | `builtin` | `!(Maybe Text)` | `(.builtin)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/AggregateType.hs:252` | `AggregateHaskellSource` | data | no | `aggregateSourceReference` | `reference` | `!(Maybe HaskellReference)` | `(.reference)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/AggregateType.hs:253` | `AggregateHaskellSource` | data | no | `aggregateSourceStaticImports` | `staticImports` | `!(Set Text)` | `(.staticImports)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:51` | `BehaviorKey` | newtype | yes | `unBehaviorKey` | `unBehaviorKey` | `Text` | explicit `unBehaviorKey` positional function | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:92` | `BehaviorExactLocation` | data | yes | `exactSourceFile` | `sourceFile` | `!FilePath` | `(.sourceFile)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:93` | `BehaviorExactLocation` | data | yes | `exactSourceLine` | `sourceLine` | `!Int` | `(.sourceLine)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:94` | `BehaviorExactLocation` | data | yes | `exactSourceColumn` | `sourceColumn` | `!Int` | `(.sourceColumn)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:99` | `BehaviorRequirement` | data | yes | `requirementKey` | `key` | `!BehaviorKey` | `(.key)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:100` | `BehaviorRequirement` | data | yes | `requirementOrigin` | `origin` | `!RequirementOrigin` | `(.origin)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:101` | `BehaviorRequirement` | data | yes | `requirementKind` | `kind` | `!ObligationKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:102` | `BehaviorRequirement` | data | yes | `requirementEvidence` | `evidence` | `!EvidenceLevel` | `(.evidence)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:103` | `BehaviorRequirement` | data | yes | `requirementGuardCoverage` | `guardCoverage` | `!GuardCoverage` | `(.guardCoverage)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:104` | `BehaviorRequirement` | data | yes | `requirementContext` | `context` | `!Name` | `(.context)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:105` | `BehaviorRequirement` | data | yes | `requirementAggregate` | `aggregate` | `!Name` | `(.aggregate)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:106` | `BehaviorRequirement` | data | yes | `requirementSource` | `source` | `!Name` | `(.source)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:107` | `BehaviorRequirement` | data | yes | `requirementCommand` | `command` | `!Name` | `(.command)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:108` | `BehaviorRequirement` | data | yes | `requirementTarget` | `target` | `!(Maybe Name)` | `(.target)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:109` | `BehaviorRequirement` | data | yes | `requirementMode` | `mode` | `!(Maybe TransitionMode)` | `(.mode)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:110` | `BehaviorRequirement` | data | yes | `requirementEvents` | `events` | `![Name]` | `(.events)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:111` | `BehaviorRequirement` | data | yes | `requirementOutputs` | `outputs` | `![OutputEvidence]` | `(.outputs)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:112` | `BehaviorRequirement` | data | yes | `requirementDomainOutcome` | `domainOutcome` | `!(Maybe TransitionOutcome)` | `(.domainOutcome)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:113` | `BehaviorRequirement` | data | yes | `requirementLocation` | `location` | `!Loc` | `(.location)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:114` | `BehaviorRequirement` | data | yes | `requirementExactLocation` | `exactLocation` | `!(Maybe BehaviorExactLocation)` | `(.exactLocation)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:115` | `BehaviorRequirement` | data | yes | `requirementOwner` | `owner` | `!(Maybe FilePath)` | `(.owner)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:116` | `BehaviorRequirement` | data | yes | `requirementCanonical` | `canonical` | `!Text` | `(.canonical)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:124` | `BehaviorRecordRow` | data | yes | `behaviorRecordKey` | `key` | `!BehaviorKey` | `(.key)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:125` | `BehaviorRecordRow` | data | yes | `behaviorRecordKind` | `kind` | `!ObligationKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:126` | `BehaviorRecordRow` | data | yes | `behaviorRecordEvidence` | `evidence` | `!EvidenceLevel` | `(.evidence)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:127` | `BehaviorRecordRow` | data | yes | `behaviorRecordAggregate` | `aggregate` | `!Name` | `(.aggregate)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:128` | `BehaviorRecordRow` | data | yes | `behaviorRecordSource` | `source` | `!Name` | `(.source)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:129` | `BehaviorRecordRow` | data | yes | `behaviorRecordCommand` | `command` | `!Name` | `(.command)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:130` | `BehaviorRecordRow` | data | yes | `behaviorRecordOwner` | `owner` | `!(Maybe FilePath)` | `(.owner)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:131` | `BehaviorRecordRow` | data | yes | `behaviorRecordOutputs` | `outputs` | `![OutputEvidence]` | `(.outputs)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:143` | `BehaviorObligationsReport` | data | yes | `behaviorSubject` | `subject` | `!FilePath` | `(.subject)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:144` | `BehaviorObligationsReport` | data | yes | `behaviorWorkspaceService` | `workspaceService` | `!(Maybe Text)` | `(.workspaceService)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorCoverage.hs:145` | `BehaviorObligationsReport` | data | yes | `behaviorRequirements` | `requirements` | `![BehaviorRequirement]` | `(.requirements)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorSourceMap.hs:38` | `BehaviorSourceFailure` | data | yes | `failureCode` | `code` | `!BehaviorSourceFailureCode` | `(.code)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorSourceMap.hs:39` | `BehaviorSourceFailure` | data | yes | `failureKey` | `key` | `!BehaviorKey` | `(.key)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorSourceMap.hs:40` | `BehaviorSourceFailure` | data | yes | `failureOrigin` | `origin` | `!RequirementOrigin` | `(.origin)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorSourceMap.hs:41` | `BehaviorSourceFailure` | data | yes | `failureAggregate` | `aggregate` | `!Text` | `(.aggregate)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorSourceMap.hs:42` | `BehaviorSourceFailure` | data | yes | `failureState` | `state` | `!Text` | `(.state)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorSourceMap.hs:43` | `BehaviorSourceFailure` | data | yes | `failureCommand` | `command` | `!Text` | `(.command)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorSourceMap.hs:44` | `BehaviorSourceFailure` | data | yes | `failureSourceSubject` | `sourceSubject` | `!SourceSubject` | `(.sourceSubject)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorSourceMap.hs:45` | `BehaviorSourceFailure` | data | yes | `failureSpan` | `span` | `!(Maybe SourceSpan)` | `(.span)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorSourceMap.hs:46` | `BehaviorSourceFailure` | data | yes | `failureMessage` | `message` | `!Text` | `(.message)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorSourceMap.hs:51` | `BehaviorSourceEntry` | data | yes | `behaviorSourceKey` | `key` | `!BehaviorKey` | `(.key)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorSourceMap.hs:52` | `BehaviorSourceEntry` | data | yes | `behaviorSourceFile` | `file` | `!FilePath` | `(.file)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorSourceMap.hs:53` | `BehaviorSourceEntry` | data | yes | `behaviorSourceLine` | `line` | `!Int` | `(.line)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/BehaviorSourceMap.hs:54` | `BehaviorSourceEntry` | data | yes | `behaviorSourceColumn` | `column` | `!Int` | `(.column)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:41` | `CheckReportLanguage` | data | yes | `reportSourceForm` | `sourceForm` | `!Text` | `(.sourceForm)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:42` | `CheckReportLanguage` | data | yes | `reportDeclaredLanguageVersion` | `declaredLanguageVersion` | `!(Maybe LanguageVersion)` | `(.declaredLanguageVersion)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:43` | `CheckReportLanguage` | data | yes | `reportEffectiveLanguageVersion` | `effectiveLanguageVersion` | `!LanguageVersion` | `(.effectiveLanguageVersion)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:44` | `CheckReportLanguage` | data | yes | `reportRuntimeSemantics` | `runtimeSemantics` | `!Text` | `(.runtimeSemantics)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:45` | `CheckReportLanguage` | data | yes | `reportLanguageSupport` | `languageSupport` | `!LanguageSupport` | `(.languageSupport)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:46` | `CheckReportLanguage` | data | yes | `reportStable` | `stable` | `!Bool` | `(.stable)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:51` | `CheckReportEnforcement` | data | yes | `reportMinLanguage` | `minLanguage` | `!(Maybe LanguageVersion)` | `(.minLanguage)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:52` | `CheckReportEnforcement` | data | yes | `reportDenyWarnings` | `denyWarnings` | `!Bool` | `(.denyWarnings)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:53` | `CheckReportEnforcement` | data | yes | `reportDenyCodes` | `denyCodes` | `![DiagnosticCode]` | `(.denyCodes)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:58` | `CheckReportRelated` | data | yes | `relatedFile` | `file` | `!FilePath` | `(.file)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:59` | `CheckReportRelated` | data | yes | `relatedLine` | `line` | `!Int` | `(.line)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:60` | `CheckReportRelated` | data | yes | `relatedNote` | `note` | `!Text` | `(.note)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:65` | `CheckReportEntry` | data | yes | `entryCode` | `code` | `!DiagnosticCode` | `(.code)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:66` | `CheckReportEntry` | data | yes | `entrySeverity` | `severity` | `!Severity` | `(.severity)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:67` | `CheckReportEntry` | data | yes | `entryFile` | `file` | `!FilePath` | `(.file)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:68` | `CheckReportEntry` | data | yes | `entryLine` | `line` | `!Int` | `(.line)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:69` | `CheckReportEntry` | data | yes | `entryMessage` | `message` | `!Text` | `(.message)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:70` | `CheckReportEntry` | data | yes | `entryDenied` | `denied` | `!Bool` | `(.denied)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:71` | `CheckReportEntry` | data | yes | `entryRelated` | `related` | `![CheckReportRelated]` | `(.related)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:76` | `CheckReportSummary` | data | yes | `summaryErrors` | `errors` | `!Int` | `(.errors)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:77` | `CheckReportSummary` | data | yes | `summaryWarnings` | `warnings` | `!Int` | `(.warnings)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:78` | `CheckReportSummary` | data | yes | `summaryDeniedWarnings` | `deniedWarnings` | `!Int` | `(.deniedWarnings)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:83` | `CheckReportMember` | data | yes | `memberPath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:84` | `CheckReportMember` | data | yes | `memberSourceForm` | `sourceForm` | `!Text` | `(.sourceForm)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:85` | `CheckReportMember` | data | yes | `memberDeclaredLanguageVersion` | `declaredLanguageVersion` | `!(Maybe LanguageVersion)` | `(.declaredLanguageVersion)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:93` | `CheckReport` | data | no | `reportKind` | `kind` | `!CheckReportKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:94` | `CheckReport` | data | no | `reportSubject` | `subject` | `!FilePath` | `(.subject)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:98` | `CheckReport` | data | no | `reportLanguage` | `language` | `!(Maybe CheckReportLanguage)` | `(.language)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:99` | `CheckReport` | data | no | `reportEnforcement` | `enforcement` | `!CheckReportEnforcement` | `(.enforcement)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:100` | `CheckReport` | data | no | `reportDiagnostics` | `diagnostics` | `![CheckReportEntry]` | `(.diagnostics)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:101` | `CheckReport` | data | no | `reportSummary` | `summary` | `!CheckReportSummary` | `(.summary)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:102` | `CheckReport` | data | no | `reportOk` | `ok` | `!Bool` | `(.ok)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CheckReport.hs:103` | `CheckReport` | data | no | `reportMembers` | `members` | `![CheckReportMember]` | `(.members)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:70` | `JsonPointer` | newtype | yes | `unJsonPointer` | `unJsonPointer` | `Text` | explicit `unJsonPointer` positional function | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:85` | `HistoricalCodec` | data | yes | `hcIdentity` | `identity` | `!Text` | `(.identity)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:86` | `HistoricalCodec` | data | yes | `hcVersion` | `version` | `!Text` | `(.version)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:87` | `HistoricalCodec` | data | yes | `hcEncode` | `encode` | `!(a -> Value)` | `(.encode)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:88` | `HistoricalCodec` | data | yes | `hcDecode` | `decode` | `!(Value -> Either Text a)` | `(.decode)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:93` | `CompareObservation` | data | yes | `coCaseName` | `caseName` | `!Text` | `(.caseName)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:94` | `CompareObservation` | data | yes | `coHistoricalValue` | `historicalValue` | `!Value` | `(.historicalValue)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:95` | `CompareObservation` | data | yes | `coGeneratedValue` | `generatedValue` | `!Value` | `(.generatedValue)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:98` | `CompareObservation` | data | yes | `coFixturePath` | `fixturePath` | `!FilePath` | `(.fixturePath)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:99` | `CompareObservation` | data | yes | `coInputValue` | `inputValue` | `!Value` | `(.inputValue)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:100` | `CompareObservation` | data | yes | `coHistoricalDecode` | `historicalDecode` | `!DecodeOutcome` | `(.historicalDecode)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:101` | `CompareObservation` | data | yes | `coGeneratedDecode` | `generatedDecode` | `!DecodeOutcome` | `(.generatedDecode)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:124` | `DeclaredBranch` | data | yes | `dbOrigin` | `origin` | `!FixtureOrigin` | `(.origin)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:125` | `DeclaredBranch` | data | yes | `dbPointer` | `pointer` | `!JsonPointer` | `(.pointer)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:126` | `DeclaredBranch` | data | yes | `dbKind` | `kind` | `!BranchKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:131` | `ObservedBranch` | data | yes | `obOrigin` | `origin` | `!FixtureOrigin` | `(.origin)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:132` | `ObservedBranch` | data | yes | `obPointer` | `pointer` | `!JsonPointer` | `(.pointer)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:133` | `ObservedBranch` | data | yes | `obKind` | `kind` | `!BranchKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:138` | `CoverageGap` | data | yes | `cgOrigin` | `origin` | `!FixtureOrigin` | `(.origin)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:139` | `CoverageGap` | data | yes | `cgPointer` | `pointer` | `!JsonPointer` | `(.pointer)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:140` | `CoverageGap` | data | yes | `cgKind` | `kind` | `!BranchKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:157` | `BranchField` | data | yes | `bfWireKey` | `wireKey` | `!Text` | `(.wireKey)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:158` | `BranchField` | data | yes | `bfPresenceOptional` | `presenceOptional` | `!Bool` | `(.presenceOptional)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:159` | `BranchField` | data | yes | `bfSchema` | `schema` | `!BranchSchema` | `(.schema)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:164` | `BranchArm` | data | yes | `baWireTag` | `wireTag` | `!Text` | `(.wireTag)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:165` | `BranchArm` | data | yes | `baPayloadSchema` | `payloadSchema` | `!(Maybe BranchSchema)` | `(.payloadSchema)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:170` | `CompareProvenance` | data | yes | `cpHistoricalCodecIdentity` | `historicalCodecIdentity` | `!Text` | `(.historicalCodecIdentity)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:171` | `CompareProvenance` | data | yes | `cpHistoricalCodecVersion` | `historicalCodecVersion` | `!Text` | `(.historicalCodecVersion)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:172` | `CompareProvenance` | data | yes | `cpCanonicalType` | `canonicalType` | `!CanonicalTypeId` | `(.canonicalType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:173` | `CompareProvenance` | data | yes | `cpBindingSymbol` | `bindingSymbol` | `!QualifiedValueName` | `(.bindingSymbol)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:174` | `CompareProvenance` | data | yes | `cpBindingVersion` | `bindingVersion` | `!BindingVersion` | `(.bindingVersion)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:175` | `CompareProvenance` | data | yes | `cpWireFingerprint` | `wireFingerprint` | `!Text` | `(.wireFingerprint)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:180` | `ClassifiedObservation` | data | yes | `classifiedOrigin` | `origin` | `!FixtureOrigin` | `(.origin)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:181` | `ClassifiedObservation` | data | yes | `classifiedName` | `name` | `!Text` | `(.name)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:182` | `ClassifiedObservation` | data | yes | `classifiedVerdict` | `verdict` | `!FixtureVerdict` | `(.verdict)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:187` | `CompareReport` | data | yes | `crProvenance` | `provenance` | `!CompareProvenance` | `(.provenance)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:188` | `CompareReport` | data | yes | `crObservations` | `observations` | `![ClassifiedObservation]` | `(.observations)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:189` | `CompareReport` | data | yes | `crInputIssues` | `inputIssues` | `![CompareInputIssue]` | `(.inputIssues)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:190` | `CompareReport` | data | yes | `crCoverageGaps` | `coverageGaps` | `![CoverageGap]` | `(.coverageGaps)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:191` | `CompareReport` | data | yes | `crAuthority` | `authority` | `!Text` | `(.authority)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:196` | `ReportWriteError` | data | yes | `reportWritePath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/CodecCompare.hs:197` | `ReportWriteError` | data | yes | `reportWriteMessage` | `message` | `!Text` | `(.message)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:58` | `ConformanceFile` | data | yes | `conformanceFilePath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:59` | `ConformanceFile` | data | yes | `conformanceFileText` | `text` | `!Text` | `(.text)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:60` | `ConformanceFile` | data | yes | `conformanceFileKind` | `kind` | `!ModuleKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:65` | `ConformancePackagePlan` | data | yes | `cppServiceKey` | `serviceKey` | `!ConformanceServiceKey` | `(.serviceKey)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:66` | `ConformancePackagePlan` | data | yes | `cppDirectory` | `directory` | `!FilePath` | `(.directory)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:67` | `ConformancePackagePlan` | data | yes | `cppPackageName` | `packageName` | `!Text` | `(.packageName)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:68` | `ConformancePackagePlan` | data | yes | `cppRuntimePackage` | `runtimePackage` | `!RuntimePackageName` | `(.runtimePackage)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:69` | `ConformancePackagePlan` | data | yes | `cppFacadeModule` | `facadeModule` | `!Text` | `(.facadeModule)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:70` | `ConformancePackagePlan` | data | yes | `cppFiles` | `files` | `![ConformanceFile]` | `(.files)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:78` | `DuplicateFactKey` | data | yes | `duplicateFactSide` | `side` | `!ConformanceFactSide` | `(.side)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:79` | `DuplicateFactKey` | data | yes | `duplicateFactKey` | `key` | `!String` | `(.key)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:101` | `ConformancePackageRecord` | data | yes | `cprSchema` | `schema` | `!Int` | `(.schema)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:102` | `ConformancePackageRecord` | data | yes | `cprServiceKey` | `serviceKey` | `!ConformanceServiceKey` | `(.serviceKey)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:103` | `ConformancePackageRecord` | data | yes | `cprRuntimePackage` | `runtimePackage` | `!RuntimePackageName` | `(.runtimePackage)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:104` | `ConformancePackageRecord` | data | yes | `cprFacadeModule` | `facadeModule` | `!Text` | `(.facadeModule)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:105` | `ConformancePackageRecord` | data | yes | `cprFiles` | `files` | `![(ModuleKind, FilePath)]` | `(.files)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:113` | `ConformanceStaleFile` | data | yes | `conformanceStaleKind` | `kind` | `!ModuleKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:114` | `ConformanceStaleFile` | data | yes | `conformanceStalePath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:115` | `ConformanceStaleFile` | data | yes | `conformanceStaleBannerPresent` | `bannerPresent` | `!(Maybe Bool)` | `(.bannerPresent)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:120` | `PreparedConformancePackage` | data | no | `preparedRoot` | `root` | `!FilePath` | `(.root)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:121` | `PreparedConformancePackage` | data | no | `preparedPlan` | `plan` | `!ConformancePackagePlan` | `(.plan)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:122` | `PreparedConformancePackage` | data | no | `preparedStale` | `stale` | `![ConformanceStaleFile]` | `(.stale)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:127` | `ConformancePackageReport` | data | yes | `conformanceReportRoot` | `root` | `!FilePath` | `(.root)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:128` | `ConformancePackageReport` | data | yes | `conformanceReportPlan` | `plan` | `!ConformancePackagePlan` | `(.plan)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:129` | `ConformancePackageReport` | data | yes | `conformanceReportDispositions` | `dispositions` | `![(ConformanceFile, ConformanceWriteDisposition)]` | `(.dispositions)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:130` | `ConformancePackageReport` | data | yes | `conformanceReportStale` | `stale` | `![ConformanceStaleFile]` | `(.stale)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:388` | `ConformanceFileRow` | data | no | `conformanceRowKind` | `kind` | `!ModuleKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/ConformancePackage.hs:389` | `ConformanceFileRow` | data | no | `conformanceRowPath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/ConsumerTypePlan.hs:27` | `HaskellTypeOccurrence` | newtype | yes | `unHaskellTypeOccurrence` | `unHaskellTypeOccurrence` | `Text` | explicit `unHaskellTypeOccurrence` positional function | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConsumerTypePlan.hs:38` | `ImportRequirement` | data | yes | `package` | `package` | `!Text` | `(.package)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConsumerTypePlan.hs:39` | `ImportRequirement` | data | yes | `moduleName` | `moduleName` | `!Text` | `(.moduleName)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConsumerTypePlan.hs:40` | `ImportRequirement` | data | yes | `occurrence` | `occurrence` | `!Text` | `(.occurrence)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConsumerTypePlan.hs:45` | `ConsumerTypePlan` | data | yes | `haskellType` | `haskellType` | `!HaskellTypeOccurrence` | `(.haskellType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConsumerTypePlan.hs:46` | `ConsumerTypePlan` | data | yes | `imports` | `imports` | `![ImportRequirement]` | `(.imports)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConsumerTypePlan.hs:47` | `ConsumerTypePlan` | data | yes | `dependencies` | `dependencies` | `!(Set MappedKey)` | `(.dependencies)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ConsumerTypePlan.hs:126` | `RenderedType` | data | no | `rendered` | `rendered` | `!Text` | `(.rendered)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/ConsumerTypePlan.hs:127` | `RenderedType` | data | no | `precedence` | `precedence` | `!TypePrecedence` | `(.precedence)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/ConsumerTypePlan.hs:128` | `RenderedType` | data | no | `requirements` | `requirements` | `!(Set ImportRequirement)` | `(.requirements)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/ConsumerTypePlan.hs:129` | `RenderedType` | data | no | `mappedDependencies` | `mappedDependencies` | `!(Set MappedKey)` | `(.mappedDependencies)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:60` | `RouterSelectionSnapshot` | data | yes | `selectionRouter` | `router` | `!Name` | `(.router)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:61` | `RouterSelectionSnapshot` | data | yes | `selectionVerification` | `verification` | `!SelectionVerification` | `(.verification)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:62` | `RouterSelectionSnapshot` | data | yes | `selectionIdentity` | `identity` | `!(Maybe Text)` | `(.identity)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:63` | `RouterSelectionSnapshot` | data | yes | `selectionVersion` | `version` | `!(Maybe Natural)` | `(.version)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:64` | `RouterSelectionSnapshot` | data | yes | `selectionFingerprint` | `fingerprint` | `!(Maybe Text)` | `(.fingerprint)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:69` | `CoordinationImpact` | data | yes | `coordinationRouter` | `router` | `!Name` | `(.router)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:70` | `CoordinationImpact` | data | yes | `coordinationSeverity` | `severity` | `!CoordinationSeverity` | `(.severity)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:71` | `CoordinationImpact` | data | yes | `coordinationReason` | `reason` | `!CoordinationReason` | `(.reason)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:72` | `CoordinationImpact` | data | yes | `previousVerification` | `previousVerification` | `!SelectionVerification` | `(.previousVerification)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:73` | `CoordinationImpact` | data | yes | `currentVerification` | `currentVerification` | `!SelectionVerification` | `(.currentVerification)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:74` | `CoordinationImpact` | data | yes | `previousIdentity` | `previousIdentity` | `!(Maybe Text)` | `(.previousIdentity)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:75` | `CoordinationImpact` | data | yes | `currentIdentity` | `currentIdentity` | `!(Maybe Text)` | `(.currentIdentity)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:76` | `CoordinationImpact` | data | yes | `previousVersion` | `previousVersion` | `!(Maybe Natural)` | `(.previousVersion)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:77` | `CoordinationImpact` | data | yes | `currentVersion` | `currentVersion` | `!(Maybe Natural)` | `(.currentVersion)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:78` | `CoordinationImpact` | data | yes | `previousFingerprint` | `previousFingerprint` | `!(Maybe Text)` | `(.previousFingerprint)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:79` | `CoordinationImpact` | data | yes | `currentFingerprint` | `currentFingerprint` | `!(Maybe Text)` | `(.currentFingerprint)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:80` | `CoordinationImpact` | data | yes | `affectedUseSites` | `affectedUseSites` | `![UseSite]` | `(.affectedUseSites)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:85` | `RouterSelectionDrift` | data | yes | `driftRouter` | `router` | `!Name` | `(.router)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:86` | `RouterSelectionDrift` | data | yes | `driftPreviousSelection` | `previousSelection` | `!(Maybe RouterSelectionSnapshot)` | `(.previousSelection)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:87` | `RouterSelectionDrift` | data | yes | `driftCurrentSelection` | `currentSelection` | `!(Maybe RouterSelectionSnapshot)` | `(.currentSelection)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:204` | `RouterSelectionState` | data | no | `stateSnapshot` | `snapshot` | `!RouterSelectionSnapshot` | `(.snapshot)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/CoordinationImpact.hs:205` | `RouterSelectionState` | data | no | `stateUseSites` | `useSites` | `![UseSite]` | `(.useSites)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:66` | `CoverageRoot` | data | yes | `rootSurface` | `surface` | `!CoverageSurface` | `(.surface)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:67` | `CoverageRoot` | data | yes | `rootConsumer` | `consumer` | `!Text` | `(.consumer)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:68` | `CoverageRoot` | data | yes | `rootPath` | `path` | `!Text` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:69` | `CoverageRoot` | data | yes | `rootMappedType` | `mappedType` | `!Text` | `(.mappedType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:70` | `CoverageRoot` | data | yes | `rootMode` | `mode` | `!CoverageMode` | `(.mode)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:71` | `CoverageRoot` | data | yes | `rootCanonicalType` | `canonicalType` | `!(Maybe Text)` | `(.canonicalType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:72` | `CoverageRoot` | data | yes | `rootCodecIdentity` | `codecIdentity` | `!(Maybe Text)` | `(.codecIdentity)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:73` | `CoverageRoot` | data | yes | `rootCodecVersion` | `codecVersion` | `!(Maybe Text)` | `(.codecVersion)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:74` | `CoverageRoot` | data | yes | `rootWireFingerprint` | `wireFingerprint` | `!Text` | `(.wireFingerprint)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:79` | `StructuralBoundary` | data | yes | `structuralRoot` | `root` | `!Text` | `(.root)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:80` | `StructuralBoundary` | data | yes | `structuralPath` | `path` | `!Text` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:81` | `StructuralBoundary` | data | yes | `structuralMappedType` | `mappedType` | `!Text` | `(.mappedType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:82` | `StructuralBoundary` | data | yes | `structuralCanonicalType` | `canonicalType` | `!Text` | `(.canonicalType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:83` | `StructuralBoundary` | data | yes | `structuralWireFingerprint` | `wireFingerprint` | `!Text` | `(.wireFingerprint)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:88` | `OpaqueBoundary` | data | yes | `opaqueRoot` | `root` | `!Text` | `(.root)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:89` | `OpaqueBoundary` | data | yes | `opaquePath` | `path` | `!Text` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:90` | `OpaqueBoundary` | data | yes | `opaqueMappedType` | `mappedType` | `!Text` | `(.mappedType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:91` | `OpaqueBoundary` | data | yes | `opaqueCodecIdentity` | `codecIdentity` | `!Text` | `(.codecIdentity)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:92` | `OpaqueBoundary` | data | yes | `opaqueCodecVersion` | `codecVersion` | `!Text` | `(.codecVersion)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:97` | `JsonBoundary` | data | yes | `jsonSurface` | `surface` | `!CoverageSurface` | `(.surface)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:98` | `JsonBoundary` | data | yes | `jsonRoot` | `root` | `!Text` | `(.root)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:99` | `JsonBoundary` | data | yes | `jsonPath` | `path` | `!Text` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:104` | `SnapshotBoundary` | data | yes | `snapshotRoot` | `root` | `!Text` | `(.root)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:105` | `SnapshotBoundary` | data | yes | `snapshotAggregate` | `aggregate` | `!Text` | `(.aggregate)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:106` | `SnapshotBoundary` | data | yes | `snapshotRegister` | `register` | `!Text` | `(.register)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:107` | `SnapshotBoundary` | data | yes | `snapshotMappedType` | `mappedType` | `!Text` | `(.mappedType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:108` | `SnapshotBoundary` | data | yes | `snapshotMode` | `mode` | `!CoverageMode` | `(.mode)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:109` | `SnapshotBoundary` | data | yes | `snapshotEncoding` | `encoding` | `!Text` | `(.encoding)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:110` | `SnapshotBoundary` | data | yes | `snapshotInvalidation` | `invalidation` | `!Text` | `(.invalidation)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:111` | `SnapshotBoundary` | data | yes | `snapshotWireFingerprint` | `wireFingerprint` | `!Text` | `(.wireFingerprint)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:112` | `SnapshotBoundary` | data | yes | `snapshotEnabled` | `enabled` | `!Bool` | `(.enabled)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:117` | `UnsupportedSurface` | data | yes | `unsupportedSurface` | `surface` | `!Text` | `(.surface)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:118` | `UnsupportedSurface` | data | yes | `unsupportedSupport` | `support` | `!Text` | `(.support)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:119` | `UnsupportedSurface` | data | yes | `unsupportedReason` | `reason` | `!Text` | `(.reason)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:124` | `CoverageCounts` | data | yes | `totalRoots` | `totalRoots` | `!Int` | `(.totalRoots)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:125` | `CoverageCounts` | data | yes | `structuralRoots` | `structuralRoots` | `!Int` | `(.structuralRoots)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:126` | `CoverageCounts` | data | yes | `opaqueRoots` | `opaqueRoots` | `!Int` | `(.opaqueRoots)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:127` | `CoverageCounts` | data | yes | `jsonBoundaries` | `jsonBoundaries` | `!Int` | `(.jsonBoundaries)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:132` | `CoverageSummary` | data | yes | `aggregateCommandPayloads` | `aggregateCommandPayloads` | `!CoverageCounts` | `(.aggregateCommandPayloads)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:133` | `CoverageSummary` | data | yes | `privateEventPayloads` | `privateEventPayloads` | `!CoverageCounts` | `(.privateEventPayloads)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:134` | `CoverageSummary` | data | yes | `snapshotRegisters` | `snapshotRegisters` | `!CoverageCounts` | `(.snapshotRegisters)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:135` | `CoverageSummary` | data | yes | `workqueuePayloads` | `workqueuePayloads` | `!CoverageCounts` | `(.workqueuePayloads)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:136` | `CoverageSummary` | data | yes | `readModelQueryInputs` | `readModelQueryInputs` | `!CoverageCounts` | `(.readModelQueryInputs)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:137` | `CoverageSummary` | data | yes | `readModelQueryResults` | `readModelQueryResults` | `!CoverageCounts` | `(.readModelQueryResults)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:138` | `CoverageSummary` | data | yes | `projectionTypedConsumers` | `projectionTypedConsumers` | `!CoverageCounts` | `(.projectionTypedConsumers)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:143` | `CoverageFinding` | data | yes | `findingSeverity` | `severity` | `!Severity` | `(.severity)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:144` | `CoverageFinding` | data | yes | `findingCode` | `code` | `!DiagnosticCode` | `(.code)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:145` | `CoverageFinding` | data | yes | `findingRoots` | `roots` | `![Text]` | `(.roots)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:146` | `CoverageFinding` | data | yes | `findingMessage` | `message` | `!Text` | `(.message)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:151` | `CoveragePrevious` | data | yes | `previousReference` | `reference` | `!Text` | `(.reference)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:152` | `CoveragePrevious` | data | yes | `previousSummary` | `summary` | `!CoverageSummary` | `(.summary)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:153` | `CoveragePrevious` | data | yes | `previousOpaqueBoundaries` | `opaqueBoundaries` | `![OpaqueBoundary]` | `(.opaqueBoundaries)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:158` | `CoverageDelta` | data | yes | `aggregateCommandRootDelta` | `aggregateCommandRootDelta` | `!Int` | `(.aggregateCommandRootDelta)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:159` | `CoverageDelta` | data | yes | `privateEventRootDelta` | `privateEventRootDelta` | `!Int` | `(.privateEventRootDelta)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:160` | `CoverageDelta` | data | yes | `snapshotRegisterRootDelta` | `snapshotRegisterRootDelta` | `!Int` | `(.snapshotRegisterRootDelta)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:161` | `CoverageDelta` | data | yes | `workqueuePayloadRootDelta` | `workqueuePayloadRootDelta` | `!Int` | `(.workqueuePayloadRootDelta)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:162` | `CoverageDelta` | data | yes | `readModelQueryInputRootDelta` | `readModelQueryInputRootDelta` | `!Int` | `(.readModelQueryInputRootDelta)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:163` | `CoverageDelta` | data | yes | `readModelQueryResultRootDelta` | `readModelQueryResultRootDelta` | `!Int` | `(.readModelQueryResultRootDelta)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:164` | `CoverageDelta` | data | yes | `projectionTypedConsumerRootDelta` | `projectionTypedConsumerRootDelta` | `!Int` | `(.projectionTypedConsumerRootDelta)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:165` | `CoverageDelta` | data | yes | `opaqueBoundaryDelta` | `opaqueBoundaryDelta` | `!Int` | `(.opaqueBoundaryDelta)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:166` | `CoverageDelta` | data | yes | `addedOpaqueBoundaries` | `addedOpaqueBoundaries` | `![OpaqueBoundary]` | `(.addedOpaqueBoundaries)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:167` | `CoverageDelta` | data | yes | `removedOpaqueBoundaries` | `removedOpaqueBoundaries` | `![OpaqueBoundary]` | `(.removedOpaqueBoundaries)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:172` | `CoverageReport` | data | yes | `coverageSpec` | `spec` | `!FilePath` | `(.spec)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:173` | `CoverageReport` | data | yes | `coverageRoots` | `roots` | `![CoverageRoot]` | `(.roots)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:174` | `CoverageReport` | data | yes | `coverageStructuralBoundaries` | `structuralBoundaries` | `![StructuralBoundary]` | `(.structuralBoundaries)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:175` | `CoverageReport` | data | yes | `coverageOpaqueBoundaries` | `opaqueBoundaries` | `![OpaqueBoundary]` | `(.opaqueBoundaries)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:176` | `CoverageReport` | data | yes | `coverageJsonBoundaries` | `jsonBoundaries` | `![JsonBoundary]` | `(.jsonBoundaries)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:177` | `CoverageReport` | data | yes | `coverageSnapshotBoundaries` | `snapshotBoundaries` | `![SnapshotBoundary]` | `(.snapshotBoundaries)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:178` | `CoverageReport` | data | yes | `coverageUnsupportedSurfaces` | `unsupportedSurfaces` | `![UnsupportedSurface]` | `(.unsupportedSurfaces)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:179` | `CoverageReport` | data | yes | `coverageSummary` | `summary` | `!CoverageSummary` | `(.summary)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:180` | `CoverageReport` | data | yes | `coverageFindings` | `findings` | `![CoverageFinding]` | `(.findings)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:181` | `CoverageReport` | data | yes | `coveragePrevious` | `previous` | `!(Maybe CoveragePrevious)` | `(.previous)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Coverage.hs:182` | `CoverageReport` | data | yes | `coverageDelta` | `delta` | `!(Maybe CoverageDelta)` | `(.delta)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:134` | `CompatibilityVector` | data | yes | `cvPrivateHistoryRead` | `privateHistoryRead` | `!SurfaceVerdict` | `(.privateHistoryRead)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:135` | `CompatibilityVector` | data | yes | `cvOldBinaryReadNewEvents` | `oldBinaryReadNewEvents` | `!SurfaceVerdict` | `(.oldBinaryReadNewEvents)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:136` | `CompatibilityVector` | data | yes | `cvSnapshotHydration` | `snapshotHydration` | `!SurfaceVerdict` | `(.snapshotHydration)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:137` | `CompatibilityVector` | data | yes | `cvPublicConsumer` | `publicConsumer` | `!SurfaceVerdict` | `(.publicConsumer)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:138` | `CompatibilityVector` | data | yes | `cvPersistedIdentity` | `persistedIdentity` | `!SurfaceVerdict` | `(.persistedIdentity)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:139` | `CompatibilityVector` | data | yes | `cvConsumerBuild` | `consumerBuild` | `!SurfaceVerdict` | `(.consumerBuild)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:140` | `CompatibilityVector` | data | yes | `cvRollout` | `rollout` | `!(Set RolloutConstraint)` | `(.rollout)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:153` | `MappedPersistedImpact` | data | yes | `mappedPersistedSurface` | `surface` | `!MappedPersistedSurface` | `(.surface)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:154` | `MappedPersistedImpact` | data | yes | `mappedPersistedVerdict` | `verdict` | `!SurfaceVerdict` | `(.verdict)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:172` | `ChangeContext` | data | no | `changeContextRoot` | `root` | `!Name` | `(.root)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:173` | `ChangeContext` | data | no | `changeContextPaths` | `paths` | `![Text]` | `(.paths)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:174` | `ChangeContext` | data | no | `contextKind` | `contextKind` | `!ContextKind` | `(.contextKind)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:175` | `ChangeContext` | data | no | `contextOriginalLabel` | `contextOriginalLabel` | `!Label` | `(.contextOriginalLabel)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:186` | `ChangeKind` | data | yes | `ckNode` | `node` | `!Name` | `(.node)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:187` | `ChangeKind` | data | yes | `ckFacet` | `facet` | `!Text` | `(.facet)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:188` | `ChangeKind` | data | yes | `ckSubject` | `subject` | `!Text` | `(.subject)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:189` | `ChangeKind` | data | yes | `ckCode` | `code` | `!DiagnosticCode` | `(.code)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:190` | `ChangeKind` | data | yes | `ckContext` | `context` | `!ChangeContext` | `(.context)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:191` | `ChangeKind` | data | yes | `ckVector` | `vector` | `!CompatibilityVector` | `(.vector)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:192` | `ChangeKind` | data | yes | `ckMappedPersistedImpact` | `mappedPersistedImpact` | `!(Maybe MappedPersistedImpact)` | `(.mappedPersistedImpact)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:193` | `ChangeKind` | data | yes | `ckMappedConsequences` | `mappedConsequences` | `!(Set MappedConsequence)` | `(.mappedConsequences)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:194` | `ChangeKind` | data | yes | `ckPaths` | `paths` | `![Text]` | `(.paths)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:195` | `ChangeKind` | data | yes | `ckDetail` | `detail` | `!Text` | `(.detail)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:669` | `DiffEnv` | data | yes | `deOld` | `old` | `!Spec` | `(.old)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:670` | `DiffEnv` | data | yes | `deNew` | `new` | `!Spec` | `(.new)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:722` | `Paired` | data | yes | `prMatched` | `matched` | `![(n, n)]` | `(.matched)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:723` | `Paired` | data | yes | `prAdded` | `added` | `![n]` | `(.added)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:724` | `Paired` | data | yes | `prRemoved` | `removed` | `![n]` | `(.removed)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:1884` | `EventFieldSig` | data | no | `eventFieldDslName` | `dslName` | `!Name` | `(.dslName)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:1885` | `EventFieldSig` | data | no | `eventFieldSelector` | `selector` | `!Name` | `(.selector)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:1886` | `EventFieldSig` | data | no | `eventFieldWireKey` | `wireKey` | `!Text` | `(.wireKey)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Diff.hs:1887` | `EventFieldSig` | data | no | `eventFieldType` | `valueType` | `!(Maybe TypeExpr)` | `(.valueType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:74` | `DiffReport` | data | no | `reportGate` | `gate` | `!(Set CompatibilitySurface)` | `(.gate)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:75` | `DiffReport` | data | no | `reportFindings` | `findings` | `![Change]` | `(.findings)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:76` | `DiffReport` | data | no | `reportSemanticImpact` | `semanticImpact` | `!(Maybe [MappedImpactDelta])` | `(.semanticImpact)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:77` | `DiffReport` | data | no | `reportCoordinationImpact` | `coordinationImpact` | `!(Maybe [CoordinationImpact])` | `(.coordinationImpact)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:97` | `OwnedSite` | data | yes | `osFile` | `file` | `!FilePath` | `(.file)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:98` | `OwnedSite` | data | yes | `osLine` | `line` | `!Int` | `(.line)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:104` | `WorkspaceChange` | data | yes | `wcChange` | `change` | `!Change` | `(.change)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:105` | `WorkspaceChange` | data | yes | `wcDeclarationSite` | `declarationSite` | `!(Maybe OwnedSite)` | `(.declarationSite)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:106` | `WorkspaceChange` | data | yes | `wcUseSites` | `useSites` | `![(Text, Maybe OwnedSite)]` | `(.useSites)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:112` | `WorkspaceMeta` | data | yes | `wmIdentity` | `identity` | `!Text` | `(.identity)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:113` | `WorkspaceMeta` | data | yes | `wmManifest` | `manifest` | `!FilePath` | `(.manifest)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:114` | `WorkspaceMeta` | data | yes | `wmSince` | `since` | `!Text` | `(.since)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:115` | `WorkspaceMeta` | data | yes | `wmMembersOld` | `membersOld` | `![FilePath]` | `(.membersOld)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:116` | `WorkspaceMeta` | data | yes | `wmMembersNew` | `membersNew` | `![FilePath]` | `(.membersNew)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:117` | `WorkspaceMeta` | data | yes | `wmAdoptionBaseline` | `adoptionBaseline` | `!Bool` | `(.adoptionBaseline)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:122` | `WorkspaceDiffReport` | data | no | `workspaceReportMeta` | `meta` | `!WorkspaceMeta` | `(.meta)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:123` | `WorkspaceDiffReport` | data | no | `workspaceReportGate` | `gate` | `!(Set CompatibilitySurface)` | `(.gate)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:124` | `WorkspaceDiffReport` | data | no | `workspaceReportFindings` | `findings` | `![WorkspaceChange]` | `(.findings)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:125` | `WorkspaceDiffReport` | data | no | `workspaceReportSemanticImpact` | `semanticImpact` | `!(Maybe [MappedImpactDelta])` | `(.semanticImpact)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/DiffReport.hs:126` | `WorkspaceDiffReport` | data | no | `workspaceReportCoordinationImpact` | `coordinationImpact` | `!(Maybe [CoordinationImpact])` | `(.coordinationImpact)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/EventOutput.hs:36` | `CheckedFieldCopy` | data | yes | `outputSelector` | `outputSelector` | `!Name` | `(.outputSelector)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/EventOutput.hs:37` | `CheckedFieldCopy` | data | yes | `outputWireName` | `outputWireName` | `!Text` | `(.outputWireName)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/EventOutput.hs:38` | `CheckedFieldCopy` | data | yes | `outputFieldType` | `outputFieldType` | `!ResolvedAggregateType` | `(.outputFieldType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/EventOutput.hs:43` | `OutputObligationKey` | newtype | yes | `unOutputObligationKey` | `unOutputObligationKey` | `Text` | explicit `unOutputObligationKey` positional function | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/EventOutput.hs:52` | `EventOutputMapping` | data | yes | `outputSourceCommand` | `sourceCommand` | `!Name` | `(.sourceCommand)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/EventOutput.hs:53` | `EventOutputMapping` | data | yes | `outputFields` | `fields` | `![CheckedFieldCopy]` | `(.fields)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/EventOutput.hs:56` | `EventOutputMapping` | data | yes | `outputObligation` | `obligation` | `!OutputObligationKey` | `(.obligation)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/EventOutput.hs:64` | `EventOutputError` | data | yes | `declaredSourceCommand` | `declaredSourceCommand` | `!Name` | `(.declaredSourceCommand)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/EventOutput.hs:65` | `EventOutputError` | data | yes | `consumingTransitionCommand` | `consumingTransitionCommand` | `!Name` | `(.consumingTransitionCommand)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/EventOutput.hs:66` | `EventOutputError` | data | yes | `emittedEventName` | `emittedEventName` | `!Name` | `(.emittedEventName)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:45` | `BindingObligation` | data | yes | `obligationMappedName` | `mappedName` | `!Name` | `(.mappedName)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:46` | `BindingObligation` | data | yes | `obligationPackage` | `package` | `!Text` | `(.package)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:47` | `BindingObligation` | data | yes | `obligationModule` | `moduleName` | `!Text` | `(.moduleName)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:48` | `BindingObligation` | data | yes | `obligationSymbol` | `symbol` | `!Text` | `(.symbol)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:49` | `BindingObligation` | data | yes | `obligationKind` | `kind` | `!BindingObligationKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:50` | `BindingObligation` | data | yes | `obligationSignature` | `signature` | `!Text` | `(.signature)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:51` | `BindingObligation` | data | yes | `obligationUseSites` | `useSites` | `![Text]` | `(.useSites)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:52` | `BindingObligation` | data | yes | `obligationBindingVersion` | `bindingVersion` | `!(Maybe Text)` | `(.bindingVersion)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:53` | `BindingObligation` | data | yes | `obligationCanonicalType` | `canonicalType` | `!(Maybe Text)` | `(.canonicalType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:54` | `BindingObligation` | data | yes | `obligationEqualityContract` | `equalityContract` | `!(Maybe Text)` | `(.equalityContract)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:55` | `BindingObligation` | data | yes | `obligationIdDomainContract` | `idDomainContract` | `!(Maybe Text)` | `(.idDomainContract)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:56` | `BindingObligation` | data | yes | `obligationCategory` | `category` | `!Text` | `(.category)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:61` | `BindingHole` | data | yes | `holeMappedName` | `mappedName` | `!Name` | `(.mappedName)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:62` | `BindingHole` | data | yes | `holeModule` | `moduleName` | `!Text` | `(.moduleName)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:63` | `BindingHole` | data | yes | `holeSymbol` | `symbol` | `!Text` | `(.symbol)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:64` | `BindingHole` | data | yes | `holeKind` | `kind` | `!BindingObligationKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:65` | `BindingHole` | data | yes | `holePath` | `path` | `!(Maybe Text)` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ExplainBindings.hs:66` | `BindingHole` | data | yes | `holeSignature` | `signature` | `!Text` | `(.signature)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Expression.hs:45` | `ExpressionEnvironment` | data | no | `environmentSpec` | `spec` | `!Spec` | `(.spec)`, pattern, or construction | Haskell API and runtime semantics | `none` |+| `keiro-dsl/src/Keiro/Dsl/Expression.hs:46` | `ExpressionEnvironment` | data | no | `environmentAggregate` | `aggregate` | `!Aggregate` | `(.aggregate)`, pattern, or construction | Haskell API and runtime semantics | `none` |+| `keiro-dsl/src/Keiro/Dsl/Expression.hs:47` | `ExpressionEnvironment` | data | no | `environmentTransition` | `transition` | `!Transition` | `(.transition)`, pattern, or construction | Haskell API and runtime semantics | `none` |+| `keiro-dsl/src/Keiro/Dsl/Expression.hs:48` | `ExpressionEnvironment` | data | no | `environmentSymbols` | `symbols` | `!AggregateSymbols` | `(.symbols)`, pattern, or construction | Haskell API and runtime semantics | `none` |+| `keiro-dsl/src/Keiro/Dsl/Expression.hs:49` | `ExpressionEnvironment` | data | no | `environmentTypeGraph` | `typeGraph` | `!(Maybe TypeGraph)` | `(.typeGraph)`, pattern, or construction | Haskell API and runtime semantics | `none` |+| `keiro-dsl/src/Keiro/Dsl/Expression.hs:88` | `ResolvedScalarProjection` | data | yes | `scalarProjectionOwner` | `owner` | `!MappedKey` | `(.owner)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Expression.hs:89` | `ResolvedScalarProjection` | data | yes | `scalarProjectionPointer` | `pointer` | `!Text` | `(.pointer)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Expression.hs:90` | `ResolvedScalarProjection` | data | yes | `scalarProjectionFields` | `fields` | `![Name]` | `(.fields)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Expression.hs:125` | `TypedScalarExpr` | data | yes | `typedScalarType` | `valueType` | `!ResolvedAggregateType` | `(.valueType)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Expression.hs:126` | `TypedScalarExpr` | data | yes | `typedScalarLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Expression.hs:127` | `TypedScalarExpr` | data | yes | `typedScalarNode` | `node` | `!TypedScalarNode` | `(.node)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Expression.hs:147` | `ExpressionDiagnostic` | data | yes | `expressionDiagnosticLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Expression.hs:148` | `ExpressionDiagnostic` | data | yes | `expressionDiagnosticCode` | `code` | `!ExpressionDiagnosticCode` | `(.code)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Expression.hs:149` | `ExpressionDiagnostic` | data | yes | `expressionDiagnosticMessage` | `message` | `!Text` | `(.message)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/FieldIdentity.hs:18` | `ResolvedFieldIdentity` | data | no | `fieldDslName` | `dslName` | `!Name` | `(.dslName)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/FieldIdentity.hs:19` | `ResolvedFieldIdentity` | data | no | `fieldSelector` | `selector` | `!Text` | `(.selector)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/FieldIdentity.hs:20` | `ResolvedFieldIdentity` | data | no | `fieldWireKey` | `wireKey` | `!Text` | `(.wireKey)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/FieldIdentity.hs:21` | `ResolvedFieldIdentity` | data | no | `fieldLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Frontend/Internal.hs:55` | `FrontendContext` | data | no | `source` | `source` | `!FilePath` | `(.source)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Frontend/Internal.hs:56` | `FrontendContext` | data | no | `language` | `language` | `!SourceLanguage` | `(.language)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Frontend/Internal.hs:57` | `FrontendContext` | data | no | `definition` | `definition` | `!LanguageDefinition` | `(.definition)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Frontend/Internal.hs:91` | `FrontendFailure` | data | no | `phase` | `phase` | `!FrontendPhase` | `(.phase)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Frontend/Internal.hs:92` | `FrontendFailure` | data | no | `code` | `code` | `!FrontendErrorCode` | `(.code)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Frontend/Internal.hs:93` | `FrontendFailure` | data | no | `span` | `span` | `!SourceSpan` | `(.span)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Frontend/Internal.hs:94` | `FrontendFailure` | data | no | `message` | `message` | `!Text` | `(.message)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Frontend/Internal.hs:95` | `FrontendFailure` | data | no | `expected` | `expected` | `![Text]` | `(.expected)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Frontend/Internal.hs:96` | `FrontendFailure` | data | no | `supportedVersions` | `supportedVersions` | `![LanguageVersion]` | `(.supportedVersions)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Frontend/Internal.hs:97` | `FrontendFailure` | data | no | `compatibility` | `compatibility` | `!ParseFailure` | `(.compatibility)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Frontend/Internal.hs:143` | `LoweringFailure` | data | no | `code` | `code` | `!LoweringFailureCode` | `(.code)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Frontend/Internal.hs:144` | `LoweringFailure` | data | no | `span` | `span` | `!SourceSpan` | `(.span)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Frontend/Internal.hs:145` | `LoweringFailure` | data | no | `message` | `message` | `!Text` | `(.message)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Goldens.hs:42` | `GoldenPayload` | data | yes | `goldenContext` | `context` | `!Text` | `(.context)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Goldens.hs:43` | `GoldenPayload` | data | yes | `goldenAggregate` | `aggregate` | `!Text` | `(.aggregate)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Goldens.hs:44` | `GoldenPayload` | data | yes | `goldenEvent` | `event` | `!Text` | `(.event)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Goldens.hs:45` | `GoldenPayload` | data | yes | `goldenVersion` | `version` | `!Int` | `(.version)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Goldens.hs:46` | `GoldenPayload` | data | yes | `goldenJson` | `json` | `!Text` | `(.json)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Goldens.hs:47` | `GoldenPayload` | data | yes | `goldenEvidence` | `evidence` | `!GoldenEvidence` | `(.evidence)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:188` | `Loc` | newtype | yes | `unLoc` | `unLoc` | `Int` | explicit `unLoc` positional function | rendered/canonical output | `deriving stock (Show)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:204` | `IdDecl` | data | yes | `idName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:205` | `IdDecl` | data | yes | `idPrefix` | `prefix` | `!Text` | `(.prefix)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:206` | `IdDecl` | data | yes | `idBinding` | `binding` | `!(Maybe NominalBindingDecl)` | `(.binding)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:207` | `IdDecl` | data | yes | `idLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:214` | `EnumDecl` | data | yes | `enumName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:215` | `EnumDecl` | data | yes | `enumCtors` | `ctors` | `![(Name, Text)]` | `(.ctors)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:216` | `EnumDecl` | data | yes | `enumBinding` | `binding` | `!(Maybe NominalBindingDecl)` | `(.binding)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:217` | `EnumDecl` | data | yes | `enumLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:225` | `RuleDecl` | data | yes | `ruleName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:226` | `RuleDecl` | data | yes | `ruleDomain` | `domain` | `!Name` | `(.domain)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:227` | `RuleDecl` | data | yes | `ruleCodomain` | `codomain` | `!Name` | `(.codomain)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:228` | `RuleDecl` | data | yes | `ruleCases` | `cases` | `![(Name, Expr)]` | `(.cases)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:229` | `RuleDecl` | data | yes | `ruleLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:269` | `WireField` | data | yes | `wfHaskell` | `haskell` | `!Name` | `(.haskell)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:270` | `WireField` | data | yes | `wfKey` | `key` | `!Text` | `(.key)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:271` | `WireField` | data | yes | `wfType` | `valueType` | `!TypeExpr` | `(.valueType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:272` | `WireField` | data | yes | `wfPresence` | `presence` | `!Presence` | `(.presence)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:273` | `WireField` | data | yes | `wfOnMissing` | `onMissing` | `!(Maybe OnMissing)` | `(.onMissing)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:274` | `WireField` | data | yes | `wfLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:282` | `UnionEncoding` | data | yes | `ueTagField` | `tagField` | `!Text` | `(.tagField)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:283` | `UnionEncoding` | data | yes | `ueContentsField` | `contentsField` | `!Text` | `(.contentsField)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:284` | `UnionEncoding` | data | yes | `ueUnknownFields` | `unknownFields` | `!UnknownFields` | `(.unknownFields)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:289` | `WireEnum` | data | yes | `weCtor` | `ctor` | `!Name` | `(.ctor)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:290` | `WireEnum` | data | yes | `weTag` | `tag` | `!Text` | `(.tag)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:291` | `WireEnum` | data | yes | `weLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:296` | `WireArm` | data | yes | `waCtor` | `ctor` | `!Name` | `(.ctor)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:297` | `WireArm` | data | yes | `waTag` | `tag` | `!Text` | `(.tag)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:298` | `WireArm` | data | yes | `waPayload` | `payload` | `!(Maybe TypeExpr)` | `(.payload)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:299` | `WireArm` | data | yes | `waLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:310` | `HaskellSource` | data | yes | `hsPackage` | `package` | `!Text` | `(.package)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:311` | `HaskellSource` | data | yes | `hsModule` | `moduleName` | `!Text` | `(.moduleName)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:312` | `HaskellSource` | data | yes | `hsType` | `valueType` | `!Name` | `(.valueType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:321` | `NominalBindingDecl` | data | yes | `nominalHaskell` | `haskell` | `!(Maybe HaskellSource)` | `(.haskell)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:322` | `NominalBindingDecl` | data | yes | `nominalBinding` | `binding` | `!(Maybe Text)` | `(.binding)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:323` | `NominalBindingDecl` | data | yes | `nominalBindingVersion` | `bindingVersion` | `!(Maybe Text)` | `(.bindingVersion)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:324` | `NominalBindingDecl` | data | yes | `nominalCanonicalType` | `canonicalType` | `!(Maybe Text)` | `(.canonicalType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:325` | `NominalBindingDecl` | data | yes | `nominalFixtures` | `fixtures` | `!(Maybe Text)` | `(.fixtures)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:326` | `NominalBindingDecl` | data | yes | `nominalInitial` | `initial` | `!(Maybe Text)` | `(.initial)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:327` | `NominalBindingDecl` | data | yes | `nominalLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:336` | `NominalScalarDecl` | data | yes | `nominalScalarName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:337` | `NominalScalarDecl` | data | yes | `nominalScalarRepresentation` | `representation` | `!Name` | `(.representation)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:338` | `NominalScalarDecl` | data | yes | `nominalScalarBinding` | `binding` | `!NominalBindingDecl` | `(.binding)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:339` | `NominalScalarDecl` | data | yes | `nominalScalarLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:345` | `MappedDecl` | data | yes | `msName` | `msName` | `!Name` | `(.msName)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:346` | `MappedDecl` | data | yes | `msHaskell` | `msHaskell` | `!(Maybe HaskellSource)` | `(.msHaskell)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:347` | `MappedDecl` | data | yes | `msBinding` | `msBinding` | `!(Maybe Text)` | `(.msBinding)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:348` | `MappedDecl` | data | yes | `msBindingVersion` | `msBindingVersion` | `!(Maybe Text)` | `(.msBindingVersion)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:349` | `MappedDecl` | data | yes | `msCanonical` | `msCanonical` | `!(Maybe Text)` | `(.msCanonical)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:350` | `MappedDecl` | data | yes | `msFixtures` | `msFixtures` | `!(Maybe Text)` | `(.msFixtures)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:351` | `MappedDecl` | data | yes | `msInitial` | `msInitial` | `!(Maybe Text)` | `(.msInitial)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:352` | `MappedDecl` | data | yes | `msShape` | `msShape` | `!MappedShape` | `(.msShape)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:353` | `MappedDecl` | data | yes | `msLoc` | `msLoc` | `!Loc` | `(.msLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:356` | `MappedDecl` | data | yes | `moName` | `moName` | `!Name` | `(.moName)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:357` | `MappedDecl` | data | yes | `moHaskell` | `moHaskell` | `!(Maybe HaskellSource)` | `(.moHaskell)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:358` | `MappedDecl` | data | yes | `moCodecId` | `moCodecId` | `!(Maybe Text)` | `(.moCodecId)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:359` | `MappedDecl` | data | yes | `moCodecVersion` | `moCodecVersion` | `!(Maybe Text)` | `(.moCodecVersion)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:360` | `MappedDecl` | data | yes | `moFixtures` | `moFixtures` | `!(Maybe Text)` | `(.moFixtures)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:361` | `MappedDecl` | data | yes | `moInitial` | `moInitial` | `!(Maybe Text)` | `(.moInitial)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:362` | `MappedDecl` | data | yes | `moLoc` | `moLoc` | `!Loc` | `(.moLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:370` | `Mapping` | data | yes | `mapPairs` | `pairs` | `![(Name, Name)]` | `(.pairs)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:371` | `Mapping` | data | yes | `mapPartial` | `partial` | `!Bool` | `(.partial)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:481` | `RegDecl` | data | yes | `regName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:482` | `RegDecl` | data | yes | `regType` | `valueType` | `!TypeExpr` | `(.valueType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:483` | `RegDecl` | data | yes | `regInitial` | `initial` | `!RegInitial` | `(.initial)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:484` | `RegDecl` | data | yes | `regLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:492` | `StateDecl` | data | yes | `stName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:493` | `StateDecl` | data | yes | `stTerminal` | `terminal` | `!Bool` | `(.terminal)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:494` | `StateDecl` | data | yes | `stLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:505` | `AggregateField` | data | yes | `aggregateFieldName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:506` | `AggregateField` | data | yes | `aggregateFieldSelector` | `selector` | `!(Maybe Name)` | `(.selector)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:507` | `AggregateField` | data | yes | `aggregateFieldWireKey` | `wireKey` | `!(Maybe Text)` | `(.wireKey)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:508` | `AggregateField` | data | yes | `aggregateFieldType` | `valueType` | `!(Maybe TypeExpr)` | `(.valueType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:509` | `AggregateField` | data | yes | `aggregateFieldLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:516` | `Field` | data | yes | `fieldName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:517` | `Field` | data | yes | `fieldType` | `valueType` | `!(Maybe Name)` | `(.valueType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:523` | `Command` | data | yes | `cmdName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:524` | `Command` | data | yes | `cmdFields` | `fields` | `![AggregateField]` | `(.fields)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:525` | `Command` | data | yes | `cmdLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:535` | `Event` | data | yes | `evName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:536` | `Event` | data | yes | `evBody` | `body` | `!EventBody` | `(.body)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:538` | `Event` | data | yes | `evVersion` | `version` | `!Int` | `(.version)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:541` | `Event` | data | yes | `evUpcastFrom` | `upcastFrom` | `!(Maybe (Int, Hole))` | `(.upcastFrom)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:546` | `Event` | data | yes | `evRetiring` | `retiring` | `!Bool` | `(.retiring)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:550` | `Event` | data | yes | `evDeprecated` | `deprecated` | `!Bool` | `(.deprecated)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:551` | `Event` | data | yes | `evLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:569` | `DomainOutcomeTypes` | data | yes | `rejectionType` | `rejectionType` | `!Name` | `(.rejectionType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:570` | `DomainOutcomeTypes` | data | yes | `noOpType` | `noOpType` | `!Name` | `(.noOpType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:571` | `DomainOutcomeTypes` | data | yes | `outcomeTypesLoc` | `outcomeTypesLoc` | `!Loc` | `(.outcomeTypesLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:591` | `Transition` | data | yes | `tSource` | `source` | `!Name` | `(.source)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:592` | `Transition` | data | yes | `tCommand` | `command` | `!Name` | `(.command)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:593` | `Transition` | data | yes | `tImplementation` | `implementation` | `!TransitionImplementation` | `(.implementation)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:594` | `Transition` | data | yes | `tGuard` | `guard` | `!(Maybe Expr)` | `(.guard)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:595` | `Transition` | data | yes | `tWrites` | `writes` | `![(Name, Expr)]` | `(.writes)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:596` | `Transition` | data | yes | `tEmits` | `emits` | `![Name]` | `(.emits)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:597` | `Transition` | data | yes | `tOutcome` | `outcome` | `!(Maybe TransitionOutcome)` | `(.outcome)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:600` | `Transition` | data | yes | `tOutcomeDuplicateLocs` | `outcomeDuplicateLocs` | `![Loc]` | `(.outcomeDuplicateLocs)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:601` | `Transition` | data | yes | `tGoto` | `goto` | `!Name` | `(.goto)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:602` | `Transition` | data | yes | `tMode` | `mode` | `!TransitionMode` | `(.mode)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:603` | `Transition` | data | yes | `tLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:631` | `WireSpec` | data | yes | `wireKind` | `kind` | `!Text` | `(.kind)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:632` | `WireSpec` | data | yes | `wireFields` | `fields` | `!Text` | `(.fields)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:633` | `WireSpec` | data | yes | `wireSchemaVersion` | `schemaVersion` | `!Int` | `(.schemaVersion)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:640` | `ProjectionSpec` | data | yes | `projTable` | `table` | `!Name` | `(.table)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:641` | `ProjectionSpec` | data | yes | `projConsistency` | `consistency` | `!(Maybe Consistency)` | `(.consistency)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:642` | `ProjectionSpec` | data | yes | `projKey` | `key` | `!Name` | `(.key)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:643` | `ProjectionSpec` | data | yes | `projStatusMap` | `statusMap` | `!(Maybe Mapping)` | `(.statusMap)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:644` | `ProjectionSpec` | data | yes | `projLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:657` | `SnapshotSpec` | data | yes | `snapPolicy` | `policy` | `!SnapPolicy` | `(.policy)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:658` | `SnapshotSpec` | data | yes | `snapCodecVersion` | `codecVersion` | `!Int` | `(.codecVersion)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:659` | `SnapshotSpec` | data | yes | `snapShapeHash` | `shapeHash` | `!Text` | `(.shapeHash)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:660` | `SnapshotSpec` | data | yes | `snapLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:667` | `Aggregate` | data | yes | `aggName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:668` | `Aggregate` | data | yes | `aggRegs` | `regs` | `![RegDecl]` | `(.regs)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:669` | `Aggregate` | data | yes | `aggStates` | `states` | `![StateDecl]` | `(.states)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:670` | `Aggregate` | data | yes | `aggCommands` | `commands` | `![Command]` | `(.commands)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:671` | `Aggregate` | data | yes | `aggEvents` | `events` | `![Event]` | `(.events)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:672` | `Aggregate` | data | yes | `aggTransitions` | `transitions` | `![Transition]` | `(.transitions)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:673` | `Aggregate` | data | yes | `aggDomainOutcomeTypes` | `domainOutcomeTypes` | `!(Maybe DomainOutcomeTypes)` | `(.domainOutcomeTypes)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:676` | `Aggregate` | data | yes | `aggDomainOutcomeDuplicateLocs` | `domainOutcomeDuplicateLocs` | `![Loc]` | `(.domainOutcomeDuplicateLocs)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:677` | `Aggregate` | data | yes | `aggWire` | `wire` | `!(Maybe WireSpec)` | `(.wire)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:678` | `Aggregate` | data | yes | `aggProjection` | `projection` | `!(Maybe ProjectionSpec)` | `(.projection)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:679` | `Aggregate` | data | yes | `aggSnapshot` | `snapshot` | `!(Maybe SnapshotSpec)` | `(.snapshot)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:680` | `Aggregate` | data | yes | `aggLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:690` | `FieldBinding` | data | yes | `fbName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:691` | `FieldBinding` | data | yes | `fbValue` | `value` | `!(Maybe Text)` | `(.value)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:698` | `InputDecl` | data | yes | `inName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:699` | `InputDecl` | data | yes | `inFields` | `fields` | `![Field]` | `(.fields)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:700` | `InputDecl` | data | yes | `inType` | `valueType` | `!(Maybe TypeExpr)` | `(.valueType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:701` | `InputDecl` | data | yes | `inLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:708` | `CorrelateDecl` | data | yes | `corrField` | `field` | `!Name` | `(.field)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:709` | `CorrelateDecl` | data | yes | `corrVia` | `via` | `!Name` | `(.via)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:717` | `SagaRef` | data | yes | `sagaAgg` | `agg` | `!Name` | `(.agg)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:718` | `SagaRef` | data | yes | `sagaCategory` | `category` | `!Text` | `(.category)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:729` | `DispatchDisposition` | data | yes | `onAppended` | `onAppended` | `!Disp` | `(.onAppended)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:730` | `DispatchDisposition` | data | yes | `onDuplicate` | `onDuplicate` | `!Disp` | `(.onDuplicate)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:731` | `DispatchDisposition` | data | yes | `onFailed` | `onFailed` | `!Disp` | `(.onFailed)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:737` | `AdvanceNode` | data | yes | `advCommand` | `advCommand` | `!Name` | `(.advCommand)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:738` | `AdvanceNode` | data | yes | `advFields` | `advFields` | `![FieldBinding]` | `(.advFields)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:744` | `DispatchNode` | data | yes | `dispTarget` | `target` | `!Name` | `(.target)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:745` | `DispatchNode` | data | yes | `dispKey` | `key` | `!Text` | `(.key)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:746` | `DispatchNode` | data | yes | `dispCommand` | `command` | `!Name` | `(.command)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:747` | `DispatchNode` | data | yes | `dispFields` | `fields` | `![FieldBinding]` | `(.fields)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:748` | `DispatchNode` | data | yes | `disposition` | `osition` | `!DispatchDisposition` | `(.osition)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:749` | `DispatchNode` | data | yes | `dispLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:756` | `HandleNode` | data | yes | `hOn` | `on` | `!Name` | `(.on)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:757` | `HandleNode` | data | yes | `hAdvance` | `advance` | `!AdvanceNode` | `(.advance)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:758` | `HandleNode` | data | yes | `hDispatch` | `dispatch` | `![DispatchNode]` | `(.dispatch)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:759` | `HandleNode` | data | yes | `hSchedule` | `schedule` | `!Name` | `(.schedule)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:765` | `IdExpr` | data | yes | `ideStrategy` | `strategy` | `!IdStrategy` | `(.strategy)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:766` | `IdExpr` | data | yes | `idePrefix` | `prefix` | `!Text` | `(.prefix)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:767` | `IdExpr` | data | yes | `ideField` | `field` | `!Name` | `(.field)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:778` | `FireAtExpr` | data | yes | `faField` | `field` | `!Name` | `(.field)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:779` | `FireAtExpr` | data | yes | `faWindow` | `window` | `!Text` | `(.window)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:789` | `FireDisposition` | data | yes | `onOk` | `onOk` | `!FireOutcome` | `(.onOk)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:790` | `FireDisposition` | data | yes | `onReject` | `onReject` | `!FireOutcome` | `(.onReject)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:791` | `FireDisposition` | data | yes | `onAmbiguous` | `onAmbiguous` | `!FireOutcome` | `(.onAmbiguous)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:792` | `FireDisposition` | data | yes | `onError` | `onError` | `!FireOutcome` | `(.onError)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:793` | `FireDisposition` | data | yes | `notMine` | `notMine` | `!FireOutcome` | `(.notMine)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:799` | `FireNode` | data | yes | `fireTarget` | `target` | `!Name` | `(.target)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:800` | `FireNode` | data | yes | `fireKey` | `key` | `!Text` | `(.key)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:801` | `FireNode` | data | yes | `fireCommand` | `command` | `!Name` | `(.command)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:802` | `FireNode` | data | yes | `fireFields` | `fields` | `![FieldBinding]` | `(.fields)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:803` | `FireNode` | data | yes | `fireFiredEventId` | `firedEventId` | `!IdExpr` | `(.firedEventId)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:804` | `FireNode` | data | yes | `fireDisposition` | `disposition` | `!FireDisposition` | `(.disposition)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:810` | `TimerNode` | data | yes | `tmName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:811` | `TimerNode` | data | yes | `tmId` | `id` | `!IdExpr` | `(.id)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:812` | `TimerNode` | data | yes | `tmFireAt` | `fireAt` | `!FireAtExpr` | `(.fireAt)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:813` | `TimerNode` | data | yes | `tmPayload` | `payload` | `![FieldBinding]` | `(.payload)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:814` | `TimerNode` | data | yes | `tmFire` | `fire` | `!FireNode` | `(.fire)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:815` | `TimerNode` | data | yes | `tmDecodeUnknown` | `decodeUnknown` | `!Name` | `(.decodeUnknown)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:816` | `TimerNode` | data | yes | `tmMaxAttempts` | `maxAttempts` | `!Int` | `(.maxAttempts)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:817` | `TimerNode` | data | yes | `tmDeadLetter` | `deadLetter` | `!Text` | `(.deadLetter)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:818` | `TimerNode` | data | yes | `tmLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:830` | `ProcessNode` | data | yes | `procId` | `id` | `!Name` | `(.id)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:832` | `ProcessNode` | data | yes | `procName` | `name` | `!Text` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:833` | `ProcessNode` | data | yes | `procInput` | `input` | `!InputDecl` | `(.input)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:834` | `ProcessNode` | data | yes | `procCorrelate` | `correlate` | `!CorrelateDecl` | `(.correlate)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:835` | `ProcessNode` | data | yes | `procSaga` | `saga` | `!SagaRef` | `(.saga)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:836` | `ProcessNode` | data | yes | `procTarget` | `target` | `!Name` | `(.target)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:837` | `ProcessNode` | data | yes | `procProjections` | `projections` | `![Name]` | `(.projections)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:838` | `ProcessNode` | data | yes | `procHandle` | `handle` | `!HandleNode` | `(.handle)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:839` | `ProcessNode` | data | yes | `procRejected` | `rejected` | `!PolicyChoice` | `(.rejected)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:840` | `ProcessNode` | data | yes | `procPoison` | `poison` | `!PolicyChoice` | `(.poison)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:841` | `ProcessNode` | data | yes | `procTimer` | `timer` | `!TimerNode` | `(.timer)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:842` | `ProcessNode` | data | yes | `procLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:859` | `RouterSelectionDecl` | data | yes | `rsIdentity` | `identity` | `!Text` | `(.identity)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:860` | `RouterSelectionDecl` | data | yes | `rsIdentityLoc` | `identityLoc` | `!Loc` | `(.identityLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:861` | `RouterSelectionDecl` | data | yes | `rsVersion` | `version` | `!Natural` | `(.version)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:862` | `RouterSelectionDecl` | data | yes | `rsVersionLoc` | `versionLoc` | `!Loc` | `(.versionLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:863` | `RouterSelectionDecl` | data | yes | `rsQuery` | `query` | `!Name` | `(.query)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:864` | `RouterSelectionDecl` | data | yes | `rsQueryLoc` | `queryLoc` | `!Loc` | `(.queryLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:865` | `RouterSelectionDecl` | data | yes | `rsQueryInput` | `queryInput` | `!Name` | `(.queryInput)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:866` | `RouterSelectionDecl` | data | yes | `rsQueryInputLoc` | `queryInputLoc` | `!Loc` | `(.queryInputLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:867` | `RouterSelectionDecl` | data | yes | `rsPredicate` | `predicate` | `!Expr` | `(.predicate)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:868` | `RouterSelectionDecl` | data | yes | `rsRecipient` | `recipient` | `!Expr` | `(.recipient)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:869` | `RouterSelectionDecl` | data | yes | `rsLimit` | `limit` | `!(Maybe (Natural, Loc))` | `(.limit)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:870` | `RouterSelectionDecl` | data | yes | `rsOrder` | `order` | `!Name` | `(.order)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:871` | `RouterSelectionDecl` | data | yes | `rsOrderLoc` | `orderLoc` | `!Loc` | `(.orderLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:872` | `RouterSelectionDecl` | data | yes | `rsDedupe` | `dedupe` | `!Name` | `(.dedupe)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:873` | `RouterSelectionDecl` | data | yes | `rsDedupeLoc` | `dedupeLoc` | `!Loc` | `(.dedupeLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:874` | `RouterSelectionDecl` | data | yes | `rsEmptyPolicy` | `emptyPolicy` | `!SelectionDispositionSyntax` | `(.emptyPolicy)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:875` | `RouterSelectionDecl` | data | yes | `rsEmptyPolicyLoc` | `emptyPolicyLoc` | `!Loc` | `(.emptyPolicyLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:876` | `RouterSelectionDecl` | data | yes | `rsFailurePolicy` | `failurePolicy` | `!SelectionDispositionSyntax` | `(.failurePolicy)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:877` | `RouterSelectionDecl` | data | yes | `rsFailurePolicyLoc` | `failurePolicyLoc` | `!Loc` | `(.failurePolicyLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:878` | `RouterSelectionDecl` | data | yes | `rsRedelivery` | `redelivery` | `!Name` | `(.redelivery)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:879` | `RouterSelectionDecl` | data | yes | `rsRedeliveryLoc` | `redeliveryLoc` | `!Loc` | `(.redeliveryLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:880` | `RouterSelectionDecl` | data | yes | `rsPartial` | `partial` | `!Name` | `(.partial)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:881` | `RouterSelectionDecl` | data | yes | `rsPartialLoc` | `partialLoc` | `!Loc` | `(.partialLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:882` | `RouterSelectionDecl` | data | yes | `rsLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:893` | `ResolveDecl` | data | yes | `rvSource` | `source` | `!ResolveSource` | `(.source)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:894` | `ResolveDecl` | data | yes | `rvRow` | `row` | `![Name]` | `(.row)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:895` | `ResolveDecl` | data | yes | `rvLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:900` | `RouterDispatchNode` | data | yes | `rdCommand` | `command` | `!Name` | `(.command)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:901` | `RouterDispatchNode` | data | yes | `rdFields` | `fields` | `![FieldBinding]` | `(.fields)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:902` | `RouterDispatchNode` | data | yes | `rdDisposition` | `disposition` | `!DispatchDisposition` | `(.disposition)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:903` | `RouterDispatchNode` | data | yes | `rdLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:911` | `RouterNode` | data | yes | `rtId` | `id` | `!Name` | `(.id)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:912` | `RouterNode` | data | yes | `rtName` | `name` | `!Text` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:913` | `RouterNode` | data | yes | `rtInput` | `input` | `!InputDecl` | `(.input)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:914` | `RouterNode` | data | yes | `rtKey` | `key` | `!CorrelateDecl` | `(.key)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:915` | `RouterNode` | data | yes | `rtResolve` | `resolve` | `!ResolveDecl` | `(.resolve)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:916` | `RouterNode` | data | yes | `rtTarget` | `target` | `!Name` | `(.target)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:917` | `RouterNode` | data | yes | `rtProjections` | `projections` | `![Name]` | `(.projections)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:918` | `RouterNode` | data | yes | `rtDispatch` | `dispatch` | `!RouterDispatchNode` | `(.dispatch)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:919` | `RouterNode` | data | yes | `rtRejected` | `rejected` | `!PolicyChoice` | `(.rejected)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:920` | `RouterNode` | data | yes | `rtPoison` | `poison` | `!PolicyChoice` | `(.poison)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:921` | `RouterNode` | data | yes | `rtLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:932` | `ContractField` | data | yes | `cfName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:933` | `ContractField` | data | yes | `cfSelector` | `selector` | `!(Maybe Name)` | `(.selector)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:934` | `ContractField` | data | yes | `cfWireKey` | `wireKey` | `!(Maybe Text)` | `(.wireKey)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:935` | `ContractField` | data | yes | `cfType` | `valueType` | `!ContractType` | `(.valueType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:936` | `ContractField` | data | yes | `cfLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:942` | `ContractEvent` | data | yes | `ceName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:943` | `ContractEvent` | data | yes | `ceTopic` | `topic` | `!Name` | `(.topic)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:944` | `ContractEvent` | data | yes | `ceFields` | `fields` | `![ContractField]` | `(.fields)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:952` | `ContractNode` | data | yes | `ctrName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:953` | `ContractNode` | data | yes | `ctrSchemaVersion` | `schemaVersion` | `!Int` | `(.schemaVersion)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:954` | `ContractNode` | data | yes | `ctrDiscriminator` | `discriminator` | `!Name` | `(.discriminator)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:956` | `ContractNode` | data | yes | `ctrTopics` | `topics` | `![(Name, Text)]` | `(.topics)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:957` | `ContractNode` | data | yes | `ctrEvents` | `events` | `![ContractEvent]` | `(.events)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:958` | `ContractNode` | data | yes | `ctrLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:974` | `BindRow` | data | yes | `brField` | `field` | `!Name` | `(.field)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:975` | `BindRow` | data | yes | `brSource` | `source` | `!WireSource` | `(.source)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:976` | `BindRow` | data | yes | `brRequired` | `required` | `!Bool` | `(.required)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:977` | `BindRow` | data | yes | `brCrossCheck` | `crossCheck` | `!Bool` | `(.crossCheck)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:993` | `DispositionRow` | data | yes | `drOutcome` | `outcome` | `!Name` | `(.outcome)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:994` | `DispositionRow` | data | yes | `drAction` | `action` | `!InboxAction` | `(.action)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:995` | `DispositionRow` | data | yes | `drLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1002` | `DecodeSpec` | data | yes | `decEnvelope` | `envelope` | `!Text` | `(.envelope)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1003` | `DecodeSpec` | data | yes | `decBodyStrict` | `bodyStrict` | `!Bool` | `(.bodyStrict)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1004` | `DecodeSpec` | data | yes | `decBodySchemaVersion` | `bodySchemaVersion` | `!Int` | `(.bodySchemaVersion)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1016` | `IntakeNode` | data | yes | `inkName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1017` | `IntakeNode` | data | yes | `inkContract` | `contract` | `!Name` | `(.contract)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1018` | `IntakeNode` | data | yes | `inkTopic` | `topic` | `!Name` | `(.topic)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1019` | `IntakeNode` | data | yes | `inkAccept` | `accept` | `![Name]` | `(.accept)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1020` | `IntakeNode` | data | yes | `inkBinds` | `binds` | `![BindRow]` | `(.binds)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1021` | `IntakeNode` | data | yes | `inkDedupeKey` | `dedupeKey` | `!Name` | `(.dedupeKey)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1022` | `IntakeNode` | data | yes | `inkDedupePolicy` | `dedupePolicy` | `!Name` | `(.dedupePolicy)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1023` | `IntakeNode` | data | yes | `inkPersist` | `persist` | `!InkPersist` | `(.persist)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1024` | `IntakeNode` | data | yes | `inkDecode` | `decode` | `!DecodeSpec` | `(.decode)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1025` | `IntakeNode` | data | yes | `inkDisposition` | `disposition` | `![DispositionRow]` | `(.disposition)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1026` | `IntakeNode` | data | yes | `inkLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1033` | `DeriveSpec` | newtype | yes | `dsPrefix` | `dsPrefix` | `Maybe Text` | `(.dsPrefix)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1038` | `EmitMapRow` | data | yes | `emrValue` | `value` | `!Text` | `(.value)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1039` | `EmitMapRow` | data | yes | `emrEvent` | `event` | `!Name` | `(.event)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1040` | `EmitMapRow` | data | yes | `emrLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1047` | `EmitNode` | data | yes | `emName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1048` | `EmitNode` | data | yes | `emContract` | `contract` | `!Name` | `(.contract)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1049` | `EmitNode` | data | yes | `emTopic` | `topic` | `!Name` | `(.topic)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1050` | `EmitNode` | data | yes | `emSource` | `source` | `!Text` | `(.source)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1051` | `EmitNode` | data | yes | `emKey` | `key` | `!Name` | `(.key)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1052` | `EmitNode` | data | yes | `emDiscriminant` | `discriminant` | `!Name` | `(.discriminant)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1053` | `EmitNode` | data | yes | `emMap` | `map` | `![EmitMapRow]` | `(.map)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1055` | `EmitNode` | data | yes | `emSkip` | `skip` | `!Bool` | `(.skip)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1056` | `EmitNode` | data | yes | `emMessageId` | `messageId` | `!DeriveSpec` | `(.messageId)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1057` | `EmitNode` | data | yes | `emIdempotencyKey` | `idempotencyKey` | `!DeriveSpec` | `(.idempotencyKey)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1058` | `EmitNode` | data | yes | `emLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1064` | `BackoffSpec` | data | yes | `boKind` | `kind` | `!Name` | `(.kind)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1065` | `BackoffSpec` | data | yes | `boWindow` | `window` | `!Text` | `(.window)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1066` | `BackoffSpec` | data | yes | `boMax` | `max` | `!(Maybe Text)` | `(.max)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1067` | `BackoffSpec` | data | yes | `boMultiplier` | `multiplier` | `!(Maybe Text)` | `(.multiplier)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1073` | `PublisherNode` | data | yes | `pubName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1074` | `PublisherNode` | data | yes | `pubEmit` | `emit` | `!Name` | `(.emit)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1075` | `PublisherNode` | data | yes | `pubOrdering` | `ordering` | `!Name` | `(.ordering)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1076` | `PublisherNode` | data | yes | `pubMaxAttempts` | `maxAttempts` | `!Int` | `(.maxAttempts)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1077` | `PublisherNode` | data | yes | `pubBackoff` | `backoff` | `!BackoffSpec` | `(.backoff)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1079` | `PublisherNode` | data | yes | `pubOutboxField` | `outboxField` | `!Name` | `(.outboxField)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1080` | `PublisherNode` | data | yes | `pubLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1110` | `WqField` | data | yes | `wqfName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1111` | `WqField` | data | yes | `wqfWire` | `wire` | `!Text` | `(.wire)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1112` | `WqField` | data | yes | `wqfType` | `valueType` | `!QueuePayloadType` | `(.valueType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1113` | `WqField` | data | yes | `wqfLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1120` | `WqDispRow` | data | yes | `wqdOutcome` | `outcome` | `!Name` | `(.outcome)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1121` | `WqDispRow` | data | yes | `wqdAction` | `action` | `!InboxAction` | `(.action)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1122` | `WqDispRow` | data | yes | `wqdLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1132` | `WqGroupKey` | data | yes | `gkField` | `field` | `!Name` | `(.field)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1133` | `WqGroupKey` | data | yes | `gkVia` | `via` | `!Name` | `(.via)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1134` | `WqGroupKey` | data | yes | `gkFixture` | `fixture` | `!(Maybe Text)` | `(.fixture)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1149` | `WorkqueueNode` | data | yes | `wqName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1150` | `WorkqueueNode` | data | yes | `wqLogical` | `logical` | `!Text` | `(.logical)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1151` | `WorkqueueNode` | data | yes | `wqPhysical` | `physical` | `!Text` | `(.physical)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1152` | `WorkqueueNode` | data | yes | `wqDlq` | `dlq` | `!Text` | `(.dlq)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1153` | `WorkqueueNode` | data | yes | `wqTable` | `table` | `!Text` | `(.table)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1154` | `WorkqueueNode` | data | yes | `wqOrdering` | `ordering` | `!WqOrdering` | `(.ordering)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1155` | `WorkqueueNode` | data | yes | `wqGroupKey` | `groupKey` | `!(Maybe WqGroupKey)` | `(.groupKey)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1156` | `WorkqueueNode` | data | yes | `wqProvision` | `provision` | `!WqProvision` | `(.provision)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1157` | `WorkqueueNode` | data | yes | `wqPayloadName` | `payloadName` | `!Name` | `(.payloadName)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1158` | `WorkqueueNode` | data | yes | `wqPayload` | `payload` | `![WqField]` | `(.payload)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1159` | `WorkqueueNode` | data | yes | `wqMaxRetries` | `maxRetries` | `!Int` | `(.maxRetries)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1160` | `WorkqueueNode` | data | yes | `wqDelay` | `delay` | `!Text` | `(.delay)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1161` | `WorkqueueNode` | data | yes | `wqDlqOn` | `dlqOn` | `!Bool` | `(.dlqOn)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1162` | `WorkqueueNode` | data | yes | `wqDisposition` | `disposition` | `![WqDispRow]` | `(.disposition)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1163` | `WorkqueueNode` | data | yes | `wqLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1170` | `PgmqDispatchNode` | data | yes | `pdName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1171` | `PgmqDispatchNode` | data | yes | `pdSourceReadModel` | `sourceReadModel` | `!Name` | `(.sourceReadModel)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1172` | `PgmqDispatchNode` | data | yes | `pdSourceKey` | `sourceKey` | `!Name` | `(.sourceKey)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1173` | `PgmqDispatchNode` | data | yes | `pdFanoutBody` | `fanoutBody` | `!Name` | `(.fanoutBody)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1174` | `PgmqDispatchNode` | data | yes | `pdDedupKey` | `dedupKey` | `!Name` | `(.dedupKey)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1175` | `PgmqDispatchNode` | data | yes | `pdDedupReadModel` | `dedupReadModel` | `!Name` | `(.dedupReadModel)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1176` | `PgmqDispatchNode` | data | yes | `pdDedupReadModelField` | `dedupReadModelField` | `!Text` | `(.dedupReadModelField)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1177` | `PgmqDispatchNode` | data | yes | `pdDedupQueue` | `dedupQueue` | `!Name` | `(.dedupQueue)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1178` | `PgmqDispatchNode` | data | yes | `pdDedupQueueField` | `dedupQueueField` | `!Text` | `(.dedupQueueField)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1179` | `PgmqDispatchNode` | data | yes | `pdEnqueueTo` | `enqueueTo` | `!Name` | `(.enqueueTo)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1180` | `PgmqDispatchNode` | data | yes | `pdLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1188` | `RmColumn` | data | yes | `rmcName` | `rmcName` | `!Text` | `(.rmcName)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1189` | `RmColumn` | data | yes | `rmcType` | `rmcType` | `!Text` | `(.rmcType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1190` | `RmColumn` | data | yes | `rmcRequired` | `rmcRequired` | `!Bool` | `(.rmcRequired)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1219` | `ReadModelSupply` | data | yes | `legacyConsistency` | `legacyConsistency` | `!Consistency` | `(.legacyConsistency)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1220` | `ReadModelSupply` | data | yes | `legacyScope` | `legacyScope` | `!(Maybe RmScope)` | `(.legacyScope)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1221` | `ReadModelSupply` | data | yes | `legacyFeed` | `legacyFeed` | `!RmFeed` | `(.legacyFeed)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1222` | `ReadModelSupply` | data | yes | `legacySubscription` | `legacySubscription` | `!(Maybe Text)` | `(.legacySubscription)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1230` | `ReadModelQueryTypes` | data | yes | `input` | `input` | `!TypeExpr` | `(.input)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1231` | `ReadModelQueryTypes` | data | yes | `result` | `result` | `!TypeExpr` | `(.result)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1232` | `ReadModelQueryTypes` | data | yes | `inputLoc` | `inputLoc` | `!Loc` | `(.inputLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1233` | `ReadModelQueryTypes` | data | yes | `resultLoc` | `resultLoc` | `!Loc` | `(.resultLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1240` | `ReadModelNode` | data | yes | `rmName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1241` | `ReadModelNode` | data | yes | `rmTable` | `table` | `!Text` | `(.table)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1242` | `ReadModelNode` | data | yes | `rmSchema` | `schema` | `!Text` | `(.schema)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1243` | `ReadModelNode` | data | yes | `rmColumns` | `columns` | `![RmColumn]` | `(.columns)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1244` | `ReadModelNode` | data | yes | `rmVersion` | `version` | `!Int` | `(.version)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1245` | `ReadModelNode` | data | yes | `rmShape` | `shape` | `!Text` | `(.shape)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1246` | `ReadModelNode` | data | yes | `rmFreshness` | `freshness` | `!QueryFreshnessNode` | `(.freshness)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1247` | `ReadModelNode` | data | yes | `rmSupply` | `supply` | `!ReadModelSupply` | `(.supply)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1248` | `ReadModelNode` | data | yes | `rmGroup` | `group` | `!(Maybe Name)` | `(.group)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1249` | `ReadModelNode` | data | yes | `rmObservedTargets` | `observedTargets` | `![Name]` | `(.observedTargets)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1250` | `ReadModelNode` | data | yes | `rmBackingTarget` | `backingTarget` | `!(Maybe Name)` | `(.backingTarget)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1251` | `ReadModelNode` | data | yes | `queryTypes` | `queryTypes` | `!(Maybe ReadModelQueryTypes)` | `(.queryTypes)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1252` | `ReadModelNode` | data | yes | `rmLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1283` | `ProjectionTargetNode` | data | yes | `ptName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1284` | `ProjectionTargetNode` | data | yes | `ptSchema` | `schema` | `!Text` | `(.schema)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1285` | `ProjectionTargetNode` | data | yes | `ptTable` | `table` | `!Text` | `(.table)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1286` | `ProjectionTargetNode` | data | yes | `ptReset` | `reset` | `!TargetResetPolicy` | `(.reset)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1287` | `ProjectionTargetNode` | data | yes | `ptDependsOn` | `dependsOn` | `![Name]` | `(.dependsOn)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1288` | `ProjectionTargetNode` | data | yes | `ptLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1294` | `RebuildGroupNode` | data | yes | `rgName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1295` | `RebuildGroupNode` | data | yes | `rgTargets` | `targets` | `![Name]` | `(.targets)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1296` | `RebuildGroupNode` | data | yes | `rgOrder` | `order` | `![Name]` | `(.order)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1297` | `RebuildGroupNode` | data | yes | `rgLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1308` | `PromotionObjectNode` | data | yes | `rpoKind` | `kind` | `!PromotionObjectKindNode` | `(.kind)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1309` | `PromotionObjectNode` | data | yes | `rpoGenerationName` | `generationName` | `!Text` | `(.generationName)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1310` | `PromotionObjectNode` | data | yes | `rpoCanonicalName` | `canonicalName` | `!Text` | `(.canonicalName)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1317` | `RevisionTargetNode` | data | yes | `prtTarget` | `target` | `!Name` | `(.target)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1318` | `RevisionTargetNode` | data | yes | `prtSchemaVersion` | `schemaVersion` | `!Text` | `(.schemaVersion)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1319` | `RevisionTargetNode` | data | yes | `prtProvisioner` | `provisioner` | `!Text` | `(.provisioner)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1320` | `RevisionTargetNode` | data | yes | `prtProvisionerVersion` | `provisionerVersion` | `!Int` | `(.provisionerVersion)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1321` | `RevisionTargetNode` | data | yes | `prtExpectedShape` | `expectedShape` | `!Text` | `(.expectedShape)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1322` | `RevisionTargetNode` | data | yes | `prtValidator` | `validator` | `!Text` | `(.validator)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1323` | `RevisionTargetNode` | data | yes | `prtValidatorVersion` | `validatorVersion` | `!Int` | `(.validatorVersion)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1324` | `RevisionTargetNode` | data | yes | `prtPromotionObjects` | `promotionObjects` | `![PromotionObjectNode]` | `(.promotionObjects)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1329` | `ProjectionRevisionNode` | data | yes | `prvName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1330` | `ProjectionRevisionNode` | data | yes | `prvGroup` | `group` | `!Name` | `(.group)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1331` | `ProjectionRevisionNode` | data | yes | `prvTargets` | `targets` | `![RevisionTargetNode]` | `(.targets)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1332` | `ProjectionRevisionNode` | data | yes | `prvLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1340` | `ExternalReadNode` | data | yes | `erName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1341` | `ExternalReadNode` | data | yes | `erVersion` | `version` | `!Int` | `(.version)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1342` | `ExternalReadNode` | data | yes | `erQueryModel` | `queryModel` | `!Name` | `(.queryModel)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1343` | `ExternalReadNode` | data | yes | `erResultSchema` | `resultSchema` | `!Text` | `(.resultSchema)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1344` | `ExternalReadNode` | data | yes | `erResultType` | `resultType` | `!Text` | `(.resultType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1345` | `ExternalReadNode` | data | yes | `erCompatibleRevisions` | `compatibleRevisions` | `![Name]` | `(.compatibleRevisions)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1346` | `ExternalReadNode` | data | yes | `erSurfaceGeneration` | `surfaceGeneration` | `!Int` | `(.surfaceGeneration)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1347` | `ExternalReadNode` | data | yes | `erLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1382` | `ProjectionOwnerNode` | data | yes | `poName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1383` | `ProjectionOwnerNode` | data | yes | `poSources` | `sources` | `![CatalogSource]` | `(.sources)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1384` | `ProjectionOwnerNode` | data | yes | `poDelivery` | `delivery` | `!ProjectionDelivery` | `(.delivery)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1385` | `ProjectionOwnerNode` | data | yes | `poGroup` | `group` | `!Name` | `(.group)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1386` | `ProjectionOwnerNode` | data | yes | `poTargets` | `targets` | `![Name]` | `(.targets)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1387` | `ProjectionOwnerNode` | data | yes | `poOrder` | `order` | `!Int` | `(.order)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1388` | `ProjectionOwnerNode` | data | yes | `poSubscription` | `subscription` | `!(Maybe Text)` | `(.subscription)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1389` | `ProjectionOwnerNode` | data | yes | `poDedup` | `dedup` | `!(Maybe Text)` | `(.dedup)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1390` | `ProjectionOwnerNode` | data | yes | `poCheckpointOnMissing` | `checkpointOnMissing` | `![CheckpointOnMissingNode]` | `(.checkpointOnMissing)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1391` | `ProjectionOwnerNode` | data | yes | `poReplay` | `replay` | `!ProjectionReplayPolicy` | `(.replay)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1392` | `ProjectionOwnerNode` | data | yes | `poLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1418` | `WorkflowNode` | data | yes | `wfId` | `id` | `!Name` | `(.id)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1420` | `WorkflowNode` | data | yes | `wfStable` | `stable` | `!Text` | `(.stable)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1421` | `WorkflowNode` | data | yes | `wfInput` | `input` | `!Name` | `(.input)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1422` | `WorkflowNode` | data | yes | `wfInputFields` | `inputFields` | `![Field]` | `(.inputFields)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1423` | `WorkflowNode` | data | yes | `wfOutput` | `output` | `!Name` | `(.output)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1425` | `WorkflowNode` | data | yes | `wfIdField` | `idField` | `!(Maybe Name)` | `(.idField)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1426` | `WorkflowNode` | data | yes | `wfIdVia` | `idVia` | `!Name` | `(.idVia)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1427` | `WorkflowNode` | data | yes | `wfBody` | `body` | `![WfBodyItem]` | `(.body)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1428` | `WorkflowNode` | data | yes | `wfLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1448` | `OperationNode` | data | yes | `opName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1449` | `OperationNode` | data | yes | `opShape` | `shape` | `!OperationShape` | `(.shape)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1450` | `OperationNode` | data | yes | `opLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1496` | `Spec` | data | yes | `specContext` | `context` | `!Name` | `(.context)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1497` | `Spec` | data | yes | `specModuleRoot` | `moduleRoot` | `!(Maybe Text)` | `(.moduleRoot)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1498` | `Spec` | data | yes | `specLayout` | `layout` | `!(Maybe Placement)` | `(.layout)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1499` | `Spec` | data | yes | `specIds` | `ids` | `![IdDecl]` | `(.ids)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1500` | `Spec` | data | yes | `specEnums` | `enums` | `![EnumDecl]` | `(.enums)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1501` | `Spec` | data | yes | `specRules` | `rules` | `![RuleDecl]` | `(.rules)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1502` | `Spec` | data | yes | `specNominalScalars` | `nominalScalars` | `![NominalScalarDecl]` | `(.nominalScalars)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1503` | `Spec` | data | yes | `specMapped` | `mapped` | `![MappedDecl]` | `(.mapped)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Grammar.hs:1504` | `Spec` | data | yes | `specNodes` | `nodes` | `![Node]` | `(.nodes)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellImport.hs:41` | `HaskellReference` | data | yes | `referenceModule` | `moduleName` | `!Text` | `(.moduleName)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellImport.hs:42` | `HaskellReference` | data | yes | `referenceName` | `name` | `!Text` | `(.name)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellImport.hs:43` | `HaskellReference` | data | yes | `referenceNamespace` | `namespace` | `!HaskellNamespace` | `(.namespace)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellImport.hs:44` | `HaskellReference` | data | yes | `referenceQualification` | `qualification` | `!QualificationPreference` | `(.qualification)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellImport.hs:49` | `ImportEnvironment` | data | yes | `targetModule` | `targetModule` | `!Text` | `(.targetModule)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellImport.hs:50` | `ImportEnvironment` | data | yes | `localNames` | `localNames` | `!(Set Text)` | `(.localNames)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellImport.hs:51` | `ImportEnvironment` | data | yes | `reservedQualifiers` | `reservedQualifiers` | `!(Set Text)` | `(.reservedQualifiers)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellImport.hs:64` | `HaskellImportPlan` | data | no | `importPlanTargetModule` | `targetModule` | `!Text` | `(.targetModule)`, pattern, or construction | Haskell API and runtime semantics | `none` |+| `keiro-dsl/src/Keiro/Dsl/HaskellImport.hs:65` | `HaskellImportPlan` | data | no | `importPlanDeclarations` | `declarations` | `!(Set Text)` | `(.declarations)`, pattern, or construction | Haskell API and runtime semantics | `none` |+| `keiro-dsl/src/Keiro/Dsl/HaskellImport.hs:66` | `HaskellImportPlan` | data | no | `importPlanReferences` | `references` | `!(Map HaskellReference Text)` | `(.references)`, pattern, or construction | Haskell API and runtime semantics | `none` |+| `keiro-dsl/src/Keiro/Dsl/HaskellName.hs:62` | `DerivedHaskellName` | data | no | `upperCamel` | `upperCamel` | `!UpperCamelName` | `(.upperCamel)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellName.hs:63` | `DerivedHaskellName` | data | no | `lowerCamel` | `lowerCamel` | `!LowerCamelName` | `(.lowerCamel)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellName.hs:96` | `NameSite` | data | no | `siteKind` | `kind` | `!NameSiteKind` | `(.kind)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellName.hs:97` | `NameSite` | data | no | `siteLogicalName` | `logicalName` | `!Text` | `(.logicalName)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellName.hs:98` | `NameSite` | data | no | `siteOwner` | `owner` | `!Text` | `(.owner)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellName.hs:99` | `NameSite` | data | no | `siteLine` | `line` | `!Int` | `(.line)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellName.hs:108` | `HaskellOccurrenceKey` | data | no | `occurrenceModule` | `moduleName` | `!Text` | `(.moduleName)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellName.hs:109` | `HaskellOccurrenceKey` | data | no | `occurrenceSpace` | `space` | `!HaskellOccurrenceSpace` | `(.space)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellName.hs:110` | `HaskellOccurrenceKey` | data | no | `occurrenceScope` | `scope` | `!Text` | `(.scope)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellName.hs:111` | `HaskellOccurrenceKey` | data | no | `occurrenceName` | `name` | `!Text` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellName.hs:116` | `PlannedOccurrence` | data | no | `plannedOccurrenceKey` | `key` | `!HaskellOccurrenceKey` | `(.key)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellName.hs:117` | `PlannedOccurrence` | data | no | `plannedOccurrenceSite` | `site` | `!NameSite` | `(.site)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellSourceMove.hs:28` | `SourceMove` | data | yes | `moveRole` | `role` | `!ModuleRole` | `(.role)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellSourceMove.hs:29` | `SourceMove` | data | yes | `moveKind` | `kind` | `!ModuleKind` | `(.kind)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellSourceMove.hs:30` | `SourceMove` | data | yes | `moveOldModule` | `oldModule` | `!Text` | `(.oldModule)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellSourceMove.hs:31` | `SourceMove` | data | yes | `moveNewModule` | `newModule` | `!Text` | `(.newModule)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellSourceMove.hs:32` | `SourceMove` | data | yes | `moveOldPath` | `oldPath` | `!FilePath` | `(.oldPath)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellSourceMove.hs:33` | `SourceMove` | data | yes | `moveNewPath` | `newPath` | `!FilePath` | `(.newPath)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellSourceMove.hs:34` | `SourceMove` | data | yes | `moveBackupPath` | `backupPath` | `!FilePath` | `(.backupPath)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellSourceMove.hs:38` | `SourceMove` | data | yes | `moveContentDigest` | `contentDigest` | `!(Maybe Text)` | `(.contentDigest)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/HaskellSourceMove.hs:41` | `SourceMove` | data | yes | `moveTransformedDigest` | `transformedDigest` | `!(Maybe Text)` | `(.transformedDigest)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:97` | `SourceLanguage` | data | yes | `declaredLanguageVersion` | `declaredLanguageVersion` | `!LanguageVersion` | `(.declaredLanguageVersion)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:98` | `SourceLanguage` | data | yes | `languageVersionLoc` | `languageVersionLoc` | `!Loc` | `(.languageVersionLoc)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:120` | `SyntaxProfile` | data | no | `profileIdentifier` | `identifier` | `!Text` | `(.identifier)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:121` | `SyntaxProfile` | data | no | `profileFeatures` | `features` | `!(Set LanguageFeature)` | `(.features)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:150` | `RuntimeSemanticsProfile` | data | no | `runtimeSemanticsIdentifier` | `identifier` | `!Text` | `(.identifier)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:151` | `RuntimeSemanticsProfile` | data | no | `runtimeSemanticsCapabilities` | `capabilities` | `!(Set RuntimeCapability)` | `(.capabilities)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:208` | `LanguageDefinition` | data | yes | `definitionVersion` | `version` | `!LanguageVersion` | `(.version)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:209` | `LanguageDefinition` | data | yes | `definitionPredecessor` | `predecessor` | `!(Maybe LanguageVersion)` | `(.predecessor)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:212` | `LanguageDefinition` | data | yes | `definitionBodyParser` | `bodyParser` | `!LanguageBodyParser` | `(.bodyParser)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:213` | `LanguageDefinition` | data | yes | `definitionSyntaxProfile` | `syntaxProfile` | `!SyntaxProfile` | `(.syntaxProfile)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:214` | `LanguageDefinition` | data | yes | `definitionRuntimeSemanticsProfile` | `runtimeSemanticsProfile` | `!RuntimeSemanticsProfile` | `(.runtimeSemanticsProfile)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:215` | `LanguageDefinition` | data | yes | `definitionSupport` | `support` | `!LanguageSupport` | `(.support)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:216` | `LanguageDefinition` | data | yes | `definitionMaturity` | `maturity` | `!LanguageMaturity` | `(.maturity)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:431` | `SourceLanguageDiagnostic` | data | yes | `sourceLanguageErrorCode` | `errorCode` | `!SourceLanguageErrorCode` | `(.errorCode)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:432` | `SourceLanguageDiagnostic` | data | yes | `sourceLanguageSource` | `source` | `!FilePath` | `(.source)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:433` | `SourceLanguageDiagnostic` | data | yes | `sourceLanguageLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:434` | `SourceLanguageDiagnostic` | data | yes | `sourceLanguageToken` | `token` | `!(Maybe Text)` | `(.token)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:435` | `SourceLanguageDiagnostic` | data | yes | `sourceLanguageDeclaredVersion` | `declaredVersion` | `!(Maybe LanguageVersion)` | `(.declaredVersion)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:436` | `SourceLanguageDiagnostic` | data | yes | `sourceLanguageSupportedVersions` | `supportedVersions` | `!(NonEmpty LanguageVersion)` | `(.supportedVersions)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:503` | `ParsedSource` | data | yes | `parsedSourceLanguage` | `sourceLanguage` | `!SourceLanguage` | `(.sourceLanguage)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs:504` | `ParsedSource` | data | yes | `parsedSpec` | `spec` | `!Spec` | `(.spec)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedCodecPlan.hs:40` | `MappedCodecPlan` | data | yes | `consumerType` | `consumerType` | `!ConsumerTypePlan` | `(.consumerType)`, pattern, or construction | serialized/wire review risk | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedCodecPlan.hs:41` | `MappedCodecPlan` | data | yes | `resolvedExpression` | `resolvedExpression` | `!ResolvedTypeExpr` | `(.resolvedExpression)`, pattern, or construction | serialized/wire review risk | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedCodecPlan.hs:42` | `MappedCodecPlan` | data | yes | `authority` | `authority` | `!(Set MappedAuthorityMode)` | `(.authority)`, pattern, or construction | serialized/wire review risk | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:25` | `ConsumerPlan` | data | yes | `consumerPackages` | `packages` | `![Text]` | `(.packages)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:26` | `ConsumerPlan` | data | yes | `consumerModules` | `modules` | `![Text]` | `(.modules)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:27` | `ConsumerPlan` | data | yes | `consumerMappings` | `mappings` | `![MappingIdentity]` | `(.mappings)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:33` | `MappingIdentity` | data | yes | `mappingSpecName` | `specName` | `!Text` | `(.specName)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:34` | `MappingIdentity` | data | yes | `mappingCanonicalType` | `canonicalType` | `!Text` | `(.canonicalType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:35` | `MappingIdentity` | data | yes | `mappingPackage` | `package` | `!Text` | `(.package)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:36` | `MappingIdentity` | data | yes | `mappingModule` | `moduleName` | `!Text` | `(.moduleName)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:37` | `MappingIdentity` | data | yes | `mappingType` | `valueType` | `!Text` | `(.valueType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:38` | `MappingIdentity` | data | yes | `mappingBindingSymbol` | `bindingSymbol` | `!Text` | `(.bindingSymbol)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:39` | `MappingIdentity` | data | yes | `mappingBindingVersion` | `bindingVersion` | `!Text` | `(.bindingVersion)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:42` | `MappingIdentity` | data | yes | `mappingSpecName` | `specName` | `!Text` | `(.specName)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:43` | `MappingIdentity` | data | yes | `mappingPackage` | `package` | `!Text` | `(.package)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:44` | `MappingIdentity` | data | yes | `mappingModule` | `moduleName` | `!Text` | `(.moduleName)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:45` | `MappingIdentity` | data | yes | `mappingType` | `valueType` | `!Text` | `(.valueType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:46` | `MappingIdentity` | data | yes | `mappingCodecIdentity` | `codecIdentity` | `!Text` | `(.codecIdentity)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:47` | `MappingIdentity` | data | yes | `mappingCodecVersion` | `codecVersion` | `!Text` | `(.codecVersion)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:50` | `MappingIdentity` | data | yes | `mappingSpecName` | `specName` | `!Text` | `(.specName)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:51` | `MappingIdentity` | data | yes | `mappingNominalCategory` | `nominalCategory` | `!Text` | `(.nominalCategory)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:52` | `MappingIdentity` | data | yes | `mappingNominalRepresentation` | `nominalRepresentation` | `!Text` | `(.nominalRepresentation)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:53` | `MappingIdentity` | data | yes | `mappingCanonicalType` | `canonicalType` | `!Text` | `(.canonicalType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:54` | `MappingIdentity` | data | yes | `mappingPackage` | `package` | `!Text` | `(.package)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:55` | `MappingIdentity` | data | yes | `mappingModule` | `moduleName` | `!Text` | `(.moduleName)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:56` | `MappingIdentity` | data | yes | `mappingType` | `valueType` | `!Text` | `(.valueType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:57` | `MappingIdentity` | data | yes | `mappingBindingSymbol` | `bindingSymbol` | `!Text` | `(.bindingSymbol)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:58` | `MappingIdentity` | data | yes | `mappingBindingVersion` | `bindingVersion` | `!Text` | `(.bindingVersion)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:59` | `MappingIdentity` | data | yes | `mappingFixtureSymbol` | `fixtureSymbol` | `!Text` | `(.fixtureSymbol)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedConsumer.hs:60` | `MappingIdentity` | data | yes | `mappingInitialSymbol` | `initialSymbol` | `!(Maybe Text)` | `(.initialSymbol)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedDiff.hs:28` | `MappedFinding` | data | yes | `mfDeclaration` | `declaration` | `!Name` | `(.declaration)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedDiff.hs:29` | `MappedFinding` | data | yes | `mfLeaf` | `leaf` | `!Text` | `(.leaf)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedDiff.hs:30` | `MappedFinding` | data | yes | `mfCode` | `code` | `!DiagnosticCode` | `(.code)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedDiff.hs:31` | `MappedFinding` | data | yes | `mfDetail` | `detail` | `!Text` | `(.detail)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedDiff.hs:32` | `MappedFinding` | data | yes | `mfUsePaths` | `usePaths` | `![UsePath]` | `(.usePaths)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/MappedDiff.hs:33` | `MappedFinding` | data | yes | `mfOldUnknownFields` | `oldUnknownFields` | `!(Maybe UnknownFields)` | `(.oldUnknownFields)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/NominalType.hs:81` | `CheckedNominalEquality` | data | yes | `equalityKeyRepresentation` | `keyRepresentation` | `!NominalEqualityKey` | `(.keyRepresentation)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/NominalType.hs:82` | `CheckedNominalEquality` | data | yes | `equalityDomain` | `domain` | `!NominalEqualityDomain` | `(.domain)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/NominalType.hs:83` | `CheckedNominalEquality` | data | yes | `equalityContractVersion` | `contractVersion` | `!Text` | `(.contractVersion)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/NominalType.hs:88` | `ConsumerNominalBinding` | data | yes | `consumerNominalHaskell` | `haskell` | `!HaskellSource` | `(.haskell)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/NominalType.hs:89` | `ConsumerNominalBinding` | data | yes | `consumerNominalBinding` | `binding` | `!QualifiedValueName` | `(.binding)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/NominalType.hs:90` | `ConsumerNominalBinding` | data | yes | `consumerNominalBindingVersion` | `bindingVersion` | `!BindingVersion` | `(.bindingVersion)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/NominalType.hs:91` | `ConsumerNominalBinding` | data | yes | `consumerNominalCanonical` | `canonical` | `!CanonicalTypeId` | `(.canonical)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/NominalType.hs:92` | `ConsumerNominalBinding` | data | yes | `consumerNominalFixtures` | `fixtures` | `!QualifiedValueName` | `(.fixtures)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/NominalType.hs:93` | `ConsumerNominalBinding` | data | yes | `consumerNominalInitial` | `initial` | `!(Maybe QualifiedValueName)` | `(.initial)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/NominalType.hs:103` | `ResolvedNominalType` | data | yes | `resolvedNominalName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/NominalType.hs:104` | `ResolvedNominalType` | data | yes | `resolvedNominalRepresentation` | `representation` | `!NominalRepresentation` | `(.representation)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/NominalType.hs:105` | `ResolvedNominalType` | data | yes | `resolvedNominalOwnership` | `ownership` | `!NominalOwnership` | `(.ownership)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/NominalType.hs:106` | `ResolvedNominalType` | data | yes | `resolvedNominalLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Parser/Core.hs:75` | `ContextualParseFailure` | data | no | `contextualFailureCode` | `code` | `!SourceLanguageErrorCode` | `(.code)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Parser/Core.hs:76` | `ContextualParseFailure` | data | no | `contextualFailureFeature` | `feature` | `!(Maybe LanguageFeature)` | `(.feature)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Parser/Core.hs:77` | `ContextualParseFailure` | data | no | `contextualFailureSpan` | `span` | `!SourceSpan` | `(.span)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Parser/Preamble.hs:60` | `InitialLanguageClause` | data | no | `initialLanguageSpan` | `span` | `!SourceSpan` | `(.span)`, pattern, or construction | Haskell API and runtime semantics | `none` |+| `keiro-dsl/src/Keiro/Dsl/Parser/Preamble.hs:61` | `InitialLanguageClause` | data | no | `initialLanguageText` | `text` | `!Text` | `(.text)`, pattern, or construction | Haskell API and runtime semantics | `none` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:39` | `ProjectionMappedRoot` | data | yes | `consumer` | `consumer` | `!DerivedMappedConsumer` | `(.consumer)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:40` | `ProjectionMappedRoot` | data | yes | `declaration` | `declaration` | `!MappedKey` | `(.declaration)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:41` | `ProjectionMappedRoot` | data | yes | `path` | `path` | `!UsePath` | `(.path)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:49` | `ProjectionOperationalImpact` | data | yes | `consumer` | `consumer` | `!DerivedMappedConsumer` | `(.consumer)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:50` | `ProjectionOperationalImpact` | data | yes | `group` | `group` | `!(Maybe Name)` | `(.group)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:51` | `ProjectionOperationalImpact` | data | yes | `targets` | `targets` | `!(Set Name)` | `(.targets)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:52` | `ProjectionOperationalImpact` | data | yes | `readModels` | `readModels` | `!(Set Name)` | `(.readModels)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:53` | `ProjectionOperationalImpact` | data | yes | `replayable` | `replayable` | `!Bool` | `(.replayable)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:54` | `ProjectionOperationalImpact` | data | yes | `sourceFingerprint` | `sourceFingerprint` | `!Text` | `(.sourceFingerprint)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:62` | `UnsupportedProjectionImpact` | data | yes | `source` | `source` | `!UnsupportedProjectionSource` | `(.source)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:63` | `UnsupportedProjectionImpact` | data | yes | `group` | `group` | `!Name` | `(.group)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:64` | `UnsupportedProjectionImpact` | data | yes | `targets` | `targets` | `!(Set Name)` | `(.targets)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:65` | `UnsupportedProjectionImpact` | data | yes | `readModels` | `readModels` | `!(Set Name)` | `(.readModels)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:66` | `UnsupportedProjectionImpact` | data | yes | `replayable` | `replayable` | `!Bool` | `(.replayable)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:71` | `ProjectionMappedImpact` | data | yes | `roots` | `roots` | `![ProjectionMappedRoot]` | `(.roots)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:72` | `ProjectionMappedImpact` | data | yes | `consumers` | `consumers` | `!(Map MappedKey (Set DerivedMappedConsumer))` | `(.consumers)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:73` | `ProjectionMappedImpact` | data | yes | `operations` | `operations` | `!(Map DerivedMappedConsumer ProjectionOperationalImpact)` | `(.operations)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionMappedImpact.hs:74` | `ProjectionMappedImpact` | data | yes | `unsupported` | `unsupported` | `![UnsupportedProjectionImpact]` | `(.unsupported)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionSupply.hs:21` | `ResolvedProjectionSupply` | data | yes | `supplyQueryModel` | `queryModel` | `!Name` | `(.queryModel)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionSupply.hs:22` | `ResolvedProjectionSupply` | data | yes | `supplyProjectionOwner` | `projectionOwner` | `!Name` | `(.projectionOwner)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionSupply.hs:23` | `ResolvedProjectionSupply` | data | yes | `supplyRebuildGroup` | `rebuildGroup` | `!Name` | `(.rebuildGroup)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionSupply.hs:24` | `ResolvedProjectionSupply` | data | yes | `supplyObservedTargets` | `observedTargets` | `!(NonEmpty Name)` | `(.observedTargets)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionSupply.hs:25` | `ResolvedProjectionSupply` | data | yes | `supplyQueryLoc` | `queryLoc` | `!Loc` | `(.queryLoc)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionSupply.hs:26` | `ResolvedProjectionSupply` | data | yes | `supplyOwnerLoc` | `ownerLoc` | `!Loc` | `(.ownerLoc)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionSupply.hs:46` | `ProjectionSupplyAnalysis` | data | yes | `resolvedProjectionSupplies` | `resolvedProjectionSupplies` | `![ResolvedProjectionSupply]` | `(.resolvedProjectionSupplies)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ProjectionSupply.hs:47` | `ProjectionSupplyAnalysis` | data | yes | `projectionSupplyIssues` | `projectionSupplyIssues` | `![ProjectionSupplyIssue]` | `(.projectionSupplyIssues)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ReadModelQueryContract.hs:35` | `QueryContractIdentity` | data | yes | `qciReadModel` | `readModel` | `!Name` | `(.readModel)`, pattern, or construction | serialized/wire review risk | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ReadModelQueryContract.hs:36` | `QueryContractIdentity` | data | yes | `qciPosition` | `position` | `!QueryContractPosition` | `(.position)`, pattern, or construction | serialized/wire review risk | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ReadModelQueryContract.hs:37` | `QueryContractIdentity` | data | yes | `qciTypeExpression` | `typeExpression` | `!Text` | `(.typeExpression)`, pattern, or construction | serialized/wire review risk | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ReadModelQueryContract.hs:38` | `QueryContractIdentity` | data | yes | `qciMappedDependencies` | `mappedDependencies` | `![Name]` | `(.mappedDependencies)`, pattern, or construction | serialized/wire review risk | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ReadModelQueryContract.hs:43` | `QueryContractDrift` | data | yes | `qcdKey` | `key` | `!(Name, QueryContractPosition)` | `(.key)`, pattern, or construction | serialized/wire review risk | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ReadModelQueryContract.hs:44` | `QueryContractDrift` | data | yes | `qcdPrevious` | `previous` | `!(Maybe QueryContractIdentity)` | `(.previous)`, pattern, or construction | serialized/wire review risk | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ReadModelQueryContract.hs:45` | `QueryContractDrift` | data | yes | `qcdCurrent` | `current` | `!(Maybe QueryContractIdentity)` | `(.current)`, pattern, or construction | serialized/wire review risk | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ReplayImpact.hs:46` | `AggregateImpact` | data | yes | `eventTypes` | `eventTypes` | `!(Set Name)` | `(.eventTypes)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ReplayImpact.hs:47` | `AggregateImpact` | data | yes | `includeSnapshotStreams` | `includeSnapshotStreams` | `!Bool` | `(.includeSnapshotStreams)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ReplayImpact.hs:62` | `CatalogReplayImpact` | data | yes | `affectedGroups` | `affectedGroups` | `!(Set Name)` | `(.affectedGroups)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ReplayImpact.hs:63` | `CatalogReplayImpact` | data | yes | `affectedTargets` | `affectedTargets` | `!(Set Name)` | `(.affectedTargets)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ReplayImpact.hs:64` | `CatalogReplayImpact` | data | yes | `affectedSources` | `affectedSources` | `!(Set Text)` | `(.affectedSources)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ReplayImpact.hs:65` | `CatalogReplayImpact` | data | yes | `affectedAdapters` | `affectedAdapters` | `!(Set Name)` | `(.affectedAdapters)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ReplayImpact.hs:66` | `CatalogReplayImpact` | data | yes | `invalidatesRunningFingerprint` | `invalidatesRunningFingerprint` | `!Bool` | `(.invalidatesRunningFingerprint)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ReplayImpact.hs:207` | `ReplaySurfaceContext` | data | no | `surfaceSpec` | `spec` | `!Spec` | `(.spec)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/ReplayImpact.hs:208` | `ReplaySurfaceContext` | data | no | `surfaceGraphResult` | `graphResult` | `Either (NE.NonEmpty TypeGraphError) TypeGraph` | `(.graphResult)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/ReplayImpact.hs:209` | `ReplaySurfaceContext` | data | no | `surfaceSymbols` | `symbols` | `AggregateSymbols` | `(.symbols)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:52` | `CheckedReadModelQuery` | data | yes | `checkedQueryName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:53` | `CheckedReadModelQuery` | data | yes | `checkedQueryInputType` | `inputType` | `!ResolvedTypeExpr` | `(.inputType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:54` | `CheckedReadModelQuery` | data | yes | `checkedQueryResultType` | `resultType` | `!ResolvedTypeExpr` | `(.resultType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:59` | `CheckedMappedExpr` | data | yes | `checkedMappedExprRoot` | `root` | `!SelectionRoot` | `(.root)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:60` | `CheckedMappedExpr` | data | yes | `checkedMappedExprType` | `valueType` | `!ResolvedTypeExpr` | `(.valueType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:65` | `CheckedMappedType` | data | yes | `checkedMappedTypeKey` | `key` | `!MappedKey` | `(.key)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:66` | `CheckedMappedType` | data | yes | `checkedMappedTypeConstructor` | `constructor` | `!Name` | `(.constructor)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:67` | `CheckedMappedType` | data | yes | `checkedMappedTypeFields` | `fields` | `![ResolvedWireField]` | `(.fields)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:84` | `CheckedSelectionPathSegment` | data | yes | `checkedPathField` | `field` | `!Name` | `(.field)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:85` | `CheckedSelectionPathSegment` | data | yes | `checkedPathWireKey` | `wireKey` | `!Text` | `(.wireKey)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:86` | `CheckedSelectionPathSegment` | data | yes | `checkedPathOwner` | `owner` | `!MappedKey` | `(.owner)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:91` | `CheckedScalarExpr` | data | yes | `checkedScalarType` | `valueType` | `!SelectionScalarType` | `(.valueType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:92` | `CheckedScalarExpr` | data | yes | `checkedScalarNode` | `node` | `!CheckedScalarNode` | `(.node)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:93` | `CheckedScalarExpr` | data | yes | `checkedScalarLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:133` | `CheckedRouterSelection` | data | yes | `checkedIdentity` | `identity` | `!Text` | `(.identity)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:134` | `CheckedRouterSelection` | data | yes | `checkedVersion` | `version` | `!Natural` | `(.version)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:135` | `CheckedRouterSelection` | data | yes | `checkedQuery` | `query` | `!CheckedReadModelQuery` | `(.query)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:136` | `CheckedRouterSelection` | data | yes | `checkedInputBinding` | `inputBinding` | `!CheckedMappedExpr` | `(.inputBinding)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:137` | `CheckedRouterSelection` | data | yes | `checkedRowBinding` | `rowBinding` | `!CheckedMappedType` | `(.rowBinding)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:138` | `CheckedRouterSelection` | data | yes | `checkedKey` | `key` | `!CheckedScalarExpr` | `(.key)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:139` | `CheckedRouterSelection` | data | yes | `checkedPredicate` | `predicate` | `!CheckedScalarExpr` | `(.predicate)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:140` | `CheckedRouterSelection` | data | yes | `checkedRecipient` | `recipient` | `!CheckedScalarExpr` | `(.recipient)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:141` | `CheckedRouterSelection` | data | yes | `checkedCommandFields` | `commandFields` | `!(Map Name CheckedScalarExpr)` | `(.commandFields)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:142` | `CheckedRouterSelection` | data | yes | `checkedTarget` | `target` | `!Name` | `(.target)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:143` | `CheckedRouterSelection` | data | yes | `checkedCommand` | `command` | `!Name` | `(.command)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:144` | `CheckedRouterSelection` | data | yes | `checkedLimit` | `limit` | `!Natural` | `(.limit)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:145` | `CheckedRouterSelection` | data | yes | `checkedOrder` | `order` | `!CheckedSelectionOrder` | `(.order)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:146` | `CheckedRouterSelection` | data | yes | `checkedDedupe` | `dedupe` | `!CheckedSelectionDedupe` | `(.dedupe)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:147` | `CheckedRouterSelection` | data | yes | `checkedEmptyPolicy` | `emptyPolicy` | `!CheckedEmptySelectionPolicy` | `(.emptyPolicy)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:148` | `CheckedRouterSelection` | data | yes | `checkedFailurePolicy` | `failurePolicy` | `!CheckedSelectionFailurePolicy` | `(.failurePolicy)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:149` | `CheckedRouterSelection` | data | yes | `checkedRedeliveryPolicy` | `redeliveryPolicy` | `!CheckedRedeliveryPolicy` | `(.redeliveryPolicy)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:150` | `CheckedRouterSelection` | data | yes | `checkedPartialPolicy` | `partialPolicy` | `!CheckedPartialDispatchPolicy` | `(.partialPolicy)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:151` | `CheckedRouterSelection` | data | yes | `checkedFingerprint` | `fingerprint` | `!Text` | `(.fingerprint)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:152` | `CheckedRouterSelection` | data | yes | `checkedUseSites` | `useSites` | `![UseSite]` | `(.useSites)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:189` | `RouterSelectionDiagnostic` | data | yes | `selectionDiagnosticLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:190` | `RouterSelectionDiagnostic` | data | yes | `selectionDiagnosticCode` | `code` | `!RouterSelectionDiagnosticCode` | `(.code)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RouterSelection.hs:191` | `RouterSelectionDiagnostic` | data | yes | `selectionDiagnosticMessage` | `message` | `!Text` | `(.message)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/RuntimePackage.hs:18` | `RuntimePackageName` | newtype | yes | `unRuntimePackageName` | `unRuntimePackageName` | `Text` | explicit `unRuntimePackageName` positional function | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:153` | `ScaffoldModule` | data | yes | `modulePath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:154` | `ScaffoldModule` | data | yes | `moduleText` | `text` | `!Text` | `(.text)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:155` | `ScaffoldModule` | data | yes | `kind` | `kind` | `!ModuleKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:156` | `ScaffoldModule` | data | yes | `origin` | `origin` | `!Text` | `(.origin)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:164` | `ModuleRole` | data | yes | `roleOwnerKind` | `ownerKind` | `!Text` | `(.ownerKind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:165` | `ModuleRole` | data | yes | `roleOwnerName` | `ownerName` | `!Text` | `(.ownerName)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:166` | `ModuleRole` | data | yes | `roleFamily` | `family` | `!Text` | `(.family)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:197` | `Context` | data | yes | `contextName` | `name` | `!Text` | `(.name)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:199` | `Context` | data | yes | `moduleRoot` | `moduleRoot` | `!Text` | `(.moduleRoot)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:201` | `Context` | data | yes | `placement` | `placement` | `!Placement` | `(.placement)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:209` | `NominalUseSite` | data | yes | `nominalUseAggregate` | `aggregate` | `!Name` | `(.aggregate)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:210` | `NominalUseSite` | data | yes | `nominalUseKind` | `kind` | `!AggregateUseSite` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:218` | `NominalGenerationOwner` | data | yes | `nominalDeclaration` | `declaration` | `!ResolvedNominalType` | `(.declaration)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:219` | `NominalGenerationOwner` | data | yes | `nominalModule` | `moduleName` | `!Text` | `(.moduleName)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:220` | `NominalGenerationOwner` | data | yes | `nominalUseSites` | `useSites` | `!(Set.Set NominalUseSite)` | `(.useSites)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:221` | `NominalGenerationOwner` | data | yes | `nominalEqualityUsed` | `equalityUsed` | `!Bool` | `(.equalityUsed)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:333` | `FirewallSurface` | data | yes | `forbiddenSymbolic` | `forbiddenSymbolic` | `![Text]` | `(.forbiddenSymbolic)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:334` | `FirewallSurface` | data | yes | `forbiddenIdents` | `forbiddenIdents` | `![Text]` | `(.forbiddenIdents)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:335` | `FirewallSurface` | data | yes | `forbiddenQualifiers` | `forbiddenQualifiers` | `![Text]` | `(.forbiddenQualifiers)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:336` | `FirewallSurface` | data | yes | `forbiddenImports` | `forbiddenImports` | `![Text]` | `(.forbiddenImports)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:337` | `FirewallSurface` | data | yes | `restrictedImports` | `restrictedImports` | `![(Text, [Text])]` | `(.restrictedImports)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:488` | `Agg` | data | yes | `aContext` | `context` | `!Context` | `(.context)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:489` | `Agg` | data | yes | `aCheckedService` | `checkedService` | `!CheckedService` | `(.checkedService)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:490` | `Agg` | data | yes | `aLanguageContract` | `languageContract` | `!EffectiveLanguageContract` | `(.languageContract)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:491` | `Agg` | data | yes | `aSpec` | `spec` | `!Spec` | `(.spec)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:492` | `Agg` | data | yes | `aAggregate` | `aggregate` | `!Aggregate` | `(.aggregate)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:493` | `Agg` | data | yes | `aCtxPascal` | `ctxPascal` | `!Text` | `(.ctxPascal)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:494` | `Agg` | data | yes | `aName` | `name` | `!Text` | `(.name)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:495` | `Agg` | data | yes | `aLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:496` | `Agg` | data | yes | `aVertexType` | `vertexType` | `!Text` | `(.vertexType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:497` | `Agg` | data | yes | `aIds` | `ids` | `![IdDecl]` | `(.ids)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:498` | `Agg` | data | yes | `aEnums` | `enums` | `![EnumDecl]` | `(.enums)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:499` | `Agg` | data | yes | `aRegs` | `regs` | `![ResolvedRegister]` | `(.regs)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:500` | `Agg` | data | yes | `aStates` | `states` | `![StateDecl]` | `(.states)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:501` | `Agg` | data | yes | `aCommands` | `commands` | `![ResolvedCtor]` | `(.commands)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:502` | `Agg` | data | yes | `aEvents` | `events` | `![ResolvedCtor]` | `(.events)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:503` | `Agg` | data | yes | `aDomainOutcomeTypes` | `domainOutcomeTypes` | `!(Maybe ResolvedDomainOutcomeTypes)` | `(.domainOutcomeTypes)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:505` | `Agg` | data | yes | `aGeneratedNominals` | `generatedNominals` | `![ResolvedNominalType]` | `(.generatedNominals)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:506` | `Agg` | data | yes | `aTransitions` | `transitions` | `![Transition]` | `(.transitions)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:507` | `Agg` | data | yes | `aOutputMappings` | `outputMappings` | `!(Map.Map (Int, Int) EventOutputMapping)` | `(.outputMappings)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:508` | `Agg` | data | yes | `aWire` | `wire` | `!WireSpec` | `(.wire)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:509` | `Agg` | data | yes | `aProjection` | `projection` | `!(Maybe ProjectionSpec)` | `(.projection)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:510` | `Agg` | data | yes | `aSnapshot` | `snapshot` | `!(Maybe SnapshotSpec)` | `(.snapshot)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:511` | `Agg` | data | yes | `aFoldFingerprint` | `foldFingerprint` | `!Text` | `(.foldFingerprint)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:512` | `Agg` | data | yes | `aReadModels` | `readModels` | `![ReadModelNode]` | `(.readModels)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:513` | `Agg` | data | yes | `aTypeGraph` | `typeGraph` | `!(Maybe TypeGraph)` | `(.typeGraph)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:514` | `Agg` | data | yes | `aSymbols` | `symbols` | `!AggregateSymbols` | `(.symbols)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:516` | `Agg` | data | yes | `aGenPrefix` | `genPrefix` | `!Text` | `(.genPrefix)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:518` | `Agg` | data | yes | `aHolePrefix` | `holePrefix` | `!Text` | `(.holePrefix)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:522` | `ResolvedDomainOutcomeTypes` | data | yes | `resolvedRejectionType` | `rejectionType` | `!ResolvedAggregateType` | `(.rejectionType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:523` | `ResolvedDomainOutcomeTypes` | data | yes | `resolvedNoOpType` | `noOpType` | `!ResolvedAggregateType` | `(.noOpType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:531` | `ResolvedRegister` | data | yes | `rrName` | `name` | `!Name` | `(.name)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:532` | `ResolvedRegister` | data | yes | `rrType` | `valueType` | `!ResolvedAggregateType` | `(.valueType)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:533` | `ResolvedRegister` | data | yes | `rrInitial` | `initial` | `!ResolvedRegisterInitial` | `(.initial)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:534` | `ResolvedRegister` | data | yes | `rrLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:541` | `ResolvedCtor` | data | yes | `rcName` | `name` | `!Text` | `(.name)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:543` | `ResolvedCtor` | data | yes | `rcFields` | `fields` | `![(ResolvedFieldIdentity, ResolvedAggregateType)]` | `(.fields)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:545` | `ResolvedCtor` | data | yes | `rcVersion` | `version` | `!Int` | `(.version)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:547` | `ResolvedCtor` | data | yes | `rcUpcastFrom` | `upcastFrom` | `!(Maybe Int)` | `(.upcastFrom)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:2155` | `RenderedShapeType` | data | no | `renderedShapeTypePrecedence` | `precedence` | `!ShapeTypePrecedence` | `(.precedence)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:2156` | `RenderedShapeType` | data | no | `renderedShapeTypeText` | `text` | `!Text` | `(.text)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:2171` | `StructuralProjection` | data | yes | `spTag` | `tag` | `!Text` | `(.tag)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:2172` | `StructuralProjection` | data | yes | `spWitness` | `witness` | `!Text` | `(.witness)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:2173` | `StructuralProjection` | data | yes | `spPointer` | `pointer` | `!Text` | `(.pointer)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:2174` | `StructuralProjection` | data | yes | `spOwner` | `owner` | `!HaskellSource` | `(.owner)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:2175` | `StructuralProjection` | data | yes | `spResult` | `result` | `!Text` | `(.result)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:2176` | `StructuralProjection` | data | yes | `spCanonical` | `canonical` | `!CanonicalTypeId` | `(.canonical)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:2177` | `StructuralProjection` | data | yes | `spBinding` | `binding` | `!QualifiedValueName` | `(.binding)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:2178` | `StructuralProjection` | data | yes | `spSelectors` | `selectors` | `![(Text, Text)]` | `(.selectors)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:3638` | `ResolvedQueueField` | data | no | `resolvedQueueField` | `field` | `!WqField` | `(.field)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:3639` | `ResolvedQueueField` | data | no | `resolvedQueueExpression` | `expression` | `!(Maybe ResolvedTypeExpr)` | `(.expression)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:3640` | `ResolvedQueueField` | data | no | `resolvedQueueCodecPlan` | `codecPlan` | `!(Maybe MappedCodecPlan)` | `(.codecPlan)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:6857` | `ResolvedGeneratedTransition` | data | no | `resolvedTransitionIndex` | `index` | `!Int` | `(.index)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:6858` | `ResolvedGeneratedTransition` | data | no | `resolvedTransitionSource` | `source` | `!Transition` | `(.source)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:6859` | `ResolvedGeneratedTransition` | data | no | `resolvedTransitionGuard` | `guard` | `!(Maybe TypedScalarExpr)` | `(.guard)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:6860` | `ResolvedGeneratedTransition` | data | no | `resolvedTransitionWrites` | `writes` | `![(Name, TypedScalarExpr)]` | `(.writes)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:6868` | `ResolvedSilentOutcome` | data | no | `resolvedSilentLayout` | `layout` | `!TransitionLayoutEntry` | `(.layout)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:6869` | `ResolvedSilentOutcome` | data | no | `resolvedSilentKind` | `kind` | `!SilentOutcomeKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:6870` | `ResolvedSilentOutcome` | data | no | `resolvedSilentReason` | `reason` | `!TypedScalarExpr` | `(.reason)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:7006` | `ProjectionAlias` | data | no | `projectionAliasTarget` | `target` | `!ProjectionAliasTarget` | `(.target)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:7007` | `ProjectionAlias` | data | no | `projectionAliasName` | `name` | `!Text` | `(.name)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:7083` | `RenderedKeikiExpr` | data | no | `renderedKeikiText` | `text` | `!Text` | `(.text)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Scaffold.hs:7084` | `RenderedKeikiExpr` | data | no | `renderedKeikiPrecedence` | `precedence` | `!Int` | `(.precedence)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:42` | `ScaffoldRecord` | data | yes | `recSpecPath` | `specPath` | `!Text` | `(.specPath)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:43` | `ScaffoldRecord` | data | yes | `recModuleRoot` | `moduleRoot` | `!Text` | `(.moduleRoot)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:44` | `ScaffoldRecord` | data | yes | `recLayout` | `layout` | `!Text` | `(.layout)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:45` | `ScaffoldRecord` | data | yes | `recSourceLanguage` | `sourceLanguage` | `!SourceLanguage` | `(.sourceLanguage)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:46` | `ScaffoldRecord` | data | yes | `recLanguageContract` | `languageContract` | `!EffectiveLanguageContract` | `(.languageContract)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:47` | `ScaffoldRecord` | data | yes | `recNamingEdition` | `namingEdition` | `!GeneratedHaskellNamingEdition` | `(.namingEdition)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:48` | `ScaffoldRecord` | data | yes | `recModuleRoles` | `moduleRoles` | `![ScaffoldModuleRoleRow]` | `(.moduleRoles)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:49` | `ScaffoldRecord` | data | yes | `recFiles` | `files` | `![(ModuleKind, FilePath)]` | `(.files)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:50` | `ScaffoldRecord` | data | yes | `recMappings` | `mappings` | `![MappingIdentity]` | `(.mappings)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:51` | `ScaffoldRecord` | data | yes | `recIdDomains` | `idDomains` | `![Text]` | `(.idDomains)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:52` | `ScaffoldRecord` | data | yes | `recNominalEqualities` | `nominalEqualities` | `![Text]` | `(.nominalEqualities)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:53` | `ScaffoldRecord` | data | yes | `recBindingObligations` | `bindingObligations` | `![BindingHole]` | `(.bindingObligations)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:54` | `ScaffoldRecord` | data | yes | `recBehaviorRequirements` | `behaviorRequirements` | `![BehaviorRecordRow]` | `(.behaviorRequirements)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:55` | `ScaffoldRecord` | data | yes | `recProjectionCatalogFacts` | `projectionCatalogFacts` | `![Text]` | `(.projectionCatalogFacts)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:56` | `ScaffoldRecord` | data | yes | `recQueryContractBaseline` | `queryContractBaseline` | `!Bool` | `(.queryContractBaseline)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:57` | `ScaffoldRecord` | data | yes | `recQueryContracts` | `queryContracts` | `![QueryContractIdentity]` | `(.queryContracts)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:58` | `ScaffoldRecord` | data | yes | `recRouterSelections` | `routerSelections` | `![RouterSelectionSnapshot]` | `(.routerSelections)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:59` | `ScaffoldRecord` | data | yes | `recSemanticImpact` | `semanticImpact` | `!(Maybe SemanticImpactSnapshot)` | `(.semanticImpact)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:64` | `ScaffoldModuleRoleRow` | data | yes | `srrRole` | `role` | `!ModuleRole` | `(.role)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:65` | `ScaffoldModuleRoleRow` | data | yes | `srrKind` | `kind` | `!ModuleKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRecord.hs:66` | `ScaffoldModuleRoleRow` | data | yes | `srrPath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:195` | `GeneratedHaskellEditionUse` | data | yes | `path` | `path` | `!FilePath` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:196` | `GeneratedHaskellEditionUse` | data | yes | `line` | `line` | `!Int` | `(.line)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:197` | `GeneratedHaskellEditionUse` | data | yes | `current` | `current` | `!Text` | `(.current)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:198` | `GeneratedHaskellEditionUse` | data | yes | `replacement` | `replacement` | `!Text` | `(.replacement)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:199` | `GeneratedHaskellEditionUse` | data | yes | `form` | `form` | `!HoleUseForm` | `(.form)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:212` | `GeneratedHaskellEditionImpact` | data | yes | `fromEdition` | `fromEdition` | `!HaskellName.GeneratedHaskellNamingEdition` | `(.fromEdition)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:213` | `GeneratedHaskellEditionImpact` | data | yes | `generatedPaths` | `generatedPaths` | `![FilePath]` | `(.generatedPaths)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:214` | `GeneratedHaskellEditionImpact` | data | yes | `sidecarPaths` | `sidecarPaths` | `![FilePath]` | `(.sidecarPaths)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:215` | `GeneratedHaskellEditionImpact` | data | yes | `handOwnedUses` | `handOwnedUses` | `![GeneratedHaskellEditionUse]` | `(.handOwnedUses)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:220` | `PreparedGeneratedHaskellEditionMigration` | data | no | `impact` | `impact` | `!GeneratedHaskellEditionImpact` | `(.impact)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:221` | `PreparedGeneratedHaskellEditionMigration` | data | no | `backups` | `backups` | `![(FilePath, FilePath)]` | `(.backups)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:222` | `PreparedGeneratedHaskellEditionMigration` | data | no | `reportPath` | `reportPath` | `!FilePath` | `(.reportPath)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:223` | `PreparedGeneratedHaskellEditionMigration` | data | no | `reportText` | `reportText` | `!Text` | `(.reportText)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:224` | `PreparedGeneratedHaskellEditionMigration` | data | no | `sourceMoves` | `sourceMoves` | `![SourceMove]` | `(.sourceMoves)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:245` | `GeneratedArtifactImpact` | data | yes | `artifactCategory` | `category` | `!GeneratedArtifactCategory` | `(.category)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:246` | `GeneratedArtifactImpact` | data | yes | `artifactRole` | `role` | `!ModuleRole` | `(.role)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:247` | `GeneratedArtifactImpact` | data | yes | `artifactPath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:248` | `GeneratedArtifactImpact` | data | yes | `artifactDisposition` | `disposition` | `!WriteDisposition` | `(.disposition)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:258` | `StaleModule` | data | yes | `staleKind` | `kind` | `!ModuleKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:259` | `StaleModule` | data | yes | `stalePath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:260` | `StaleModule` | data | yes | `staleGeneratedEvidence` | `generatedEvidence` | `!(Maybe StaleGeneratedEvidence)` | `(.generatedEvidence)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:265` | `MappingDrift` | data | yes | `driftSpecName` | `specName` | `!Text` | `(.specName)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:266` | `MappingDrift` | data | yes | `driftPrevious` | `previous` | `!(Maybe MappingIdentity)` | `(.previous)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:267` | `MappingDrift` | data | yes | `driftCurrent` | `current` | `!(Maybe MappingIdentity)` | `(.current)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:272` | `SourceLanguageDrift` | data | yes | `languageDriftPrevious` | `previous` | `!SourceLanguage` | `(.previous)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:273` | `SourceLanguageDrift` | data | yes | `languageDriftCurrent` | `current` | `!SourceLanguage` | `(.current)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:278` | `ScaffoldReport` | data | yes | `reportSpecPath` | `specPath` | `!FilePath` | `(.specPath)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:279` | `ScaffoldReport` | data | yes | `reportOutDir` | `outDir` | `!FilePath` | `(.outDir)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:280` | `ScaffoldReport` | data | yes | `reportContext` | `context` | `!Context` | `(.context)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:281` | `ScaffoldReport` | data | yes | `reportDispositions` | `dispositions` | `![(ScaffoldModule, WriteDisposition)]` | `(.dispositions)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:282` | `ScaffoldReport` | data | yes | `reportInertNodes` | `inertNodes` | `![(Text, Text)]` | `(.inertNodes)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:283` | `ScaffoldReport` | data | yes | `reportManifestPath` | `manifestPath` | `!FilePath` | `(.manifestPath)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:284` | `ScaffoldReport` | data | yes | `reportRecordPath` | `recordPath` | `!FilePath` | `(.recordPath)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:285` | `ScaffoldReport` | data | yes | `reportPreviousSpecPath` | `previousSpecPath` | `!(Maybe Text)` | `(.previousSpecPath)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:286` | `ScaffoldReport` | data | yes | `reportStale` | `stale` | `![StaleModule]` | `(.stale)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:287` | `ScaffoldReport` | data | yes | `reportConsumerPlan` | `consumerPlan` | `!ConsumerPlan` | `(.consumerPlan)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:288` | `ScaffoldReport` | data | yes | `reportConstraintPlan` | `constraintPlan` | `![Text]` | `(.constraintPlan)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:289` | `ScaffoldReport` | data | yes | `reportMappingDrift` | `mappingDrift` | `![MappingDrift]` | `(.mappingDrift)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:290` | `ScaffoldReport` | data | yes | `reportQueryContractBaselineUnavailable` | `queryContractBaselineUnavailable` | `!Bool` | `(.queryContractBaselineUnavailable)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:291` | `ScaffoldReport` | data | yes | `reportQueryContractDrift` | `queryContractDrift` | `![QueryContractDrift]` | `(.queryContractDrift)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:292` | `ScaffoldReport` | data | yes | `reportQueryContractMigrations` | `queryContractMigrations` | `![QueryContractMigration]` | `(.queryContractMigrations)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:293` | `ScaffoldReport` | data | yes | `reportSemanticImpact` | `semanticImpact` | `!SemanticImpactReport` | `(.semanticImpact)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:294` | `ScaffoldReport` | data | yes | `reportRouterSelectionDrift` | `routerSelectionDrift` | `![RouterSelectionDrift]` | `(.routerSelectionDrift)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:295` | `ScaffoldReport` | data | yes | `reportProjectionMappedImpact` | `projectionMappedImpact` | `!(Maybe ProjectionMappedImpact)` | `(.projectionMappedImpact)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:296` | `ScaffoldReport` | data | yes | `reportGeneratedArtifactImpact` | `generatedArtifactImpact` | `![GeneratedArtifactImpact]` | `(.generatedArtifactImpact)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:297` | `ScaffoldReport` | data | yes | `reportSourceLanguageDrift` | `sourceLanguageDrift` | `!(Maybe SourceLanguageDrift)` | `(.sourceLanguageDrift)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:298` | `ScaffoldReport` | data | yes | `reportNewHoles` | `newHoles` | `![BindingHole]` | `(.newHoles)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:299` | `ScaffoldReport` | data | yes | `reportAddedBehavior` | `addedBehavior` | `![BehaviorRecordRow]` | `(.addedBehavior)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:300` | `ScaffoldReport` | data | yes | `reportRemovedBehavior` | `removedBehavior` | `![BehaviorRecordRow]` | `(.removedBehavior)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:301` | `ScaffoldReport` | data | yes | `reportObsoleteOutputHooks` | `obsoleteOutputHooks` | `![(Text, Text)]` | `(.obsoleteOutputHooks)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:302` | `ScaffoldReport` | data | yes | `reportConformancePackage` | `conformancePackage` | `!(Maybe ConformancePackageReport)` | `(.conformancePackage)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:303` | `ScaffoldReport` | data | yes | `reportNameMoves` | `nameMoves` | `![SourceMove]` | `(.nameMoves)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:304` | `ScaffoldReport` | data | yes | `reportSidecarMoves` | `sidecarMoves` | `![SidecarMove]` | `(.sidecarMoves)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:309` | `QueryContractMigration` | data | yes | `qcmOwner` | `owner` | `!Text` | `(.owner)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:310` | `QueryContractMigration` | data | yes | `path` | `path` | `!FilePath` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/ScaffoldRun.hs:311` | `QueryContractMigration` | data | yes | `qcmRequiredImport` | `requiredImport` | `!Text` | `(.requiredImport)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticContract.hs:63` | `EffectiveLanguageContract` | data | yes | `effectiveContractLanguageVersion` | `contractLanguageVersion` | `!LanguageVersion` | `(.contractLanguageVersion)`, pattern, or construction | serialized/wire review risk | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticContract.hs:64` | `EffectiveLanguageContract` | data | yes | `effectiveRuntimeProfile` | `runtimeProfile` | `!RuntimeSemanticsProfile` | `(.runtimeProfile)`, pattern, or construction | serialized/wire review risk | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticContract.hs:160` | `CheckedService` | data | no | `serviceLanguageContract` | `languageContract` | `!EffectiveLanguageContract` | `(.languageContract)`, pattern, or construction | serialized/wire review risk | `none` |+| `keiro-dsl/src/Keiro/Dsl/SemanticContract.hs:161` | `CheckedService` | data | no | `serviceSpec` | `spec` | `!Spec` | `(.spec)`, pattern, or construction | serialized/wire review risk | `none` |+| `keiro-dsl/src/Keiro/Dsl/SemanticContract.hs:162` | `CheckedService` | data | no | `serviceTypeGraph` | `typeGraph` | `Either (NonEmpty TypeGraphError) TypeGraph` | `(.typeGraph)`, pattern, or construction | serialized/wire review risk | `none` |+| `keiro-dsl/src/Keiro/Dsl/SemanticContract.hs:163` | `CheckedService` | data | no | `serviceProjectionSupplies` | `projectionSupplies` | `ProjectionSupplyAnalysis` | `(.projectionSupplies)`, pattern, or construction | serialized/wire review risk | `none` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:100` | `MappedRoot` | data | yes | `mappedRootConsumer` | `consumer` | `!MappedConsumer` | `(.consumer)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:101` | `MappedRoot` | data | yes | `mappedRootKind` | `kind` | `!MappedRootKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:102` | `MappedRoot` | data | yes | `mappedRootUseSite` | `useSite` | `!UseSite` | `(.useSite)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:103` | `MappedRoot` | data | yes | `mappedRootDeclaration` | `declaration` | `!MappedKey` | `(.declaration)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:111` | `MappedRootEvidence` | data | yes | `evidenceConsumer` | `consumer` | `!MappedConsumer` | `(.consumer)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:112` | `MappedRootEvidence` | data | yes | `evidenceRootKind` | `rootKind` | `!MappedRootKind` | `(.rootKind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:113` | `MappedRootEvidence` | data | yes | `evidencePath` | `path` | `!Text` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:114` | `MappedRootEvidence` | data | yes | `evidenceOperation` | `operation` | `!(Maybe Text)` | `(.operation)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:141` | `SemanticImpact` | data | yes | `impactRoots` | `roots` | `![MappedRoot]` | `(.roots)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:142` | `SemanticImpact` | data | yes | `impactUsePaths` | `usePaths` | `!(Map MappedKey [UsePath])` | `(.usePaths)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:143` | `SemanticImpact` | data | yes | `impactAggregateDeclarations` | `aggregateDeclarations` | `!(Map MappedConsumer (Set MappedKey))` | `(.aggregateDeclarations)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:144` | `SemanticImpact` | data | yes | `impactDeclarationConsumers` | `declarationConsumers` | `!(Map MappedKey (Set MappedConsumer))` | `(.declarationConsumers)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:145` | `SemanticImpact` | data | yes | `impactDeclarationEvidence` | `declarationEvidence` | `!(Map MappedKey (Set MappedRootEvidence))` | `(.declarationEvidence)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:146` | `SemanticImpact` | data | yes | `impactDeclarationConsequences` | `declarationConsequences` | `!(Map MappedKey (Set MappedConsequence))` | `(.declarationConsequences)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:147` | `SemanticImpact` | data | yes | `impactServiceDeclarations` | `serviceDeclarations` | `!(Set MappedKey)` | `(.serviceDeclarations)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:148` | `SemanticImpact` | data | yes | `impactDeclarationIdentities` | `declarationIdentities` | `!(Map MappedKey Text)` | `(.declarationIdentities)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:149` | `SemanticImpact` | data | yes | `impactUnsupportedProjectionSources` | `unsupportedProjectionSources` | `![UnsupportedProjectionSource]` | `(.unsupportedProjectionSources)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:159` | `SemanticImpactSnapshot` | data | yes | `snapshotMappedConsumers` | `mappedConsumers` | `!(Map MappedKey (Set MappedConsumer))` | `(.mappedConsumers)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:160` | `SemanticImpactSnapshot` | data | yes | `snapshotMappedEvidence` | `mappedEvidence` | `!(Maybe (Map MappedKey (Set MappedRootEvidence)))` | `(.mappedEvidence)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:161` | `SemanticImpactSnapshot` | data | yes | `snapshotMappedConsequences` | `mappedConsequences` | `!(Maybe (Map MappedKey (Set MappedConsequence)))` | `(.mappedConsequences)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:162` | `SemanticImpactSnapshot` | data | yes | `snapshotServiceInventory` | `serviceInventory` | `!(Set MappedKey)` | `(.serviceInventory)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:163` | `SemanticImpactSnapshot` | data | yes | `snapshotDeclarationIdentities` | `declarationIdentities` | `!(Map MappedKey Text)` | `(.declarationIdentities)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:170` | `MappedImpactDelta` | data | yes | `impactDeclaration` | `declaration` | `!MappedKey` | `(.declaration)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:171` | `MappedImpactDelta` | data | yes | `impactPreviousConsumers` | `previousConsumers` | `!(Set MappedConsumer)` | `(.previousConsumers)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:172` | `MappedImpactDelta` | data | yes | `impactCurrentConsumers` | `currentConsumers` | `!(Set MappedConsumer)` | `(.currentConsumers)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:173` | `MappedImpactDelta` | data | yes | `impactPreviousEvidence` | `previousEvidence` | `!(Maybe (Set MappedRootEvidence))` | `(.previousEvidence)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:174` | `MappedImpactDelta` | data | yes | `impactCurrentEvidence` | `currentEvidence` | `!(Maybe (Set MappedRootEvidence))` | `(.currentEvidence)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:175` | `MappedImpactDelta` | data | yes | `impactPreviousConsequences` | `previousConsequences` | `!(Maybe (Set MappedConsequence))` | `(.previousConsequences)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:176` | `MappedImpactDelta` | data | yes | `impactCurrentConsequences` | `currentConsequences` | `!(Maybe (Set MappedConsequence))` | `(.currentConsequences)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:177` | `MappedImpactDelta` | data | yes | `impactServiceConformance` | `serviceConformance` | `!Bool` | `(.serviceConformance)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:185` | `SemanticImpactReport` | data | yes | `semanticReportPrevious` | `previous` | `!(Maybe SemanticImpactSnapshot)` | `(.previous)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:186` | `SemanticImpactReport` | data | yes | `semanticReportCurrent` | `current` | `!SemanticImpactSnapshot` | `(.current)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:187` | `SemanticImpactReport` | data | yes | `semanticReportDeclarations` | `declarations` | `![MappedKey]` | `(.declarations)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:188` | `SemanticImpactReport` | data | yes | `semanticReportDeltas` | `deltas` | `![MappedImpactDelta]` | `(.deltas)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:514` | `SelectionEvidence` | data | no | `selectionEvidenceRoot` | `root` | `!MappedRoot` | `(.root)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/SemanticImpact.hs:515` | `SelectionEvidence` | data | no | `selectionEvidencePath` | `path` | `!Text` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/ServiceHarness.hs:28` | `DuplicateServiceFactKey` | newtype | yes | `duplicateServiceFactKey` | `duplicateServiceFactKey` | `Text` | `(.duplicateServiceFactKey)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show)` |+| `keiro-dsl/src/Keiro/Dsl/SidecarMigration.hs:48` | `SidecarMove` | data | yes | `sidecarOldPath` | `oldPath` | `!FilePath` | `(.oldPath)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/SidecarMigration.hs:49` | `SidecarMove` | data | yes | `sidecarNewPath` | `newPath` | `!FilePath` | `(.newPath)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/SidecarMigration.hs:50` | `SidecarMove` | data | yes | `sidecarBackupPath` | `backupPath` | `!(Maybe FilePath)` | `(.backupPath)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/SidecarMigration.hs:51` | `SidecarMove` | data | yes | `sidecarMoveDisposition` | `moveDisposition` | `!SidecarMoveDisposition` | `(.moveDisposition)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Source.hs:22` | `SourcePoint` | data | yes | `offset` | `offset` | `!Int` | `(.offset)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Source.hs:23` | `SourcePoint` | data | yes | `line` | `line` | `!Int` | `(.line)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Source.hs:24` | `SourcePoint` | data | yes | `column` | `column` | `!Int` | `(.column)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Source.hs:38` | `SourceSpan` | data | yes | `source` | `source` | `!FilePath` | `(.source)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Source.hs:39` | `SourceSpan` | data | yes | `start` | `start` | `!SourcePoint` | `(.start)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Source.hs:40` | `SourceSpan` | data | yes | `end` | `end` | `!SourcePoint` | `(.end)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Source.hs:61` | `Located` | data | yes | `span` | `span` | `!SourceSpan` | `(.span)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show, Functor, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Source.hs:62` | `Located` | data | yes | `value` | `value` | `!a` | `(.value)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Ord, Show, Functor, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SourceIndex.hs:60` | `IndexedSourcePosition` | data | no | `quality` | `quality` | `!SourcePositionQuality` | `(.quality)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SourceIndex.hs:61` | `IndexedSourcePosition` | data | no | `span` | `span` | `!SourceSpan` | `(.span)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SourceIndex.hs:66` | `SemanticSourceIndex` | newtype | no | `positions` | `positions` | `Map SourceSubject IndexedSourcePosition` | `(.positions)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SourceIndex.hs:72` | `ParsedSourceDocument` | data | yes | `documentParsedSource` | `parsedSource` | `!ParsedSource` | `(.parsedSource)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SourceIndex.hs:73` | `ParsedSourceDocument` | data | yes | `documentSourceIndex` | `sourceIndex` | `!SemanticSourceIndex` | `(.sourceIndex)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SourceIndex.hs:85` | `SourceIndexFailure` | data | yes | `failureCode` | `code` | `!SourceIndexFailureCode` | `(.code)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SourceIndex.hs:86` | `SourceIndexFailure` | data | yes | `failureSubject` | `subject` | `!(Maybe SourceSubject)` | `(.subject)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SourceIndex.hs:87` | `SourceIndexFailure` | data | yes | `failureSpan` | `span` | `!(Maybe SourceSpan)` | `(.span)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/SourceIndex.hs:88` | `SourceIndexFailure` | data | yes | `failureMessage` | `message` | `!Text` | `(.message)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/StructuralConformance.hs:78` | `ConformanceRendering` | data | no | `renderingContext` | `context` | `!Context` | `(.context)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/StructuralConformance.hs:79` | `ConformanceRendering` | data | no | `renderingGraph` | `graph` | `!TypeGraph` | `(.graph)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/StructuralConformance.hs:80` | `ConformanceRendering` | data | no | `renderingDeclarations` | `declarations` | `![ResolvedMappedDecl]` | `(.declarations)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/StructuralConformance.hs:81` | `ConformanceRendering` | data | no | `renderingProjections` | `projections` | `![StructuralProjection]` | `(.projections)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/StructuralConformance.hs:82` | `ConformanceRendering` | data | no | `renderingImportPlan` | `importPlan` | `!HaskellImportPlan` | `(.importPlan)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Syntax.hs:33` | `SurfaceSource` | data | yes | `source` | `source` | `!FilePath` | `(.source)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Syntax.hs:34` | `SurfaceSource` | data | yes | `language` | `language` | `!SourceLanguage` | `(.language)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Syntax.hs:35` | `SurfaceSource` | data | yes | `preamble` | `preamble` | `!(Maybe (Located SourceLanguage))` | `(.preamble)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Syntax.hs:36` | `SurfaceSource` | data | yes | `spec` | `spec` | `!(Located SurfaceSpec)` | `(.spec)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Syntax.hs:43` | `SurfaceSpec` | data | yes | `context` | `context` | `!(Located Text)` | `(.context)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Syntax.hs:44` | `SurfaceSpec` | data | yes | `moduleRoot` | `moduleRoot` | `!(Maybe (Located Text))` | `(.moduleRoot)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Syntax.hs:45` | `SurfaceSpec` | data | yes | `layout` | `layout` | `!(Maybe (Located Placement))` | `(.layout)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Syntax.hs:46` | `SurfaceSpec` | data | yes | `items` | `items` | `![Located SurfaceTopItem]` | `(.items)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/Syntax.hs:47` | `SurfaceSpec` | data | yes | `elements` | `elements` | `![Located SurfaceElement]` | `(.elements)`, pattern, or construction | Haskell API and runtime semantics | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:77` | `QualifiedValueName` | newtype | yes | `unQualifiedValueName` | `unQualifiedValueName` | `Text` | explicit `unQualifiedValueName` positional function | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:83` | `CanonicalTypeId` | newtype | yes | `unCanonicalTypeId` | `unCanonicalTypeId` | `Text` | explicit `unCanonicalTypeId` positional function | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:89` | `BindingVersion` | newtype | yes | `unBindingVersion` | `unBindingVersion` | `Text` | explicit `unBindingVersion` positional function | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:95` | `CodecIdentity` | newtype | yes | `unCodecIdentity` | `unCodecIdentity` | `Text` | explicit `unCodecIdentity` positional function | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:101` | `CodecVersion` | newtype | yes | `unCodecVersion` | `unCodecVersion` | `Text` | explicit `unCodecVersion` positional function | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:148` | `StructuralDecl` | data | yes | `sdName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:149` | `StructuralDecl` | data | yes | `sdHaskell` | `haskell` | `!HaskellSource` | `(.haskell)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:150` | `StructuralDecl` | data | yes | `sdBinding` | `binding` | `!QualifiedValueName` | `(.binding)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:151` | `StructuralDecl` | data | yes | `sdBindingVersion` | `bindingVersion` | `!BindingVersion` | `(.bindingVersion)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:152` | `StructuralDecl` | data | yes | `sdCanonical` | `canonical` | `!CanonicalTypeId` | `(.canonical)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:153` | `StructuralDecl` | data | yes | `sdFixtures` | `fixtures` | `!QualifiedValueName` | `(.fixtures)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:154` | `StructuralDecl` | data | yes | `sdInitial` | `initial` | `!(Maybe QualifiedValueName)` | `(.initial)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:155` | `StructuralDecl` | data | yes | `sdLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:160` | `OpaqueDecl` | data | yes | `odName` | `name` | `!Name` | `(.name)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:161` | `OpaqueDecl` | data | yes | `odHaskell` | `haskell` | `!HaskellSource` | `(.haskell)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:162` | `OpaqueDecl` | data | yes | `odCodecIdentity` | `codecIdentity` | `!CodecIdentity` | `(.codecIdentity)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:163` | `OpaqueDecl` | data | yes | `odCodecVersion` | `codecVersion` | `!CodecVersion` | `(.codecVersion)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:164` | `OpaqueDecl` | data | yes | `odFixtures` | `fixtures` | `!QualifiedValueName` | `(.fixtures)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:165` | `OpaqueDecl` | data | yes | `odInitial` | `initial` | `!(Maybe QualifiedValueName)` | `(.initial)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:166` | `OpaqueDecl` | data | yes | `odLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:222` | `MappedKey` | newtype | yes | `unMappedKey` | `unMappedKey` | `Name` | explicit `unMappedKey` positional function | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:243` | `ResolvedWireField` | data | yes | `rwfHaskell` | `haskell` | `!Name` | `(.haskell)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:244` | `ResolvedWireField` | data | yes | `rwfKey` | `key` | `!Text` | `(.key)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:245` | `ResolvedWireField` | data | yes | `rwfType` | `valueType` | `!ResolvedTypeExpr` | `(.valueType)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:246` | `ResolvedWireField` | data | yes | `rwfPresence` | `presence` | `!Presence` | `(.presence)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:247` | `ResolvedWireField` | data | yes | `rwfOnMissing` | `onMissing` | `!(Maybe OnMissing)` | `(.onMissing)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:248` | `ResolvedWireField` | data | yes | `rwfLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:253` | `ResolvedWireArm` | data | yes | `rwaCtor` | `ctor` | `!Name` | `(.ctor)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:254` | `ResolvedWireArm` | data | yes | `rwaTag` | `tag` | `!Text` | `(.tag)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:255` | `ResolvedWireArm` | data | yes | `rwaPayload` | `payload` | `!(Maybe ResolvedTypeExpr)` | `(.payload)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:256` | `ResolvedWireArm` | data | yes | `rwaLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:298` | `UsePath` | data | yes | `upRoot` | `root` | `!UseSite` | `(.root)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:299` | `UsePath` | data | yes | `upSegments` | `segments` | `![PathSeg]` | `(.segments)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Ord, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:319` | `TypeGraph` | data | yes | `tgDeclarations` | `declarations` | `!(Map MappedKey ResolvedMappedDecl)` | `(.declarations)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:320` | `TypeGraph` | data | yes | `tgReachability` | `reachability` | `!(Map MappedKey (Set MappedKey))` | `(.reachability)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:321` | `TypeGraph` | data | yes | `tgUseSites` | `useSites` | `![UseSite]` | `(.useSites)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:322` | `TypeGraph` | data | yes | `tgRootSegments` | `rootSegments` | `!(Map UseSite [PathSeg])` | `(.rootSegments)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:323` | `TypeGraph` | data | yes | `tgDerivedMappedConsumers` | `derivedMappedConsumers` | `![DerivedMappedConsumer]` | `(.derivedMappedConsumers)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:324` | `TypeGraph` | data | yes | `tgReplayableProjectionGroups` | `replayableProjectionGroups` | `!(Map DerivedMappedConsumer Name)` | `(.replayableProjectionGroups)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:325` | `TypeGraph` | data | yes | `tgProjectionOperationalIdentities` | `projectionOperationalIdentities` | `!(Map DerivedMappedConsumer Text)` | `(.projectionOperationalIdentities)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:326` | `TypeGraph` | data | yes | `tgUnsupportedProjectionSources` | `unsupportedProjectionSources` | `![UnsupportedProjectionSource]` | `(.unsupportedProjectionSources)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show, Generic)` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:746` | `TypeExprAlgebra` | data | yes | `onText` | `onText` | `a` | `(.onText)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:747` | `TypeExprAlgebra` | data | yes | `onInt` | `onInt` | `a` | `(.onInt)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:748` | `TypeExprAlgebra` | data | yes | `onInteger` | `onInteger` | `a` | `(.onInteger)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:749` | `TypeExprAlgebra` | data | yes | `onBool` | `onBool` | `a` | `(.onBool)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:750` | `TypeExprAlgebra` | data | yes | `onNatural` | `onNatural` | `a` | `(.onNatural)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:751` | `TypeExprAlgebra` | data | yes | `onTime` | `onTime` | `a` | `(.onTime)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:752` | `TypeExprAlgebra` | data | yes | `onJson` | `onJson` | `a` | `(.onJson)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:753` | `TypeExprAlgebra` | data | yes | `onOptional` | `onOptional` | `a -> a` | `(.onOptional)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:754` | `TypeExprAlgebra` | data | yes | `onList` | `onList` | `a -> a` | `(.onList)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:755` | `TypeExprAlgebra` | data | yes | `onMap` | `onMap` | `a -> a` | `(.onMap)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:756` | `TypeExprAlgebra` | data | yes | `onRef` | `onRef` | `MappedKey -> a` | `(.onRef)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:774` | `MappedShapeAlgebra` | data | yes | `onRecord` | `onRecord` | `Name -> UnknownFields -> [ResolvedWireField] -> a` | `(.onRecord)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:775` | `MappedShapeAlgebra` | data | yes | `onEnum` | `onEnum` | `[WireEnum] -> a` | `(.onEnum)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:776` | `MappedShapeAlgebra` | data | yes | `onUnion` | `onUnion` | `UnionEncoding -> [ResolvedWireArm] -> a` | `(.onUnion)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:786` | `MappedDeclAlgebra` | data | yes | `onStructuralDecl` | `onStructuralDecl` | `StructuralDecl -> ResolvedMappedShape -> a` | `(.onStructuralDecl)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/TypeGraph.hs:787` | `MappedDeclAlgebra` | data | yes | `onOpaqueDecl` | `onOpaqueDecl` | `OpaqueDecl -> a` | `(.onOpaqueDecl)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Validate.hs:711` | `Diagnostic` | data | yes | `line` | `line` | `!Int` | `(.line)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Validate.hs:712` | `Diagnostic` | data | yes | `severity` | `severity` | `!Severity` | `(.severity)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Validate.hs:713` | `Diagnostic` | data | yes | `code` | `code` | `!DiagnosticCode` | `(.code)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Validate.hs:714` | `Diagnostic` | data | yes | `relatedLocations` | `relatedLocations` | `![(Int, Text)]` | `(.relatedLocations)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Validate.hs:715` | `Diagnostic` | data | yes | `message` | `message` | `!Text` | `(.message)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Validate.hs:1423` | `NullabilityFacts` | data | no | `nfTopNull` | `topNull` | `!Bool` | `(.topNull)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Validate.hs:1424` | `NullabilityFacts` | data | no | `nfBadOptional` | `badOptional` | `!Bool` | `(.badOptional)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:140` | `WorkspaceManifest` | data | yes | `wmfService` | `service` | `!Text` | `(.service)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:141` | `WorkspaceManifest` | data | yes | `wmfServiceLoc` | `serviceLoc` | `!Loc` | `(.serviceLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:143` | `WorkspaceManifest` | data | yes | `wmfRuntimePackage` | `runtimePackage` | `!(Maybe RuntimePackageName)` | `(.runtimePackage)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:145` | `WorkspaceManifest` | data | yes | `wmfRuntimePackageLoc` | `runtimePackageLoc` | `!Loc` | `(.runtimePackageLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:147` | `WorkspaceManifest` | data | yes | `wmfModuleRoot` | `moduleRoot` | `!(Maybe Text)` | `(.moduleRoot)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:149` | `WorkspaceManifest` | data | yes | `wmfModuleRootLoc` | `moduleRootLoc` | `!Loc` | `(.moduleRootLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:151` | `WorkspaceManifest` | data | yes | `wmfLayout` | `layout` | `!(Maybe Placement)` | `(.layout)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:153` | `WorkspaceManifest` | data | yes | `wmfLayoutLoc` | `layoutLoc` | `!Loc` | `(.layoutLoc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:155` | `WorkspaceManifest` | data | yes | `wmfMembers` | `members` | `!(NonEmpty WorkspaceMemberRef)` | `(.members)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:162` | `WorkspaceMemberRef` | data | yes | `wmrPath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:163` | `WorkspaceMemberRef` | data | yes | `wmrLoc` | `loc` | `!Loc` | `(.loc)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:542` | `WorkspaceLocation` | data | yes | `wlFile` | `file` | `!WorkspaceFile` | `(.file)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:543` | `WorkspaceLocation` | data | yes | `wlLine` | `line` | `!Int` | `(.line)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:544` | `WorkspaceLocation` | data | yes | `wlRole` | `role` | `!Text` | `(.role)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:554` | `WorkspaceDiagnostic` | data | yes | `wdLocations` | `locations` | `!(NonEmpty WorkspaceLocation)` | `(.locations)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:555` | `WorkspaceDiagnostic` | data | yes | `wdSeverity` | `severity` | `!Severity` | `(.severity)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:556` | `WorkspaceDiagnostic` | data | yes | `wdCode` | `code` | `!DiagnosticCode` | `(.code)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:557` | `WorkspaceDiagnostic` | data | yes | `wdSourceLanguageCause` | `sourceLanguageCause` | `!(Maybe SourceLanguageDiagnostic)` | `(.sourceLanguageCause)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:558` | `WorkspaceDiagnostic` | data | yes | `wdMessage` | `message` | `!Text` | `(.message)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:625` | `LineMap` | newtype | yes | `lmRanges` | `lmRanges` | `[(Int, Int, FilePath)]` | `(.lmRanges)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:634` | `OwnershipIndex` | data | yes | `oiDeclarations` | `declarations` | `!(Map (Text, Name) (FilePath, Loc))` | `(.declarations)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:635` | `OwnershipIndex` | data | yes | `oiNodes` | `nodes` | `!(Map (Text, Name) (FilePath, Loc))` | `(.nodes)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:650` | `WorkspaceMember` | data | yes | `wmPath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:652` | `WorkspaceMember` | data | yes | `wmSpec` | `spec` | `!Spec` | `(.spec)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:654` | `WorkspaceMember` | data | yes | `wmSourceLanguage` | `sourceLanguage` | `!SourceLanguage` | `(.sourceLanguage)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:657` | `WorkspaceMember` | data | yes | `wmSourceIndex` | `sourceIndex` | `!SemanticSourceIndex` | `(.sourceIndex)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:659` | `WorkspaceMember` | data | yes | `wmLineBase` | `lineBase` | `!Int` | `(.lineBase)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:661` | `WorkspaceMember` | data | yes | `wmLineCount` | `lineCount` | `!Int` | `(.lineCount)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:677` | `WorkspaceSpec` | data | yes | `wsService` | `service` | `!Text` | `(.service)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:678` | `WorkspaceSpec` | data | yes | `wsManifestPath` | `manifestPath` | `!FilePath` | `(.manifestPath)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:681` | `WorkspaceSpec` | data | yes | `wsLanguageContract` | `languageContract` | `!EffectiveLanguageContract` | `(.languageContract)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:683` | `WorkspaceSpec` | data | yes | `wsContext` | `context` | `!Name` | `(.context)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:684` | `WorkspaceSpec` | data | yes | `wsRuntimePackage` | `runtimePackage` | `!(Maybe RuntimePackageName)` | `(.runtimePackage)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:685` | `WorkspaceSpec` | data | yes | `wsModuleRoot` | `moduleRoot` | `!(Maybe Text)` | `(.moduleRoot)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:686` | `WorkspaceSpec` | data | yes | `wsLayout` | `layout` | `!(Maybe Placement)` | `(.layout)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:688` | `WorkspaceSpec` | data | yes | `wsMembers` | `members` | `![WorkspaceMember]` | `(.members)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:689` | `WorkspaceSpec` | data | yes | `wsMergedSpec` | `mergedSpec` | `!Spec` | `(.mergedSpec)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:691` | `WorkspaceSpec` | data | yes | `wsSourceIndex` | `sourceIndex` | `!SemanticSourceIndex` | `(.sourceIndex)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:692` | `WorkspaceSpec` | data | yes | `wsLineMap` | `lineMap` | `!LineMap` | `(.lineMap)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:693` | `WorkspaceSpec` | data | yes | `wsOwnership` | `ownership` | `!OwnershipIndex` | `(.ownership)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/Workspace.hs:1306` | `ContentSource` | newtype | yes | `csRead` | `csRead` | `FilePath -> IO (Either Text Text)` | `(.csRead)`, pattern, or construction | rendered/canonical output | `none` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceAdoption.hs:63` | `ClaimedFile` | data | yes | `cfPath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceAdoption.hs:64` | `ClaimedFile` | data | yes | `cfEvidence` | `evidence` | `!ClaimEvidence` | `(.evidence)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceAdoption.hs:66` | `ClaimedFile` | data | yes | `cfSource` | `source` | `!(Maybe Text)` | `(.source)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceAdoption.hs:68` | `ClaimedFile` | data | yes | `cfSpec` | `spec` | `!(Maybe Text)` | `(.spec)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceAdoption.hs:75` | `MigrationReport` | data | yes | `mrService` | `service` | `!Text` | `(.service)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceAdoption.hs:77` | `MigrationReport` | data | yes | `mrLegacyRecord` | `legacyRecord` | `!(Maybe (FilePath, Text))` | `(.legacyRecord)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceAdoption.hs:78` | `MigrationReport` | data | yes | `mrClaimed` | `claimed` | `![ClaimedFile]` | `(.claimed)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceAdoption.hs:79` | `MigrationReport` | data | yes | `mrLikelyStale` | `likelyStale` | `![StaleModule]` | `(.likelyStale)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceAdoption.hs:80` | `MigrationReport` | data | yes | `mrUnclaimed` | `unclaimed` | `![FilePath]` | `(.unclaimed)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:82` | `WorkspaceModuleRow` | data | yes | `wrmKind` | `kind` | `!ModuleKind` | `(.kind)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:83` | `WorkspaceModuleRow` | data | yes | `wrmPath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:84` | `WorkspaceModuleRow` | data | yes | `wrmOwner` | `owner` | `!(Maybe FilePath)` | `(.owner)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:85` | `WorkspaceModuleRow` | data | yes | `wrmRole` | `role` | `!(Maybe ModuleRole)` | `(.role)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:126` | `WorkspaceSourceLanguageRow` | data | yes | `wrslPath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:127` | `WorkspaceSourceLanguageRow` | data | yes | `wrslSourceLanguage` | `sourceLanguage` | `!SourceLanguage` | `(.sourceLanguage)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:159` | `AdoptedRow` | data | yes | `adPath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:160` | `AdoptedRow` | data | yes | `adEvidence` | `evidence` | `!Text` | `(.evidence)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:162` | `AdoptedRow` | data | yes | `adSource` | `source` | `!(Maybe Text)` | `(.source)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:164` | `AdoptedRow` | data | yes | `adSpec` | `spec` | `!(Maybe Text)` | `(.spec)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:192` | `WorkspaceRecord` | data | yes | `wrService` | `service` | `!Text` | `(.service)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:197` | `WorkspaceRecord` | data | yes | `wrManifest` | `manifest` | `!Text` | `(.manifest)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:198` | `WorkspaceRecord` | data | yes | `wrContext` | `context` | `!Text` | `(.context)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:199` | `WorkspaceRecord` | data | yes | `wrModuleRoot` | `moduleRoot` | `!Text` | `(.moduleRoot)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:200` | `WorkspaceRecord` | data | yes | `wrLayout` | `layout` | `!Text` | `(.layout)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:202` | `WorkspaceRecord` | data | yes | `wrMembers` | `members` | `![FilePath]` | `(.members)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:203` | `WorkspaceRecord` | data | yes | `wrSourceLanguages` | `sourceLanguages` | `![WorkspaceSourceLanguageRow]` | `(.sourceLanguages)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:204` | `WorkspaceRecord` | data | yes | `wrLanguageContract` | `languageContract` | `!EffectiveLanguageContract` | `(.languageContract)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:205` | `WorkspaceRecord` | data | yes | `wrNamingEdition` | `namingEdition` | `!GeneratedHaskellNamingEdition` | `(.namingEdition)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:206` | `WorkspaceRecord` | data | yes | `wrModules` | `modules` | `![WorkspaceModuleRow]` | `(.modules)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:207` | `WorkspaceRecord` | data | yes | `wrMappings` | `mappings` | `![MappingIdentity]` | `(.mappings)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:208` | `WorkspaceRecord` | data | yes | `wrIdDomains` | `idDomains` | `![Text]` | `(.idDomains)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:209` | `WorkspaceRecord` | data | yes | `wrNominalEqualities` | `nominalEqualities` | `![Text]` | `(.nominalEqualities)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:210` | `WorkspaceRecord` | data | yes | `wrBindingObligations` | `bindingObligations` | `![BindingHole]` | `(.bindingObligations)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:211` | `WorkspaceRecord` | data | yes | `requirements` | `requirements` | `![BehaviorRecordRow]` | `(.requirements)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:212` | `WorkspaceRecord` | data | yes | `wrProjectionCatalogFacts` | `projectionCatalogFacts` | `![Text]` | `(.projectionCatalogFacts)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:213` | `WorkspaceRecord` | data | yes | `wrQueryContractBaseline` | `queryContractBaseline` | `!Bool` | `(.queryContractBaseline)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:214` | `WorkspaceRecord` | data | yes | `wrQueryContracts` | `queryContracts` | `![QueryContractIdentity]` | `(.queryContracts)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:215` | `WorkspaceRecord` | data | yes | `wrRouterSelections` | `routerSelections` | `![RouterSelectionSnapshot]` | `(.routerSelections)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:216` | `WorkspaceRecord` | data | yes | `wrAdopted` | `adopted` | `![AdoptedRow]` | `(.adopted)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceRecord.hs:217` | `WorkspaceRecord` | data | yes | `wrSemanticImpact` | `semanticImpact` | `!(Maybe SemanticImpactSnapshot)` | `(.semanticImpact)`, pattern, or construction | serialized/wire review risk, rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:167` | `WorkspacePlan` | data | yes | `wpWorkspace` | `workspace` | `!WorkspaceSpec` | `(.workspace)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:168` | `WorkspacePlan` | data | yes | `wpCheckedService` | `checkedService` | `!CheckedService` | `(.checkedService)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:169` | `WorkspacePlan` | data | yes | `wpContext` | `context` | `!Context` | `(.context)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:170` | `WorkspacePlan` | data | yes | `wpRuntimePackage` | `runtimePackage` | `!(Maybe RuntimePackageName)` | `(.runtimePackage)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:171` | `WorkspacePlan` | data | yes | `wpConformancePackage` | `conformancePackage` | `!(Maybe ConformancePackagePlan)` | `(.conformancePackage)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:175` | `WorkspacePlan` | data | yes | `wpGoldenRoot` | `goldenRoot` | `!FilePath` | `(.goldenRoot)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:176` | `WorkspacePlan` | data | yes | `wpModules` | `modules` | `![(ScaffoldModule, ModuleProvenance)]` | `(.modules)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:401` | `OwnershipMove` | data | yes | `omPath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:402` | `OwnershipMove` | data | yes | `omPrevious` | `previous` | `!(Maybe FilePath)` | `(.previous)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:403` | `OwnershipMove` | data | yes | `omCurrent` | `current` | `!(Maybe FilePath)` | `(.current)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:408` | `WorkspaceSourceLanguageDrift` | data | yes | `wsldPath` | `path` | `!FilePath` | `(.path)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:409` | `WorkspaceSourceLanguageDrift` | data | yes | `wsldPrevious` | `previous` | `!SourceLanguage` | `(.previous)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:410` | `WorkspaceSourceLanguageDrift` | data | yes | `wsldCurrent` | `current` | `!SourceLanguage` | `(.current)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:416` | `WorkspaceScaffoldReport` | data | yes | `wsrManifestPath` | `manifestPath` | `!FilePath` | `(.manifestPath)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:417` | `WorkspaceScaffoldReport` | data | yes | `wsrOutDir` | `outDir` | `!FilePath` | `(.outDir)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:418` | `WorkspaceScaffoldReport` | data | yes | `wsrService` | `service` | `!Text` | `(.service)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:419` | `WorkspaceScaffoldReport` | data | yes | `wsrContext` | `context` | `!Context` | `(.context)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:420` | `WorkspaceScaffoldReport` | data | yes | `wsrMembers` | `members` | `![FilePath]` | `(.members)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:421` | `WorkspaceScaffoldReport` | data | yes | `wsrDispositions` | `dispositions` | `![(ScaffoldModule, ModuleProvenance, WriteDisposition)]` | `(.dispositions)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:422` | `WorkspaceScaffoldReport` | data | yes | `wsrBuildManifestPath` | `buildManifestPath` | `!FilePath` | `(.buildManifestPath)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:423` | `WorkspaceScaffoldReport` | data | yes | `wsrRecordPath` | `recordPath` | `!FilePath` | `(.recordPath)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:426` | `WorkspaceScaffoldReport` | data | yes | `wsrPreviousManifest` | `previousManifest` | `!(Maybe Text)` | `(.previousManifest)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:427` | `WorkspaceScaffoldReport` | data | yes | `wsrStale` | `stale` | `![StaleModule]` | `(.stale)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:428` | `WorkspaceScaffoldReport` | data | yes | `wsrOwnershipMoves` | `ownershipMoves` | `![OwnershipMove]` | `(.ownershipMoves)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:429` | `WorkspaceScaffoldReport` | data | yes | `wsrConsumerPlan` | `consumerPlan` | `!ConsumerPlan` | `(.consumerPlan)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:430` | `WorkspaceScaffoldReport` | data | yes | `wsrConstraintPlan` | `constraintPlan` | `![Text]` | `(.constraintPlan)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:431` | `WorkspaceScaffoldReport` | data | yes | `wsrMappingDrift` | `mappingDrift` | `![MappingDrift]` | `(.mappingDrift)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:432` | `WorkspaceScaffoldReport` | data | yes | `wsrQueryContractBaselineUnavailable` | `queryContractBaselineUnavailable` | `!Bool` | `(.queryContractBaselineUnavailable)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:433` | `WorkspaceScaffoldReport` | data | yes | `wsrQueryContractDrift` | `queryContractDrift` | `![QueryContractDrift]` | `(.queryContractDrift)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:434` | `WorkspaceScaffoldReport` | data | yes | `wsrQueryContractMigrations` | `queryContractMigrations` | `![QueryContractMigration]` | `(.queryContractMigrations)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:435` | `WorkspaceScaffoldReport` | data | yes | `wsrSemanticImpact` | `semanticImpact` | `!SemanticImpactReport` | `(.semanticImpact)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:436` | `WorkspaceScaffoldReport` | data | yes | `wsrRouterSelectionDrift` | `routerSelectionDrift` | `![RouterSelectionDrift]` | `(.routerSelectionDrift)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:437` | `WorkspaceScaffoldReport` | data | yes | `wsrProjectionMappedImpact` | `projectionMappedImpact` | `!(Maybe ProjectionMappedImpact)` | `(.projectionMappedImpact)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:438` | `WorkspaceScaffoldReport` | data | yes | `wsrGeneratedArtifactImpact` | `generatedArtifactImpact` | `![GeneratedArtifactImpact]` | `(.generatedArtifactImpact)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:439` | `WorkspaceScaffoldReport` | data | yes | `wsrSourceLanguageDrift` | `sourceLanguageDrift` | `![WorkspaceSourceLanguageDrift]` | `(.sourceLanguageDrift)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:440` | `WorkspaceScaffoldReport` | data | yes | `wsrNewHoles` | `newHoles` | `![BindingHole]` | `(.newHoles)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:441` | `WorkspaceScaffoldReport` | data | yes | `wsrAddedBehavior` | `addedBehavior` | `![BehaviorRecordRow]` | `(.addedBehavior)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:442` | `WorkspaceScaffoldReport` | data | yes | `wsrRemovedBehavior` | `removedBehavior` | `![BehaviorRecordRow]` | `(.removedBehavior)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:443` | `WorkspaceScaffoldReport` | data | yes | `wsrObsoleteOutputHooks` | `obsoleteOutputHooks` | `![(Text, Text)]` | `(.obsoleteOutputHooks)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:447` | `WorkspaceScaffoldReport` | data | yes | `wsrInertNodes` | `inertNodes` | `![(Text, Text)]` | `(.inertNodes)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:448` | `WorkspaceScaffoldReport` | data | yes | `wsrConformancePackage` | `conformancePackage` | `!(Maybe ConformancePackageReport)` | `(.conformancePackage)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:449` | `WorkspaceScaffoldReport` | data | yes | `wsrNameMoves` | `nameMoves` | `![SourceMove]` | `(.nameMoves)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:450` | `WorkspaceScaffoldReport` | data | yes | `wsrSidecarMoves` | `sidecarMoves` | `![SidecarMove]` | `(.sidecarMoves)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |+| `keiro-dsl/src/Keiro/Dsl/WorkspaceScaffold.hs:452` | `WorkspaceScaffoldReport` | data | yes | `wsrMigration` | `migration` | `!(Maybe MigrationReport)` | `(.migration)`, pattern, or construction | rendered/canonical output | `deriving stock (Eq, Show)` |++Regenerate or check this inventory with:++```bash+python3 scripts/generate-record-migration-manifests.py --check+```

src/Keiro/Dsl/AggregateGenerationPlan.hs view

@@ -11,9 +11,9 @@ import Keiro.Dsl.Grammar (Name, Transition (..))  data TransitionLayoutEntry = TransitionLayoutEntry-  { layoutDeclarationIndex :: !Int,-    layoutOutgoingIndex :: !Int,-    layoutTransition :: !Transition+  { declarationIndex :: !Int,+    outgoingIndex :: !Int,+    transition :: !Transition   }   deriving stock (Eq, Show) @@ -21,7 +21,7 @@ transitionLayout transitions = snd (mapAccumL buildEntry Map.empty (zip [1 ..] transitions))   where     buildEntry counts (declarationIndex, transition) =-      let source = tSource transition+      let source = (.source) transition           outgoingIndex = Map.findWithDefault 0 source counts           counts' = Map.insert source (outgoingIndex + 1) counts           entry = TransitionLayoutEntry declarationIndex outgoingIndex transition@@ -30,7 +30,7 @@ groupTransitionLayoutBySource :: [TransitionLayoutEntry] -> [(Name, [TransitionLayoutEntry])] groupTransitionLayoutBySource entries =   [ (source, transitionLayoutForSource source entries)-  | source <- firstOccurrences (map (tSource . layoutTransition) entries)+  | source <- firstOccurrences (map ((.source) . (.transition)) entries)   ]   where     firstOccurrences = foldl appendNew []@@ -39,4 +39,4 @@       | otherwise = seen ++ [value]  transitionLayoutForSource :: Name -> [TransitionLayoutEntry] -> [TransitionLayoutEntry]-transitionLayoutForSource source = filter ((== source) . tSource . layoutTransition)+transitionLayoutForSource source = filter ((== source) . (.source) . (.transition))

src/Keiro/Dsl/AggregateType.hs view

@@ -82,9 +82,9 @@   deriving stock (Eq, Ord, Show)  data AggregateSymbols = AggregateSymbols-  { symbolNominals :: !(Map Name ResolvedNominalType),-    symbolVertices :: !(Map Name [Name]),-    symbolMapped :: !(Map MappedKey ResolvedMappedDecl)+  { nominals :: !(Map Name ResolvedNominalType),+    vertices :: !(Map Name [Name]),+    mapped :: !(Map MappedKey ResolvedMappedDecl)   }  aggregateSymbols :: Spec -> AggregateSymbols@@ -92,22 +92,22 @@   aggregateSymbolsFromGraphResult (resolveTypeGraph spec) spec  aggregateSymbolsFromGraph :: TypeGraph -> Spec -> AggregateSymbols-aggregateSymbolsFromGraph graph = aggregateSymbolsFromDeclarations (tgDeclarations graph)+aggregateSymbolsFromGraph graph = aggregateSymbolsFromDeclarations ((.declarations) graph)  aggregateSymbolsFromGraphResult :: Either (NE.NonEmpty TypeGraphError) TypeGraph -> Spec -> AggregateSymbols aggregateSymbolsFromGraphResult graphResult =-  aggregateSymbolsFromDeclarations (either (const Map.empty) tgDeclarations graphResult)+  aggregateSymbolsFromDeclarations (either (const Map.empty) (.declarations) graphResult)  aggregateSymbolsFromDeclarations :: Map MappedKey ResolvedMappedDecl -> Spec -> AggregateSymbols aggregateSymbolsFromDeclarations mappedDeclarations spec =   AggregateSymbols-    { symbolNominals = either (const Map.empty) nominalTypes (resolveNominalTypes spec),-      symbolVertices =+    { nominals = either (const Map.empty) nominalTypes (resolveNominalTypes spec),+      vertices =         Map.fromList-          [ (aggName aggregate <> "Vertex", map stName (aggStates aggregate))-          | NAggregate aggregate <- specNodes spec+          [ ((.name) aggregate <> "Vertex", map (.name) ((.states) aggregate))+          | NAggregate aggregate <- (.nodes) spec           ],-      symbolMapped = mappedDeclarations+      mapped = mappedDeclarations     }  data AggregateTypeErrorReason@@ -118,9 +118,9 @@   deriving stock (Eq, Show)  data AggregateTypeError = AggregateTypeError-  { aggregateTypeErrorLoc :: !Loc,-    aggregateTypeErrorUseSite :: !AggregateUseSite,-    aggregateTypeErrorReason :: !AggregateTypeErrorReason+  { loc :: !Loc,+    useSite :: !AggregateUseSite,+    reason :: !AggregateTypeErrorReason   }   deriving stock (Eq, Show) @@ -138,9 +138,9 @@     TList {} -> unsupportedShape     TMap {} -> unsupportedShape     TRef name-      | Just nominal <- Map.lookup name (symbolNominals symbols) -> pure (AggregateNominal nominal)-      | Map.member name (symbolVertices symbols) -> pure (AggregateVertex name)-      | Map.member (MappedKey name) (symbolMapped symbols) -> pure (AggregateMapped (MappedKey name))+      | Just nominal <- Map.lookup name ((.nominals) symbols) -> pure (AggregateNominal nominal)+      | Map.member name ((.vertices) symbols) -> pure (AggregateVertex name)+      | Map.member (MappedKey name) ((.mapped) symbols) -> pure (AggregateMapped (MappedKey name))       | otherwise -> Left (AggregateTypeError loc useSite (UnknownAggregateType name))   case aggregateCapability useSite resolved of     Unsupported -> Left (AggregateTypeError loc useSite (UnsupportedAggregateCapability resolved))@@ -151,17 +151,17 @@  inferAggregateFieldType :: AggregateSymbols -> Aggregate -> AggregateUseSite -> AggregateField -> Either AggregateTypeError ResolvedAggregateType inferAggregateFieldType symbols aggregate useSite field =-  resolveAggregateType symbols (aggregateFieldLoc field) useSite inferred+  resolveAggregateType symbols ((.loc) field) useSite inferred   where-    inferred = case aggregateFieldType field of+    inferred = case (.valueType) field of       Just expression -> expression-      Nothing -> case [regType register | register <- aggRegs aggregate, regName register == aggregateFieldName field] of+      Nothing -> case [(.valueType) register | register <- (.regs) aggregate, (.name) register == (.name) field] of         expression : _ -> expression         [] ->-          let candidate = pascal (aggregateFieldName field)-           in if Map.member candidate (symbolNominals symbols)-                || Map.member candidate (symbolVertices symbols)-                || Map.member (MappedKey candidate) (symbolMapped symbols)+          let candidate = pascal ((.name) field)+           in if Map.member candidate ((.nominals) symbols)+                || Map.member candidate ((.vertices) symbols)+                || Map.member (MappedKey candidate) ((.mapped) symbols)                 then TRef candidate                 else TText @@ -169,7 +169,7 @@ aggregateCapability useSite resolved = case useSite of   EqualityGuardUse -> case resolved of     AggregateMapped {} -> Unsupported-    AggregateNominal nominal -> case resolvedNominalRepresentation nominal of+    AggregateNominal nominal -> case (.representation) nominal of       ScalarRepresentation {} -> SolverVisible       IdRepresentation {} -> SolverVisible       EnumRepresentation {} -> SolverVisible@@ -206,13 +206,13 @@   AggregateMapped {} -> OpaqueOnly  nominalSolverVisibility :: ResolvedNominalType -> AggregateCapability-nominalSolverVisibility nominal = case resolvedNominalRepresentation nominal of+nominalSolverVisibility nominal = case (.representation) nominal of   ScalarRepresentation {} -> SolverVisible   IdRepresentation {} -> OpaqueOnly   EnumRepresentation {} -> OpaqueOnly  nominalOrderingCapability :: ResolvedNominalType -> AggregateCapability-nominalOrderingCapability nominal = case resolvedNominalRepresentation nominal of+nominalOrderingCapability nominal = case (.representation) nominal of   ScalarRepresentation NominalInt -> SolverVisible   ScalarRepresentation NominalNatural -> SolverVisible   ScalarRepresentation NominalTime -> SolverVisible@@ -229,7 +229,7 @@   AggregateBool -> "Bool"   AggregateTime -> "Time"   AggregateNatural -> "Natural"-  AggregateNominal nominal -> resolvedNominalName nominal+  AggregateNominal nominal -> (.name) nominal   AggregateVertex name -> name   AggregateMapped key -> unMappedKey key @@ -248,19 +248,19 @@   TRef name -> name  data AggregateHaskellSource = AggregateHaskellSource-  { aggregateSourceBuiltin :: !(Maybe Text),-    aggregateSourceReference :: !(Maybe HaskellReference),-    aggregateSourceStaticImports :: !(Set Text)+  { builtin :: !(Maybe Text),+    reference :: !(Maybe HaskellReference),+    staticImports :: !(Set Text)   }  aggregateConsumerHaskellSource :: AggregateSymbols -> ResolvedAggregateType -> AggregateHaskellSource aggregateConsumerHaskellSource symbols resolved = case resolved of   AggregateTime -> builtin "UTCTime" timeImports   AggregateNatural -> builtin "Natural" (Set.singleton "Numeric.Natural (Natural)")-  AggregateNominal nominal -> case resolvedNominalOwnership nominal of-    GeneratedNominal -> builtin (resolvedNominalName nominal) Set.empty-    ConsumerNominal binding -> external (consumerNominalHaskell binding)-  AggregateMapped key -> case Map.lookup key (symbolMapped symbols) of+  AggregateNominal nominal -> case (.ownership) nominal of+    GeneratedNominal -> builtin ((.name) nominal) Set.empty+    ConsumerNominal binding -> external ((.haskell) binding)+  AggregateMapped key -> case Map.lookup key ((.mapped) symbols) of     Just declaration -> external (mappedHaskell declaration)     Nothing -> builtin (unMappedKey key) Set.empty   _ -> builtin (aggregateCanonicalName resolved) Set.empty@@ -269,18 +269,21 @@     external source =       AggregateHaskellSource         Nothing-        (Just (HaskellReference (hsModule source) (hsType source) TypeNamespace PreferUnqualified))+        (Just (HaskellReference ((.moduleName) source) ((.valueType) source) TypeNamespace PreferUnqualified))         Set.empty-    mappedHaskell (ResolvedStructural declaration _) = sdHaskell declaration-    mappedHaskell (ResolvedOpaque declaration) = odHaskell declaration+    mappedHaskell (ResolvedStructural declaration _) = (.haskell) declaration+    mappedHaskell (ResolvedOpaque declaration) = (.haskell) declaration     timeImports =       Set.singleton "Data.Time.Clock (UTCTime)"  aggregateSourceReferences :: AggregateHaskellSource -> Set HaskellReference-aggregateSourceReferences source = maybe Set.empty Set.singleton (aggregateSourceReference source)+aggregateSourceReferences source = maybe Set.empty Set.singleton ((.reference) source) +aggregateSourceStaticImports :: AggregateHaskellSource -> Set Text+aggregateSourceStaticImports = (.staticImports)+ renderAggregateHaskellSource :: HaskellImportPlan -> AggregateHaskellSource -> Either HaskellImportError Text-renderAggregateHaskellSource plan source = case (aggregateSourceBuiltin source, aggregateSourceReference source) of+renderAggregateHaskellSource plan source = case ((.builtin) source, (.reference) source) of   (Just builtin, Nothing) -> pure builtin   (Nothing, Just reference) -> renderPlannedReference plan reference   _ -> error "invalid aggregate Haskell source description"@@ -288,45 +291,45 @@ aggregatePackages :: AggregateSymbols -> ResolvedAggregateType -> Set Text aggregatePackages symbols resolved = case resolved of   AggregateTime -> Set.singleton "time"-  AggregateNominal nominal -> case resolvedNominalOwnership nominal of+  AggregateNominal nominal -> case (.ownership) nominal of     GeneratedNominal -> Set.empty-    ConsumerNominal binding -> Set.singleton (hsPackage (consumerNominalHaskell binding))-  AggregateMapped key -> case Map.lookup key (symbolMapped symbols) of-    Just declaration -> Set.singleton (hsPackage (mappedHaskell declaration))+    ConsumerNominal binding -> Set.singleton ((.package) ((.haskell) binding))+  AggregateMapped key -> case Map.lookup key ((.mapped) symbols) of+    Just declaration -> Set.singleton ((.package) (mappedHaskell declaration))     Nothing -> Set.empty   _ -> Set.empty   where-    mappedHaskell (ResolvedStructural declaration _) = sdHaskell declaration-    mappedHaskell (ResolvedOpaque declaration) = odHaskell declaration+    mappedHaskell (ResolvedStructural declaration _) = (.haskell) declaration+    mappedHaskell (ResolvedOpaque declaration) = (.haskell) declaration  aggregateSampleHaskell :: AggregateSymbols -> Text -> ResolvedAggregateType -> Text-aggregateSampleHaskell symbols fieldName resolved = case resolved of-  AggregateText -> tshow ("sample-" <> fieldName)+aggregateSampleHaskell symbols sampleName resolved = case resolved of+  AggregateText -> tshow ("sample-" <> sampleName)   AggregateInt -> "0"   AggregateInteger -> "0"   AggregateBool -> "False"   AggregateTime -> "(UTCTime (fromGregorian 2026 1 2) (picosecondsToDiffTime 11045123456789012))"   AggregateNatural -> "0"   AggregateNominal nominal -> nominalSample nominal-  AggregateVertex name -> firstConstructor name-  AggregateMapped key -> case Map.lookup key (symbolMapped symbols) of+  AggregateVertex vertexName -> firstConstructor vertexName+  AggregateMapped key -> case Map.lookup key ((.mapped) symbols) of     Just declaration -> "(snd (NonEmpty.head (fixtureCases " <> unQualifiedValueName (mappedFixtures declaration) <> ")))"     Nothing -> unMappedKey key <> ".sample"   where-    firstConstructor name = case Map.lookup name (symbolVertices symbols) of+    firstConstructor vertexName = case Map.lookup vertexName ((.vertices) symbols) of       Just (constructor : _) -> constructor-      _ -> name-    nominalSample nominal = case resolvedNominalOwnership nominal of+      _ -> vertexName+    nominalSample nominal = case (.ownership) nominal of       ConsumerNominal binding ->         "(nominalFixtureDomain (NonEmpty.head (nominalFixtureCases "-          <> unQualifiedValueName (consumerNominalFixtures binding)+          <> unQualifiedValueName ((.fixtures) binding)           <> ")))"-      GeneratedNominal -> case resolvedNominalRepresentation nominal of-        IdRepresentation {} -> "(" <> resolvedNominalName nominal <> " \"sample\")"+      GeneratedNominal -> case (.representation) nominal of+        IdRepresentation {} -> "(" <> (.name) nominal <> " \"sample\")"         EnumRepresentation constructors -> fst (NE.head constructors)-        ScalarRepresentation {} -> resolvedNominalName nominal <> ".sample"-    mappedFixtures (ResolvedStructural declaration _) = sdFixtures declaration-    mappedFixtures (ResolvedOpaque declaration) = odFixtures declaration+        ScalarRepresentation {} -> (.name) nominal <> ".sample"+    mappedFixtures (ResolvedStructural declaration _) = (.fixtures) declaration+    mappedFixtures (ResolvedOpaque declaration) = (.fixtures) declaration  data ResolvedRegisterInitial   = InitialText !Text@@ -364,21 +367,21 @@       Just number | number >= 0 -> pure (InitialNatural (fromInteger number))       _ -> invalid "Natural initials must be non-negative integral literals"     RegInitText _ -> invalid "Natural initials must be unquoted non-negative integral literals"-  AggregateNominal nominal -> case resolvedNominalOwnership nominal of+  AggregateNominal nominal -> case (.ownership) nominal of     ConsumerNominal binding -> case syntax of-      RegInitBare "initial" -> case consumerNominalInitial binding of-        Just value -> pure (InitialNominal (resolvedNominalName nominal) value)+      RegInitBare "initial" -> case (.initial) binding of+        Just value -> pure (InitialNominal ((.name) nominal) value)         Nothing -> invalid "consumer-owned nominal register type must declare an initial symbol"       _ -> invalid "consumer-owned nominal register initials must use the bare initial token"-    GeneratedNominal -> case resolvedNominalRepresentation nominal of+    GeneratedNominal -> case (.representation) nominal of       IdRepresentation {} -> case syntax of-        RegInitBare "placeholder" -> pure (InitialId (resolvedNominalName nominal))+        RegInitBare "placeholder" -> pure (InitialId ((.name) nominal))         _ -> invalid "ID initials must use placeholder"-      EnumRepresentation constructors -> namedInitial (resolvedNominalName nominal) (Just (map fst (NE.toList constructors)))+      EnumRepresentation constructors -> namedInitial ((.name) nominal) (Just (map fst (NE.toList constructors)))       ScalarRepresentation {} -> invalid "generated nominal scalars are unsupported"-  AggregateVertex name -> namedInitial name (Map.lookup name (symbolVertices symbols))+  AggregateVertex name -> namedInitial name (Map.lookup name ((.vertices) symbols))   AggregateMapped key -> case syntax of-    RegInitBare "initial" -> case Map.lookup key (symbolMapped symbols) >>= mappedInitial of+    RegInitBare "initial" -> case Map.lookup key ((.mapped) symbols) >>= mappedInitial of       Just value -> pure (InitialMapped key value)       Nothing -> invalid "mapped register type must declare an initial symbol"     _ -> invalid "mapped register initials must use the bare initial token"@@ -387,8 +390,8 @@     namedInitial name constructors = case syntax of       RegInitBare constructor | maybe False (constructor `elem`) constructors -> pure (InitialNamed resolved constructor)       _ -> invalid ("initial must name a constructor of " <> name)-    mappedInitial (ResolvedStructural declaration _) = sdInitial declaration-    mappedInitial (ResolvedOpaque declaration) = odInitial declaration+    mappedInitial (ResolvedStructural declaration _) = (.initial) declaration+    mappedInitial (ResolvedOpaque declaration) = (.initial) declaration  renderRegisterInitial :: ResolvedRegisterInitial -> Text renderRegisterInitial initial = case initial of@@ -432,15 +435,15 @@ pascal :: Text -> Text pascal value =   case HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site of-    Right derived -> HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)+    Right derived -> HaskellName.renderUpperCamelName ((.upperCamel) derived)     Left _ -> value   where     site =       HaskellName.NameSite-        { HaskellName.siteKind = HaskellName.GeneratedTypeSite,-          HaskellName.siteLogicalName = value,-          HaskellName.siteOwner = "aggregate-type",-          HaskellName.siteLine = 0+        { HaskellName.kind = HaskellName.GeneratedTypeSite,+          HaskellName.logicalName = value,+          HaskellName.owner = "aggregate-type",+          HaskellName.line = 0         }  tshow :: Text -> Text

src/Keiro/Dsl/BehaviorCoverage.hs view

@@ -7,6 +7,7 @@ -- consumer contract reconciles and executes witness values in a later layer. module Keiro.Dsl.BehaviorCoverage   ( BehaviorKey (..),+    unBehaviorKey,     ObligationKind (..),     EvidenceLevel (..),     GuardCoverage (..),@@ -50,6 +51,9 @@ newtype BehaviorKey = BehaviorKey {unBehaviorKey :: Text}   deriving stock (Eq, Ord, Show) +unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value+ data ObligationKind   = LiveTransition   | RequiredRejection@@ -85,31 +89,31 @@ -- | 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+  { sourceFile :: !FilePath,+    sourceLine :: !Int,+    sourceColumn :: !Int   }   deriving stock (Eq, Ord, Show)  data BehaviorRequirement = BehaviorRequirement-  { requirementKey :: !BehaviorKey,-    requirementOrigin :: !RequirementOrigin,-    requirementKind :: !ObligationKind,-    requirementEvidence :: !EvidenceLevel,-    requirementGuardCoverage :: !GuardCoverage,-    requirementContext :: !Name,-    requirementAggregate :: !Name,-    requirementSource :: !Name,-    requirementCommand :: !Name,-    requirementTarget :: !(Maybe Name),-    requirementMode :: !(Maybe TransitionMode),-    requirementEvents :: ![Name],-    requirementOutputs :: ![OutputEvidence],-    requirementDomainOutcome :: !(Maybe TransitionOutcome),-    requirementLocation :: !Loc,-    requirementExactLocation :: !(Maybe BehaviorExactLocation),-    requirementOwner :: !(Maybe FilePath),-    requirementCanonical :: !Text+  { key :: !BehaviorKey,+    origin :: !RequirementOrigin,+    kind :: !ObligationKind,+    evidence :: !EvidenceLevel,+    guardCoverage :: !GuardCoverage,+    context :: !Name,+    aggregate :: !Name,+    source :: !Name,+    command :: !Name,+    target :: !(Maybe Name),+    mode :: !(Maybe TransitionMode),+    events :: ![Name],+    outputs :: ![OutputEvidence],+    domainOutcome :: !(Maybe TransitionOutcome),+    location :: !Loc,+    exactLocation :: !(Maybe BehaviorExactLocation),+    owner :: !(Maybe FilePath),+    canonical :: !Text   }   deriving stock (Eq, Show) @@ -117,14 +121,14 @@ -- retain enough human-readable identity to report additions and removals -- without re-reading or attempting to understand consumer Haskell. data BehaviorRecordRow = BehaviorRecordRow-  { behaviorRecordKey :: !BehaviorKey,-    behaviorRecordKind :: !ObligationKind,-    behaviorRecordEvidence :: !EvidenceLevel,-    behaviorRecordAggregate :: !Name,-    behaviorRecordSource :: !Name,-    behaviorRecordCommand :: !Name,-    behaviorRecordOwner :: !(Maybe FilePath),-    behaviorRecordOutputs :: ![OutputEvidence]+  { key :: !BehaviorKey,+    kind :: !ObligationKind,+    evidence :: !EvidenceLevel,+    aggregate :: !Name,+    source :: !Name,+    command :: !Name,+    owner :: !(Maybe FilePath),+    outputs :: ![OutputEvidence]   }   deriving stock (Eq, Ord, Show) @@ -136,9 +140,9 @@   deriving stock (Eq, Show)  data BehaviorObligationsReport = BehaviorObligationsReport-  { behaviorSubject :: !FilePath,-    behaviorWorkspaceService :: !(Maybe Text),-    behaviorRequirements :: ![BehaviorRequirement]+  { subject :: !FilePath,+    workspaceService :: !(Maybe Text),+    requirements :: ![BehaviorRequirement]   }   deriving stock (Eq, Show) @@ -189,15 +193,15 @@ instance ToJSON BehaviorRecordRow where   toJSON row =     object-      ( [ "key" .= behaviorRecordKey row,-          "kind" .= behaviorRecordKind row,-          "evidence" .= behaviorRecordEvidence row,-          "aggregate" .= behaviorRecordAggregate row,-          "source" .= behaviorRecordSource row,-          "command" .= behaviorRecordCommand row,-          "outputs" .= behaviorRecordOutputs row+      ( [ "key" .= (.key) row,+          "kind" .= (.kind) row,+          "evidence" .= (.evidence) row,+          "aggregate" .= (.aggregate) row,+          "source" .= (.source) row,+          "command" .= (.command) row,+          "outputs" .= (.outputs) row         ]-          <> ["owner" .= owner | Just owner <- [behaviorRecordOwner row]]+          <> ["owner" .= owner | Just owner <- [(.owner) row]]       )  instance FromJSON BehaviorRecordRow where@@ -215,38 +219,38 @@ 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,+      ( [ "key" .= (.key) requirement,+          "kind" .= (.kind) requirement,+          "evidence" .= (.evidence) requirement,+          "guardCoverage" .= (.guardCoverage) requirement,+          "context" .= (.context) requirement,+          "aggregate" .= (.aggregate) requirement,+          "source" .= (.source) requirement,+          "command" .= (.command) requirement,+          "target" .= (.target) requirement,+          "mode" .= fmap transitionModeText ((.mode) requirement),+          "events" .= (.events) requirement,+          "outputs" .= (.outputs) 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)]+              ( ["line" .= maybe (unLoc ((.location) requirement)) (.sourceLine) ((.exactLocation) requirement)]+                  <> ["member" .= owner | Just owner <- [(.owner) requirement]]+                  <> ["file" .= (.sourceFile) exact | Just exact <- [(.exactLocation) requirement]]+                  <> ["column" .= (.sourceColumn) exact | Just exact <- [(.exactLocation) requirement]]+                  <> ["quality" .= maybe ("line-only" :: Text) (const "exact") ((.exactLocation) requirement)]               )         ]-          <> ["domainOutcome" .= canonicalTransitionOutcome (Just outcome) | Just outcome <- [requirementDomainOutcome requirement]]+          <> ["domainOutcome" .= canonicalTransitionOutcome (Just outcome) | Just outcome <- [(.domainOutcome) requirement]]       )  instance ToJSON BehaviorObligationsReport where   toJSON report =     object       ( [ "schema" .= ("keiro-dsl/behavior-obligations/1" :: Text),-          "subject" .= behaviorSubject report,-          "requirements" .= behaviorRequirements report+          "subject" .= (.subject) report,+          "requirements" .= (.requirements) report         ]-          <> ["workspace" .= object ["service" .= service] | Just service <- [behaviorWorkspaceService report]]+          <> ["workspace" .= object ["service" .= service] | Just service <- [(.workspaceService) report]]       )  deriveBehaviorRequirements :: Spec -> Either [BehaviorDerivationError] [BehaviorRequirement]@@ -261,9 +265,9 @@   Left derivationError -> Left [derivationError]   Right raw -> do     rejectIdentityDefects raw-    pure (sortOn requirementKey raw)+    pure (sortOn (.key) raw)   where-    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]+    aggregates = [aggregate | NAggregate aggregate <- (.nodes) spec]  deriveAggregateBehaviorRequirements :: Spec -> Aggregate -> Either BehaviorDerivationError [BehaviorRequirement] deriveAggregateBehaviorRequirements spec = deriveAggregateBehaviorRequirementsWithGraphResult (resolveTypeGraph spec) spec@@ -271,21 +275,21 @@ 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)+      indexedTransitions = zip (map TransitionOrdinal [0 ..]) ((.transitions) aggregate)       liveTransitions =         [ (ordinal, transition)         | (ordinal, transition) <- indexedTransitions,-          tMode transition == TmLive,-          tSource transition `Set.member` reachable+          (.mode) transition == TmLive,+          (.source) transition `Set.member` reachable         ]-      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 =+      replayTransitions = [(ordinal, transition) | (ordinal, transition) <- indexedTransitions, (.mode) transition == TmReplayOnly]+      commands = map (\command -> command.name) ((.commands) aggregate)+      cells = [(state, commandName) | state <- Set.toAscList reachable, commandName <- commands]+      cellTransitions state commandName =         [ (ordinal, transition)         | (ordinal, transition) <- liveTransitions,-          tSource transition == state,-          tCommand transition == command+          (.source) transition == state,+          (.command) transition == commandName         ]       transitionRows =         [ transitionRequirement typeGraphResult spec aggregate (cellGuardCoverage (map snd siblings)) ordinal transition@@ -306,19 +310,38 @@   where     toRow requirement =       BehaviorRecordRow-        { behaviorRecordKey = requirementKey requirement,-          behaviorRecordKind = requirementKind requirement,-          behaviorRecordEvidence = requirementEvidence requirement,-          behaviorRecordAggregate = requirementAggregate requirement,-          behaviorRecordSource = requirementSource requirement,-          behaviorRecordCommand = requirementCommand requirement,-          behaviorRecordOwner = requirementOwner requirement,-          behaviorRecordOutputs = requirementOutputs requirement+        { key = (.key) requirement,+          kind = (.kind) requirement,+          evidence = (.evidence) requirement,+          aggregate = (.aggregate) requirement,+          source = (.source) requirement,+          command = (.command) requirement,+          owner = (.owner) requirement,+          outputs = (.outputs) requirement         }  attributeBehaviorOwner :: (Name -> Maybe FilePath) -> BehaviorRequirement -> BehaviorRequirement-attributeBehaviorOwner ownerForAggregate requirement =-  requirement {requirementOwner = ownerForAggregate (requirementAggregate requirement)}+attributeBehaviorOwner ownerForAggregate BehaviorRequirement {key, origin, kind, evidence, guardCoverage, context, aggregate, source, command, target, mode, events, outputs, domainOutcome, location, exactLocation, canonical} =+  BehaviorRequirement+    { key,+      origin,+      kind,+      evidence,+      guardCoverage,+      context,+      aggregate,+      source,+      command,+      target,+      mode,+      events,+      outputs,+      domainOutcome,+      location,+      exactLocation,+      owner = ownerForAggregate aggregate,+      canonical+    }  behaviorObligationsReport :: FilePath -> Spec -> Either [BehaviorDerivationError] BehaviorObligationsReport behaviorObligationsReport subject spec =@@ -326,59 +349,59 @@  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))+  if null ((.emits) transition) && ((.source) transition /= (.goto) transition || not (null ((.writes) transition)))+    then Left (EventlessStateChange ((.name) aggregate) ((.source) transition) ((.command) transition))     else pure ()   mappings <-     traverse       (\(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+      (zip [1 ..] ((.emits) transition))+  let kind = if (.mode) transition == TmLive then LiveTransition else ReplayTransition       outputs = map outputEvidence mappings       canonical = transitionCanonical spec aggregate kind transition mappings   pure     BehaviorRequirement-      { requirementKey = canonicalKey canonical,-        requirementOrigin = TransitionRequirementOrigin (aggName aggregate) ordinal,-        requirementKind = kind,-        requirementEvidence = transitionEvidence transition,-        requirementGuardCoverage = guardCoverage,-        requirementContext = specContext spec,-        requirementAggregate = aggName aggregate,-        requirementSource = tSource transition,-        requirementCommand = tCommand transition,-        requirementTarget = Just (tGoto transition),-        requirementMode = Just (tMode transition),-        requirementEvents = tEmits transition,-        requirementOutputs = outputs,-        requirementDomainOutcome = tOutcome transition,-        requirementLocation = tLoc transition,-        requirementExactLocation = Nothing,-        requirementOwner = Nothing,-        requirementCanonical = canonical+      { key = canonicalKey canonical,+        origin = TransitionRequirementOrigin ((.name) aggregate) ordinal,+        kind = kind,+        evidence = transitionEvidence transition,+        guardCoverage = guardCoverage,+        context = (.context) spec,+        aggregate = (.name) aggregate,+        source = (.source) transition,+        command = (.command) transition,+        target = Just ((.goto) transition),+        mode = Just ((.mode) transition),+        events = (.emits) transition,+        outputs = outputs,+        domainOutcome = (.outcome) transition,+        location = (.loc) transition,+        exactLocation = Nothing,+        owner = Nothing,+        canonical = canonical       }  rejectionRequirement :: Spec -> Aggregate -> Name -> Name -> BehaviorRequirement rejectionRequirement spec aggregate state command =   BehaviorRequirement-    { requirementKey = canonicalKey canonical,-      requirementOrigin = RejectionRequirementOrigin (aggName aggregate) state,-      requirementKind = RequiredRejection,-      requirementEvidence = aggregateEvidence aggregate,-      requirementGuardCoverage = GuardNotApplicable,-      requirementContext = specContext spec,-      requirementAggregate = aggName aggregate,-      requirementSource = state,-      requirementCommand = command,-      requirementTarget = Nothing,-      requirementMode = Nothing,-      requirementEvents = [],-      requirementOutputs = [],-      requirementDomainOutcome = Nothing,-      requirementLocation = maybe (aggLoc aggregate) stLoc (find ((== state) . stName) (aggStates aggregate)),-      requirementExactLocation = Nothing,-      requirementOwner = Nothing,-      requirementCanonical = canonical+    { key = canonicalKey canonical,+      origin = RejectionRequirementOrigin ((.name) aggregate) state,+      kind = RequiredRejection,+      evidence = aggregateEvidence aggregate,+      guardCoverage = GuardNotApplicable,+      context = (.context) spec,+      aggregate = (.name) aggregate,+      source = state,+      command = command,+      target = Nothing,+      mode = Nothing,+      events = [],+      outputs = [],+      domainOutcome = Nothing,+      location = maybe ((.loc) aggregate) (.loc) (find ((== state) . (.name)) ((.states) aggregate)),+      exactLocation = Nothing,+      owner = Nothing,+      canonical = canonical     }   where     canonical =@@ -386,8 +409,8 @@         "|"         [ "behavior-v1",           "kind=rejection",-          "context=" <> specContext spec,-          "aggregate=" <> aggName aggregate,+          "context=" <> (.context) spec,+          "aggregate=" <> (.name) aggregate,           "source=" <> state,           "command=" <> command         ]@@ -398,27 +421,27 @@     "|"     ( [ "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),+        "context=" <> (.context) spec,+        "aggregate=" <> (.name) aggregate,+        "mode=" <> transitionModeText ((.mode) transition),+        "source=" <> (.source) transition,+        "command=" <> (.command) transition,+        "implementation=" <> implementationText ((.implementation) transition),+        "guard=" <> maybe "" renderExpr ((.guard) transition),+        "writes=" <> T.intercalate ";" [name <> ":=" <> renderExpr expression | (name, expression) <- (.writes) transition],+        "events=" <> T.intercalate "," ((.emits) transition),         "outputs=" <> T.intercalate "," (map eventOutputCanonical mappings),-        "target=" <> tGoto transition+        "target=" <> (.goto) transition       ]         ++ outcomeSegments     )   where-    outcomeSegments = case aggDomainOutcomeTypes aggregate of+    outcomeSegments = case (.domainOutcomeTypes) aggregate of       Nothing -> []       Just declaration ->-        [ "outcome-rejection-type=" <> rejectionType declaration,-          "outcome-no-op-type=" <> noOpType declaration,-          "domain-outcome=" <> canonicalTransitionOutcome (tOutcome transition)+        [ "outcome-rejection-type=" <> (.rejectionType) declaration,+          "outcome-no-op-type=" <> (.noOpType) declaration,+          "domain-outcome=" <> canonicalTransitionOutcome ((.outcome) transition)         ]  canonicalKey :: Text -> BehaviorKey@@ -430,25 +453,25 @@   HandOwnedEventOutput obligation -> HandOwnedOutput obligation  transitionEvidence :: Transition -> EvidenceLevel-transitionEvidence transition = case tImplementation transition of+transitionEvidence transition = case (.implementation) transition of   LegacyHoleImplementation -> LegacyRuntimeWitness   GeneratedImplementation -> GeneratedAuthoritative   HoleImplementation -> HoleWitnessed  aggregateEvidence :: Aggregate -> EvidenceLevel aggregateEvidence aggregate-  | any ((/= LegacyHoleImplementation) . tImplementation) (aggTransitions aggregate) = GeneratedAuthoritative+  | any ((/= LegacyHoleImplementation) . (.implementation)) ((.transitions) aggregate) = GeneratedAuthoritative   | otherwise = LegacyRuntimeWitness  cellGuardCoverage :: [Transition] -> GuardCoverage cellGuardCoverage transitions-  | any ((== Nothing) . tGuard) transitions = GuardTotal+  | any ((== Nothing) . (.guard)) transitions = GuardTotal   | any crossesOneWayProjection guards = GuardUnknown   | complementary = GuardTotal   | all isLiteralFalse guards = GuardPartial   | otherwise = GuardUnknown   where-    guards = [guard | transition <- transitions, Just guard <- [tGuard transition]]+    guards = [guard | transition <- transitions, Just guard <- [(.guard) transition]]     complementary = or [left == complementExpr right | left <- guards, right <- guards, left /= right]     isLiteralFalse (EAtom (ABool False)) = True     isLiteralFalse _ = False@@ -468,22 +491,22 @@  replayGuardCoverage :: Transition -> GuardCoverage replayGuardCoverage transition-  | maybe False crossesOneWayProjection (tGuard transition) = GuardUnknown+  | maybe False crossesOneWayProjection ((.guard) transition) = GuardUnknown   | otherwise = GuardNotApplicable  liveReachableStates :: Aggregate -> Set Name-liveReachableStates aggregate = case map stName (aggStates aggregate) of+liveReachableStates aggregate = case map (\state -> state.name) ((.states) aggregate) of   [] -> Set.empty   initial : _ -> go (Set.singleton initial) [initial]   where     go seen [] = seen     go seen (source : remaining) =       let next =-            [ tGoto transition-            | transition <- aggTransitions aggregate,-              tMode transition == TmLive,-              tSource transition == source,-              tGoto transition `Set.notMember` seen+            [ (.goto) transition+            | transition <- (.transitions) aggregate,+              (.mode) transition == TmLive,+              (.source) transition == source,+              (.goto) transition `Set.notMember` seen             ]        in go (foldr Set.insert seen next) (remaining <> next) @@ -492,18 +515,18 @@   [] -> Right ()   errors -> Left errors   where-    byCanonical = groupsOn requirementCanonical requirements+    byCanonical = groupsOn (.canonical) requirements     duplicateErrors =-      [ DuplicateBehaviorIdentity canonical (map requirementLocation duplicates)+      [ DuplicateBehaviorIdentity canonicalIdentity (map (\requirement -> requirement.location) duplicates)       | duplicates@(first : _ : _) <- byCanonical,-        let canonical = requirementCanonical first+        let canonicalIdentity = (.canonical) first       ]-    byKey = groupsOn requirementKey requirements+    byKey = groupsOn (.key) requirements     collisionErrors =-      [ BehaviorKeyCollision key canonicals+      [ BehaviorKeyCollision behaviorKey canonicals       | collisions@(first : _ : _) <- byKey,-        let key = requirementKey first,-        let canonicals = Set.toAscList (Set.fromList (map requirementCanonical collisions)),+        let behaviorKey = (.key) first,+        let canonicals = Set.toAscList (Set.fromList (map (\requirement -> requirement.canonical) collisions)),         length canonicals > 1       ] @@ -513,40 +536,40 @@ renderBehaviorObligationsText :: BehaviorObligationsReport -> Text renderBehaviorObligationsText report =   T.unlines-    ( [ "behavior obligations: " <> T.pack (behaviorSubject report),+    ( [ "behavior obligations: " <> T.pack ((.subject) report),         "schema: keiro-dsl/behavior-obligations/1",-        "required: " <> tshow (length (behaviorRequirements report))+        "required: " <> tshow (length ((.requirements) report))       ]-        <> map renderRequirement (behaviorRequirements report)+        <> map renderRequirement ((.requirements) report)     )   where     renderRequirement requirement =-      unBehaviorKey (requirementKey requirement)+      unBehaviorKey ((.key) requirement)         <> " "-        <> obligationKindText (requirementKind requirement)+        <> obligationKindText ((.kind) requirement)         <> " "-        <> requirementAggregate requirement+        <> (.aggregate) requirement         <> ":"-        <> requirementSource requirement+        <> (.source) requirement         <> " -- "-        <> requirementCommand requirement+        <> (.command) requirement         <> " ["-        <> evidenceLevelText (requirementEvidence requirement)+        <> evidenceLevelText ((.evidence) requirement)         <> ", guard="-        <> guardCoverageText (requirementGuardCoverage requirement)+        <> guardCoverageText ((.guardCoverage) requirement)         <> "]"-        <> maybe (renderLineOnly requirement) renderExact (requirementExactLocation requirement)+        <> maybe (renderLineOnly requirement) renderExact ((.exactLocation) requirement)     renderExact exact =       " "-        <> T.pack (exactSourceFile exact)+        <> T.pack ((.sourceFile) exact)         <> ":"-        <> tshow (exactSourceLine exact)+        <> tshow ((.sourceLine) exact)         <> ":"-        <> tshow (exactSourceColumn exact)+        <> tshow ((.sourceColumn) exact)         <> " [location-quality=exact]"     renderLineOnly requirement =       " line "-        <> tshow (unLoc (requirementLocation requirement))+        <> tshow (unLoc ((.location) requirement))         <> " [location-quality=line-only]"  encodeBehaviorObligationsJson :: BehaviorObligationsReport -> Text

src/Keiro/Dsl/BehaviorSourceMap.hs view

@@ -17,15 +17,8 @@ import Keiro.Dsl.BehaviorCoverage   ( BehaviorExactLocation (..),     BehaviorKey,-    BehaviorRequirement,+    BehaviorRequirement (..),     RequirementOrigin (..),-    requirementAggregate,-    requirementCanonical,-    requirementCommand,-    requirementExactLocation,-    requirementKey,-    requirementOrigin,-    requirementSource,   ) import Keiro.Dsl.Source (SourcePoint (..), SourceSpan (..)) import Keiro.Dsl.SourceIndex@@ -42,23 +35,23 @@   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+  { code :: !BehaviorSourceFailureCode,+    key :: !BehaviorKey,+    origin :: !RequirementOrigin,+    aggregate :: !Text,+    state :: !Text,+    command :: !Text,+    sourceSubject :: !SourceSubject,+    span :: !(Maybe SourceSpan),+    message :: !Text   }   deriving stock (Eq, Show)  data BehaviorSourceEntry = BehaviorSourceEntry-  { behaviorSourceKey :: !BehaviorKey,-    behaviorSourceFile :: !FilePath,-    behaviorSourceLine :: !Int,-    behaviorSourceColumn :: !Int+  { key :: !BehaviorKey,+    file :: !FilePath,+    line :: !Int,+    column :: !Int   }   deriving stock (Eq, Ord, Show) @@ -76,44 +69,44 @@       | otherwise -> Left (missingJoinFailures requirementKeys entryKeys)     failures -> Left (sortOn failureSortKey failures)   where-    duplicateFailures = concatMap duplicateKeyFailure (groupsOn requirementKey requirements)+    duplicateFailures = concatMap duplicateKeyFailure (groupsOn (.key) 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+          { code = BehaviorSourceAnchorCollision,+            key = (.key) first,+            origin = (.origin) first,+            aggregate = (.aggregate) first,+            state = (.source) first,+            command = (.command) first,+            sourceSubject = requirementSourceSubject ((.origin) first),+            span = Nothing,+            message =+              if Set.size (Set.fromList (map (.canonical) 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]+    uniqueRequirements = [requirement | [requirement] <- groupsOn (.key) 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)+    sortedEntries = sortOn (.key) [entry | Right entry <- planned]+    requirementKeys = Set.fromList (map (.key) requirements)+    entryKeys = Set.fromList (map (.key) 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"+          { code = BehaviorSourceAnchorMissing,+            key = (.key) requirement,+            origin = (.origin) requirement,+            aggregate = (.aggregate) requirement,+            state = (.source) requirement,+            command = (.command) requirement,+            sourceSubject = requirementSourceSubject ((.origin) requirement),+            span = Nothing,+            message = "behavior requirement is absent from the completed source-map join"           }       | requirement <- requirements,-        requirementKey requirement `Set.member` (expected Set.\\ actual)+        (.key) requirement `Set.member` (expected Set.\\ actual)       ]  -- | Attach exact presentation data after a successful complete join. Unknown@@ -123,20 +116,42 @@ 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+    byKey = Map.fromList [((.key) entry, entry) | entry <- entries]+    attach requirement = case Map.lookup ((.key) requirement) byKey of       Nothing -> requirement       Just entry ->-        requirement-          { requirementExactLocation =-              Just-                BehaviorExactLocation-                  { exactSourceFile = behaviorSourceFile entry,-                    exactSourceLine = behaviorSourceLine entry,-                    exactSourceColumn = behaviorSourceColumn entry-                  }-          }+        replaceRequirementExactLocation+          ( Just+              BehaviorExactLocation+                { sourceFile = entry.file,+                  sourceLine = entry.line,+                  sourceColumn = entry.column+                }+          )+          requirement +    replaceRequirementExactLocation exactLocation requirement =+      BehaviorRequirement+        { key = requirement.key,+          origin = requirement.origin,+          kind = requirement.kind,+          evidence = requirement.evidence,+          guardCoverage = requirement.guardCoverage,+          context = requirement.context,+          aggregate = requirement.aggregate,+          source = requirement.source,+          command = requirement.command,+          target = requirement.target,+          mode = requirement.mode,+          events = requirement.events,+          outputs = requirement.outputs,+          domainOutcome = requirement.domainOutcome,+          location = requirement.location,+          exactLocation,+          owner = requirement.owner,+          canonical = requirement.canonical+        }+ planEntry :: SemanticSourceIndex -> BehaviorRequirement -> Either BehaviorSourceFailure BehaviorSourceEntry planEntry sourceIndex requirement =   case lookupSourceSpan subject sourceIndex of@@ -146,24 +161,24 @@     Just (ExactSourcePosition, SourceSpan {source, start = SourcePoint {line, column}}) ->       Right         BehaviorSourceEntry-          { behaviorSourceKey = requirementKey requirement,-            behaviorSourceFile = source,-            behaviorSourceLine = line,-            behaviorSourceColumn = column+          { key = (.key) requirement,+            file = source,+            line = line,+            column = column           }   where-    subject = requirementSourceSubject (requirementOrigin requirement)-    failure failureCode failureSpan failureMessage =+    subject = requirementSourceSubject ((.origin) requirement)+    failure code sourceSpan message =       BehaviorSourceFailure-        { failureCode,-          failureKey = requirementKey requirement,-          failureOrigin = requirementOrigin requirement,-          failureAggregate = requirementAggregate requirement,-          failureState = requirementSource requirement,-          failureCommand = requirementCommand requirement,-          failureSourceSubject = subject,-          failureSpan,-          failureMessage+        { code,+          key = (.key) requirement,+          origin = (.origin) requirement,+          aggregate = (.aggregate) requirement,+          state = (.source) requirement,+          command = (.command) requirement,+          sourceSubject = subject,+          span = sourceSpan,+          message         }  requirementSourceSubject :: RequirementOrigin -> SourceSubject@@ -175,5 +190,5 @@ groupsOn key = groupBy (\left right -> key left == key right) . sortOn key  failureSortKey :: BehaviorSourceFailure -> (BehaviorSourceFailureCode, BehaviorKey, RequirementOrigin)-failureSortKey BehaviorSourceFailure {failureCode, failureKey, failureOrigin} =-  (failureCode, failureKey, failureOrigin)+failureSortKey BehaviorSourceFailure {code, key, origin} =+  (code, key, origin)

src/Keiro/Dsl/CanonicalEncoding.hs view

@@ -42,7 +42,7 @@ canonicalDomainOutcomeTypes :: Maybe DomainOutcomeTypes -> Text canonicalDomainOutcomeTypes Nothing = "" canonicalDomainOutcomeTypes (Just declaration) =-  "rejection=" <> rejectionType declaration <> "|no-op=" <> noOpType 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@@ -101,18 +101,18 @@ docTransition :: Transition -> Doc ann docTransition transition =   vsep $-    [modePrefix <> pretty (tSource transition) <+> "--" <+> pretty (tCommand transition) <+> "-->"]+    [modePrefix <> pretty ((.source) transition) <+> "--" <+> pretty ((.command) transition) <+> "-->"]       ++ map (indent 2) clauses   where-    modePrefix = case tMode transition of+    modePrefix = case (.mode) transition of       TmLive -> mempty       TmReplayOnly -> "replay-only "     clauses =-      ["implementation hole" | tImplementation transition == HoleImplementation]-        ++ maybe [] (\guardExpression -> ["guard" <+> docExpr 0 guardExpression]) (tGuard transition)-        ++ map (\(registerName, expression) -> "write" <+> pretty registerName <+> ":=" <+> docExpr 0 expression) (tWrites transition)-        ++ map (\eventName -> "emit" <+> pretty eventName) (tEmits transition)-        ++ ["goto" <+> pretty (tGoto transition)]+      ["implementation hole" | (.implementation) transition == HoleImplementation]+        ++ maybe [] (\guardExpression -> ["guard" <+> docExpr 0 guardExpression]) ((.guard) transition)+        ++ map (\(registerName, expression) -> "write" <+> pretty registerName <+> ":=" <+> docExpr 0 expression) ((.writes) transition)+        ++ map (\eventName -> "emit" <+> pretty eventName) ((.emits) transition)+        ++ ["goto" <+> pretty ((.goto) transition)]  -- | @showsPrec@-style frozen expression encoding. Precedence levels are -- @||@ = 1, @&&@ = 2, comparisons = 3, addition/subtraction = 4,

src/Keiro/Dsl/CheckReport.hs view

@@ -33,56 +33,56 @@ import Data.Set qualified as Set import Data.Text (Text) import Keiro.Dsl.LanguageVersion (LanguageSupport (..), LanguageVersion, SourceLanguage, declaredLanguageVersionMaybe, languageSupportText, sourceFormText)-import Keiro.Dsl.SemanticContract (EffectiveLanguageContract, effectiveContractLanguageVersion, effectiveLanguageSupport, effectiveRuntimeSemantics)+import Keiro.Dsl.SemanticContract (EffectiveLanguageContract (..), effectiveLanguageSupport, effectiveRuntimeSemantics) import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode, Severity (..), diagnosticCodeText) import Keiro.Dsl.Workspace (WorkspaceDiagnostic (..), WorkspaceLocation (..), WorkspaceMember (..), WorkspaceSpec (..), workspaceDisplayPath)  data CheckReportLanguage = CheckReportLanguage-  { reportSourceForm :: !Text,-    reportDeclaredLanguageVersion :: !(Maybe LanguageVersion),-    reportEffectiveLanguageVersion :: !LanguageVersion,-    reportRuntimeSemantics :: !Text,-    reportLanguageSupport :: !LanguageSupport,-    reportStable :: !Bool+  { sourceForm :: !Text,+    declaredLanguageVersion :: !(Maybe LanguageVersion),+    effectiveLanguageVersion :: !LanguageVersion,+    runtimeSemantics :: !Text,+    languageSupport :: !LanguageSupport,+    stable :: !Bool   }   deriving stock (Eq, Show)  data CheckReportEnforcement = CheckReportEnforcement-  { reportMinLanguage :: !(Maybe LanguageVersion),-    reportDenyWarnings :: !Bool,-    reportDenyCodes :: ![DiagnosticCode]+  { minLanguage :: !(Maybe LanguageVersion),+    denyWarnings :: !Bool,+    denyCodes :: ![DiagnosticCode]   }   deriving stock (Eq, Show)  data CheckReportRelated = CheckReportRelated-  { relatedFile :: !FilePath,-    relatedLine :: !Int,-    relatedNote :: !Text+  { file :: !FilePath,+    line :: !Int,+    note :: !Text   }   deriving stock (Eq, Show)  data CheckReportEntry = CheckReportEntry-  { entryCode :: !DiagnosticCode,-    entrySeverity :: !Severity,-    entryFile :: !FilePath,-    entryLine :: !Int,-    entryMessage :: !Text,-    entryDenied :: !Bool,-    entryRelated :: ![CheckReportRelated]+  { code :: !DiagnosticCode,+    severity :: !Severity,+    file :: !FilePath,+    line :: !Int,+    message :: !Text,+    denied :: !Bool,+    related :: ![CheckReportRelated]   }   deriving stock (Eq, Show)  data CheckReportSummary = CheckReportSummary-  { summaryErrors :: !Int,-    summaryWarnings :: !Int,-    summaryDeniedWarnings :: !Int+  { errors :: !Int,+    warnings :: !Int,+    deniedWarnings :: !Int   }   deriving stock (Eq, Show)  data CheckReportMember = CheckReportMember-  { memberPath :: !FilePath,-    memberSourceForm :: !Text,-    memberDeclaredLanguageVersion :: !(Maybe LanguageVersion)+  { path :: !FilePath,+    sourceForm :: !Text,+    declaredLanguageVersion :: !(Maybe LanguageVersion)   }   deriving stock (Eq, Show) @@ -90,17 +90,17 @@   deriving stock (Eq, Show)  data CheckReport = CheckReport-  { reportKind :: !CheckReportKind,-    reportSubject :: !FilePath,+  { kind :: !CheckReportKind,+    subject :: !FilePath,     -- | 'Nothing' only for a workspace that was refused during composition:     -- there is no composed service, so no effective language contract exists to     -- describe. Such a report serializes @"language": null@.-    reportLanguage :: !(Maybe CheckReportLanguage),-    reportEnforcement :: !CheckReportEnforcement,-    reportDiagnostics :: ![CheckReportEntry],-    reportSummary :: !CheckReportSummary,-    reportOk :: !Bool,-    reportMembers :: ![CheckReportMember]+    language :: !(Maybe CheckReportLanguage),+    enforcement :: !CheckReportEnforcement,+    diagnostics :: ![CheckReportEntry],+    summary :: !CheckReportSummary,+    ok :: !Bool,+    members :: ![CheckReportMember]   }   deriving stock (Eq, Show) @@ -108,8 +108,8 @@ -- by report entries. @--deny-warnings@ is the union with every registered code. effectiveDenyCodes :: CheckReportEnforcement -> Set DiagnosticCode effectiveDenyCodes enforcement-  | reportDenyWarnings enforcement = Set.fromList [minBound .. maxBound]-  | otherwise = Set.fromList (reportDenyCodes enforcement)+  | (.denyWarnings) enforcement = Set.fromList [minBound .. maxBound]+  | otherwise = Set.fromList ((.denyCodes) enforcement)  checkReport ::   FilePath ->@@ -143,7 +143,7 @@     (Just (workspaceLanguageValue contract))     enforcement     (map (workspaceEntry subject deniedCodes) diagnostics)-    (map memberValue (wsMembers workspace))+    (map memberValue ((.members) workspace))  -- | The report for a workspace refused during composition, before any service -- graph exists. Composition refusals are coded diagnostics, so they belong in@@ -175,21 +175,21 @@   CheckReport buildReport kind subject language enforcement entries members =   CheckReport-    { reportKind = kind,-      reportSubject = subject,-      reportLanguage = language,-      reportEnforcement = enforcement,-      reportDiagnostics = entries,-      reportSummary = summary,-      reportOk = summaryErrors summary == 0 && summaryDeniedWarnings summary == 0,-      reportMembers = members+    { kind = kind,+      subject = subject,+      language = language,+      enforcement = enforcement,+      diagnostics = entries,+      summary = summary,+      ok = (.errors) summary == 0 && (.deniedWarnings) summary == 0,+      members = members     }   where     summary =       CheckReportSummary-        { summaryErrors = length [() | entry <- entries, entrySeverity entry == Error],-          summaryWarnings = length [() | entry <- entries, entrySeverity entry == Warning],-          summaryDeniedWarnings = length [() | entry <- entries, entryDenied entry]+        { errors = length [() | entry <- entries, (.severity) entry == Error],+          warnings = length [() | entry <- entries, (.severity) entry == Warning],+          deniedWarnings = length [() | entry <- entries, (.denied) entry]         }  sourceLanguageValue :: SourceLanguage -> EffectiveLanguageContract -> CheckReportLanguage@@ -205,12 +205,12 @@ languageValue :: Text -> Maybe LanguageVersion -> EffectiveLanguageContract -> CheckReportLanguage languageValue sourceForm declared contract =   CheckReportLanguage-    { reportSourceForm = sourceForm,-      reportDeclaredLanguageVersion = declared,-      reportEffectiveLanguageVersion = effectiveContractLanguageVersion contract,-      reportRuntimeSemantics = effectiveRuntimeSemantics contract,-      reportLanguageSupport = support,-      reportStable = support == Stable+    { sourceForm = sourceForm,+      declaredLanguageVersion = declared,+      effectiveLanguageVersion = (.contractLanguageVersion) contract,+      runtimeSemantics = effectiveRuntimeSemantics contract,+      languageSupport = support,+      stable = support == Stable     }   where     support = effectiveLanguageSupport contract@@ -218,45 +218,45 @@ memberValue :: WorkspaceMember -> CheckReportMember memberValue member =   CheckReportMember-    { memberPath = wmPath member,-      memberSourceForm = sourceFormText (wmSourceLanguage member),-      memberDeclaredLanguageVersion = declaredLanguageVersionMaybe (wmSourceLanguage member)+    { path = (.path) member,+      sourceForm = sourceFormText ((.sourceLanguage) member),+      declaredLanguageVersion = declaredLanguageVersionMaybe ((.sourceLanguage) member)     }  sourceEntry :: FilePath -> Set DiagnosticCode -> Diagnostic -> CheckReportEntry sourceEntry subject deniedCodes diagnostic =   CheckReportEntry-    { entryCode = code diagnostic,-      entrySeverity = severity diagnostic,-      entryFile = subject,-      entryLine = line diagnostic,-      entryMessage = message diagnostic,-      entryDenied = warningDenied deniedCodes (severity diagnostic) (code diagnostic),-      entryRelated =+    { code = (.code) diagnostic,+      severity = (.severity) diagnostic,+      file = subject,+      line = (.line) diagnostic,+      message = (.message) diagnostic,+      denied = warningDenied deniedCodes ((.severity) diagnostic) ((.code) diagnostic),+      related =         [ CheckReportRelated subject relatedLineNumber note-        | (relatedLineNumber, note) <- relatedLocations diagnostic+        | (relatedLineNumber, note) <- (.relatedLocations) diagnostic         ]     }  workspaceEntry :: FilePath -> Set DiagnosticCode -> WorkspaceDiagnostic -> CheckReportEntry workspaceEntry subject deniedCodes diagnostic =   CheckReportEntry-    { entryCode = wdCode diagnostic,-      entrySeverity = wdSeverity diagnostic,-      entryFile = workspaceDisplayPath subject (wlFile primary),-      entryLine = wlLine primary,-      entryMessage = wdMessage diagnostic,-      entryDenied = warningDenied deniedCodes (wdSeverity diagnostic) (wdCode diagnostic),-      entryRelated =+    { code = (.code) diagnostic,+      severity = (.severity) diagnostic,+      file = workspaceDisplayPath subject ((.file) primary),+      line = (.line) primary,+      message = (.message) diagnostic,+      denied = warningDenied deniedCodes ((.severity) diagnostic) ((.code) diagnostic),+      related =         [ CheckReportRelated-            (workspaceDisplayPath subject (wlFile location))-            (wlLine location)-            (wlRole location)-        | location <- NE.tail (wdLocations diagnostic)+            (workspaceDisplayPath subject ((.file) location))+            ((.line) location)+            ((.role) location)+        | location <- NE.tail ((.locations) diagnostic)         ]     }   where-    primary = NE.head (wdLocations diagnostic)+    primary = NE.head ((.locations) diagnostic)  warningDenied :: Set DiagnosticCode -> Severity -> DiagnosticCode -> Bool warningDenied deniedCodes severityValue diagnosticCode =@@ -266,15 +266,15 @@   toJSON report =     object       ( [ "schema" .= ("keiro-dsl/check-report/1" :: Text),-          "kind" .= kindText (reportKind report),-          "subject" .= reportSubject report,-          "language" .= fmap languageJson (reportLanguage report),-          "enforcement" .= enforcementJson (reportEnforcement report),-          "diagnostics" .= map entryJson (reportDiagnostics report),-          "summary" .= summaryJson (reportSummary report),-          "ok" .= reportOk report+          "kind" .= kindText ((.kind) report),+          "subject" .= (.subject) report,+          "language" .= fmap languageJson ((.language) report),+          "enforcement" .= enforcementJson ((.enforcement) report),+          "diagnostics" .= map entryJson ((.diagnostics) report),+          "summary" .= summaryJson ((.summary) report),+          "ok" .= (.ok) report         ]-          <> ["members" .= map memberJson (reportMembers report) | reportKind report == WorkspaceReport]+          <> ["members" .= map memberJson ((.members) report) | (.kind) report == WorkspaceReport]       )  kindText :: CheckReportKind -> Text@@ -284,56 +284,56 @@ languageJson :: CheckReportLanguage -> Value languageJson language =   object-    [ "sourceForm" .= reportSourceForm language,-      "declaredLanguageVersion" .= reportDeclaredLanguageVersion language,-      "effectiveLanguageVersion" .= reportEffectiveLanguageVersion language,-      "runtimeSemantics" .= reportRuntimeSemantics language,-      "languageSupport" .= languageSupportText (reportLanguageSupport language),-      "stable" .= reportStable language+    [ "sourceForm" .= (.sourceForm) language,+      "declaredLanguageVersion" .= (.declaredLanguageVersion) language,+      "effectiveLanguageVersion" .= (.effectiveLanguageVersion) language,+      "runtimeSemantics" .= (.runtimeSemantics) language,+      "languageSupport" .= languageSupportText ((.languageSupport) language),+      "stable" .= (.stable) language     ]  enforcementJson :: CheckReportEnforcement -> Value enforcementJson enforcement =   object-    [ "minLanguage" .= reportMinLanguage enforcement,-      "denyWarnings" .= reportDenyWarnings enforcement,-      "denyCodes" .= map diagnosticCodeText (Set.toAscList (Set.fromList (reportDenyCodes enforcement)))+    [ "minLanguage" .= (.minLanguage) enforcement,+      "denyWarnings" .= (.denyWarnings) enforcement,+      "denyCodes" .= map diagnosticCodeText (Set.toAscList (Set.fromList ((.denyCodes) enforcement)))     ]  entryJson :: CheckReportEntry -> Value entryJson entry =   object-    [ "code" .= diagnosticCodeText (entryCode entry),-      "severity" .= severityText (entrySeverity entry),-      "file" .= entryFile entry,-      "line" .= entryLine entry,-      "message" .= entryMessage entry,-      "denied" .= entryDenied entry,-      "related" .= map relatedJson (entryRelated entry)+    [ "code" .= diagnosticCodeText ((.code) entry),+      "severity" .= severityText ((.severity) entry),+      "file" .= (.file) entry,+      "line" .= (.line) entry,+      "message" .= (.message) entry,+      "denied" .= (.denied) entry,+      "related" .= map relatedJson ((.related) entry)     ]  relatedJson :: CheckReportRelated -> Value relatedJson related =   object-    [ "file" .= relatedFile related,-      "line" .= relatedLine related,-      "note" .= relatedNote related+    [ "file" .= (.file) related,+      "line" .= (.line) related,+      "note" .= (.note) related     ]  summaryJson :: CheckReportSummary -> Value summaryJson summary =   object-    [ "errors" .= summaryErrors summary,-      "warnings" .= summaryWarnings summary,-      "deniedWarnings" .= summaryDeniedWarnings summary+    [ "errors" .= (.errors) summary,+      "warnings" .= (.warnings) summary,+      "deniedWarnings" .= (.deniedWarnings) summary     ]  memberJson :: CheckReportMember -> Value memberJson member =   object-    [ "path" .= memberPath member,-      "sourceForm" .= memberSourceForm member,-      "declaredLanguageVersion" .= memberDeclaredLanguageVersion member+    [ "path" .= (.path) member,+      "sourceForm" .= (.sourceForm) member,+      "declaredLanguageVersion" .= (.declaredLanguageVersion) member     ]  severityText :: Severity -> Text

src/Keiro/Dsl/CodecCompare.hs view

@@ -9,6 +9,7 @@   ( FixtureOrigin (..),     DecodeOutcome (..),     JsonPointer (..),+    unJsonPointer,     ComparisonDifference (..),     HistoricalCodec (..),     CompareObservation (..),@@ -69,6 +70,9 @@ newtype JsonPointer = JsonPointer {unJsonPointer :: Text}   deriving stock (Eq, Ord, Show) +unJsonPointer :: JsonPointer -> Text+unJsonPointer (JsonPointer value) = value+ data ComparisonDifference   = EncodedValueDifference !JsonPointer !Value !Value   | DecodedValueDifference !JsonPointer !Value !Value@@ -78,23 +82,23 @@ -- | A historical codec is an explicit value supplied by consumer-owned test -- code. Its identity and version are report provenance, not dispatch keys. data HistoricalCodec a = HistoricalCodec-  { hcIdentity :: !Text,-    hcVersion :: !Text,-    hcEncode :: !(a -> Value),-    hcDecode :: !(Value -> Either Text a)+  { identity :: !Text,+    version :: !Text,+    encode :: !(a -> Value),+    decode :: !(Value -> Either Text a)   }  data CompareObservation   = EncodeObservation-      { coCaseName :: !Text,-        coHistoricalValue :: !Value,-        coGeneratedValue :: !Value+      { caseName :: !Text,+        historicalValue :: !Value,+        generatedValue :: !Value       }   | DecodeObservation-      { coFixturePath :: !FilePath,-        coInputValue :: !Value,-        coHistoricalDecode :: !DecodeOutcome,-        coGeneratedDecode :: !DecodeOutcome+      { fixturePath :: !FilePath,+        inputValue :: !Value,+        historicalDecode :: !DecodeOutcome,+        generatedDecode :: !DecodeOutcome       }   deriving stock (Eq, Show) @@ -117,23 +121,23 @@   deriving stock (Eq, Ord, Show)  data DeclaredBranch = DeclaredBranch-  { dbOrigin :: !FixtureOrigin,-    dbPointer :: !JsonPointer,-    dbKind :: !BranchKind+  { origin :: !FixtureOrigin,+    pointer :: !JsonPointer,+    kind :: !BranchKind   }   deriving stock (Eq, Ord, Show)  data ObservedBranch = ObservedBranch-  { obOrigin :: !FixtureOrigin,-    obPointer :: !JsonPointer,-    obKind :: !BranchKind+  { origin :: !FixtureOrigin,+    pointer :: !JsonPointer,+    kind :: !BranchKind   }   deriving stock (Eq, Ord, Show)  data CoverageGap = CoverageGap-  { cgOrigin :: !FixtureOrigin,-    cgPointer :: !JsonPointer,-    cgKind :: !BranchKind+  { origin :: !FixtureOrigin,+    pointer :: !JsonPointer,+    kind :: !BranchKind   }   deriving stock (Eq, Ord, Show) @@ -150,47 +154,47 @@   deriving stock (Eq, Show)  data BranchField = BranchField-  { bfWireKey :: !Text,-    bfPresenceOptional :: !Bool,-    bfSchema :: !BranchSchema+  { wireKey :: !Text,+    presenceOptional :: !Bool,+    schema :: !BranchSchema   }   deriving stock (Eq, Show)  data BranchArm = BranchArm-  { baWireTag :: !Text,-    baPayloadSchema :: !(Maybe BranchSchema)+  { wireTag :: !Text,+    payloadSchema :: !(Maybe BranchSchema)   }   deriving stock (Eq, Show)  data CompareProvenance = CompareProvenance-  { cpHistoricalCodecIdentity :: !Text,-    cpHistoricalCodecVersion :: !Text,-    cpCanonicalType :: !CanonicalTypeId,-    cpBindingSymbol :: !QualifiedValueName,-    cpBindingVersion :: !BindingVersion,-    cpWireFingerprint :: !Text+  { historicalCodecIdentity :: !Text,+    historicalCodecVersion :: !Text,+    canonicalType :: !CanonicalTypeId,+    bindingSymbol :: !QualifiedValueName,+    bindingVersion :: !BindingVersion,+    wireFingerprint :: !Text   }   deriving stock (Eq, Show)  data ClassifiedObservation = ClassifiedObservation-  { classifiedOrigin :: !FixtureOrigin,-    classifiedName :: !Text,-    classifiedVerdict :: !FixtureVerdict+  { origin :: !FixtureOrigin,+    name :: !Text,+    verdict :: !FixtureVerdict   }   deriving stock (Eq, Show)  data CompareReport = CompareReport-  { crProvenance :: !CompareProvenance,-    crObservations :: ![ClassifiedObservation],-    crInputIssues :: ![CompareInputIssue],-    crCoverageGaps :: ![CoverageGap],-    crAuthority :: !Text+  { provenance :: !CompareProvenance,+    observations :: ![ClassifiedObservation],+    inputIssues :: ![CompareInputIssue],+    coverageGaps :: ![CoverageGap],+    authority :: !Text   }   deriving stock (Eq, Show)  data ReportWriteError = ReportWriteError-  { reportWritePath :: !FilePath,-    reportWriteMessage :: !Text+  { path :: !FilePath,+    message :: !Text   }   deriving stock (Eq, Show) @@ -227,11 +231,11 @@   CompareReport compareReport provenance suppliedIssues observations declaredBranches observedBranches =   CompareReport-    { crProvenance = provenance,-      crObservations = classified,-      crInputIssues = provenanceIssues provenance <> suppliedIssues <> classificationIssues,-      crCoverageGaps = coverageGaps declaredBranches observedBranches,-      crAuthority = authorityStatement+    { provenance = provenance,+      observations = classified,+      inputIssues = provenanceIssues provenance <> suppliedIssues <> classificationIssues,+      coverageGaps = coverageGaps declaredBranches observedBranches,+      authority = authorityStatement     }   where     outcomes = map classify observations@@ -243,9 +247,9 @@       Right verdict ->         Right           ClassifiedObservation-            { classifiedOrigin = observationOrigin observation,-              classifiedName = observationName observation,-              classifiedVerdict = verdict+            { origin = observationOrigin observation,+              name = observationName observation,+              verdict = verdict             }  observationOrigin :: CompareObservation -> FixtureOrigin@@ -253,28 +257,28 @@ observationOrigin DecodeObservation {} = HistoricalGolden  observationName :: CompareObservation -> Text-observationName EncodeObservation {coCaseName = name} = name-observationName DecodeObservation {coFixturePath = path} = T.pack path+observationName EncodeObservation {caseName = name} = name+observationName DecodeObservation {fixturePath = path} = T.pack path  provenanceIssues :: CompareProvenance -> [CompareInputIssue] provenanceIssues provenance =   [ HistoricalCodecProvenanceInvalid "historical codec identity must not be blank"-  | T.null (T.strip (cpHistoricalCodecIdentity provenance))+  | T.null (T.strip ((.historicalCodecIdentity) provenance))   ]     <> [ HistoricalCodecProvenanceInvalid "historical codec version must not be blank"-       | T.null (T.strip (cpHistoricalCodecVersion provenance))+       | T.null (T.strip ((.historicalCodecVersion) provenance))        ]  coverageGaps :: [DeclaredBranch] -> [ObservedBranch] -> [CoverageGap] coverageGaps declared observed =-  [ CoverageGap (dbOrigin branch) (dbPointer branch) (dbKind branch)+  [ CoverageGap ((.origin) branch) ((.pointer) branch) ((.kind) branch)   | branch <- declared,     branchKey branch `Set.notMember` observedKeys   ]   where     observedKeys = Set.fromList (map observedBranchKey observed)-    branchKey branch = (dbOrigin branch, dbPointer branch, dbKind branch)-    observedBranchKey branch = (obOrigin branch, obPointer branch, obKind branch)+    branchKey branch = ((.origin) branch, (.pointer) branch, (.kind) branch)+    observedBranchKey branch = ((.origin) branch, (.pointer) branch, (.kind) branch)  declaredBranchesFor :: FixtureOrigin -> BranchSchema -> [DeclaredBranch] declaredBranchesFor origin = Set.toAscList . go ""@@ -290,18 +294,18 @@       BranchMap nested -> go (appendPointer pointer "*") nested       BranchRecord fields ->         Set.unions-          [ presenceBranches pointer field <> go (appendPointer pointer (bfWireKey field)) (bfSchema field)+          [ presenceBranches pointer field <> go (appendPointer pointer ((.wireKey) field)) ((.schema) field)           | field <- fields           ]       BranchUnion _tagField contentsField arms ->         Set.unions-          [ declared pointer (UnionArm (baWireTag arm))-              <> maybe Set.empty (go (appendPointer pointer contentsField)) (baPayloadSchema arm)+          [ declared pointer (UnionArm ((.wireTag) arm))+              <> maybe Set.empty (go (appendPointer pointer contentsField)) ((.payloadSchema) arm)           | arm <- arms           ]     presenceBranches pointer field-      | bfPresenceOptional field =-          let fieldPointer = appendPointer pointer (bfWireKey field)+      | (.presenceOptional) field =+          let fieldPointer = appendPointer pointer ((.wireKey) field)            in case origin of                 HistoricalGolden -> declared fieldPointer OptionalMissing <> declared fieldPointer OptionalPresent                 FromBinding -> declared fieldPointer OptionalPresent@@ -327,43 +331,43 @@         _ -> Set.empty       BranchUnion tagField contentsField arms -> case value of         Object values -> case KeyMap.lookup (Key.fromText tagField) values of-          Just (String tag) -> case filter ((== tag) . baWireTag) arms of+          Just (String tag) -> case filter ((== tag) . (.wireTag)) arms of             arm : _ ->               observed pointer (UnionArm tag)-                <> case (baPayloadSchema arm, KeyMap.lookup (Key.fromText contentsField) values) of+                <> case ((.payloadSchema) arm, KeyMap.lookup (Key.fromText contentsField) values) of                   (Just nested, Just payload) -> go (appendPointer pointer contentsField) nested payload                   _ -> Set.empty             [] -> Set.empty           _ -> Set.empty         _ -> Set.empty     observeField pointer values field =-      let fieldPointer = appendPointer pointer (bfWireKey field)-       in case KeyMap.lookup (Key.fromText (bfWireKey field)) values of+      let fieldPointer = appendPointer pointer ((.wireKey) field)+       in case KeyMap.lookup (Key.fromText ((.wireKey) field)) values of             Nothing-              | bfPresenceOptional field -> observed fieldPointer OptionalMissing+              | (.presenceOptional) field -> observed fieldPointer OptionalMissing               | otherwise -> Set.empty             Just fieldValue ->-              (if bfPresenceOptional field then observed fieldPointer OptionalPresent else Set.empty)-                <> go fieldPointer (bfSchema field) fieldValue+              (if (.presenceOptional) field then observed fieldPointer OptionalPresent else Set.empty)+                <> go fieldPointer ((.schema) field) fieldValue  reportSucceeded :: CompareReport -> Bool reportSucceeded report =-  null (crInputIssues report)-    && null (crCoverageGaps report)-    && all ((== JsonParity) . classifiedVerdict) (crObservations report)+  null ((.inputIssues) report)+    && null ((.coverageGaps) report)+    && all ((== JsonParity) . (.verdict)) ((.observations) report)  renderCompareReport :: CompareReport -> Text renderCompareReport report =   T.unlines     ( [ "codec comparison: "-          <> unCanonicalTypeId (cpCanonicalType provenance)+          <> (.unCanonicalTypeId) ((.canonicalType) provenance)           <> " (binding-version \""-          <> unBindingVersion (cpBindingVersion provenance)+          <> (.unBindingVersion) ((.bindingVersion) provenance)           <> "\")",         "historical codec: \""-          <> cpHistoricalCodecIdentity provenance+          <> (.historicalCodecIdentity) provenance           <> "\" version \""-          <> cpHistoricalCodecVersion provenance+          <> (.historicalCodecVersion) provenance           <> "\"",         "observations: " <> tshow (length observations),         "  encode parity: " <> ratio FromBinding,@@ -371,38 +375,38 @@         "requires explicit version/upcaster work: " <> tshow (length differences) <> " observations  [" <> codeText CodecCompareDifference <> "]"       ]         <> concatMap renderDifference differences-        <> [ "input issues: " <> tshow (length (crInputIssues report)) <> "  [" <> codeText CodecCompareInvalidInput <> "]"+        <> [ "input issues: " <> tshow (length ((.inputIssues) report)) <> "  [" <> codeText CodecCompareInvalidInput <> "]"            ]-        <> map ("  " <>) (map renderInputIssue (crInputIssues report))-        <> [ "coverage gaps: " <> tshow (length (crCoverageGaps report)) <> "  [" <> codeText CodecCompareCoverageGap <> "]"+        <> map ("  " <>) (map renderInputIssue ((.inputIssues) report))+        <> [ "coverage gaps: " <> tshow (length ((.coverageGaps) report)) <> "  [" <> codeText CodecCompareCoverageGap <> "]"            ]-        <> map ("  " <>) (map renderCoverageGap (crCoverageGaps report))+        <> map ("  " <>) (map renderCoverageGap ((.coverageGaps) report))         <> [ if reportSucceeded report                then "result: PARITY"                else "result: NOT PARITY — " <> tshow (length differences) <> " differences",-             crAuthority report+             (.authority) report            ]     )   where-    provenance = crProvenance report-    observations = crObservations report-    differences = filter ((/= JsonParity) . classifiedVerdict) observations+    provenance = (.provenance) report+    observations = (.observations) report+    differences = filter ((/= JsonParity) . (.verdict)) observations     ratio origin =-      let matching = filter ((== origin) . classifiedOrigin) observations-          parityCount = length (filter ((== JsonParity) . classifiedVerdict) matching)+      let matching = filter ((== origin) . (.origin)) observations+          parityCount = length (filter ((== JsonParity) . (.verdict)) matching)        in tshow parityCount <> "/" <> tshow (length matching) <> suffix origin     suffix FromBinding = " (RFC 8785 canonical form)"     suffix HistoricalGolden = ""  renderDifference :: ClassifiedObservation -> [Text]-renderDifference observation = case classifiedVerdict observation of+renderDifference observation = case (.verdict) observation of   JsonParity -> []   RequiresVersionWork difference ->-    [ "  " <> classifiedName observation <> " [" <> direction <> "] at " <> pointerOf difference,+    [ "  " <> (.name) observation <> " [" <> direction <> "] at " <> pointerOf difference,       "    " <> reasonOf difference     ]   where-    direction = case classifiedOrigin observation of+    direction = case (.origin) observation of       FromBinding -> "encode"       HistoricalGolden -> "decode" @@ -414,11 +418,11 @@  renderCoverageGap :: CoverageGap -> Text renderCoverageGap gap =-  originName (cgOrigin gap)+  originName ((.origin) gap)     <> " "-    <> renderPointer (cgPointer gap)+    <> renderPointer ((.pointer) gap)     <> ": "-    <> branchKindName (cgKind gap)+    <> branchKindName ((.kind) gap)  pointerOf :: ComparisonDifference -> Text pointerOf difference = case difference of@@ -643,9 +647,9 @@ instance ToJSON DeclaredBranch where   toJSON branch =     object-      [ "origin" .= dbOrigin branch,-        "pointer" .= dbPointer branch,-        "branch" .= dbKind branch+      [ "origin" .= (.origin) branch,+        "pointer" .= (.pointer) branch,+        "branch" .= (.kind) branch       ]  instance FromJSON DeclaredBranch where@@ -655,9 +659,9 @@ instance ToJSON ObservedBranch where   toJSON branch =     object-      [ "origin" .= obOrigin branch,-        "pointer" .= obPointer branch,-        "branch" .= obKind branch+      [ "origin" .= (.origin) branch,+        "pointer" .= (.pointer) branch,+        "branch" .= (.kind) branch       ]  instance FromJSON ObservedBranch where@@ -668,9 +672,9 @@   toJSON gap =     object       [ "code" .= codeText CodecCompareCoverageGap,-        "origin" .= cgOrigin gap,-        "pointer" .= cgPointer gap,-        "branch" .= cgKind gap+        "origin" .= (.origin) gap,+        "pointer" .= (.pointer) gap,+        "branch" .= (.kind) gap       ]  instance FromJSON CoverageGap where@@ -680,12 +684,12 @@ instance ToJSON CompareProvenance where   toJSON provenance =     object-      [ "historicalCodecIdentity" .= cpHistoricalCodecIdentity provenance,-        "historicalCodecVersion" .= cpHistoricalCodecVersion provenance,-        "canonicalType" .= unCanonicalTypeId (cpCanonicalType provenance),-        "bindingSymbol" .= unQualifiedValueName (cpBindingSymbol provenance),-        "bindingVersion" .= unBindingVersion (cpBindingVersion provenance),-        "wireFingerprint" .= cpWireFingerprint provenance+      [ "historicalCodecIdentity" .= (.historicalCodecIdentity) provenance,+        "historicalCodecVersion" .= (.historicalCodecVersion) provenance,+        "canonicalType" .= (.unCanonicalTypeId) ((.canonicalType) provenance),+        "bindingSymbol" .= (.unQualifiedValueName) ((.bindingSymbol) provenance),+        "bindingVersion" .= (.unBindingVersion) ((.bindingVersion) provenance),+        "wireFingerprint" .= (.wireFingerprint) provenance       ]  instance FromJSON CompareProvenance where@@ -701,9 +705,9 @@ instance ToJSON ClassifiedObservation where   toJSON observation =     object-      [ "origin" .= classifiedOrigin observation,-        "name" .= classifiedName observation,-        "result" .= classifiedVerdict observation+      [ "origin" .= (.origin) observation,+        "name" .= (.name) observation,+        "result" .= (.verdict) observation       ]  instance FromJSON ClassifiedObservation where@@ -714,20 +718,20 @@   toJSON report =     object       [ "schema" .= ("keiro-dsl/codec-compare-report/1" :: Text),-        "authority" .= crAuthority report,-        "provenance" .= crProvenance report,+        "authority" .= (.authority) report,+        "provenance" .= (.provenance) report,         "success" .= reportSucceeded report,         "summary"           .= object-            [ "observations" .= length (crObservations report),-              "parity" .= length (filter ((== JsonParity) . classifiedVerdict) (crObservations report)),-              "differences" .= length (filter ((/= JsonParity) . classifiedVerdict) (crObservations report)),-              "inputIssues" .= length (crInputIssues report),-              "coverageGaps" .= length (crCoverageGaps report)+            [ "observations" .= length ((.observations) report),+              "parity" .= length (filter ((== JsonParity) . (.verdict)) ((.observations) report)),+              "differences" .= length (filter ((/= JsonParity) . (.verdict)) ((.observations) report)),+              "inputIssues" .= length ((.inputIssues) report),+              "coverageGaps" .= length ((.coverageGaps) report)             ],-        "observations" .= crObservations report,-        "inputIssues" .= crInputIssues report,-        "coverageGaps" .= crCoverageGaps report+        "observations" .= (.observations) report,+        "inputIssues" .= (.inputIssues) report,+        "coverageGaps" .= (.coverageGaps) report       ]  instance FromJSON CompareReport where

src/Keiro/Dsl/ConformancePackage.hs view

@@ -55,19 +55,19 @@   deriving stock (Eq, Ord, Show)  data ConformanceFile = ConformanceFile-  { conformanceFilePath :: !FilePath,-    conformanceFileText :: !Text,-    conformanceFileKind :: !ModuleKind+  { path :: !FilePath,+    text :: !Text,+    kind :: !ModuleKind   }   deriving stock (Eq, Show)  data ConformancePackagePlan = ConformancePackagePlan-  { cppServiceKey :: !ConformanceServiceKey,-    cppDirectory :: !FilePath,-    cppPackageName :: !Text,-    cppRuntimePackage :: !RuntimePackageName,-    cppFacadeModule :: !Text,-    cppFiles :: ![ConformanceFile]+  { serviceKey :: !ConformanceServiceKey,+    directory :: !FilePath,+    packageName :: !Text,+    runtimePackage :: !RuntimePackageName,+    facadeModule :: !Text,+    files :: ![ConformanceFile]   }   deriving stock (Eq, Show) @@ -75,8 +75,8 @@   deriving stock (Eq, Ord, Show)  data DuplicateFactKey = DuplicateFactKey-  { duplicateFactSide :: !ConformanceFactSide,-    duplicateFactKey :: !String+  { side :: !ConformanceFactSide,+    key :: !String   }   deriving stock (Eq, Ord, Show) @@ -98,11 +98,11 @@   deriving stock (Eq, Show)  data ConformancePackageRecord = ConformancePackageRecord-  { cprSchema :: !Int,-    cprServiceKey :: !ConformanceServiceKey,-    cprRuntimePackage :: !RuntimePackageName,-    cprFacadeModule :: !Text,-    cprFiles :: ![(ModuleKind, FilePath)]+  { schema :: !Int,+    serviceKey :: !ConformanceServiceKey,+    runtimePackage :: !RuntimePackageName,+    facadeModule :: !Text,+    files :: ![(ModuleKind, FilePath)]   }   deriving stock (Eq, Show) @@ -110,24 +110,24 @@   deriving stock (Eq, Show)  data ConformanceStaleFile = ConformanceStaleFile-  { conformanceStaleKind :: !ModuleKind,-    conformanceStalePath :: !FilePath,-    conformanceStaleBannerPresent :: !(Maybe Bool)+  { kind :: !ModuleKind,+    path :: !FilePath,+    bannerPresent :: !(Maybe Bool)   }   deriving stock (Eq, Show)  data PreparedConformancePackage = PreparedConformancePackage-  { preparedRoot :: !FilePath,-    preparedPlan :: !ConformancePackagePlan,-    preparedStale :: ![ConformanceStaleFile]+  { root :: !FilePath,+    plan :: !ConformancePackagePlan,+    stale :: ![ConformanceStaleFile]   }   deriving stock (Eq, Show)  data ConformancePackageReport = ConformancePackageReport-  { conformanceReportRoot :: !FilePath,-    conformanceReportPlan :: !ConformancePackagePlan,-    conformanceReportDispositions :: ![(ConformanceFile, ConformanceWriteDisposition)],-    conformanceReportStale :: ![ConformanceStaleFile]+  { root :: !FilePath,+    plan :: !ConformancePackagePlan,+    dispositions :: ![(ConformanceFile, ConformanceWriteDisposition)],+    stale :: ![ConformanceStaleFile]   }   deriving stock (Eq, Show) @@ -171,32 +171,32 @@         ConformanceFile "src/Main.hs" (renderMain banner facadeModule) Generated,         ConformanceFile "src/KeiroConformance/Expectations.hs" (renderExpectations factValues) HoleStub       ]-    recordRows = [(conformanceFileKind file, conformanceFilePath file) | file <- baseFiles] <> [(Generated, conformanceRecordFileName)]+    recordRows = [((.kind) file, (.path) file) | file <- baseFiles] <> [(Generated, conformanceRecordFileName)]     record =       ConformancePackageRecord-        { cprSchema = 1,-          cprServiceKey = serviceKey,-          cprRuntimePackage = runtimePackage,-          cprFacadeModule = facadeModule,-          cprFiles = recordRows+        { schema = 1,+          serviceKey = serviceKey,+          runtimePackage = runtimePackage,+          facadeModule = facadeModule,+          files = recordRows         }     recordFile = ConformanceFile conformanceRecordFileName (banner <> "\n" <> renderConformancePackageRecord record) Generated     files = baseFiles <> [recordFile]-    paths = packageDirectory : map conformanceFilePath files+    paths = packageDirectory : map (.path) files     unsafePaths = filter (not . safeRelativePath) paths     collisions =       [ entries-      | entries <- Map.elems (Map.fromListWith (<>) [(T.toCaseFold (T.pack path), [path]) | path <- map conformanceFilePath files]),+      | entries <- Map.elems (Map.fromListWith (<>) [(T.toCaseFold (T.pack path), [path]) | path <- map (.path) files]),         length entries > 1       ]     plan =       ConformancePackagePlan-        { cppServiceKey = serviceKey,-          cppDirectory = packageDirectory,-          cppPackageName = packageName,-          cppRuntimePackage = runtimePackage,-          cppFacadeModule = facadeModule,-          cppFiles = files+        { serviceKey = serviceKey,+          directory = packageDirectory,+          packageName = packageName,+          runtimePackage = runtimePackage,+          facadeModule = facadeModule,+          files = files         }  renderCabal :: Text -> Text -> RuntimePackageName -> Text -> Text@@ -218,7 +218,7 @@       "  ghc-options: -Wall",       "  build-depends:",       "      base >=4.18 && <5",-      "    , " <> unRuntimePackageName runtimePackage,+      "    , " <> (.unRuntimePackageName) runtimePackage,       "  default-language: GHC2024",       "  default-extensions: OverloadedStrings"     ]@@ -320,11 +320,11 @@ renderConformancePackageRecord record =   T.unlines $     [ conformanceLedgerHeader,-      "service-key " <> renderServiceKey (cprServiceKey record),-      "runtime-package " <> unRuntimePackageName (cprRuntimePackage record),-      "facade-module " <> cprFacadeModule record+      "service-key " <> renderServiceKey ((.serviceKey) record),+      "runtime-package " <> (.unRuntimePackageName) ((.runtimePackage) record),+      "facade-module " <> (.facadeModule) record     ]-      <> ["file " <> encodeConformanceFileRow (ConformanceFileRow fileKind path) | (fileKind, path) <- cprFiles record]+      <> ["file " <> encodeConformanceFileRow (ConformanceFileRow fileKind path) | (fileKind, path) <- (.files) record]  parseConformancePackageRecord :: Text -> Maybe ConformancePackageRecord parseConformancePackageRecord input = case meaningfulLines input of@@ -337,16 +337,16 @@       runtimePackage <- exactlyOne [value | row <- rows, Just raw <- [T.stripPrefix "runtime-package " row], Right value <- [mkRuntimePackageName raw]]       facadeModule <- exactlyOne [value | row <- rows, Just value <- [T.stripPrefix "facade-module " row], not (T.null value), T.all (not . (`elem` [' ', '\t'])) value]       fileRows <- traverse decodeConformanceFileRow [row | row <- rows, "file " `T.isPrefixOf` row]-      let files = [(conformanceRowKind row, conformanceRowPath row) | row <- fileRows]+      let files = [((.kind) row, (.path) row) | row <- fileRows]       if safeServiceKey serviceKey && safeConformanceFiles files         then           Just             ConformancePackageRecord-              { cprSchema = 1,-                cprServiceKey = serviceKey,-                cprRuntimePackage = runtimePackage,-                cprFacadeModule = facadeModule,-                cprFiles = files+              { schema = 1,+                serviceKey = serviceKey,+                runtimePackage = runtimePackage,+                facadeModule = facadeModule,+                files = files               }         else Nothing @@ -365,11 +365,11 @@     then       Just         ConformancePackageRecord-          { cprSchema = schema,-            cprServiceKey = serviceKey,-            cprRuntimePackage = runtimePackage,-            cprFacadeModule = facadeModule,-            cprFiles = files+          { schema = schema,+            serviceKey = serviceKey,+            runtimePackage = runtimePackage,+            facadeModule = facadeModule,+            files = files           }     else Nothing   where@@ -385,15 +385,15 @@ conformanceLedgerHeader = "keiro-dsl conformance ledger v1"  data ConformanceFileRow = ConformanceFileRow-  { conformanceRowKind :: !ModuleKind,-    conformanceRowPath :: !FilePath+  { kind :: !ModuleKind,+    path :: !FilePath   }  instance ToJSON ConformanceFileRow where   toJSON row =     object-      [ "kind" .= case conformanceRowKind row of Generated -> "generated" :: Text; HoleStub -> "create-once",-        "path" .= T.pack (conformanceRowPath row)+      [ "kind" .= case (.kind) row of Generated -> "generated" :: Text; HoleStub -> "create-once",+        "path" .= T.pack ((.path) row)       ]  instance FromJSON ConformanceFileRow where@@ -438,16 +438,16 @@  preflightConformancePackage :: FilePath -> Bool -> ConformancePackagePlan -> IO (Either [ConformancePackageFailure] PreparedConformancePackage) preflightConformancePackage out forceGeneratedOverwrite plan = do-  bannerless <- if forceGeneratedOverwrite then pure [] else missingPackageBanners root (cppFiles plan)+  bannerless <- if forceGeneratedOverwrite then pure [] else missingPackageBanners root ((.files) plan)   previousResult <- readPreviousRecord root forceGeneratedOverwrite bannerless plan-  case [ConformanceGeneratedBannerMissing (map (cppDirectory plan </>) bannerless) | not (null bannerless)] <> either id (const []) previousResult of+  case [ConformanceGeneratedBannerMissing (map ((.directory) plan </>) bannerless) | not (null bannerless)] <> either id (const []) previousResult of     failures@(_ : _) -> pure (Left failures)     [] -> do       let previous = either (const Nothing) id previousResult-      stale <- maybe (pure []) (stalePackageFiles root (map conformanceFilePath (cppFiles plan))) previous-      pure (Right PreparedConformancePackage {preparedRoot = root, preparedPlan = plan, preparedStale = stale})+      stale <- maybe (pure []) (stalePackageFiles root (map (.path) ((.files) plan))) previous+      pure (Right PreparedConformancePackage {root = root, plan = plan, stale = stale})   where-    root = out </> cppDirectory plan+    root = out </> (.directory) plan  readPreviousRecord :: FilePath -> Bool -> [FilePath] -> ConformancePackagePlan -> IO (Either [ConformancePackageFailure] (Maybe ConformancePackageRecord)) readPreviousRecord root forceGeneratedOverwrite bannerless plan = do@@ -458,22 +458,22 @@     else do       parsed <- parseConformancePackageRecord <$> TIO.readFile path       pure $ case parsed of-        Nothing -> Left [InvalidConformancePackageRecord (cppDirectory plan </> conformanceRecordFileName)]+        Nothing -> Left [InvalidConformancePackageRecord ((.directory) plan </> conformanceRecordFileName)]         Just record-          | cprServiceKey record == cppServiceKey plan -> Right (Just record)-          | otherwise -> Left [ConformancePackageRecordMismatch (cppDirectory plan </> conformanceRecordFileName)]+          | (.serviceKey) record == (.serviceKey) plan -> Right (Just record)+          | otherwise -> Left [ConformancePackageRecordMismatch ((.directory) plan </> conformanceRecordFileName)]  missingPackageBanners :: FilePath -> [ConformanceFile] -> IO [FilePath] missingPackageBanners root files = fmap concat . forM generated $ \file -> do-  let path = root </> conformanceFilePath file+  let path = root </> (.path) file   exists <- doesFileExist path   if not exists     then pure []     else do       contents <- TIO.readFile path-      pure [conformanceFilePath file | not (any isGeneratedBannerLine (T.lines contents))]+      pure [(.path) file | not (any isGeneratedBannerLine (T.lines contents))]   where-    generated = [file | file <- files, conformanceFileKind file == Generated]+    generated = [file | file <- files, (.kind) file == Generated]  stalePackageFiles :: FilePath -> [FilePath] -> ConformancePackageRecord -> IO [ConformanceStaleFile] stalePackageFiles root current record = fmap concat . forM removed $ \(fileKind, path) -> do@@ -489,40 +489,40 @@       pure [ConformanceStaleFile fileKind path evidence]   where     currentSet = Set.fromList current-    removed = [(fileKind, path) | (fileKind, path) <- cprFiles record, path `Set.notMember` currentSet]+    removed = [(fileKind, path) | (fileKind, path) <- (.files) record, path `Set.notMember` currentSet]  executePreparedConformancePackage :: PreparedConformancePackage -> IO ConformancePackageReport executePreparedConformancePackage prepared = do-  dispositions <- traverse (writeConformanceFile (preparedRoot prepared)) (cppFiles plan)+  dispositions <- traverse (writeConformanceFile ((.root) prepared)) ((.files) plan)   pure     ConformancePackageReport-      { conformanceReportRoot = preparedRoot prepared,-        conformanceReportPlan = plan,-        conformanceReportDispositions = dispositions,-        conformanceReportStale = preparedStale prepared+      { root = (.root) prepared,+        plan = plan,+        dispositions = dispositions,+        stale = (.stale) prepared       }   where-    plan = preparedPlan prepared+    plan = (.plan) prepared  writeConformanceFile :: FilePath -> ConformanceFile -> IO (ConformanceFile, ConformanceWriteDisposition) writeConformanceFile root file = do-  let path = root </> conformanceFilePath file+  let path = root </> (.path) file   exists <- doesFileExist path-  case conformanceFileKind file of+  case (.kind) file of     HoleStub       | exists -> pure (file, ConformanceSkipped)       | otherwise -> write path ConformanceCreated     Generated       | exists -> do           existing <- TIO.readFile path-          if existing == conformanceFileText file+          if existing == (.text) file             then pure (file, ConformanceUnchanged)             else write path ConformanceOverwritten       | otherwise -> write path ConformanceCreated   where     write path disposition = do       createDirectoryIfMissing True (takeDirectory path)-      TIO.writeFile path (conformanceFileText file)+      TIO.writeFile path ((.text) file)       pure (file, disposition)  compareConformanceFacts :: [(String, String)] -> [(String, String)] -> Either [DuplicateFactKey] [ConformanceFactResult]@@ -556,7 +556,7 @@   ConformancePathCollision paths -> ["error: conformance package path collision -- refusing to scaffold; nothing was written"] <> map ("  " <>) (map T.pack paths)   PackageDuplicateFactKeys duplicates ->     ["error: duplicate conformance fact keys -- refusing to scaffold; nothing was written"]-      <> ["  " <> sideLabel (duplicateFactSide duplicate) <> "/" <> T.pack (duplicateFactKey duplicate) | duplicate <- duplicates]+      <> ["  " <> sideLabel ((.side) duplicate) <> "/" <> T.pack ((.key) duplicate) | duplicate <- duplicates]   ConformanceGeneratedBannerMissing paths ->     ["error: refusing to overwrite generated conformance package files without a recognized '-- @generated' banner"]       <> map ("  " <>) (map T.pack paths)@@ -570,33 +570,33 @@ renderConformancePackageReport :: ConformancePackageReport -> [Text] renderConformancePackageReport report =   [ "conformance-package: " <> T.pack cabalPath,-    "conformance-target: cabal test " <> cppPackageName plan+    "conformance-target: cabal test " <> (.packageName) plan   ]-    <> [ "conformance-file: " <> T.pack (root </> conformanceFilePath file) <> " " <> dispositionTag disposition+    <> [ "conformance-file: " <> T.pack (root </> (.path) file) <> " " <> dispositionTag disposition        | (file, disposition) <- dispositions,-         conformanceFileKind file == Generated,-         conformanceFilePath file /= conformanceRecordFileName+         (.kind) file == Generated,+         (.path) file /= conformanceRecordFileName        ]-    <> ["expectations: " <> T.pack (root </> conformanceFilePath file) <> " " <> dispositionTag disposition | (file, disposition) <- dispositions, conformanceFileKind file == HoleStub]-    <> ["conformance-record: " <> T.pack (root </> conformanceRecordFileName) <> " " <> dispositionTag disposition | (file, disposition) <- dispositions, conformanceFilePath file == conformanceRecordFileName]+    <> ["expectations: " <> T.pack (root </> (.path) file) <> " " <> dispositionTag disposition | (file, disposition) <- dispositions, (.kind) file == HoleStub]+    <> ["conformance-record: " <> T.pack (root </> conformanceRecordFileName) <> " " <> dispositionTag disposition | (file, disposition) <- dispositions, (.path) file == conformanceRecordFileName]     <> staleLines   where-    plan = conformanceReportPlan report-    root = conformanceReportRoot report-    dispositions = conformanceReportDispositions report-    cabalPath = root </> T.unpack (cppPackageName plan) <> ".cabal"+    plan = (.plan) report+    root = (.root) report+    dispositions = (.dispositions) report+    cabalPath = root </> T.unpack ((.packageName) plan) <> ".cabal"     dispositionTag ConformanceCreated = "(created)"     dispositionTag ConformanceOverwritten = "(overwritten)"     dispositionTag ConformanceSkipped = "(skipped: already present)"     dispositionTag ConformanceUnchanged = "(unchanged)"-    staleLines = case conformanceReportStale report of+    staleLines = case (.stale) report of       [] -> []       stale ->         ["conformance-stale: " <> tshow (length stale) <> " file(s) are no longer produced; keiro-dsl never deletes files."]-          <> ["  " <> staleKindLabel (conformanceStaleKind file) <> " " <> T.pack (root </> conformanceStalePath file) <> staleEvidence file | file <- stale]+          <> ["  " <> staleKindLabel ((.kind) file) <> " " <> T.pack (root </> (.path) file) <> staleEvidence file | file <- stale]     staleKindLabel Generated = "generated"     staleKindLabel HoleStub = "create-once"-    staleEvidence file = case conformanceStaleBannerPresent file of+    staleEvidence file = case (.bannerPresent) file of       Nothing -> " (hand-owned; preserve and review)"       Just True -> " (recognized generated banner present; review before deleting)"       Just False -> " (generated banner missing; preserve and review)"

src/Keiro/Dsl/ConsumerTypePlan.hs view

@@ -5,6 +5,7 @@ -- queue and read-model emitters add their own surface authority around it. module Keiro.Dsl.ConsumerTypePlan   ( HaskellTypeOccurrence (..),+    unHaskellTypeOccurrence,     ImportRequirement (..),     ConsumerTypePlan (..),     ConsumerTypePlanError (..),@@ -27,6 +28,9 @@   }   deriving stock (Eq, Ord, Show) +unHaskellTypeOccurrence :: HaskellTypeOccurrence -> Text+unHaskellTypeOccurrence (HaskellTypeOccurrence value) = value+ -- | 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.@@ -70,16 +74,16 @@       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+      RRef key -> case Map.lookup key ((.declarations) graph) of         Nothing -> Left (ConsumerTypePlanUnknownDeclaration key)         Just declaration ->           let source = mappedSource declaration            in Right                 RenderedType-                  { rendered = hsType source,+                  { rendered = (.valueType) source,                     precedence = AtomicType,-                    requirements = Set.singleton (ImportRequirement (hsPackage source) (hsModule source) (hsType source)),-                    mappedDependencies = Set.insert key (Map.findWithDefault Set.empty key (tgReachability graph))+                    requirements = Set.singleton (ImportRequirement ((.package) source) ((.moduleName) source) ((.valueType) source)),+                    mappedDependencies = Set.insert key (Map.findWithDefault Set.empty key ((.reachability) graph))                   }      atom rendered requiredImports =@@ -92,33 +96,29 @@           }      application constructor requiredImports value =-      value-        { rendered = constructor <> " " <> argument value,-          precedence = ApplicationType,-          requirements = Set.fromList requiredImports <> requirements value-        }+      replaceRenderedType+        (constructor <> " " <> argument value)+        ApplicationType+        (Set.fromList requiredImports <> value.requirements)+        value -    listType value =-      value-        { rendered = "[" <> rendered value <> "]",-          precedence = AtomicType-        }+    listType value = replaceRenderedType ("[" <> value.rendered <> "]") AtomicType value.requirements value      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-        }+      replaceRenderedType+        ("Map Text " <> argument value)+        ApplicationType+        ( Set.fromList+            [ ImportRequirement "containers" "Data.Map.Strict" "Map",+              ImportRequirement "text" "Data.Text" "Text"+            ]+            <> value.requirements+        )+        value -    argument value = case precedence value of-      AtomicType -> rendered value-      ApplicationType -> "(" <> rendered value <> ")"+    argument value = case (.precedence) value of+      AtomicType -> (.rendered) value+      ApplicationType -> "(" <> (.rendered) value <> ")"  data TypePrecedence = AtomicType | ApplicationType @@ -130,14 +130,14 @@   }  mappedSource :: ResolvedMappedDecl -> HaskellSource-mappedSource (ResolvedStructural declaration _) = sdHaskell declaration-mappedSource (ResolvedOpaque declaration) = odHaskell declaration+mappedSource (ResolvedStructural declaration _) = (.haskell) declaration+mappedSource (ResolvedOpaque declaration) = (.haskell) declaration  consumerTypeReferences :: ConsumerTypePlan -> Set HaskellReference consumerTypeReferences planned =   Set.fromList     [ HaskellReference moduleName occurrence TypeNamespace PreferUnqualified-    | ImportRequirement {package, moduleName, occurrence} <- imports planned,+    | ImportRequirement {package, moduleName, occurrence} <- (.imports) planned,       package `Set.notMember` standardPackages     ]   where@@ -147,7 +147,7 @@ -- 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+renderConsumerType importPlan graph = fmap (HaskellTypeOccurrence . (.rendered)) . render   where     render = \case       RText -> pure (plainAtom "Text")@@ -161,23 +161,29 @@       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+        pure $+          replaceRenderedType ("Map Text " <> argument renderedValue) ApplicationType renderedValue.requirements renderedValue+      RRef key -> case Map.lookup key ((.declarations) graph) of         Nothing -> Left (ConsumerTypePlanUnknownDeclaration key)         Just declaration ->           let source = mappedSource declaration-           in atom (hsType source) (reference (hsModule source) (hsType source))+           in atom ((.valueType) source) (reference ((.moduleName) source) ((.valueType) 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 <> ")"+    application constructor value = replaceRenderedType (constructor <> " " <> argument value) ApplicationType value.requirements value+    listType value = replaceRenderedType ("[" <> value.rendered <> "]") AtomicType value.requirements value+    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++replaceRenderedType :: Text -> TypePrecedence -> Set ImportRequirement -> RenderedType -> RenderedType+replaceRenderedType rendered precedence requirements value =+  RenderedType+    { rendered,+      precedence,+      requirements,+      mappedDependencies = value.mappedDependencies+    }

src/Keiro/Dsl/CoordinationImpact.hs view

@@ -57,18 +57,18 @@ -- | 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)+  { router :: !Name,+    verification :: !SelectionVerification,+    identity :: !(Maybe Text),+    version :: !(Maybe Natural),+    fingerprint :: !(Maybe Text)   }   deriving stock (Eq, Ord, Show, Generic)  data CoordinationImpact = CoordinationImpact-  { coordinationRouter :: !Name,-    coordinationSeverity :: !CoordinationSeverity,-    coordinationReason :: !CoordinationReason,+  { router :: !Name,+    severity :: !CoordinationSeverity,+    reason :: !CoordinationReason,     previousVerification :: !SelectionVerification,     currentVerification :: !SelectionVerification,     previousIdentity :: !(Maybe Text),@@ -82,9 +82,9 @@   deriving stock (Eq, Show, Generic)  data RouterSelectionDrift = RouterSelectionDrift-  { driftRouter :: !Name,-    driftPreviousSelection :: !(Maybe RouterSelectionSnapshot),-    driftCurrentSelection :: !(Maybe RouterSelectionSnapshot)+  { router :: !Name,+    previousSelection :: !(Maybe RouterSelectionSnapshot),+    currentSelection :: !(Maybe RouterSelectionSnapshot)   }   deriving stock (Eq, Show, Generic) @@ -102,11 +102,11 @@ instance ToJSON RouterSelectionSnapshot where   toJSON snapshot =     object-      [ "router" .= selectionRouter snapshot,-        "verification" .= selectionVerification snapshot,-        "identity" .= selectionIdentity snapshot,-        "version" .= selectionVersion snapshot,-        "fingerprint" .= selectionFingerprint snapshot+      [ "router" .= (.router) snapshot,+        "verification" .= (.verification) snapshot,+        "identity" .= (.identity) snapshot,+        "version" .= (.version) snapshot,+        "fingerprint" .= (.fingerprint) snapshot       ]  instance FromJSON RouterSelectionSnapshot where@@ -124,23 +124,23 @@ 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)+      [ "router" .= (.router) impact,+        "severity" .= severityIdentity ((.severity) impact),+        "reason" .= reasonIdentity ((.reason) 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+routerSelectionSnapshots = sortOn (.router) . map (.snapshot) . routerSelectionStates  routerSelectionDrift :: [RouterSelectionSnapshot] -> [RouterSelectionSnapshot] -> [RouterSelectionDrift] routerSelectionDrift previous current =@@ -151,23 +151,23 @@     old /= new   ]   where-    oldByRouter = Map.fromList [(selectionRouter snapshot, snapshot) | snapshot <- previous]-    newByRouter = Map.fromList [(selectionRouter snapshot, snapshot) | snapshot <- current]+    oldByRouter = Map.fromList [((.router) snapshot, snapshot) | snapshot <- previous]+    newByRouter = Map.fromList [((.router) 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)+      [ "  " <> (.router) drift,+        "    previous: " <> maybe "(none)" renderSnapshot ((.previousSelection) drift),+        "    current:  " <> maybe "(none)" renderSnapshot ((.currentSelection) drift)       ]     renderSnapshot snapshot =-      verificationIdentity (selectionVerification snapshot)-        <> maybe "" (" identity=" <>) (selectionIdentity snapshot)-        <> maybe "" ((" version=" <>) . T.pack . show) (selectionVersion snapshot)-        <> maybe "" (" fingerprint=" <>) (selectionFingerprint snapshot)+      verificationIdentity ((.verification) snapshot)+        <> maybe "" (" identity=" <>) ((.identity) snapshot)+        <> maybe "" ((" version=" <>) . T.pack . show) ((.version) snapshot)+        <> maybe "" (" fingerprint=" <>) ((.fingerprint) snapshot)  coordinationImpact :: CheckedService -> CheckedService -> [MappedImpactDelta] -> [CoordinationImpact] coordinationImpact previous current mappedDeltas =@@ -184,7 +184,7 @@       Set.toAscList . Set.fromList $         [ router         | delta <- mappedDeltas,-          consumer <- Set.toList (impactPreviousConsumers delta <> impactCurrentConsumers delta),+          consumer <- Set.toList ((.previousConsumers) delta <> (.currentConsumers) delta),           RouterSelectionConsumer router _ <- [consumer]         ]     mappedImpacts =@@ -193,20 +193,20 @@           SelectionMappedDependencyChanged           oldState           newState-          (stateUseSites oldState <> stateUseSites newState)+          ((.useSites) oldState <> (.useSites) newState)       | router <- affectedRouters,         Just oldState <- [Map.lookup router previousStates],         Just newState <- [Map.lookup router currentStates]       ]-    impactOrder impact = (coordinationRouter impact, coordinationReason impact)+    impactOrder impact = ((.router) impact, (.reason) impact)  data RouterSelectionState = RouterSelectionState-  { stateSnapshot :: !RouterSelectionSnapshot,-    stateUseSites :: ![UseSite]+  { snapshot :: !RouterSelectionSnapshot,+    useSites :: ![UseSite]   }  stateMap :: CheckedService -> Map Name RouterSelectionState-stateMap = Map.fromList . map (\state -> (selectionRouter (stateSnapshot state), state)) . routerSelectionStates+stateMap = Map.fromList . map (\state -> ((.router) ((.snapshot) state), state)) . routerSelectionStates  routerSelectionStates :: CheckedService -> [RouterSelectionState] routerSelectionStates service = case checkedTypeGraph service of@@ -214,35 +214,35 @@   Right graph -> map (routerState graph) routers   where     spec = checkedSpec service-    routers = [router | NRouter router <- specNodes spec]-    routerState graph router = case rvSource (rtResolve router) of+    routers = [router | NRouter router <- (.nodes) spec]+    routerState graph router = case (.source) ((.resolve) 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 =+            { snapshot =                 RouterSelectionSnapshot-                  { selectionRouter = rtId router,-                    selectionVerification = DeclarativeVerified,-                    selectionIdentity = Just (checkedIdentity selection),-                    selectionVersion = Just (checkedVersion selection),-                    selectionFingerprint = Just (checkedFingerprint selection)+                  { router = (.id) router,+                    verification = DeclarativeVerified,+                    identity = Just ((.identity) selection),+                    version = Just ((.version) selection),+                    fingerprint = Just ((.fingerprint) selection)                   },-              stateUseSites = checkedUseSites selection+              useSites = (.useSites) selection             }       ResolveReadModel {} -> customState router       ResolveHole -> customState router     customState router =       RouterSelectionState-        { stateSnapshot =+        { snapshot =             RouterSelectionSnapshot-              { selectionRouter = rtId router,-                selectionVerification = CustomUnverified,-                selectionIdentity = Nothing,-                selectionVersion = Nothing,-                selectionFingerprint = Nothing+              { router = (.id) router,+                verification = CustomUnverified,+                identity = Nothing,+                version = Nothing,+                fingerprint = Nothing               },-          stateUseSites = []+          useSites = []         }  directImpact :: RouterSelectionState -> RouterSelectionState -> Maybe CoordinationImpact@@ -256,51 +256,51 @@   | 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+    old = (.snapshot) oldState+    new = (.snapshot) newState+    oldVerification = (.verification) old+    newVerification = (.verification) new+    oldIdentity = (.identity) old+    newIdentity = (.identity) new+    oldVersion = (.version) old+    newVersion = (.version) new+    oldFingerprint = (.fingerprint) old+    newFingerprint = (.fingerprint) new+    useSites = (.useSites) oldState <> (.useSites) 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,+    { router = (.router) new,+      severity = severity,+      reason = reason,+      previousVerification = (.verification) old,+      currentVerification = (.verification) new,+      previousIdentity = (.identity) old,+      currentIdentity = (.identity) new,+      previousVersion = (.version) old,+      currentVersion = (.version) new,+      previousFingerprint = (.fingerprint) old,+      currentFingerprint = (.fingerprint) new,       affectedUseSites = Set.toAscList (Set.fromList useSites)     }   where-    old = stateSnapshot oldState-    new = stateSnapshot newState+    old = (.snapshot) oldState+    new = (.snapshot) 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)+      [ "  " <> (.router) impact <> ": " <> severityIdentity ((.severity) impact) <> " (" <> reasonIdentity ((.reason) 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)@@ -308,11 +308,11 @@     renderUseSites values = T.intercalate ", " (map (renderUsePath . (`UsePath` [])) values)  snapshotValid :: RouterSelectionSnapshot -> Bool-snapshotValid snapshot = case selectionVerification snapshot of+snapshotValid snapshot = case (.verification) snapshot of   DeclarativeVerified -> allPresent   CustomUnverified -> allAbsent   where-    fields = [() <$ selectionIdentity snapshot, () <$ selectionVersion snapshot, () <$ selectionFingerprint snapshot]+    fields = [() <$ (.identity) snapshot, () <$ (.version) snapshot, () <$ (.fingerprint) snapshot]     allPresent = all (/= Nothing) fields     allAbsent = all (== Nothing) fields

src/Keiro/Dsl/Coverage.hs view

@@ -63,60 +63,60 @@   deriving stock (Eq, Ord, Show)  data CoverageRoot = CoverageRoot-  { rootSurface :: !CoverageSurface,-    rootConsumer :: !Text,-    rootPath :: !Text,-    rootMappedType :: !Text,-    rootMode :: !CoverageMode,-    rootCanonicalType :: !(Maybe Text),-    rootCodecIdentity :: !(Maybe Text),-    rootCodecVersion :: !(Maybe Text),-    rootWireFingerprint :: !Text+  { surface :: !CoverageSurface,+    consumer :: !Text,+    path :: !Text,+    mappedType :: !Text,+    mode :: !CoverageMode,+    canonicalType :: !(Maybe Text),+    codecIdentity :: !(Maybe Text),+    codecVersion :: !(Maybe Text),+    wireFingerprint :: !Text   }   deriving stock (Eq, Ord, Show)  data StructuralBoundary = StructuralBoundary-  { structuralRoot :: !Text,-    structuralPath :: !Text,-    structuralMappedType :: !Text,-    structuralCanonicalType :: !Text,-    structuralWireFingerprint :: !Text+  { root :: !Text,+    path :: !Text,+    mappedType :: !Text,+    canonicalType :: !Text,+    wireFingerprint :: !Text   }   deriving stock (Eq, Ord, Show)  data OpaqueBoundary = OpaqueBoundary-  { opaqueRoot :: !Text,-    opaquePath :: !Text,-    opaqueMappedType :: !Text,-    opaqueCodecIdentity :: !Text,-    opaqueCodecVersion :: !Text+  { root :: !Text,+    path :: !Text,+    mappedType :: !Text,+    codecIdentity :: !Text,+    codecVersion :: !Text   }   deriving stock (Eq, Ord, Show)  data JsonBoundary = JsonBoundary-  { jsonSurface :: !CoverageSurface,-    jsonRoot :: !Text,-    jsonPath :: !Text+  { surface :: !CoverageSurface,+    root :: !Text,+    path :: !Text   }   deriving stock (Eq, Ord, Show)  data SnapshotBoundary = SnapshotBoundary-  { snapshotRoot :: !Text,-    snapshotAggregate :: !Text,-    snapshotRegister :: !Text,-    snapshotMappedType :: !Text,-    snapshotMode :: !CoverageMode,-    snapshotEncoding :: !Text,-    snapshotInvalidation :: !Text,-    snapshotWireFingerprint :: !Text,-    snapshotEnabled :: !Bool+  { root :: !Text,+    aggregate :: !Text,+    register :: !Text,+    mappedType :: !Text,+    mode :: !CoverageMode,+    encoding :: !Text,+    invalidation :: !Text,+    wireFingerprint :: !Text,+    enabled :: !Bool   }   deriving stock (Eq, Ord, Show)  data UnsupportedSurface = UnsupportedSurface-  { unsupportedSurface :: !Text,-    unsupportedSupport :: !Text,-    unsupportedReason :: !Text+  { surface :: !Text,+    support :: !Text,+    reason :: !Text   }   deriving stock (Eq, Ord, Show) @@ -140,17 +140,17 @@   deriving stock (Eq, Show)  data CoverageFinding = CoverageFinding-  { findingSeverity :: !Severity,-    findingCode :: !DiagnosticCode,-    findingRoots :: ![Text],-    findingMessage :: !Text+  { severity :: !Severity,+    code :: !DiagnosticCode,+    roots :: ![Text],+    message :: !Text   }   deriving stock (Eq, Show)  data CoveragePrevious = CoveragePrevious-  { previousReference :: !Text,-    previousSummary :: !CoverageSummary,-    previousOpaqueBoundaries :: ![OpaqueBoundary]+  { reference :: !Text,+    summary :: !CoverageSummary,+    opaqueBoundaries :: ![OpaqueBoundary]   }   deriving stock (Eq, Show) @@ -169,17 +169,17 @@   deriving stock (Eq, Show)  data CoverageReport = CoverageReport-  { coverageSpec :: !FilePath,-    coverageRoots :: ![CoverageRoot],-    coverageStructuralBoundaries :: ![StructuralBoundary],-    coverageOpaqueBoundaries :: ![OpaqueBoundary],-    coverageJsonBoundaries :: ![JsonBoundary],-    coverageSnapshotBoundaries :: ![SnapshotBoundary],-    coverageUnsupportedSurfaces :: ![UnsupportedSurface],-    coverageSummary :: !CoverageSummary,-    coverageFindings :: ![CoverageFinding],-    coveragePrevious :: !(Maybe CoveragePrevious),-    coverageDelta :: !(Maybe CoverageDelta)+  { spec :: !FilePath,+    roots :: ![CoverageRoot],+    structuralBoundaries :: ![StructuralBoundary],+    opaqueBoundaries :: ![OpaqueBoundary],+    jsonBoundaries :: ![JsonBoundary],+    snapshotBoundaries :: ![SnapshotBoundary],+    unsupportedSurfaces :: ![UnsupportedSurface],+    summary :: !CoverageSummary,+    findings :: ![CoverageFinding],+    previous :: !(Maybe CoveragePrevious),+    delta :: !(Maybe CoverageDelta)   }   deriving stock (Eq, Show) @@ -191,126 +191,144 @@   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))+      roots = sortOn (\root -> ((.path) root, (.consumer) root, (.surface) root)) (map (coverageRoot graph) ((.roots) impact))       structural = structuralBoundaryInventory graph       opaque = opaqueBoundaryInventory graph-      json = sortOn jsonPath (jsonBoundaryInventory graph <> queueExplicitJsonBoundaries spec)+      json = sortOn (.path) (jsonBoundaryInventory graph <> queueExplicitJsonBoundaries spec)       snapshots = snapshotBoundaryInventory spec graph       summary = summarize roots json       findings = opaqueSurfaceFindings opaque   pure     CoverageReport-      { coverageSpec = specPath,-        coverageRoots = roots,-        coverageStructuralBoundaries = structural,-        coverageOpaqueBoundaries = opaque,-        coverageJsonBoundaries = json,-        coverageSnapshotBoundaries = snapshots,-        coverageUnsupportedSurfaces = unsupportedInventory graph,-        coverageSummary = summary,-        coverageFindings = findings,-        coveragePrevious = Nothing,-        coverageDelta = Nothing+      { spec = specPath,+        roots = roots,+        structuralBoundaries = structural,+        opaqueBoundaries = opaque,+        jsonBoundaries = json,+        snapshotBoundaries = snapshots,+        unsupportedSurfaces = unsupportedInventory graph,+        summary = summary,+        findings = findings,+        previous = Nothing,+        delta = Nothing       }  coverageDiffReport :: FilePath -> Text -> Spec -> Spec -> Either (NonEmpty TypeGraphError) CoverageReport coverageDiffReport specPath reference oldSpec newSpec = do   oldReport <- coverageReport (T.unpack reference <> ":" <> specPath) oldSpec   newReport <- coverageReport specPath newSpec-  let oldOpaque = Set.fromList (coverageOpaqueBoundaries oldReport)-      newOpaque = Set.fromList (coverageOpaqueBoundaries newReport)+  let oldOpaque = Set.fromList ((.opaqueBoundaries) oldReport)+      newOpaque = Set.fromList ((.opaqueBoundaries) newReport)       added = Set.toAscList (newOpaque `Set.difference` oldOpaque)       removed = Set.toAscList (oldOpaque `Set.difference` newOpaque)-      oldSummary = coverageSummary oldReport-      newSummary = coverageSummary newReport+      oldSummary = (.summary) oldReport+      newSummary = (.summary) newReport       delta =         CoverageDelta-          { 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),+          { 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           }       addedFindings =         [ CoverageFinding-            { findingSeverity = Warning,-              findingCode = CoverageOpaqueBoundaryAdded,-              findingRoots = [opaqueRoot boundary],-              findingMessage = "opaque boundary added at " <> opaquePath boundary+            { severity = Warning,+              code = CoverageOpaqueBoundaryAdded,+              roots = [(.root) boundary],+              message = "opaque boundary added at " <> (.path) boundary             }         | boundary <- added         ]-  pure-    newReport-      { coverageFindings = coverageFindings newReport <> addedFindings,-        coveragePrevious =-          Just-            CoveragePrevious-              { previousReference = reference,-                previousSummary = oldSummary,-                previousOpaqueBoundaries = coverageOpaqueBoundaries oldReport-              },-        coverageDelta = Just delta-      }+  pure $+    replaceCoverageReportComparison+      (newReport.findings <> addedFindings)+      ( Just+          CoveragePrevious+            { reference = reference,+              summary = oldSummary,+              opaqueBoundaries = oldReport.opaqueBoundaries+            }+      )+      (Just delta)+      newReport  failOnOpaque :: CoverageReport -> CoverageReport failOnOpaque report   | null boundaries = report-  | otherwise = report {coverageFindings = coverageFindings report <> [gateFinding "opaque persisted boundaries are forbidden by --fail-on-opaque" boundaries]}+  | otherwise = replaceCoverageReportFindings (report.findings <> [gateFinding "opaque persisted boundaries are forbidden by --fail-on-opaque" boundaries]) report   where-    boundaries = coverageOpaqueBoundaries report+    boundaries = (.opaqueBoundaries) report  failOnOpaqueIncrease :: CoverageReport -> CoverageReport-failOnOpaqueIncrease report = case coverageDelta report of+failOnOpaqueIncrease report = case (.delta) report of   Just delta-    | not (null (addedOpaqueBoundaries delta)) ->-        report-          { coverageFindings =-              coverageFindings report-                <> [gateFinding "new opaque persisted boundaries are forbidden by --fail-on-opaque-increase" (addedOpaqueBoundaries delta)]-          }+    | not (null ((.addedOpaqueBoundaries) delta)) ->+        replaceCoverageReportFindings+          (report.findings <> [gateFinding "new opaque persisted boundaries are forbidden by --fail-on-opaque-increase" delta.addedOpaqueBoundaries])+          report   _ -> report +replaceCoverageReportFindings :: [CoverageFinding] -> CoverageReport -> CoverageReport+replaceCoverageReportFindings findings report =+  replaceCoverageReportComparison findings report.previous report.delta report++replaceCoverageReportComparison :: [CoverageFinding] -> Maybe CoveragePrevious -> Maybe CoverageDelta -> CoverageReport -> CoverageReport+replaceCoverageReportComparison findings previous delta report =+  CoverageReport+    { spec = report.spec,+      roots = report.roots,+      structuralBoundaries = report.structuralBoundaries,+      opaqueBoundaries = report.opaqueBoundaries,+      jsonBoundaries = report.jsonBoundaries,+      snapshotBoundaries = report.snapshotBoundaries,+      unsupportedSurfaces = report.unsupportedSurfaces,+      summary = report.summary,+      findings,+      previous,+      delta+    }+ coverageSucceeded :: CoverageReport -> Bool-coverageSucceeded = all ((/= Error) . findingSeverity) . coverageFindings+coverageSucceeded = all ((/= Error) . (.severity)) . (.findings)  renderCoverageSummary :: CoverageReport -> Text 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: " <> 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",+      "  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: " <> 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-    summary = coverageSummary report+    summary = (.summary) report     renderCounts counts =-      T.pack (show (totalRoots counts))+      T.pack (show ((.totalRoots) counts))         <> " mapped roots ("-        <> T.pack (show (structuralRoots counts))+        <> T.pack (show ((.structuralRoots) counts))         <> " structural, "-        <> T.pack (show (opaqueRoots counts))+        <> T.pack (show ((.opaqueRoots) counts))         <> " opaque, "-        <> T.pack (show (jsonBoundaries counts))+        <> T.pack (show ((.jsonBoundaries) counts))         <> " Json boundaries)"  renderCoverageFinding :: FilePath -> CoverageFinding -> Text renderCoverageFinding specPath finding =   T.pack specPath     <> ":0: "-    <> severityText (findingSeverity finding)+    <> severityText ((.severity) finding)     <> "["-    <> T.pack (show (findingCode finding))+    <> T.pack (show ((.code) finding))     <> "]: "     <> coverageFindingMessage finding   where@@ -320,9 +338,9 @@ -- | The finding's message with its root list appended, shared by the rendered -- stderr line and the machine check-report entry so both say the same thing. coverageFindingMessage :: CoverageFinding -> Text-coverageFindingMessage finding = findingMessage finding <> rootsSuffix+coverageFindingMessage finding = (.message) finding <> rootsSuffix   where-    rootsSuffix = case findingRoots finding of+    rootsSuffix = case (.roots) finding of       [] -> ""       roots -> " (roots: " <> T.intercalate ", " roots <> ")" @@ -332,7 +350,7 @@   Aeson.encodeFile path report  persistedSites :: TypeGraph -> [UseSite]-persistedSites = filter isPersisted . tgUseSites+persistedSites = filter isPersisted . (.useSites)   where     isPersisted RootEventField {} = True     isPersisted RootRegister {} = True@@ -343,73 +361,73 @@  coverageRoot :: TypeGraph -> MappedRoot -> CoverageRoot coverageRoot graph mappedRoot =-  let site = mappedRootUseSite mappedRoot-      key = mappedRootDeclaration mappedRoot+  let site = (.useSite) mappedRoot+      key = (.declaration) mappedRoot       path = renderUsePath (UsePath site (useSiteSegments graph site))       fingerprint = wireFingerprint graph (unMappedKey key)-   in case Map.lookup key (tgDeclarations graph) of+   in case Map.lookup key ((.declarations) graph) of         Just (ResolvedStructural declaration _) ->           CoverageRoot-            { rootSurface = rootKindSurface (mappedRootKind mappedRoot),-              rootConsumer = mappedConsumerIdentity (mappedRootConsumer mappedRoot),-              rootPath = path,-              rootMappedType = unMappedKey key,-              rootMode = StructuralCoverage,-              rootCanonicalType = Just (unCanonicalTypeId (sdCanonical declaration)),-              rootCodecIdentity = Nothing,-              rootCodecVersion = Nothing,-              rootWireFingerprint = fingerprint+            { surface = rootKindSurface ((.kind) mappedRoot),+              consumer = mappedConsumerIdentity ((.consumer) mappedRoot),+              path = path,+              mappedType = unMappedKey key,+              mode = StructuralCoverage,+              canonicalType = Just (unCanonicalTypeId ((.canonical) declaration)),+              codecIdentity = Nothing,+              codecVersion = Nothing,+              wireFingerprint = fingerprint             }         Just (ResolvedOpaque declaration) ->           CoverageRoot-            { rootSurface = rootKindSurface (mappedRootKind mappedRoot),-              rootConsumer = mappedConsumerIdentity (mappedRootConsumer mappedRoot),-              rootPath = path,-              rootMappedType = unMappedKey key,-              rootMode = OpaqueCoverage,-              rootCanonicalType = Nothing,-              rootCodecIdentity = Just (unCodecIdentity (odCodecIdentity declaration)),-              rootCodecVersion = Just (unCodecVersion (odCodecVersion declaration)),-              rootWireFingerprint = fingerprint+            { surface = rootKindSurface ((.kind) mappedRoot),+              consumer = mappedConsumerIdentity ((.consumer) mappedRoot),+              path = path,+              mappedType = unMappedKey key,+              mode = OpaqueCoverage,+              canonicalType = Nothing,+              codecIdentity = Just (unCodecIdentity ((.codecIdentity) declaration)),+              codecVersion = Just (unCodecVersion ((.codecVersion) declaration)),+              wireFingerprint = fingerprint             }         Nothing -> error "coverageRoot: resolved use-site key missing from graph"  structuralBoundaryInventory :: TypeGraph -> [StructuralBoundary] structuralBoundaryInventory graph =   sortOn-    structuralPath+    (.path)     [ StructuralBoundary-        { structuralRoot = rootText (upRoot path),-          structuralPath = renderUsePath path,-          structuralMappedType = sdName declaration,-          structuralCanonicalType = unCanonicalTypeId (sdCanonical declaration),-          structuralWireFingerprint = wireFingerprint graph (sdName declaration)+        { root = rootText ((.root) path),+          path = renderUsePath path,+          mappedType = (.name) declaration,+          canonicalType = unCanonicalTypeId ((.canonical) declaration),+          wireFingerprint = wireFingerprint graph ((.name) declaration)         }-    | ResolvedStructural declaration _ <- Map.elems (tgDeclarations graph),-      path <- usePaths graph (sdName declaration),-      isWireSite (upRoot path)+    | ResolvedStructural declaration _ <- Map.elems ((.declarations) graph),+      path <- usePaths graph ((.name) declaration),+      isWireSite ((.root) path)     ]  opaqueBoundaryInventory :: TypeGraph -> [OpaqueBoundary] opaqueBoundaryInventory graph =   sortOn-    opaquePath+    (.path)     [ OpaqueBoundary-        { opaqueRoot = rootText (upRoot path),-          opaquePath = renderUsePath path,-          opaqueMappedType = odName declaration,-          opaqueCodecIdentity = unCodecIdentity (odCodecIdentity declaration),-          opaqueCodecVersion = unCodecVersion (odCodecVersion declaration)+        { root = rootText ((.root) path),+          path = renderUsePath path,+          mappedType = (.name) declaration,+          codecIdentity = unCodecIdentity ((.codecIdentity) declaration),+          codecVersion = unCodecVersion ((.codecVersion) declaration)         }-    | ResolvedOpaque declaration <- Map.elems (tgDeclarations graph),-      path <- usePaths graph (odName declaration),-      isWireSite (upRoot path)+    | ResolvedOpaque declaration <- Map.elems ((.declarations) graph),+      path <- usePaths graph ((.name) declaration),+      isWireSite ((.root) path)     ]  jsonBoundaryInventory :: TypeGraph -> [JsonBoundary] jsonBoundaryInventory graph =   sortOn-    jsonPath+    (.path)     [ boundary site completeSegments     | site <- persistedSites graph,       isWireSite site,@@ -419,23 +437,23 @@   where     boundary site segments =       JsonBoundary-        { jsonSurface = useSiteSurface site,-          jsonRoot = rootText site,-          jsonPath = renderUsePath (UsePath site segments)+        { surface = useSiteSurface site,+          root = rootText site,+          path = renderUsePath (UsePath site segments)         }  queueExplicitJsonBoundaries :: Spec -> [JsonBoundary] queueExplicitJsonBoundaries spec =   [ JsonBoundary-      { jsonSurface = WorkqueuePayload,-        jsonRoot = root,-        jsonPath = root <> renderSegments segments+      { surface = WorkqueuePayload,+        root = root,+        path = root <> renderSegments segments       }-  | NWorkqueue workqueue <- specNodes spec,-    field <- wqPayload workqueue,-    TypedQueueExpression expression <- [wqfType field],+  | NWorkqueue workqueue <- (.nodes) spec,+    field <- (.payload) workqueue,+    TypedQueueExpression expression <- [(.valueType) field],     segments <- explicitJsonPaths expression,-    let root = "workqueue " <> wqName workqueue <> " payload ." <> wqfName field+    let root = "workqueue " <> (.name) workqueue <> " payload ." <> (.name) field   ]   where     explicitJsonPaths TJson = [[]]@@ -456,31 +474,31 @@ snapshotBoundaryInventory :: Spec -> TypeGraph -> [SnapshotBoundary] snapshotBoundaryInventory spec graph =   sortOn-    snapshotRoot+    (.root)     [ SnapshotBoundary-        { snapshotRoot = renderUsePath (UsePath site []),-          snapshotAggregate = aggregate,-          snapshotRegister = register,-          snapshotMappedType = unMappedKey key,-          snapshotMode = declarationMode declaration,-          snapshotEncoding = "consumer-json-cache",-          snapshotInvalidation = "tracked-by-mapped-wire-fingerprint",-          snapshotWireFingerprint = wireFingerprint graph (unMappedKey key),-          snapshotEnabled = aggregateHasSnapshot aggregate+        { root = renderUsePath (UsePath site []),+          aggregate = aggregate,+          register = register,+          mappedType = unMappedKey key,+          mode = declarationMode declaration,+          encoding = "consumer-json-cache",+          invalidation = "tracked-by-mapped-wire-fingerprint",+          wireFingerprint = wireFingerprint graph (unMappedKey key),+          enabled = aggregateHasSnapshot aggregate         }     | site@(RootRegister aggregate register key) <- persistedSites graph,-      Just declaration <- [Map.lookup key (tgDeclarations graph)]+      Just declaration <- [Map.lookup key ((.declarations) graph)]     ]   where     aggregateHasSnapshot name =       any-        (\case NAggregate aggregate -> aggName aggregate == name && maybe False (const True) (aggSnapshot aggregate); _ -> False)-        (specNodes spec)+        (\case NAggregate aggregate -> (.name) aggregate == name && maybe False (const True) ((.snapshot) aggregate); _ -> False)+        ((.nodes) spec)  jsonPathsFromDecl :: TypeGraph -> Set.Set MappedKey -> MappedKey -> [[PathSeg]] jsonPathsFromDecl graph visited key   | key `Set.member` visited = []-  | otherwise = case Map.lookup key (tgDeclarations graph) of+  | otherwise = case Map.lookup key ((.declarations) graph) of       Nothing -> []       Just declaration ->         foldMappedDecl@@ -496,13 +514,13 @@     MappedShapeAlgebra       { onRecord = \_ _ fields ->           concat-            [ map (SegField (rwfHaskell field) (rwfKey field) :) (jsonPathsFromExpr graph visited (rwfType field))+            [ map (SegField ((.haskell) field) ((.key) field) :) (jsonPathsFromExpr graph visited ((.valueType) field))             | field <- fields             ],         onEnum = const [],         onUnion = \_ arms ->           concat-            [ map (SegArm (rwaCtor arm) (rwaTag arm) :) (maybe [] (jsonPathsFromExpr graph visited) (rwaPayload arm))+            [ map (SegArm ((.ctor) arm) ((.tag) arm) :) (maybe [] (jsonPathsFromExpr graph visited) ((.payload) arm))             | arm <- arms             ]       }@@ -537,49 +555,49 @@     }   where     countsFor surface =-      let matching = filter ((== surface) . rootSurface) roots-          jsonCount = length (filter ((== surface) . jsonSurface) json)+      let matching = filter ((== surface) . (.surface)) roots+          jsonCount = length (filter ((== surface) . (.surface)) json)        in CoverageCounts             { totalRoots = length matching,-              structuralRoots = length (filter ((== StructuralCoverage) . rootMode) matching),-              opaqueRoots = length (filter ((== OpaqueCoverage) . rootMode) matching),+              structuralRoots = length (filter ((== StructuralCoverage) . (.mode)) matching),+              opaqueRoots = length (filter ((== OpaqueCoverage) . (.mode)) matching),               jsonBoundaries = jsonCount             }  opaqueSurfaceFindings :: [OpaqueBoundary] -> [CoverageFinding] opaqueSurfaceFindings boundaries =   [ CoverageFinding-      { findingSeverity = Warning,-        findingCode = CoverageOpaqueSurface,-        findingRoots = [root],-        findingMessage = "persisted mapped root contains opaque mapped boundaries"+      { severity = Warning,+        code = CoverageOpaqueSurface,+        roots = [root],+        message = "persisted mapped root contains opaque mapped boundaries"       }-  | root <- Set.toAscList (Set.fromList (map opaqueRoot boundaries))+  | root <- Set.toAscList (Set.fromList (map (.root) boundaries))   ]  gateFinding :: Text -> [OpaqueBoundary] -> CoverageFinding gateFinding message boundaries =   CoverageFinding-    { findingSeverity = Error,-      findingCode = CoverageOpaqueGateExceeded,-      findingRoots = Set.toAscList (Set.fromList (map opaqueRoot boundaries)),-      findingMessage = message+    { severity = Error,+      code = CoverageOpaqueGateExceeded,+      roots = Set.toAscList (Set.fromList (map (.root) boundaries)),+      message = message     }  unsupportedInventory :: TypeGraph -> [UnsupportedSurface] unsupportedInventory graph =   [ UnsupportedSurface-      { unsupportedSurface = "public-contracts",-        unsupportedSupport = "not-applicable",-        unsupportedReason = "public contracts have a separately owned grammar and compatibility surface"+      { surface = "public-contracts",+        support = "not-applicable",+        reason = "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"+           { surface = unsupportedProjectionIdentity boundary,+             support = "operational-only",+             reason = "heterogeneous projection sources have no single generated event type or mapped declaration root"            }-       | boundary <- tgUnsupportedProjectionSources graph+       | boundary <- (.unsupportedProjectionSources) graph        ]   where     unsupportedProjectionIdentity (UnsupportedCatalogCategory owner categoryName) = "projection-category:" <> owner <> ":" <> categoryName@@ -649,90 +667,90 @@ instance ToJSON CoverageRoot where   toJSON root =     object-      [ "surface" .= rootSurface root,-        "consumer" .= rootConsumer root,-        "path" .= rootPath root,-        "mappedType" .= rootMappedType root,-        "mode" .= rootMode root,-        "canonicalType" .= rootCanonicalType root,-        "codecIdentity" .= rootCodecIdentity root,-        "codecVersion" .= rootCodecVersion root,-        "wireFingerprint" .= rootWireFingerprint root+      [ "surface" .= (.surface) root,+        "consumer" .= (.consumer) root,+        "path" .= (.path) root,+        "mappedType" .= (.mappedType) root,+        "mode" .= (.mode) root,+        "canonicalType" .= (.canonicalType) root,+        "codecIdentity" .= (.codecIdentity) root,+        "codecVersion" .= (.codecVersion) root,+        "wireFingerprint" .= (.wireFingerprint) root       ]  instance ToJSON StructuralBoundary where   toJSON boundary =     object-      [ "root" .= structuralRoot boundary,-        "path" .= structuralPath boundary,-        "mappedType" .= structuralMappedType boundary,-        "canonicalType" .= structuralCanonicalType boundary,-        "wireFingerprint" .= structuralWireFingerprint boundary+      [ "root" .= (.root) boundary,+        "path" .= (.path) boundary,+        "mappedType" .= (.mappedType) boundary,+        "canonicalType" .= (.canonicalType) boundary,+        "wireFingerprint" .= (.wireFingerprint) boundary       ]  instance ToJSON OpaqueBoundary where   toJSON boundary =     object-      [ "root" .= opaqueRoot boundary,-        "path" .= opaquePath boundary,-        "mappedType" .= opaqueMappedType boundary,-        "codecIdentity" .= opaqueCodecIdentity boundary,-        "codecVersion" .= opaqueCodecVersion boundary+      [ "root" .= (.root) boundary,+        "path" .= (.path) boundary,+        "mappedType" .= (.mappedType) boundary,+        "codecIdentity" .= (.codecIdentity) boundary,+        "codecVersion" .= (.codecVersion) boundary       ]  instance ToJSON JsonBoundary where-  toJSON boundary = object ["surface" .= jsonSurface boundary, "root" .= jsonRoot boundary, "path" .= jsonPath boundary]+  toJSON boundary = object ["surface" .= (.surface) boundary, "root" .= (.root) boundary, "path" .= (.path) boundary]  instance ToJSON SnapshotBoundary where   toJSON boundary =     object-      [ "root" .= snapshotRoot boundary,-        "aggregate" .= snapshotAggregate boundary,-        "register" .= snapshotRegister boundary,-        "mappedType" .= snapshotMappedType boundary,-        "mode" .= snapshotMode boundary,-        "snapshotEncoding" .= snapshotEncoding boundary,-        "invalidation" .= snapshotInvalidation boundary,-        "wireFingerprint" .= snapshotWireFingerprint boundary,-        "snapshotEnabled" .= snapshotEnabled boundary+      [ "root" .= (.root) boundary,+        "aggregate" .= (.aggregate) boundary,+        "register" .= (.register) boundary,+        "mappedType" .= (.mappedType) boundary,+        "mode" .= (.mode) boundary,+        "snapshotEncoding" .= (.encoding) boundary,+        "invalidation" .= (.invalidation) boundary,+        "wireFingerprint" .= (.wireFingerprint) boundary,+        "snapshotEnabled" .= (.enabled) boundary       ]  instance ToJSON UnsupportedSurface where   toJSON surface =     object-      [ "surface" .= unsupportedSurface surface,-        "support" .= unsupportedSupport surface,-        "reason" .= unsupportedReason surface+      [ "surface" .= (.surface) surface,+        "support" .= (.support) surface,+        "reason" .= (.reason) surface       ]  instance ToJSON CoverageCounts where   toJSON counts =     object-      [ "totalRoots" .= totalRoots counts,-        "structuralRoots" .= structuralRoots counts,-        "opaqueRoots" .= opaqueRoots counts,-        "jsonBoundaries" .= jsonBoundaries counts+      [ "totalRoots" .= (.totalRoots) counts,+        "structuralRoots" .= (.structuralRoots) counts,+        "opaqueRoots" .= (.opaqueRoots) counts,+        "jsonBoundaries" .= (.jsonBoundaries) counts       ]  instance ToJSON CoverageSummary where   toJSON summary =     object-      [ "aggregateCommandPayloads" .= aggregateCommandPayloads summary,-        "privateEventPayloads" .= privateEventPayloads summary,-        "snapshotRegisters" .= snapshotRegisters summary,-        "workqueuePayloads" .= workqueuePayloads summary,-        "readModelQueryInputs" .= readModelQueryInputs summary,-        "readModelQueryResults" .= readModelQueryResults summary,-        "projectionTypedConsumers" .= projectionTypedConsumers 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   toJSON finding =     object-      [ "severity" .= severityValue (findingSeverity finding),-        "code" .= show (findingCode finding),-        "roots" .= findingRoots finding,-        "message" .= findingMessage finding+      [ "severity" .= severityValue ((.severity) finding),+        "code" .= show ((.code) finding),+        "roots" .= (.roots) finding,+        "message" .= (.message) finding       ]     where       -- One severity vocabulary across every keiro-dsl JSON report. The check@@ -744,39 +762,39 @@ instance ToJSON CoveragePrevious where   toJSON previous =     object-      [ "reference" .= previousReference previous,-        "summary" .= previousSummary previous,-        "opaqueBoundaries" .= previousOpaqueBoundaries previous+      [ "reference" .= (.reference) previous,+        "summary" .= (.summary) previous,+        "opaqueBoundaries" .= (.opaqueBoundaries) previous       ]  instance ToJSON CoverageDelta where   toJSON delta =     object-      [ "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+      [ "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       ]  instance ToJSON CoverageReport where   toJSON report =     object       [ "schema" .= ("keiro-dsl/coverage-report/1" :: Text),-        "spec" .= coverageSpec report,-        "roots" .= coverageRoots report,-        "structuralBoundaries" .= coverageStructuralBoundaries report,-        "opaqueBoundaries" .= coverageOpaqueBoundaries report,-        "jsonBoundaries" .= coverageJsonBoundaries report,-        "snapshotBoundaries" .= coverageSnapshotBoundaries report,-        "unsupportedSurfaces" .= coverageUnsupportedSurfaces report,-        "summary" .= coverageSummary report,-        "findings" .= coverageFindings report,-        "previous" .= coveragePrevious report,-        "delta" .= coverageDelta report+        "spec" .= (.spec) report,+        "roots" .= (.roots) report,+        "structuralBoundaries" .= (.structuralBoundaries) report,+        "opaqueBoundaries" .= (.opaqueBoundaries) report,+        "jsonBoundaries" .= (.jsonBoundaries) report,+        "snapshotBoundaries" .= (.snapshotBoundaries) report,+        "unsupportedSurfaces" .= (.unsupportedSurfaces) report,+        "summary" .= (.summary) report,+        "findings" .= (.findings) report,+        "previous" .= (.previous) report,+        "delta" .= (.delta) report       ]

src/Keiro/Dsl/Diff.hs view

@@ -22,3024 +22,3098 @@     MappedPersistedSurface (..),     MappedPersistedImpact (..),     ChangeContext,-    privateEventContext,-    privateEventAdditionContext,-    snapshotContext,-    queueContext,-    publicContractContext,-    persistedIdentityContext,-    consumerBuildContext,-    advisoryAt,-    changeContextRoot,-    changeContextPaths,-    classifyCompatibility,-    verdictFor,-    defaultGate,-    gateWith,-    deriveLabel,-    gatedBreaking,-    isBreaking,-    isAdvisory,-    diffSources,-    sourceLanguageChange,-    diffServices,-    mappedSemanticImpact,-    mappedSemanticImpactForServices,-    DiffEnv (..),-    NodeFamily (..),-    familyOf,-    FamilyDiff (..),-    familyRegistry,-    Paired (..),-    pairByName,-    readModelDiff,-    classifyWorkflowBody,-  )-where--import Data.Char (toUpper)-import Data.Foldable (traverse_)-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,-    resolveContractFieldIdentity,-  )-import Keiro.Dsl.FoldFingerprint (FoldSurfaceError, aggregateFoldSurfaceForService)-import Keiro.Dsl.Grammar-import Keiro.Dsl.HaskellName qualified as HaskellName-import Keiro.Dsl.IdDomain (IdDomainContract (..), contractIdDomainContractFor, idDomainContractFor)-import Keiro.Dsl.LanguageVersion (ParsedSource (..), SourceLanguage, declaredLanguageVersionMaybe, languageVersionText, sourceFormText)-import Keiro.Dsl.MappedDiff (MappedFinding (..), diffMapped, renderMappedSubject)-import Keiro.Dsl.PrettyPrint-  ( renderHandleSurface,-    renderResolveSurface,-    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, 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.-data Change-  = Additive ChangeKind-  | Advisory ChangeKind-  | Breaking ChangeKind-  deriving stock (Eq, Show)---- | The stable headline classification retained by the text interface.-data Label = LabelAdditive | LabelAdvisory | LabelBreaking-  deriving stock (Eq, Show)---- | Independently gateable compatibility questions for one finding.-data CompatibilitySurface-  = PrivateHistoryRead-  | OldBinaryReadNewEvents-  | SnapshotHydration-  | PublicConsumer-  | PersistedIdentity-  | ConsumerBuild-  deriving stock (Eq, Ord, Show, Enum, Bounded)---- | A verdict on one surface.  Constructor order is deliberately not policy.-data SurfaceVerdict = VCompatible | VAdvisory | VBreaking | VNotApplicable-  deriving stock (Eq, Show)---- | Deployment ordering that remains after byte compatibility is classified.-data RolloutConstraint-  = RolloutStopTheWorld-  | RolloutWorkersFirst-  | RolloutDrainRequired-  | RolloutProducerLast-  | RolloutProducerFirst-  deriving stock (Eq, Ord, Show)---- | The explicit, compile-forcing compatibility result for one finding.-data CompatibilityVector = CompatibilityVector-  { cvPrivateHistoryRead :: !SurfaceVerdict,-    cvOldBinaryReadNewEvents :: !SurfaceVerdict,-    cvSnapshotHydration :: !SurfaceVerdict,-    cvPublicConsumer :: !SurfaceVerdict,-    cvPersistedIdentity :: !SurfaceVerdict,-    cvConsumerBuild :: !SurfaceVerdict,-    cvRollout :: !(Set RolloutConstraint)-  }-  deriving stock (Eq, Show)---- | 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-  | ContextPrivateEventAddition-  | ContextSnapshot-  | ContextQueue-  | ContextPublicContract-  | ContextPersistedIdentity-  | ContextConsumerBuild-  deriving stock (Eq, Show)---- | Facts that select a compatibility row.  The constructor stays private so--- callers cannot manufacture contradictory ownership and surface claims.-data ChangeContext = ChangeContext-  { changeContextRoot :: !Name,-    changeContextPaths :: ![Text],-    contextKind :: !ContextKind,-    contextOriginalLabel :: !Label-  }-  deriving stock (Eq, Show)--data ChangeKind = ChangeKind-  { ckNode :: !Name,-    ckFacet :: !Text,-    ckSubject :: !Text,-    ckCode :: !DiagnosticCode,-    ckContext :: !ChangeContext,-    ckVector :: !CompatibilityVector,-    ckMappedPersistedImpact :: !(Maybe MappedPersistedImpact),-    ckMappedConsequences :: !(Set MappedConsequence),-    ckPaths :: ![Text],-    ckDetail :: !Text-  }-  deriving stock (Eq, Show)--privateEventContext :: Name -> [Text] -> ChangeContext-privateEventContext root paths = ChangeContext root paths ContextPrivateEvent LabelBreaking--privateEventAdditionContext :: Name -> [Text] -> ChangeContext-privateEventAdditionContext root paths = ChangeContext root paths ContextPrivateEventAddition LabelAdvisory--snapshotContext :: Name -> [Text] -> ChangeContext-snapshotContext root paths = ChangeContext root paths ContextSnapshot LabelAdvisory--queueContext :: Name -> [Text] -> ChangeContext-queueContext root paths = ChangeContext root paths ContextQueue LabelBreaking--publicContractContext :: Name -> [Text] -> ChangeContext-publicContractContext root paths = ChangeContext root paths ContextPublicContract LabelBreaking--persistedIdentityContext :: Name -> [Text] -> ChangeContext-persistedIdentityContext root paths = ChangeContext root paths ContextPersistedIdentity LabelBreaking--consumerBuildContext :: Name -> [Text] -> ChangeContext-consumerBuildContext root paths = ChangeContext root paths ContextConsumerBuild LabelAdvisory--compatibleVector :: CompatibilityVector-compatibleVector =-  CompatibilityVector-    VCompatible-    VCompatible-    VNotApplicable-    VNotApplicable-    VNotApplicable-    VNotApplicable-    Set.empty--sourceProvenanceVector :: CompatibilityVector-sourceProvenanceVector =-  CompatibilityVector-    VCompatible-    VCompatible-    VCompatible-    VCompatible-    VCompatible-    VCompatible-    Set.empty--privateDecodeBreakingVector :: CompatibilityVector-privateDecodeBreakingVector =-  CompatibilityVector-    VBreaking-    VBreaking-    VAdvisory-    VNotApplicable-    VNotApplicable-    VNotApplicable-    (Set.singleton RolloutStopTheWorld)--persistedIdentityBreakingVector :: CompatibilityVector-persistedIdentityBreakingVector =-  CompatibilityVector-    VNotApplicable-    VNotApplicable-    VNotApplicable-    VNotApplicable-    VBreaking-    VNotApplicable-    Set.empty--publicBreakingVector :: CompatibilityVector-publicBreakingVector =-  CompatibilityVector-    VNotApplicable-    VNotApplicable-    VNotApplicable-    VBreaking-    VNotApplicable-    VNotApplicable-    (Set.singleton RolloutProducerLast)--queueBreakingVector :: CompatibilityVector-queueBreakingVector =-  CompatibilityVector-    VNotApplicable-    VNotApplicable-    VNotApplicable-    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-    { cvPrivateHistoryRead = verdict PrivateHistoryRead,-      cvOldBinaryReadNewEvents = verdict OldBinaryReadNewEvents,-      cvSnapshotHydration = verdict SnapshotHydration,-      cvPublicConsumer = verdict PublicConsumer,-      cvPersistedIdentity = verdict PersistedIdentity,-      cvConsumerBuild = verdict ConsumerBuild,-      cvRollout = rollout-    }-  where-    verdict candidate-      | candidate == surface = VAdvisory-      | otherwise = verdictFor candidate compatibleVector---- | Classify one code at an explicitly owned use site.  Codes emitted by the--- differ are grouped by their actual persisted/public surface; the context is--- load-bearing for codes such as 'EnumCtorAdded' that vary by use site.-classifyCompatibility :: ChangeContext -> DiagnosticCode -> CompatibilityVector-classifyCompatibility context code-  | code == SourceLanguageDeclarationChanged = sourceProvenanceVector-  | code == 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-  | code `elem` [MappedHaskellSourceChanged, MappedRecordConstructorChanged, MappedFixturesChanged] = mappedBuildVector-  | code == MappedBindingChanged = mappedBindingVector context-  | code `elem` [MappedInitialChanged, MappedCanonicalTypeChanged] = mappedSnapshotBuildVector context-  | code == NominalFixturesChanged = mappedBuildVector-  | code == NominalBindingChanged = mappedBindingVector context-  | code `elem` [NominalInitialChanged, NominalCanonicalTypeChanged] = mappedSnapshotBuildVector context-  | code == NominalRepresentationChanged = mappedWireBreakingVector context-  | code == NominalIdDecoderTightened =-      (advisoryVector PrivateHistoryRead Set.empty) {cvConsumerBuild = VAdvisory}-  | code == ContractTypeIdDomainChanged = contractTypeIdDomainVector-  | code == IdDomainContractChanged = idDomainContractVector-  | code == MappedDeclAdded = compatibleVector-  | code `elem` privateDecodeCodes = privateDecodeBreakingVector-  | code `elem` identityCodes = persistedIdentityBreakingVector-  | 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}-  | code == AggGuardTightened = advisoryVector PrivateHistoryRead Set.empty-  | code `elem` [RouterDecideSurfaceChanged, ProcessDecideSurfaceChanged] =-      compatibleVector {cvRollout = Set.singleton RolloutDrainRequired}-  | code == ProcessTimerPayloadChanged = advisoryVector PrivateHistoryRead (Set.singleton RolloutProducerLast)-  | code == TimerWindowChanged = advisoryVector PrivateHistoryRead Set.empty-  | code == ProjectionChanged = advisoryVector PersistedIdentity Set.empty-  | code == EmitMappingChanged = advisoryVector PublicConsumer (Set.singleton RolloutProducerLast)-  | code == DecodePostureChanged = advisoryVector PublicConsumer Set.empty-  | code == IntakePersistenceChanged = advisoryVector PrivateHistoryRead Set.empty-  | code `elem` [PublisherPolicyChanged, DispatchRetargeted] = advisoryVector PersistedIdentity Set.empty-  | code `elem` [DeprecatedEventReplayHazard, EventRetirementInProgress] = advisoryVector PrivateHistoryRead Set.empty-  | code == EventUndeprecated = advisoryVector OldBinaryReadNewEvents (Set.singleton RolloutProducerLast)-  | code == EnumCtorAdded = case contextKind context of-      ContextPrivateEventAddition ->-        compatibleVector-          { cvOldBinaryReadNewEvents = VBreaking,-            cvRollout = Set.singleton RolloutProducerLast-          }-      ContextSnapshot -> advisoryVector SnapshotHydration Set.empty-      _ -> compatibleVector-  | code `elem` additiveCodes = compatibleVector-  | otherwise = case contextOriginalLabel context of-      LabelAdditive -> compatibleVector-      LabelAdvisory -> advisoryVector (surfaceForContext context) Set.empty-      LabelBreaking -> breakingVectorForContext context-  where-    privateDecodeCodes =-      [ EvtFieldAddedWithoutBump,-        EvtFieldRemovedSameVersion,-        EvtFieldWireKeyChanged,-        EvtFieldTypeChanged,-        EvtVersionDecreased,-        EvtVersionMissingUpcaster,-        UpcasterChainGap,-        EvtRemovedNotDeprecated,-        EnumCtorRemoved,-        EnumWireSpellingChanged,-        WireSpecChanged,-        ProcessInputChanged,-        WorkflowShapeChanged,-        WorkflowBodyChanged,-        WorkflowPatchRemoved,-        WorkflowContinueSeedChanged-      ]--    identityCodes =-      [ DerivedIdentityChanged,-        IdPrefixChanged,-        DedupeIdentityChanged,-        QueueIdentityChanged,-        RouterStableNameChanged,-        WorkflowStableNameChanged-      ]-    publicBreakingCodes =-      [ ContractEventRemoved,-        ContractFieldChanged,-        ContractDiscriminatorChanged,-        ContractTopicChanged,-        ContractSchemaVersionDecreased-      ]-    queueBreakingCodes = [WqPayloadFieldChanged, WqOrderingChanged, WqProvisionChanged, WqGroupKeyChanged]-    readModelBreakingCodes =-      [ ReadModelVersionDecreased,-        ReadModelShapeChangedWithoutBump,-        ReadModelFeedChanged,-        ReadModelConsistencyWeakened-      ]-    catalogIdentityCodes =-      [ CatalogTargetRemoved,-        CatalogTargetLocationChanged,-        CatalogTargetDependencyChanged,-        CatalogGroupChanged,-        CatalogOwnerRemoved,-        CatalogFeedIdentityChanged,-        CatalogQueryBindingChanged,-        ProjectionDeliveryChanged,-        QueryFreshnessChanged-      ]-    catalogReplayCodes = [CatalogSourceChanged, CatalogReplayPolicyChanged]-    additiveCodes =-      [ DeclarationAdded,-        VersionBumped,-        CompatibilityStrengthened,-        EventRetirementAbandoned,-        ContractEventAdded,-        ContractTopicAdded,-        WorkflowEvolutionGuardAdded-      ]--idDomainContractVector :: CompatibilityVector-idDomainContractVector =-  CompatibilityVector-    { cvPrivateHistoryRead = VCompatible,-      cvOldBinaryReadNewEvents = VCompatible,-      cvSnapshotHydration = VAdvisory,-      cvPublicConsumer = VBreaking,-      cvPersistedIdentity = VCompatible,-      cvConsumerBuild = VAdvisory,-      cvRollout = Set.singleton RolloutProducerLast-    }--contractTypeIdDomainVector :: CompatibilityVector-contractTypeIdDomainVector =-  CompatibilityVector-    { cvPrivateHistoryRead = VNotApplicable,-      cvOldBinaryReadNewEvents = VNotApplicable,-      cvSnapshotHydration = VNotApplicable,-      cvPublicConsumer = VBreaking,-      cvPersistedIdentity = VNotApplicable,-      cvConsumerBuild = VBreaking,-      cvRollout = Set.fromList [RolloutDrainRequired, RolloutProducerFirst]-    }--mappedWireBreakingCodes :: [DiagnosticCode]-mappedWireBreakingCodes =-  [ MappedFieldAddedNoDefault,-    MappedFieldRemoved,-    MappedFieldTypeChanged,-    MappedPresenceChanged,-    MappedNullabilityChanged,-    MappedDefaultRemoved,-    MappedDefaultChanged,-    MappedWireKeyChanged,-    MappedUnionEncodingChanged,-    MappedArmRemoved,-    MappedArmTagChanged,-    MappedEnumValueRemoved,-    MappedEnumSpellingChanged,-    MappedOpaqueCodecChanged,-    MappedModeCrossed,-    MappedDeclRemoved-  ]--mappedFieldAdditionVector :: ChangeContext -> CompatibilityVector-mappedFieldAdditionVector context = case contextKind context of-  ContextPrivateEvent ->-    compatibleVector-      { cvOldBinaryReadNewEvents = oldBinaryVerdict,-        cvRollout = rollout-      }-    where-      rejectsUnknown = contextOriginalLabel context == LabelBreaking-      oldBinaryVerdict = if rejectsUnknown then VBreaking else VCompatible-      rollout = if rejectsUnknown then Set.singleton RolloutProducerLast else Set.empty-  ContextSnapshot -> mappedSnapshotVector-  ContextQueue -> queueBreakingVector-  ContextConsumerBuild -> mappedBuildVector-  _ -> compatibleVector--mappedDirectionalAdditionVector :: ChangeContext -> CompatibilityVector-mappedDirectionalAdditionVector context = case contextKind context of-  ContextPrivateEvent ->-    compatibleVector-      { cvOldBinaryReadNewEvents = VBreaking,-        cvRollout = Set.singleton RolloutProducerLast-      }-  ContextSnapshot -> mappedSnapshotVector-  ContextQueue -> queueBreakingVector-  ContextConsumerBuild -> mappedBuildVector-  _ -> compatibleVector--mappedWireBreakingVector :: ChangeContext -> CompatibilityVector-mappedWireBreakingVector context = case contextKind context of-  ContextPrivateEvent ->-    CompatibilityVector-      VBreaking-      VBreaking-      VNotApplicable-      VNotApplicable-      VNotApplicable-      VNotApplicable-      (Set.singleton RolloutStopTheWorld)-  ContextSnapshot -> mappedSnapshotVector-  ContextQueue -> queueBreakingVector-  ContextConsumerBuild -> mappedBuildVector-  _ -> mappedBuildVector--mappedBuildVector :: CompatibilityVector-mappedBuildVector =-  CompatibilityVector-    VCompatible-    VCompatible-    VNotApplicable-    VNotApplicable-    VNotApplicable-    VAdvisory-    Set.empty--mappedSnapshotVector :: CompatibilityVector-mappedSnapshotVector =-  CompatibilityVector-    VCompatible-    VCompatible-    VAdvisory-    VNotApplicable-    VNotApplicable-    VNotApplicable-    Set.empty--mappedBindingVector :: ChangeContext -> CompatibilityVector-mappedBindingVector context = case contextKind context of-  ContextPrivateEvent ->-    CompatibilityVector-      VAdvisory-      VAdvisory-      VNotApplicable-      VNotApplicable-      VNotApplicable-      VAdvisory-      Set.empty-  ContextSnapshot ->-    mappedSnapshotVector {cvConsumerBuild = VAdvisory}-  ContextQueue -> queueBreakingVector-  _ -> mappedBuildVector--mappedSnapshotBuildVector :: ChangeContext -> CompatibilityVector-mappedSnapshotBuildVector context = case contextKind context of-  ContextSnapshot -> mappedSnapshotVector {cvConsumerBuild = VAdvisory}-  _ -> mappedBuildVector--surfaceForContext :: ChangeContext -> CompatibilitySurface-surfaceForContext context = case contextKind context of-  ContextPrivateEvent -> PrivateHistoryRead-  ContextPrivateEventAddition -> OldBinaryReadNewEvents-  ContextSnapshot -> SnapshotHydration-  ContextQueue -> PrivateHistoryRead-  ContextPublicContract -> PublicConsumer-  ContextPersistedIdentity -> PersistedIdentity-  ContextConsumerBuild -> ConsumerBuild-  ContextGeneral -> PrivateHistoryRead--breakingVectorForContext :: ChangeContext -> CompatibilityVector-breakingVectorForContext context = case contextKind context of-  ContextPublicContract -> publicBreakingVector-  ContextPersistedIdentity -> persistedIdentityBreakingVector-  ContextQueue -> queueBreakingVector-  ContextConsumerBuild -> (advisoryVector ConsumerBuild Set.empty) {cvConsumerBuild = VBreaking}-  _ -> privateDecodeBreakingVector--verdictFor :: CompatibilitySurface -> CompatibilityVector -> SurfaceVerdict-verdictFor surface vector = case surface of-  PrivateHistoryRead -> cvPrivateHistoryRead vector-  OldBinaryReadNewEvents -> cvOldBinaryReadNewEvents vector-  SnapshotHydration -> cvSnapshotHydration vector-  PublicConsumer -> cvPublicConsumer vector-  PersistedIdentity -> cvPersistedIdentity vector-  ConsumerBuild -> cvConsumerBuild vector--defaultGate :: Set CompatibilitySurface-defaultGate = Set.delete OldBinaryReadNewEvents (Set.fromList [minBound .. maxBound])--gateWith :: [CompatibilitySurface] -> Set CompatibilitySurface-gateWith surfaces = defaultGate <> Set.fromList surfaces--deriveLabel :: Set CompatibilitySurface -> CompatibilityVector -> Label-deriveLabel gate vector-  | any ((== VBreaking) . (`verdictFor` vector)) (Set.toList gate) = LabelBreaking-  | any (`elem` [VAdvisory, VBreaking]) verdicts || not (Set.null (cvRollout vector)) = LabelAdvisory-  | otherwise = LabelAdditive-  where-    verdicts = [verdictFor surface vector | surface <- [minBound .. maxBound]]--gatedBreaking :: Set CompatibilitySurface -> Change -> Bool-gatedBreaking gate change = deriveLabel gate (ckVector (changeKind change)) == LabelBreaking--changeKind :: Change -> ChangeKind-changeKind (Additive kind) = kind-changeKind (Advisory kind) = kind-changeKind (Breaking kind) = kind--isBreaking :: Change -> Bool-isBreaking (Breaking _) = True-isBreaking (Additive _) = False-isBreaking (Advisory _) = False--isAdvisory :: Change -> Bool-isAdvisory (Advisory _) = True-isAdvisory (Additive _) = False-isAdvisory (Breaking _) = False---- | Both specs supplied to a node-family differ, always old then new.-data DiffEnv = DiffEnv-  { deOld :: !Spec,-    deNew :: !Spec-  }-  deriving stock (Eq, Show)---- | The closed set of node families currently present in 'Node'.-data NodeFamily-  = FamAggregate-  | FamProcess-  | FamRouter-  | FamContract-  | FamIntake-  | FamEmit-  | FamPublisher-  | FamWorkqueue-  | FamPgmqDispatch-  | FamReadModel-  | FamProjectionTarget-  | FamRebuildGroup-  | FamProjectionRevision-  | FamExternalRead-  | FamProjectionOwner-  | FamWorkflow-  | FamOperation-  deriving stock (Eq, Ord, Show, Enum, Bounded)---- | Total by construction: one explicit arm per 'Node' constructor.-familyOf :: Node -> NodeFamily-familyOf (NAggregate _) = FamAggregate-familyOf (NProcess _) = FamProcess-familyOf (NRouter _) = FamRouter-familyOf (NContract _) = FamContract-familyOf (NIntake _) = FamIntake-familyOf (NEmit _) = FamEmit-familyOf (NPublisher _) = FamPublisher-familyOf (NWorkqueue _) = FamWorkqueue-familyOf (NPgmqDispatch _) = FamPgmqDispatch-familyOf (NReadModel _) = FamReadModel-familyOf (NProjectionTarget _) = FamProjectionTarget-familyOf (NRebuildGroup _) = FamRebuildGroup-familyOf (NProjectionRevision _) = FamProjectionRevision-familyOf (NExternalRead _) = FamExternalRead-familyOf (NProjectionOwner _) = FamProjectionOwner-familyOf (NWorkflow _) = FamWorkflow-familyOf (NOperation _) = FamOperation---- | A family either has a differ or an explicit reason it is not compared.-data FamilyDiff-  = DiffFamily (DiffEnv -> [Change])-  | OutOfDiffScope Text---- | Pair the old and new declarations of one node family by stable name.-data Paired n = Paired-  { prMatched :: ![(n, n)],-    prAdded :: ![n],-    prRemoved :: ![n]-  }-  deriving stock (Eq, Show)--pairByName :: (Node -> Maybe n) -> (n -> Name) -> DiffEnv -> Paired n-pairByName project nameOf env =-  Paired-    { prMatched =-        [ (oldNode, newNode)-        | newNode <- newNodes,-          Just oldNode <- [find ((== nameOf newNode) . nameOf) oldNodes]-        ],-      prAdded =-        [ newNode-        | newNode <- newNodes,-          isNothing (find ((== nameOf newNode) . nameOf) oldNodes)-        ],-      prRemoved =-        [ oldNode-        | oldNode <- oldNodes,-          isNothing (find ((== nameOf oldNode) . nameOf) newNodes)-        ]-    }-  where-    oldNodes = mapMaybe project (specNodes (deOld env))-    newNodes = mapMaybe project (specNodes (deNew env))---- | Registry invariant: every 'Node' constructor maps to a family via the--- total 'familyOf' case, and every family occurs exactly once here.  The unit--- suite enforces registry coverage and non-empty out-of-scope rationales.-familyRegistry :: [(NodeFamily, FamilyDiff)]-familyRegistry =-  [ (FamAggregate, DiffFamily aggregateDiff),-    (FamProcess, DiffFamily processDiff),-    (FamRouter, DiffFamily routerDiff),-    (FamContract, DiffFamily contractDiff),-    (FamIntake, DiffFamily intakeDiff),-    (FamEmit, DiffFamily emitDiff),-    (FamPublisher, DiffFamily publisherDiff),-    (FamWorkqueue, DiffFamily workqueueDiff),-    (FamPgmqDispatch, DiffFamily pgmqDispatchDiff),-    (FamReadModel, DiffFamily readModelDiff),-    (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")-  ]---- | Compare two graphs under their effective semantic contracts. The ordinary--- graph differ runs first; service-aware admission and fold findings then expose--- semantic-profile changes that leave the normalized graph itself unchanged.-diffServices :: CheckedService -> CheckedService -> Either FoldSurfaceError [Change]-diffServices oldService newService = do-  traverse_ (aggregateFoldSurfaceForService oldService . snd) oldAggregates-  traverse_ (aggregateFoldSurfaceForService newService . snd) newAggregates-  semanticContractFoldChanges <- fmap concat (traverse semanticContractFoldChange oldAggregates)-  pure (diffCheckedSpecs oldSpec newSpec <> idDomainContractChanges <> contractTypeIdDomainChanges <> semanticContractFoldChanges)-  where-    oldSpec = checkedSpec oldService-    newSpec = checkedSpec newService-    oldAggregates = [(aggName aggregate, aggregate) | NAggregate aggregate <- specNodes oldSpec]-    newAggregates = [(aggName aggregate, aggregate) | NAggregate aggregate <- specNodes newSpec]-    idDomainContractChanges =-      [ breaking-          (idName newDeclaration)-          "id-domain-contract"-          (idName newDeclaration)-          IdDomainContractChanged-          ( "ID admission contract changed "-              <> renderIdDomainContract oldContract-              <> " -> "-              <> renderIdDomainContract newContract-              <> "; public construction, command decoding, current JSON codecs, and literals use the new contract; historical event replay retains its legacy decoder; old snapshots miss and rebuild from readable events, while rebuilt state that still contains legacy-invalid text remains intentionally uncacheable until overwritten or explicitly migrated"-          )-      | newDeclaration <- specIds newSpec,-        Just oldDeclaration <- [find ((== idName newDeclaration) . idName) (specIds oldSpec)],-        let oldContract = idDomainContractFor (checkedLanguageContract oldService) (idPrefix oldDeclaration),-        let newContract = idDomainContractFor (checkedLanguageContract newService) (idPrefix newDeclaration),-        oldContract /= newContract-      ]-    contractTypeIdDomainChanges =-      [ breaking-          (ctrName newContract)-          "contract-typeid-domain"-          (ceName newEvent <> "." <> cfName newField)-          ContractTypeIdDomainChanged-          ( renderContractIdDomainChange-              (cfType newField)-              oldContract-              newContract'-          )-      | newContract <- [contract | NContract contract <- specNodes newSpec],-        Just oldContractNode <- [find ((== ctrName newContract) . ctrName) [contract | NContract contract <- specNodes oldSpec]],-        newEvent <- ctrEvents newContract,-        Just oldEvent <- [find ((== ceName newEvent) . ceName) (ctrEvents oldContractNode)],-        newField <- ceFields newEvent,-        Just oldField <- [find ((== cfName newField) . cfName) (ceFields oldEvent)],-        cfType oldField == cfType newField,-        let oldContract = contractFieldIdDomain (checkedLanguageContract oldService) oldField,-        let newContract' = contractFieldIdDomain (checkedLanguageContract newService) newField,-        oldContract /= newContract'-      ]-    semanticContractFoldChange (name, oldAggregate) = case lookup name newAggregates of-      Nothing -> pure []-      Just newAggregate -> do-        oldLegacySurface <- aggregateFoldSurfaceForService (legacyCheckedService oldSpec) oldAggregate-        newLegacySurface <- aggregateFoldSurfaceForService (legacyCheckedService newSpec) newAggregate-        oldSurface <- aggregateFoldSurfaceForService oldService oldAggregate-        newSurface <- aggregateFoldSurfaceForService newService newAggregate-        pure-          [ advisory-              name-              "semantic-contract"-              name-              AggFoldSurfaceChanged-              "effective runtime semantics changed the aggregate fold surface even though the normalized graph is unchanged; re-scaffold, redeploy, and audit replay under the candidate contract"-          | oldLegacySurface == newLegacySurface,-            oldSurface /= newSurface-          ]--renderIdDomainContract :: Maybe IdDomainContract -> Text-renderIdDomainContract Nothing = "legacy-unchecked"-renderIdDomainContract (Just contract) =-  idDomainVersion contract <> "(prefix=" <> idDomainPrefix contract <> ",json=" <> idDomainJsonRepresentation contract <> ")"--contractFieldIdDomain :: EffectiveLanguageContract -> ContractField -> Maybe IdDomainContract-contractFieldIdDomain languageContract field = case cfType field of-  CTypeId prefix -> contractIdDomainContractFor languageContract prefix-  _ -> Nothing--renderContractIdDomainChange :: ContractType -> Maybe IdDomainContract -> Maybe IdDomainContract -> Text-renderContractIdDomainChange fieldType oldContract newContract =-  "contract TypeID admission changed "-    <> renderIdDomainContract oldContract-    <> " -> "-    <> renderIdDomainContract newContract-    <> representationChange-  where-    prefix = case fieldType of-      CTypeId value -> value-      _ -> ""-    representationChange = case (oldContract, newContract) of-      (Nothing, Just _) ->-        "; generated Haskell changes from Text to KindID \""-          <> prefix-          <> "\" while valid JSON stays canonical text; newly generated consumers reject malformed, wrong-prefix, non-canonical, and non-v7 values"-      (Just _, Nothing) ->-        "; generated Haskell changes from KindID \""-          <> prefix-          <> "\" to Text and the generated decoder no longer enforces the frozen TypeID-v7 domain"-      _ -> "; generated contract admission changed while the source field type remained unchanged"--diffCheckedSpecs :: Spec -> Spec -> [Change]-diffCheckedSpecs old new =-  sharedDeclarationDiff env-    ++ concatMap (runFamily env . snd) familyRegistry-  where-    env = DiffEnv old new---- | Compare provenance first, then delegate semantic graphs to 'diffServices'.-diffSources :: ParsedSource -> ParsedSource -> Either FoldSurfaceError [Change]-diffSources old new = do-  semanticChanges <- diffServices (checkedSource old) (checkedSource new)-  pure-    ( sourceLanguageChange-        (specContext (parsedSpec new))-        "declaration"-        (parsedSourceLanguage old)-        (parsedSourceLanguage new)-        <> semanticChanges-    )---- | One all-compatible source-provenance finding, reusable per workspace member.-sourceLanguageChange :: Name -> Text -> SourceLanguage -> SourceLanguage -> [Change]-sourceLanguageChange root subject old new-  | old == new = []-  | otherwise =-      [ mkChange-          LabelAdditive-          (ChangeContext root [] ContextGeneral LabelAdditive)-          root-          "source-language"-          subject-          SourceLanguageDeclarationChanged-          ( "source form changed "-              <> renderSourceLanguage old-              <> " -> "-              <> renderSourceLanguage new-              <> if oldRuntime == newRuntime-                then "; normalized runtime semantics are unchanged"-                else "; effective runtime semantics changed " <> oldRuntime <> " -> " <> newRuntime <> "; see the accompanying semantic-contract findings"-          )-      ]-  where-    oldRuntime = effectiveRuntimeSemantics (effectiveLanguageContract old)-    newRuntime = effectiveRuntimeSemantics (effectiveLanguageContract new)-    renderSourceLanguage sourceLanguage =-      sourceFormText sourceLanguage-        <> maybe "" ((" v" <>) . languageVersionText) (declaredLanguageVersionMaybe sourceLanguage)--runFamily :: DiffEnv -> FamilyDiff -> [Change]-runFamily env (DiffFamily f) = f env-runFamily _ (OutOfDiffScope _) = []---- Rules are outside the decode and persisted-identity axes, but referenced--- rule bodies are compared as part of each aggregate's replay fold surface.-sharedDeclarationDiff :: DiffEnv -> [Change]-sharedDeclarationDiff env = enumDiff env ++ idDiff env ++ nominalScalarDiff env ++ mappedDeclarationDiff env--mappedDeclarationDiff :: DiffEnv -> [Change]-mappedDeclarationDiff env =-  concatMap-    (\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]-  | mfCode finding `elem` [MappedHaskellSourceChanged, MappedRecordConstructorChanged, MappedFixturesChanged, GeneratedHaskellNameChanged] =-      [mappedBuildChange finding]-  | mfCode finding `elem` [MappedInitialChanged, MappedCanonicalTypeChanged] =-      mappedBuildChange finding : map (mappedUseChange finding) registerPaths-  | null paths = [mappedBuildChange finding]-  | otherwise = map (mappedUseChange finding) paths-  where-    paths = mfUsePaths finding-    registerPaths = [path | path@UsePath {upRoot = RootRegister {}} <- paths]--mappedBuildChange :: MappedFinding -> Change-mappedBuildChange finding =-  mappedChange context (mfDeclaration finding) "mapped-build" subject finding-  where-    subject = declarationSubject finding-    renderedPaths = map (\path -> renderMappedSubject path (mfLeaf finding)) (mfUsePaths finding)-    context = (consumerBuildContext (mfDeclaration finding) renderedPaths) {contextOriginalLabel = LabelAdvisory}--mappedDeclarationChange :: Label -> MappedFinding -> Change-mappedDeclarationChange label finding =-  mappedChange context (mfDeclaration finding) "mapped-declaration" (declarationSubject finding) finding-  where-    context = ChangeContext (mfDeclaration finding) [] ContextGeneral label--mappedUseChange :: MappedFinding -> UsePath -> Change-mappedUseChange finding path =-  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-        Just IgnoreUnknown -> LabelAdditive-        _ -> LabelBreaking-    | mfCode finding `elem` [MappedArmAdded, MappedEnumValueAdded] -> LabelAdvisory-    | mfCode finding `elem` [MappedBindingChanged, MappedInitialChanged, MappedCanonicalTypeChanged] -> LabelAdvisory-    | otherwise -> LabelBreaking-  _ -> LabelAdvisory--mappedChange :: ChangeContext -> Name -> Text -> Text -> MappedFinding -> Change-mappedChange context node facet subject finding =-  mkChange label context node facet subject (mfCode finding) 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 =-  mfDeclaration finding <> if T.null (mfLeaf finding) then "" else " " <> mfLeaf finding--nodeAggregate :: Node -> Maybe Aggregate-nodeAggregate (NAggregate a) = Just a-nodeAggregate _ = Nothing--nodeProcess :: Node -> Maybe ProcessNode-nodeProcess (NProcess process) = Just process-nodeProcess _ = Nothing--nodeRouter :: Node -> Maybe RouterNode-nodeRouter (NRouter router) = Just router-nodeRouter _ = Nothing--nodeContract :: Node -> Maybe ContractNode-nodeContract (NContract contract) = Just contract-nodeContract _ = Nothing--nodeIntake :: Node -> Maybe IntakeNode-nodeIntake (NIntake intake) = Just intake-nodeIntake _ = Nothing--nodeEmit :: Node -> Maybe EmitNode-nodeEmit (NEmit emit) = Just emit-nodeEmit _ = Nothing--nodePublisher :: Node -> Maybe PublisherNode-nodePublisher (NPublisher publisher) = Just publisher-nodePublisher _ = Nothing--nodeWorkqueue :: Node -> Maybe WorkqueueNode-nodeWorkqueue (NWorkqueue workqueue) = Just workqueue-nodeWorkqueue _ = Nothing--nodePgmqDispatch :: Node -> Maybe PgmqDispatchNode-nodePgmqDispatch (NPgmqDispatch dispatch) = Just dispatch-nodePgmqDispatch _ = Nothing--nodeReadModel :: Node -> Maybe ReadModelNode-nodeReadModel (NReadModel readModel) = Just readModel-nodeReadModel _ = Nothing--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---- | Router identity is replay-sensitive: the stable name and key feed every--- target-keyed dispatch id, and the target selects the persisted stream family.-routerDiff :: DiffEnv -> [Change]-routerDiff env =-  concatMap (uncurry routerPairDiff) (prMatched paired)-    ++ [additive (rtId router) "router" (rtId router) DeclarationAdded "new router declaration" | router <- prAdded paired]-    ++ [breaking (rtId router) "router-identity" (rtId router) RouterStableNameChanged "router removed while replayable source events may still derive target-keyed dispatch ids from its stable identity" | router <- prRemoved paired]-  where-    paired = pairByName nodeRouter rtId env--routerPairDiff :: RouterNode -> RouterNode -> [Change]-routerPairDiff oldRouter newRouter =-  stableName-    ++ keyDerivation-    ++ target-    ++ routerDecideSurfaceDiff oldRouter newRouter-  where-    nodeName = rtId newRouter-    stableName =-      [ breaking nodeName "router-stable-name" nodeName RouterStableNameChanged $-          "router stable name changed from '" <> rtName oldRouter <> "' to '" <> rtName newRouter <> "'; every deterministicRouterCommandId is re-keyed, so redelivery can duplicate the full resolved fan-out"-      | rtName oldRouter /= rtName newRouter-      ]-    keyDerivation =-      [ breaking nodeName "router-key" (corrField (rtKey newRouter)) DerivedIdentityChanged "router key field or derivation changed; replay derives different target dispatch ids"-      | rtKey oldRouter /= rtKey newRouter-      ]-    target =-      [ breaking nodeName "router-target" (rtTarget newRouter) DerivedIdentityChanged "router target aggregate changed; replay addresses a different persisted stream family"-      | rtTarget oldRouter /= rtTarget newRouter-      ]--routerDecideSurfaceDiff :: RouterNode -> RouterNode -> [Change]-routerDecideSurfaceDiff oldRouter newRouter =-  [ advisory-      (rtId newRouter)-      "router-decide"-      (rtId newRouter)-      RouterDecideSurfaceChanged-      "router dispatch surface changed: a source event redelivered across the deploy dispatches under the same deterministic ids, so half-old/half-new fan-out merges silently. Drain or pause the router's subscription and replay or discard dead letters before deploying; see docs/user/deploy-ordering.md. Hole-only decide changes are not visible to diff; the same drain rule applies to those too."-  | oldSurface /= newSurface-  ]-  where-    oldSurface =-      ( renderResolveSurface (rtResolve oldRouter),-        renderRouterDispatchSurface (rtDispatch oldRouter)-      )-    newSurface =-      ( renderResolveSurface (rtResolve newRouter),-        renderRouterDispatchSurface (rtDispatch newRouter)-      )--readModelDiff :: DiffEnv -> [Change]-readModelDiff env =-  concatMap (uncurry (readModelPairDiff env 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 -> ProjectionSupplyAnalysis -> ProjectionSupplyAnalysis -> ReadModelNode -> ReadModelNode -> [Change]-readModelPairDiff env oldSupplies newSupplies oldReadModel newReadModel =-  versionChanges-    ++ shapeChanges-    ++ identityChanges-    ++ policyChanges-    ++ bindingChanges-    ++ queryContractChanges-  where-    nodeName = rmName newReadModel-    versionChanges-      | rmVersion newReadModel < rmVersion oldReadModel =-          [ breaking nodeName "read-model-version" nodeName ReadModelVersionDecreased ("version decreased from " <> tInt (rmVersion oldReadModel) <> " to " <> tInt (rmVersion newReadModel))-          ]-      | rmVersion newReadModel > rmVersion oldReadModel =-          [ additive nodeName "read-model-version" nodeName VersionBumped ("version increased from " <> tInt (rmVersion oldReadModel) <> " to " <> tInt (rmVersion newReadModel) <> "; register and rebuild the new shape before serving it")-          ]-      | otherwise = []-    oldShape = (rmColumns oldReadModel, rmShape oldReadModel)-    newShape = (rmColumns newReadModel, rmShape newReadModel)-    shapeChanges =-      [ breaking nodeName "read-model-shape" nodeName ReadModelShapeChangedWithoutBump ("declared columns or captured shape hash changed at version " <> tInt (rmVersion newReadModel) <> "; bump version and rebuild")-      | oldShape /= newShape,-        rmVersion oldReadModel == rmVersion newReadModel-      ]-    oldRegistry = registryNameFor (specContext (deOld env)) oldReadModel-    newRegistry = registryNameFor (specContext (deNew env)) newReadModel-    oldSubscription = subscriptionNameFor (specContext (deOld env)) oldReadModel-    newSubscription = subscriptionNameFor (specContext (deNew env)) newReadModel-    identityChanges =-      [ breaking nodeName "read-model-identity" nodeName DerivedIdentityChanged ("registry name changed '" <> oldRegistry <> "' -> '" <> newRegistry <> "'; the old registration row is orphaned")-      | oldRegistry /= newRegistry-      ]-        ++ [ breaking nodeName "read-model-table" nodeName DerivedIdentityChanged ("qualified table changed '" <> qualifiedIdentity oldReadModel <> "' -> '" <> qualifiedIdentity newReadModel <> "'; existing data remains under the old identity")-           | (rmSchema oldReadModel, rmTable oldReadModel) /= (rmSchema newReadModel, rmTable newReadModel)-           ]-        ++ [ breaking nodeName "read-model-subscription" nodeName DerivedIdentityChanged ("subscription changed '" <> oldSubscription <> "' -> '" <> newSubscription <> "'; the worker cursor remains under the old identity")-           | oldSubscription /= newSubscription-           ]-    -- 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-      ]-    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"]-      (Just Eventual, Just Strong) ->-        [additive nodeName "read-model-consistency" nodeName CompatibilityStrengthened "default consistency changed Eventual -> Strong; callers gain a cursor-wait guarantee"]-      _ -> []-    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"]--removedReadModelDiff :: ReadModelNode -> [Change]-removedReadModelDiff readModel =-  [breaking (rmName readModel) "read-model-identity" (rmName readModel) DerivedIdentityChanged "read model removed while registered metadata, data, subscription cursors, and callers may remain"]--qualifiedIdentity :: ReadModelNode -> Text-qualifiedIdentity readModel = rmSchema readModel <> "." <> rmTable readModel--renderFeed :: RmFeed -> Text-renderFeed RmInline = "inline"-renderFeed RmSubscription = "subscription"--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--scopeStrengthened :: RmScope -> RmScope -> Bool-scopeStrengthened (RmCategory _) RmEntireLog = True-scopeStrengthened _ _ = False--renderScope :: RmScope -> Text-renderScope RmEntireLog = "entire-log"-renderScope (RmCategory categoryName) = "category '" <> categoryName <> "'"--aggregateDiff :: DiffEnv -> [Change]-aggregateDiff env =-  concatMap-    (\(oldAggregate, newAggregate) -> aggregatePairDiff (deOld env) (deNew env) oldAggregate newAggregate)-    (prMatched paired)-    ++ concatMap addedAggregateDiff (prAdded paired)-    ++ concatMap removedAggregateDiff (prRemoved paired)-  where-    paired = pairByName nodeAggregate aggName env--aggregatePairDiff :: Spec -> Spec -> Aggregate -> Aggregate -> [Change]-aggregatePairDiff oldSpec newSpec oldAgg newAgg =-  commandFieldIdentityDiff oldAgg newAgg-    ++ concatMap (eventDiff oldAgg newAgg) (aggEvents newAgg)-    ++ removedEvents oldAgg newAgg-    ++ 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]-transitionSurfaceDiff oldSpec newSpec oldAgg newAgg-  | aggregateFoldSurfaceForService (legacyCheckedService oldSpec) oldAgg == aggregateFoldSurfaceForService (legacyCheckedService newSpec) newAgg = []-  | otherwise =-      [ advisory-          (aggName newAgg)-          "transitions"-          (aggName newAgg)-          AggFoldSurfaceChanged-          "aggregate fold surface changed: replay now interprets the existing log under the new fold. Old snapshots are invalidated automatically once the regenerated fold fingerprint deploys; if the change is fold-neutral confirm it, otherwise re-scaffold and redeploy, and bump `state-codec version=` for any accompanying Holes-only change."-      ]---- | Plan 143: guard changes are replay-relevant. Hydration re-inverts each--- stored event and re-checks the edge guard, so a stored event legally appended--- under the old guard may no longer satisfy the new one — the next command on--- any stream containing such an event fails hydration with no inverting edge.--- The remedy is mechanical, so the tool computes it: the removed region is--- @old-guard ∧ ¬new-guard@ ('complementExpr' eliminates the negation inside the--- existing grammar), and the advisory prints a paste-ready replay-only twin--- carrying that region with the OLD transition's writes\/emits\/goto. Whether--- history should stay replayable (paste the twin) or be truncated instead is a--- business decision, so the twin is never auto-applied.------ Detection is conservative: any guard change on a paired live (source,--- command) transition where the new spec declares a guard and does not already--- contain a replay-only twin for the pair. A pure loosening also matches; the--- advisory says how to confirm no stored data is affected (the replay audit,--- docs/plans/142) rather than guessing.-guardTighteningDiff :: Aggregate -> Aggregate -> [Change]-guardTighteningDiff oldAgg newAgg =-  [ advisory (aggName newAgg) "transition" subject AggGuardTightened detail-  | newT <- aggTransitions newAgg,-    tMode newT == TmLive,-    Just oldT <--      [ find-          (\o -> tSource o == tSource newT && tCommand o == tCommand newT && tMode o == TmLive)-          (aggTransitions oldAgg)-      ],-    tGuard newT /= tGuard oldT,-    Just newGuard <- [tGuard newT],-    not (hasReplayOnlyTwin newT),-    let subject = tSource newT <> " -- " <> tCommand newT,-    let removedRegion =-          maybe (complementExpr newGuard) (\o -> EAnd o (complementExpr newGuard)) (tGuard oldT),-    let twin = oldT {tGuard = Just removedRegion, tMode = TmReplayOnly},-    let detail =-          "guard changed on "-            <> subject-            <> ". Stored events appended under the old guard may no longer invert: "-            <> "the next command on any stream containing one fails hydration with "-            <> "no inverting edge. Either confirm via the replay audit that no stored "-            <> "stream exercises the removed region, or keep history replayable by "-            <> "adding the computed replay-only twin (the removed region with the old "-            <> "transition's writes/emits/goto):\n\n"-            <> renderTransition twin-  ]-  where-    hasReplayOnlyTwin newT =-      any-        (\t -> tMode t == TmReplayOnly && tSource t == tSource newT && tCommand t == tCommand newT)-        (aggTransitions newAgg)--addedAggregateDiff :: Aggregate -> [Change]-addedAggregateDiff newAgg =-  [ additive (aggName newAgg) "event" (evName e) DeclarationAdded "new event type (new aggregate)"-  | e <- aggEvents newAgg-  ]--removedAggregateDiff :: Aggregate -> [Change]-removedAggregateDiff oldAgg =-  [ breaking (aggName oldAgg) "event" (evName e) EvtRemovedNotDeprecated "aggregate removed; its event tags are no longer decodable"-  | e <- aggEvents oldAgg-  ]---- | Per-event classification for an event present in the new aggregate.-eventDiff :: Aggregate -> Aggregate -> Event -> [Change]-eventDiff oldAgg newAgg e =-  case find ((== evName e) . evName) (aggEvents oldAgg) of-    Nothing ->-      [additive (aggName newAgg) "event" (evName e) DeclarationAdded "new event type"]-    Just oldE-      | evVersion e > evVersion oldE ->-          selectorChanges oldE-            ++ if evVersion e == evVersion oldE + 1 && evUpcastFrom e `hasSource` evVersion oldE-              then-                [additive (aggName newAgg) "event" (evName e) VersionBumped ("new version v" <> tInt (evVersion e) <> " with upcaster from v" <> tInt (evVersion oldE))]-                  ++ [ breaking-                         (aggName newAgg)-                         "event"-                         (evName e)-                         UpcasterChainGap-                         ( "bumping v"-                             <> tInt (evVersion oldE)-                             <> " to v"-                             <> tInt (evVersion e)-                             <> " replaced the 'upcast from v"-                             <> tInt vanishedSource-                             <> "' rung; stored v"-                             <> tInt vanishedSource-                             <> " payloads can no longer decode"-                         )-                     | Just (vanishedSource, _) <- [evUpcastFrom oldE],-                       not (aggregateHasUpcasterSource newAgg vanishedSource)-                     ]-              else-                [ breaking-                    (aggName newAgg)-                    "event"-                    (evName e)-                    EvtVersionMissingUpcaster-                    ( "version changed from v"-                        <> tInt (evVersion oldE)-                        <> " to v"-                        <> tInt (evVersion e)-                        <> " without the required contiguous upcaster from v"-                        <> tInt (evVersion oldE)-                    )-                ]-      | evVersion e < evVersion oldE ->-          selectorChanges oldE-            ++ [breaking (aggName newAgg) "event" (evName e) EvtVersionDecreased ("version decreased from v" <> tInt (evVersion oldE) <> " to v" <> tInt (evVersion e))]-      | otherwise ->-          selectorChanges oldE ++ sameVersionEventDiff oldAgg newAgg oldE e-  where-    selectorChanges oldEvent = eventFieldSelectorChanges oldAgg newAgg oldEvent e---- | Events present in the old aggregate but absent in the new one. Removing a--- tag entirely is breaking; deprecation preserves decoding but needs a retained--- replay-only emitter to preserve replay.-removedEvents :: Aggregate -> Aggregate -> [Change]-removedEvents oldAgg newAgg =-  [ breaking (aggName newAgg) "event" (evName oldE) EvtRemovedNotDeprecated "event removed entirely; its stored payloads can neither decode nor replay. Deprecating instead restores decode-ability only — replay still fails on live streams unless an equivalent replay-only emitting transition is retained; truncate or terminalize affected streams before deleting it"-  | oldE <- aggEvents oldAgg,-    isNothing (find ((== evName oldE) . evName) (aggEvents newAgg))-  ]--hasSource :: Maybe (Int, Hole) -> Int -> Bool-hasSource (Just (m, _)) n = m == n-hasSource Nothing _ = False--aggregateHasUpcasterSource :: Aggregate -> Int -> Bool-aggregateHasUpcasterSource aggregate source =-  any ((== Just source) . fmap fst . evUpcastFrom) (aggEvents aggregate)--hasReplayOnlyEmitter :: Aggregate -> Name -> Bool-hasReplayOnlyEmitter aggregate eventName =-  any-    (\transition -> tMode transition == TmReplayOnly && eventName `elem` tEmits transition)-    (aggTransitions aggregate)--data EventFieldSig = EventFieldSig-  { eventFieldDslName :: !Name,-    eventFieldSelector :: !Name,-    eventFieldWireKey :: !Text,-    eventFieldType :: !(Maybe TypeExpr)-  }-  deriving stock (Eq, Show)--eventFieldSigs :: Aggregate -> Event -> [EventFieldSig]-eventFieldSigs agg e = case evBody e of-  EventFields fs -> map fieldSig fs-  EventFromCommand cn ->-    maybe [] (map fieldSig . cmdFields) (find ((== cn) . cmdName) (aggCommands agg))-  where-    fieldSig field =-      let identity = resolveAggregateFieldIdentity field-       in EventFieldSig-            { eventFieldDslName = fieldDslName identity,-              eventFieldSelector = fieldSelector identity,-              eventFieldWireKey = fieldWireKey identity,-              eventFieldType = aggregateFieldType field-            }--eventFieldSelectorChanges :: Aggregate -> Aggregate -> Event -> Event -> [Change]-eventFieldSelectorChanges oldAggregate newAggregate oldEvent newEvent =-  [ fieldSelectorChange-      (aggName newAggregate)-      "event-field-selector"-      (evName newEvent <> "." <> eventFieldDslName newField)-      (eventFieldSelector oldField)-      (eventFieldSelector newField)-      "event field selector"-  | newField <- eventFieldSigs newAggregate newEvent,-    Just oldField <- [find ((== eventFieldDslName newField) . eventFieldDslName) (eventFieldSigs oldAggregate oldEvent)],-    eventFieldSelector oldField /= eventFieldSelector newField-  ]--commandFieldIdentityDiff :: Aggregate -> Aggregate -> [Change]-commandFieldIdentityDiff oldAggregate newAggregate =-  [ fieldSelectorChange-      (aggName newAggregate)-      "command-field-selector"-      (cmdName newCommand <> "." <> aggregateFieldName newField)-      (fieldSelector (resolveAggregateFieldIdentity oldField))-      (fieldSelector (resolveAggregateFieldIdentity newField))-      "command field selector"-  | newCommand <- aggCommands newAggregate,-    Just oldCommand <- [find ((== cmdName newCommand) . cmdName) (aggCommands oldAggregate)],-    newField <- cmdFields newCommand,-    Just oldField <- [find ((== aggregateFieldName newField) . aggregateFieldName) (cmdFields oldCommand)],-    fieldSelector (resolveAggregateFieldIdentity oldField)-      /= fieldSelector (resolveAggregateFieldIdentity newField)-  ]--sameVersionEventDiff :: Aggregate -> Aggregate -> Event -> Event -> [Change]-sameVersionEventDiff oldAgg newAgg oldE newE =-  addedChanges-    ++ removedChanges-    ++ typeChanges-    ++ wireKeyChanges-    ++ deprecationChanges-    ++ retirementChanges-  where-    oldFields = eventFieldSigs oldAgg oldE-    newFields = eventFieldSigs newAgg newE-    oldNames = map eventFieldDslName oldFields-    newNames = map eventFieldDslName newFields-    added = newNames \\ oldNames-    removed = oldNames \\ newNames-    changed =-      [ (eventFieldDslName oldField, eventFieldType oldField, eventFieldType newField)-      | oldField <- oldFields,-        Just newField <- [find ((== eventFieldDslName oldField) . eventFieldDslName) newFields],-        eventFieldType oldField /= eventFieldType newField-      ]-    addedChanges =-      [ breaking (aggName newAgg) "event" (evName newE) EvtFieldAddedWithoutBump ("field(s) " <> commas added <> " added at the same version v" <> tInt (evVersion newE) <> " without a version bump or upcaster")-      | not (null added)-      ]-    removedChanges =-      [ breaking (aggName newAgg) "event" (evName newE) EvtFieldRemovedSameVersion ("field(s) " <> commas removed <> " removed at the same version v" <> tInt (evVersion newE))-      | not (null removed)-      ]-    typeChanges =-      [ breaking-          (aggName newAgg)-          "event-field"-          (evName newE <> "." <> field)-          EvtFieldTypeChanged-          ("type changed " <> renderAggregateFieldType oldType <> " -> " <> renderAggregateFieldType newType <> " at the same version v" <> tInt (evVersion newE))-      | (field, oldType, newType) <- changed-      ]-    wireKeyChanges =-      [ breaking-          (aggName newAgg)-          "event-field-wire-key"-          (evName newE <> "." <> eventFieldDslName newField)-          EvtFieldWireKeyChanged-          ( "wire key changed '"-              <> eventFieldWireKey oldField-              <> "' -> '"-              <> eventFieldWireKey newField-              <> "'; restore the old key, or version the event and retain an upcaster"-          )-      | newField <- newFields,-        Just oldField <- [find ((== eventFieldDslName newField) . eventFieldDslName) oldFields],-        eventFieldWireKey oldField /= eventFieldWireKey newField-      ]-    deprecationChanges-      | not (evDeprecated oldE) && evDeprecated newE =-          [ if hasReplayOnlyEmitter newAgg (evName newE)-              then-                advisory-                  (aggName newAgg)-                  "event"-                  (evName newE)-                  EventRetirementInProgress-                  "event deprecated and removed from the live write path, while an equivalent replay-only transition preserves hydration. Retain that transition until every affected stream is terminal, truncated, or passes the replay audit"-              else-                advisory-                  (aggName newAgg)-                  "event"-                  (evName newE)-                  DeprecatedEventReplayHazard-                  ( "event deprecated: old payloads remain decodable but are no longer replayable — hydration of live streams containing them fails at the first command (HydrationNoInvertingEdge). Add an equivalent replay-only emitting transition or confirm every affected stream is terminal or truncated before deploying"-                      <> if evRetiring oldE then "" else "; consider a 'retiring event' stage first"-                  )-          ]-      | evDeprecated oldE && not (evDeprecated newE) && not (evRetiring newE) =-          [advisory (aggName newAgg) "event" (evName newE) EventUndeprecated "event returned to the write surface; old payloads remain decodable but new writes resume"]-      | otherwise = []-    retirementChanges-      | not (evRetiring oldE) && evRetiring newE =-          [advisory (aggName newAgg) "event" (evName newE) EventRetirementInProgress "retirement started; keep the live emitting transition until affected streams are terminal or truncated, then cut over to deprecated plus an equivalent replay-only emitting transition"]-      | evRetiring oldE && not (evRetiring newE) && not (evDeprecated newE) =-          [additive (aggName newAgg) "event" (evName newE) EventRetirementAbandoned "event retirement abandoned; ordinary live writes continue"]-      | otherwise = []--renderAggregateFieldType :: Maybe TypeExpr -> Text-renderAggregateFieldType Nothing = "(declared)"-renderAggregateFieldType (Just expression) = typeExprCanonicalName expression--renderFieldType :: Maybe Name -> Text-renderFieldType Nothing = "(declared)"-renderFieldType (Just name) = name--wireDiff :: Aggregate -> Aggregate -> [Change]-wireDiff oldAgg newAgg-  | effectiveWire (aggWire oldAgg) == effectiveWire (aggWire newAgg) = []-  | otherwise =-      [ breaking-          (aggName newAgg)-          "wire"-          (aggName newAgg)-          WireSpecChanged-          ("effective wire convention changed " <> renderWire (effectiveWire (aggWire oldAgg)) <> " -> " <> renderWire (effectiveWire (aggWire newAgg)))-      ]--effectiveWire :: Maybe WireSpec -> (Text, Text)-effectiveWire Nothing = ("ctorName", "camelCase")-effectiveWire (Just w) = (wireKind w, wireFields w)--renderWire :: (Text, Text) -> Text-renderWire (kindName, fieldNames) = "kind=" <> kindName <> ", fields=" <> fieldNames--projectionDiff :: Aggregate -> Aggregate -> [Change]-projectionDiff oldAggregate newAggregate-  | projectionSurface (aggProjection oldAggregate) == projectionSurface (aggProjection newAggregate) = []-  | otherwise =-      [ advisory-          (aggName newAggregate)-          "projection"-          (aggName newAggregate)-          ProjectionChanged-          "projection table, consistency, key, or status mapping changed; coordinate the read-model migration"-      ]--projectionSurface :: Maybe ProjectionSpec -> Maybe (Name, Maybe Consistency, Name, Maybe Mapping)-projectionSurface projection = do-  value <- projection-  pure (projTable value, projConsistency value, projKey value, projStatusMap value)--idDiff :: DiffEnv -> [Change]-idDiff env =-  concatMap (uncurry (idPairDiff (deOld env))) (prMatched paired)-    ++ concatMap addedIdDiff (prAdded paired)-    ++ concatMap removedIdDiff (prRemoved paired)-  where-    paired = pairDeclarations idName (specIds (deOld env)) (specIds (deNew env))--idPairDiff :: Spec -> IdDecl -> IdDecl -> [Change]-idPairDiff oldSpec oldId newId =-  [ breaking (idName newId) "id-prefix" (idName newId) IdPrefixChanged ("prefix changed '" <> idPrefix oldId <> "' -> '" <> idPrefix newId <> "'; stored and newly minted ids no longer share an identity domain")-  | idPrefix oldId /= idPrefix newId-  ]-    <> nominalBindingDeclDiff oldSpec "id" (idName newId) (idBinding oldId) (idBinding newId)-    <> [ nominalUseChange-           use-           NominalIdDecoderTightened-           "adopting a checked KindID binding tightens historical decoding; keep a committed valid old-payload fixture and run the targeted real-log audit for this event"-       | idBinding oldId == Nothing,-         isJust (idBinding newId),-         use@NominalEventUse {} <- nominalUses oldSpec (idName oldId)-       ]--addedIdDiff :: IdDecl -> [Change]-addedIdDiff declaration = [additive (idName declaration) "id-prefix" (idName declaration) DeclarationAdded "new id declaration"]--removedIdDiff :: IdDecl -> [Change]-removedIdDiff declaration = [breaking (idName declaration) "id-prefix" (idName declaration) IdPrefixChanged "id declaration removed; persisted ids still use its prefix"]--enumDiff :: DiffEnv -> [Change]-enumDiff env =-  concatMap (uncurry (enumPairDiff (deOld env))) (prMatched paired)-    ++ concatMap addedEnumDiff (prAdded paired)-    ++ concatMap (removedEnumDiff (deOld env)) (prRemoved paired)-  where-    paired = pairDeclarations enumName (specEnums (deOld env)) (specEnums (deNew env))--enumPairDiff :: Spec -> EnumDecl -> EnumDecl -> [Change]-enumPairDiff oldSpec oldEnum newEnum =-  [ breaking (enumName newEnum) "enum-constructor" ctor EnumCtorRemoved ("constructor removed; stored wire value '" <> wire <> "' no longer decodes" <> enumUsageSuffix oldSpec (enumName oldEnum))-  | (ctor, wire) <- enumCtors oldEnum,-    isNothing (lookup ctor (enumCtors newEnum))-  ]-    ++ [ breaking (enumName newEnum) "enum-constructor" ctor EnumWireSpellingChanged ("wire spelling changed '" <> oldWire <> "' -> '" <> newWire <> "'; stored values using the old spelling no longer decode" <> enumUsageSuffix oldSpec (enumName oldEnum))-       | (ctor, oldWire) <- enumCtors oldEnum,-         Just newWire <- [lookup ctor (enumCtors newEnum)],-         oldWire /= newWire-       ]-    ++ concat-      [ enumAdditionDiff oldSpec newEnum ctor wire-      | (ctor, wire) <- enumCtors newEnum,-        isNothing (lookup ctor (enumCtors oldEnum))-      ]-      <> nominalBindingDeclDiff oldSpec "enum" (enumName newEnum) (enumBinding oldEnum) (enumBinding newEnum)--nominalScalarDiff :: DiffEnv -> [Change]-nominalScalarDiff env =-  concatMap (uncurry scalarPairDiff) (prMatched paired)-    <> [nominalDeclarationChange (nominalScalarName declaration) DeclarationAdded "new nominal scalar declaration" | declaration <- prAdded paired]-    <> [nominalDeclarationChange (nominalScalarName declaration) NominalRepresentationChanged "nominal scalar declaration removed while persisted uses may remain" | declaration <- prRemoved paired]-  where-    paired = pairDeclarations nominalScalarName (specNominalScalars (deOld env)) (specNominalScalars (deNew env))-    scalarPairDiff oldDeclaration newDeclaration =-      [ nominalDeclarationChange-          (nominalScalarName newDeclaration)-          NominalRepresentationChanged-          ( "nominal scalar representation changed '"-              <> nominalScalarRepresentation oldDeclaration-              <> "' -> '"-              <> nominalScalarRepresentation newDeclaration-              <> "'"-          )-      | nominalScalarRepresentation oldDeclaration /= nominalScalarRepresentation newDeclaration-      ]-        <> nominalBindingDeclDiff-          (deOld env)-          "scalar"-          (nominalScalarName newDeclaration)-          (Just (nominalScalarBinding oldDeclaration))-          (Just (nominalScalarBinding newDeclaration))--data NominalUse-  = NominalCommandUse !Name !Name !Name-  | NominalEventUse !Name !Name !Name-  | NominalRegisterUse !Name !Name--nominalUses :: Spec -> Name -> [NominalUse]-nominalUses spec target = concatMap usesInAggregate [aggregate | NAggregate aggregate <- specNodes spec]-  where-    usesInAggregate aggregate =-      [ NominalCommandUse (aggName aggregate) (cmdName command) (aggregateFieldName field)-      | command <- aggCommands aggregate,-        field <- cmdFields command,-        fieldReferences target field-      ]-        <> [ NominalEventUse (aggName aggregate) (evName event) (aggregateFieldName field)-           | event <- aggEvents aggregate,-             field <- eventFields aggregate event,-             fieldReferences target field-           ]-        <> [ NominalRegisterUse (aggName aggregate) (regName register)-           | register <- aggRegs aggregate,-             regType register == TRef target-           ]-    eventFields aggregate event = case evBody event of-      EventFields fields -> fields-      EventFromCommand commandName -> concat [cmdFields command | command <- aggCommands aggregate, cmdName command == commandName]-    fieldReferences targetName field = case aggregateFieldType field of-      Just (TRef typeName) -> typeName == targetName-      Just _ -> False-      Nothing -> pascalName (aggregateFieldName field) == targetName-    pascalName value = case T.uncons value of-      Nothing -> value-      Just (initialChar, rest) -> T.cons (toUpper initialChar) rest--nominalBindingDeclDiff :: Spec -> Text -> Name -> Maybe NominalBindingDecl -> Maybe NominalBindingDecl -> [Change]-nominalBindingDeclDiff oldSpec category name oldBinding newBinding =-  concat-    [ nominalFinding NominalBindingChanged "binding source, symbol, or version changed; rebuild every consumer use and audit persisted event uses because hand-written conversion behavior is opaque"-    | bindingRuntimeFacts oldBinding /= bindingRuntimeFacts newBinding-    ]-    <> concat-      [ nominalFinding NominalFixturesChanged "fixture symbol changed; rerun nominal conformance without claiming runtime wire behavior changed"-      | (nominalFixtures =<< oldBinding) /= (nominalFixtures =<< newBinding)-      ]-    <> concat-      [ nominalFinding NominalCanonicalTypeChanged "canonical nominal identity changed; rebuild consumers and invalidate snapshot caches at register uses"-      | (nominalCanonicalType =<< oldBinding) /= (nominalCanonicalType =<< newBinding)-      ]-    <> concat-      [ nominalFinding NominalInitialChanged "consumer-owned initial value symbol changed; rebuild and invalidate snapshot-bearing register streams"-      | (nominalInitial =<< oldBinding) /= (nominalInitial =<< newBinding)-      ]-  where-    bindingRuntimeFacts declaration =-      ( nominalHaskell =<< declaration,-        nominalBinding =<< declaration,-        nominalBindingVersion =<< declaration-      )-    nominalFinding code detail =-      nominalDeclarationChange name code (category <> " " <> detail)-        : [nominalUseChange use code detail | use <- nominalUses oldSpec name, includeUse code use]-    includeUse NominalFixturesChanged _ = False-    includeUse NominalCanonicalTypeChanged NominalRegisterUse {} = True-    includeUse NominalCanonicalTypeChanged _ = False-    includeUse NominalInitialChanged NominalRegisterUse {} = True-    includeUse NominalInitialChanged _ = False-    includeUse _ NominalCommandUse {} = False-    includeUse _ _ = True--nominalDeclarationChange :: Name -> DiagnosticCode -> Text -> Change-nominalDeclarationChange name code detail =-  mkChange-    (deriveLabel defaultGate vector)-    context-    name-    "nominal-build"-    name-    code-    detail-  where-    context = (consumerBuildContext name [name]) {contextOriginalLabel = LabelAdvisory}-    vector = classifyCompatibility context code--nominalUseChange :: NominalUse -> DiagnosticCode -> Text -> Change-nominalUseChange use code detail =-  mkChange (deriveLabel defaultGate vector) context root facet subject code detail-  where-    (root, facet, subject, kind) = case use of-      NominalCommandUse aggregate command field -> (aggregate, "nominal-command", aggregate <> " command " <> command <> " ." <> field, ContextConsumerBuild)-      NominalEventUse aggregate event field -> (aggregate, "nominal-event", aggregate <> " event " <> event <> " ." <> field, ContextPrivateEvent)-      NominalRegisterUse aggregate register -> (aggregate, "nominal-register", aggregate <> " register " <> register, ContextSnapshot)-    context = ChangeContext root [subject] kind LabelAdvisory-    vector = classifyCompatibility context code--addedEnumDiff :: EnumDecl -> [Change]-addedEnumDiff enumDecl =-  [additive (enumName enumDecl) "enum-constructor" ctor EnumCtorAdded ("new enum constructor with wire spelling '" <> wire <> "'") | (ctor, wire) <- enumCtors enumDecl]--enumAdditionDiff :: Spec -> EnumDecl -> Name -> Text -> [Change]-enumAdditionDiff oldSpec enumDecl ctor wire = case enumUsages oldSpec (enumName enumDecl) of-  [] ->-    [ additive-        (enumName enumDecl)-        "enum-constructor"-        ctor-        EnumCtorAdded-        ("new constructor with wire spelling '" <> wire <> "'")-    ]-  usages -> map finding usages-  where-    finding usage-      | ".reg." `T.isInfixOf` usage =-          advisoryAt-            (snapshotContext (enumName enumDecl) [usage])-            (enumName enumDecl)-            "enum-constructor"-            ctor-            EnumCtorAdded-            ("new constructor with wire spelling '" <> wire <> "' is used by " <> usage <> "; invalidate or rebuild snapshots before values using the new arm hydrate")-      | otherwise =-          advisoryAt-            (privateEventAdditionContext (enumName enumDecl) [usage])-            (enumName enumDecl)-            "enum-constructor"-            ctor-            EnumCtorAdded-            ("new constructor with wire spelling '" <> wire <> "' is used by " <> usage <> "; deploy consumers before producers emit the new arm")--removedEnumDiff :: Spec -> EnumDecl -> [Change]-removedEnumDiff oldSpec enumDecl =-  [ breaking (enumName enumDecl) "enum-constructor" ctor EnumCtorRemoved ("enum removed; stored wire value '" <> wire <> "' no longer decodes" <> enumUsageSuffix oldSpec (enumName enumDecl))-  | (ctor, wire) <- enumCtors enumDecl-  ]--enumUsageSuffix :: Spec -> Name -> Text-enumUsageSuffix spec enumType = case enumUsages spec enumType of-  [] -> ""-  usages -> "; used by " <> commas usages--enumUsages :: Spec -> Name -> [Text]-enumUsages spec enumType =-  [aggName agg <> ".reg." <> regName reg | agg <- aggregates, reg <- aggRegs agg, regType reg == TRef enumType]-    ++ [ aggName agg <> ".event." <> evName event <> "." <> eventFieldDslName field-       | agg <- aggregates,-         event <- aggEvents agg,-         field <- eventFieldSigs agg event,-         Just fieldTypeName <- [eventFieldType field],-         fieldTypeName == TRef enumType-       ]-  where-    aggregates = [agg | NAggregate agg <- specNodes spec]--pairDeclarations :: (n -> Name) -> [n] -> [n] -> Paired n-pairDeclarations nameOf oldNodes newNodes =-  Paired-    { prMatched =-        [ (oldNode, newNode)-        | newNode <- newNodes,-          Just oldNode <- [find ((== nameOf newNode) . nameOf) oldNodes]-        ],-      prAdded = [newNode | newNode <- newNodes, isNothing (find ((== nameOf newNode) . nameOf) oldNodes)],-      prRemoved = [oldNode | oldNode <- oldNodes, isNothing (find ((== nameOf oldNode) . nameOf) newNodes)]-    }--contractDiff :: DiffEnv -> [Change]-contractDiff env =-  concatMap (uncurry contractPairDiff) (prMatched paired)-    ++ concatMap addedContractDiff (prAdded paired)-    ++ concatMap removedContractDiff (prRemoved paired)-  where-    paired = pairByName nodeContract ctrName env--contractPairDiff :: ContractNode -> ContractNode -> [Change]-contractPairDiff oldContract newContract =-  schemaChanges-    ++ discriminatorChanges-    ++ topicChanges-    ++ concatMap eventPairChanges matchedEvents-    ++ concatMap addedEventChanges addedEvents-    ++ concatMap removedEventChanges removedEvents'-  where-    schemaChanges =-      [ breaking-          (ctrName newContract)-          "schema-version"-          (ctrName newContract)-          ContractSchemaVersionDecreased-          ("schemaVersion decreased from " <> tInt (ctrSchemaVersion oldContract) <> " to " <> tInt (ctrSchemaVersion newContract))-      | ctrSchemaVersion newContract < ctrSchemaVersion oldContract-      ]-    discriminatorChanges =-      [ breaking-          (ctrName newContract)-          "discriminator"-          (ctrName newContract)-          ContractDiscriminatorChanged-          ("discriminator changed " <> ctrDiscriminator oldContract <> " -> " <> ctrDiscriminator newContract)-      | ctrDiscriminator oldContract /= ctrDiscriminator newContract-      ]-    topicChanges = contractTopicDiff oldContract newContract-    eventPairs = pairDeclarations ceName (ctrEvents oldContract) (ctrEvents newContract)-    matchedEvents = prMatched eventPairs-    addedEvents = prAdded eventPairs-    removedEvents' = prRemoved eventPairs-    eventPairChanges (oldEvent, newEvent) = contractEventDiff oldContract newContract oldEvent newEvent-    addedEventChanges event =-      [additive (ctrName newContract) "contract-event" (ceName event) ContractEventAdded "new contract event"]-    removedEventChanges event =-      [breaking (ctrName newContract) "contract-event" (ceName event) ContractEventRemoved "contract event removed; existing cross-service payloads no longer have a declared decoder"]--addedContractDiff :: ContractNode -> [Change]-addedContractDiff contract =-  [additive (ctrName contract) "contract-event" (ceName event) ContractEventAdded "new event in a new contract" | event <- ctrEvents contract]--removedContractDiff :: ContractNode -> [Change]-removedContractDiff contract =-  [breaking (ctrName contract) "contract-event" (ceName event) ContractEventRemoved "contract removed; its cross-service event decoder is no longer declared" | event <- ctrEvents contract]--contractTopicDiff :: ContractNode -> ContractNode -> [Change]-contractTopicDiff oldContract newContract =-  [ breaking-      (ctrName newContract)-      "contract-topic"-      alias-      ContractTopicChanged-      ("topic alias removed; previous topic was '" <> oldTopic <> "'")-  | (alias, oldTopic) <- ctrTopics oldContract,-    isNothing (lookup alias (ctrTopics newContract))-  ]-    ++ [ breaking-           (ctrName newContract)-           "contract-topic"-           alias-           ContractTopicChanged-           ("real topic changed '" <> oldTopic <> "' -> '" <> newTopic <> "'")-       | (alias, oldTopic) <- ctrTopics oldContract,-         Just newTopic <- [lookup alias (ctrTopics newContract)],-         oldTopic /= newTopic-       ]-    ++ [ additive (ctrName newContract) "contract-topic" alias ContractTopicAdded ("new topic alias for '" <> topic <> "'")-       | (alias, topic) <- ctrTopics newContract,-         isNothing (lookup alias (ctrTopics oldContract))-       ]--contractEventDiff :: ContractNode -> ContractNode -> ContractEvent -> ContractEvent -> [Change]-contractEventDiff oldContract newContract oldEvent newEvent =-  topicAliasChange-    ++ removedFieldChanges-    ++ changedFieldChanges-    ++ selectorFieldChanges-    ++ wireKeyFieldChanges-    ++ addedFieldChanges-  where-    fieldPairs = pairDeclarations cfName (ceFields oldEvent) (ceFields newEvent)-    topicAliasChange =-      [ breaking-          (ctrName newContract)-          "contract-topic"-          (ceName newEvent)-          ContractTopicChanged-          ("event topic alias changed " <> ceTopic oldEvent <> " -> " <> ceTopic newEvent)-      | ceTopic oldEvent /= ceTopic newEvent-      ]-    removedFieldChanges =-      [ breaking (ctrName newContract) "contract-field" (ceName newEvent <> "." <> cfName field) ContractFieldChanged "field removed; existing messages still carry the old contract shape"-      | field <- prRemoved fieldPairs-      ]-    changedFieldChanges =-      [ breaking-          (ctrName newContract)-          "contract-field"-          (ceName newEvent <> "." <> cfName newField)-          ContractFieldChanged-          ("field type changed " <> renderContractType (cfType oldField) <> " -> " <> renderContractType (cfType newField))-      | (oldField, newField) <- prMatched fieldPairs,-        cfType oldField /= cfType newField-      ]-    selectorFieldChanges =-      [ fieldSelectorChange-          (ctrName newContract)-          "contract-field-selector"-          (ceName newEvent <> "." <> cfName newField)-          (fieldSelector (resolveContractFieldIdentity oldField))-          (fieldSelector (resolveContractFieldIdentity newField))-          "contract field selector"-      | (oldField, newField) <- prMatched fieldPairs,-        fieldSelector (resolveContractFieldIdentity oldField)-          /= fieldSelector (resolveContractFieldIdentity newField)-      ]-    wireKeyFieldChanges =-      [ breaking-          (ctrName newContract)-          "contract-field"-          (ceName newEvent <> "." <> cfName newField)-          ContractFieldChanged-          ( "wire key changed '"-              <> fieldWireKey (resolveContractFieldIdentity oldField)-              <> "' -> '"-              <> fieldWireKey (resolveContractFieldIdentity newField)-              <> "'; restore the old key or revise the public contract with a consumer-first rollout"-          )-      | (oldField, newField) <- prMatched fieldPairs,-        fieldWireKey (resolveContractFieldIdentity oldField)-          /= fieldWireKey (resolveContractFieldIdentity newField)-      ]-    addedFieldChanges =-      [ if ctrSchemaVersion newContract > ctrSchemaVersion oldContract-          then advisory (ctrName newContract) "contract-field" subject ContractSchemaVersionBumped ("field added with schemaVersion bump " <> tInt (ctrSchemaVersion oldContract) <> " -> " <> tInt (ctrSchemaVersion newContract) <> "; coordinate the cross-service rollout")-          else breaking (ctrName newContract) "contract-field" subject ContractFieldChanged "field added without a schemaVersion bump; older in-flight messages do not contain it"-      | field <- prAdded fieldPairs,-        let subject = ceName newEvent <> "." <> cfName field-      ]--renderContractType :: ContractType -> Text-renderContractType (CTypeId prefix) = "typeid '" <> prefix <> "'"-renderContractType CText = "text"-renderContractType CInt = "int"--workqueueDiff :: DiffEnv -> [Change]-workqueueDiff env =-  concatMap (uncurry workqueuePairDiff) (prMatched paired)-    ++ concatMap addedWorkqueueDiff (prAdded paired)-    ++ concatMap removedWorkqueueDiff (prRemoved paired)-  where-    paired = pairWorkqueues env---- | Prefer source identity, then pair a uniquely renamed queue by its complete--- explicit runtime identity. This permits a generated module-segment rename to--- remain a build-only finding without guessing when an external identity is--- ambiguous.-pairWorkqueues :: DiffEnv -> Paired WorkqueueNode-pairWorkqueues env =-  Paired-    { prMatched = exact <> fallback,-      prAdded = [queue | queue <- unmatchedNew, queue `notElem` map snd fallback],-      prRemoved = [queue | queue <- unmatchedOld, queue `notElem` map fst fallback]-    }-  where-    oldQueues = mapMaybe nodeWorkqueue (specNodes (deOld env))-    newQueues = mapMaybe nodeWorkqueue (specNodes (deNew env))-    exact =-      [ (oldQueue, newQueue)-      | newQueue <- newQueues,-        Just oldQueue <- [find ((== wqName newQueue) . wqName) oldQueues]-      ]-    exactOldNames = map (wqName . fst) exact-    exactNewNames = map (wqName . snd) exact-    unmatchedOld = [queue | queue <- oldQueues, wqName queue `notElem` exactOldNames]-    unmatchedNew = [queue | queue <- newQueues, wqName queue `notElem` exactNewNames]-    fallback =-      [ (oldQueue, newQueue)-      | newQueue <- unmatchedNew,-        let matchingOld = [queue | queue <- unmatchedOld, queueIdentity queue == queueIdentity newQueue],-        [oldQueue] <- [matchingOld],-        length [queue | queue <- unmatchedNew, queueIdentity queue == queueIdentity newQueue] == 1-      ]--workqueuePairDiff :: WorkqueueNode -> WorkqueueNode -> [Change]-workqueuePairDiff oldQueue newQueue =-  generatedNameChanges-    ++ concatMap pairedFieldDiff (prMatched fields)-    ++ concatMap addedFieldDiff (prAdded fields)-    ++ concatMap removedFieldDiff (prRemoved fields)-    ++ queueIdentityDiff oldQueue newQueue-    ++ queuePolicyDiff oldQueue newQueue-  where-    generatedNameChanges =-      [ generatedNameChange-          (wqName newQueue)-          "workqueue-module"-          (wqName newQueue)-          (wqName oldQueue)-          (wqName newQueue)-          "workqueue module segment"-      | wqName oldQueue /= wqName newQueue,-        normalizedGeneratedUpper (wqName oldQueue) /= normalizedGeneratedUpper (wqName newQueue)-      ]-        ++ [ generatedNameChange-               (wqName newQueue)-               "workqueue-payload-type"-               (wqPayloadName newQueue)-               (wqPayloadName oldQueue)-               (wqPayloadName newQueue)-               "workqueue payload type"-           | wqPayloadName oldQueue /= wqPayloadName newQueue,-             normalizedGeneratedUpper (wqPayloadName oldQueue) /= normalizedGeneratedUpper (wqPayloadName newQueue)-           ]-    fields = pairDeclarations wqfName (wqPayload oldQueue) (wqPayload newQueue)-    pairedFieldDiff (oldField, newField)-      | wqfWire oldField /= wqfWire newField = [payloadBreaking newField ("wire name changed '" <> wqfWire oldField <> "' -> '" <> wqfWire newField <> "'")]-      | wqfType oldField /= wqfType newField = [payloadBreaking newField ("type changed " <> 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 =-      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 =-  [additive (wqName queue) "payload-field" (wqfName field) DeclarationAdded "field belongs to a new workqueue payload" | field <- wqPayload queue]--removedWorkqueueDiff :: WorkqueueNode -> [Change]-removedWorkqueueDiff queue =-  [breaking (wqName queue) "payload-field" (wqfName field) WqPayloadFieldChanged "workqueue removed while persisted jobs may still carry this payload" | field <- wqPayload queue]-    ++ [breaking (wqName queue) "queue-identity" (wqName queue) QueueIdentityChanged "workqueue removed; its physical queue, DLQ, and pgmq table may still hold state"]--queueIdentityDiff :: WorkqueueNode -> WorkqueueNode -> [Change]-queueIdentityDiff oldQueue newQueue =-  [ breaking-      (wqName newQueue)-      "queue-identity"-      (wqName newQueue)-      QueueIdentityChanged-      "logical, physical, DLQ, or table name changed; queued jobs and dispatch dedupe records remain under the old identity"-  | queueIdentity oldQueue /= queueIdentity newQueue-  ]--queueIdentity :: WorkqueueNode -> (Text, Text, Text, Text)-queueIdentity queue = (wqLogical queue, wqPhysical queue, wqDlq queue, wqTable queue)--generatedNameChange :: Name -> Text -> Text -> Text -> Text -> Text -> Change-generatedNameChange node facet subject oldLogical newLogical occurrenceKind =-  advisory-    node-    facet-    subject-    GeneratedHaskellNameChanged-    ( occurrenceKind-        <> " changed '"-        <> normalizedGeneratedUpper oldLogical-        <> "' -> '"-        <> normalizedGeneratedUpper newLogical-        <> "' while wire, SQL, queue, registry, subscription, and persisted runtime identities remain unchanged; re-scaffold and recompile consumers"-    )--fieldSelectorChange :: Name -> Text -> Text -> Text -> Text -> Text -> Change-fieldSelectorChange node facet subject oldSelector newSelector occurrenceKind =-  advisory-    node-    facet-    subject-    GeneratedHaskellNameChanged-    ( occurrenceKind-        <> " changed '"-        <> oldSelector-        <> "' -> '"-        <> newSelector-        <> "' while DSL and wire identities remain unchanged; re-scaffold and recompile consumers"-    )--normalizedGeneratedUpper :: Text -> Text-normalizedGeneratedUpper logicalName =-  case HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site of-    Right derived -> HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)-    Left _ -> logicalName-  where-    site =-      HaskellName.NameSite-        { HaskellName.siteKind = HaskellName.GeneratedTypeSite,-          HaskellName.siteLogicalName = logicalName,-          HaskellName.siteOwner = "diff",-          HaskellName.siteLine = 0-        }--queuePolicyDiff :: WorkqueueNode -> WorkqueueNode -> [Change]-queuePolicyDiff oldQueue newQueue = ordering ++ provision ++ groupKey-  where-    nodeName = wqName newQueue-    ordering =-      [ breaking nodeName "queue-ordering" nodeName WqOrderingChanged $-          "ordering changed " <> renderWqOrdering (wqOrdering oldQueue) <> " -> " <> renderWqOrdering (wqOrdering newQueue) <> "; consumers were written against the old delivery-order contract"-      | wqOrdering oldQueue /= wqOrdering newQueue-      ]-    provision =-      [ breaking nodeName "queue-provision" nodeName WqProvisionChanged $-          "provision changed " <> renderWqProvision (wqProvision oldQueue) <> " -> " <> renderWqProvision (wqProvision newQueue) <> "; provisioning is create-time only, so migrate the existing queue operationally before changing the spec"-      | wqProvision oldQueue /= wqProvision newQueue-      ]-    groupKey =-      [ breaking nodeName "queue-group-key" nodeName WqGroupKeyChanged $-          "group key derivation changed " <> renderWqGroupKey (wqGroupKey oldQueue) <> " -> " <> renderWqGroupKey (wqGroupKey newQueue) <> "; FIFO messages are re-partitioned across durable ordering groups"-      | wqGroupKey oldQueue /= wqGroupKey newQueue-      ]--renderWqOrdering :: WqOrdering -> Text-renderWqOrdering WqUnordered = "unordered"-renderWqOrdering WqFifoThroughput = "fifo-throughput"-renderWqOrdering WqFifoRoundRobin = "fifo-roundrobin"--renderWqProvision :: WqProvision -> Text-renderWqProvision WqStandard = "standard"-renderWqProvision WqUnlogged = "unlogged"-renderWqProvision (WqPartitioned interval duration) = "partitioned(interval=" <> interval <> ", retention=" <> duration <> ")"--renderWqGroupKey :: Maybe WqGroupKey -> Text-renderWqGroupKey Nothing = "none"-renderWqGroupKey (Just groupKey) =-  gkField groupKey-    <> " via "-    <> gkVia groupKey-    <> maybe "" (" fixture " <>) (gkFixture groupKey)--processDiff :: DiffEnv -> [Change]-processDiff env =-  concatMap (uncurry processPairDiff) (prMatched paired)-    ++ concatMap addedProcessDiff (prAdded paired)-    ++ concatMap removedProcessDiff (prRemoved paired)-  where-    paired = pairByName nodeProcess procId env--processPairDiff :: ProcessNode -> ProcessNode -> [Change]-processPairDiff oldProcess newProcess =-  concatMap pairedFieldDiff (prMatched fields)-    ++ map (fieldChange "field added; source events at the old shape cannot populate it") (prAdded fields)-    ++ map (fieldChange "field removed; the generated process input decoder changed") (prRemoved fields)-    ++ processIdentityDiff oldProcess newProcess-    ++ processTimerWindowDiff oldProcess newProcess-    ++ processDecideSurfaceDiff oldProcess newProcess-    ++ processTimerPayloadDiff oldProcess newProcess-  where-    -- inName is a generated Haskell type name; the wire shape is inFields.-    fields = pairDeclarations fieldName (inFields (procInput oldProcess)) (inFields (procInput newProcess))-    pairedFieldDiff (oldField, newField)-      | fieldType oldField /= fieldType newField = [fieldChange ("type changed " <> renderFieldType (fieldType oldField) <> " -> " <> renderFieldType (fieldType newField)) newField]-      | otherwise = []-    fieldChange detail field = breaking (procId newProcess) "input-field" (fieldName field) ProcessInputChanged (detail <> "; version the source event before changing process input")--addedProcessDiff :: ProcessNode -> [Change]-addedProcessDiff process =-  [additive (procId process) "input-field" (fieldName field) DeclarationAdded "field belongs to a new process input" | field <- inFields (procInput process)]--removedProcessDiff :: ProcessNode -> [Change]-removedProcessDiff process =-  [breaking (procId process) "input-field" (fieldName field) ProcessInputChanged "process removed while persisted source events may still require this input decoder" | field <- inFields (procInput process)]-    ++ [breaking (procId process) "derived-identity" (procId process) DerivedIdentityChanged "process removed while persisted saga, dispatch, and timer identities may still exist"]--processIdentityDiff :: ProcessNode -> ProcessNode -> [Change]-processIdentityDiff oldProcess newProcess =-  [ breaking-      (procId newProcess)-      "derived-identity"-      (procId newProcess)-      DerivedIdentityChanged-      "process name, correlation derivation, saga stream category, timer id expression, or fired-event-id expression changed; replays and retries no longer derive the persisted identity"-  | processIdentity oldProcess /= processIdentity newProcess-  ]--processIdentity :: ProcessNode -> (Text, Name, Name, Text, Text, Name, Text, Name)-processIdentity process =-  ( procName process,-    corrField (procCorrelate process),-    corrVia (procCorrelate process),-    sagaCategory (procSaga process),-    idePrefix (tmId (procTimer process)),-    ideField (tmId (procTimer process)),-    idePrefix (fireFiredEventId (tmFire (procTimer process))),-    ideField (fireFiredEventId (tmFire (procTimer process)))-  )--processTimerWindowDiff :: ProcessNode -> ProcessNode -> [Change]-processTimerWindowDiff oldProcess newProcess =-  [ advisory-      (procId newProcess)-      "timer"-      (tmName (procTimer newProcess))-      TimerWindowChanged-      ( "fireAt source/window changed "-          <> renderFireAt (tmFireAt (procTimer oldProcess))-          <> " -> "-          <> renderFireAt (tmFireAt (procTimer newProcess))-          <> "; already-scheduled timers keep their persisted deadline"-      )-  | tmFireAt (procTimer oldProcess) /= tmFireAt (procTimer newProcess)-  ]--processDecideSurfaceDiff :: ProcessNode -> ProcessNode -> [Change]-processDecideSurfaceDiff oldProcess newProcess =-  [ advisory-      (procId newProcess)-      "process-decide"-      (procId newProcess)-      ProcessDecideSurfaceChanged-      "process dispatch surface changed: a source event redelivered across the deploy dispatches under the same deterministic ids, so half-old/half-new fan-out merges silently. Drain or pause the process subscription and replay or discard dead letters before deploying; see docs/user/deploy-ordering.md. Hole-only decide changes are not visible to diff; the same drain rule applies to those too."-  | renderHandleSurface (procHandle oldProcess)-      /= renderHandleSurface (procHandle newProcess)-  ]--processTimerPayloadDiff :: ProcessNode -> ProcessNode -> [Change]-processTimerPayloadDiff oldProcess newProcess =-  [ advisory-      (procId newProcess)-      "timer-payload"-      (tmName (procTimer newProcess))-      ProcessTimerPayloadChanged-      "timer payload shape changed: rows scheduled before the deploy carry the old shape, unversioned, and fire under new code — the fire decoder must accept every historically scheduled shape or the timer dead-letters after maxAttempts. Hole-only timer-decoder changes are not visible to diff; the same drain rule applies to those too."-  | renderTimerPayloadSurface (procTimer oldProcess)-      /= renderTimerPayloadSurface (procTimer newProcess)-  ]--renderFireAt :: FireAtExpr -> Text-renderFireAt expression = "input." <> faField expression <> " + " <> faWindow expression--workflowDiff :: DiffEnv -> [Change]-workflowDiff env =-  concatMap (uncurry workflowPairDiff) (prMatched paired)-    ++ concatMap addedWorkflowDiff (prAdded paired)-    ++ concatMap removedWorkflowDiff (prRemoved paired)-  where-    paired = pairByName nodeWorkflow wfId env--workflowPairDiff :: WorkflowNode -> WorkflowNode -> [Change]-workflowPairDiff oldWorkflow newWorkflow =-  inputChanges-    ++ outputChanges-    ++ classifyWorkflowBody oldWorkflow newWorkflow-    ++ workflowIdentityDiff oldWorkflow newWorkflow-  where-    fields = pairDeclarations fieldName (wfInputFields oldWorkflow) (wfInputFields newWorkflow)-    inputChanges =-      [workflowShape field "input field added; journaled inputs at the old shape do not contain it" | field <- prAdded fields]-        ++ [workflowShape field "input field removed; journaled inputs still contain the old shape" | field <- prRemoved fields]-        ++ [ workflowShape newField ("input field type changed " <> renderFieldType (fieldType oldField) <> " -> " <> renderFieldType (fieldType newField))-           | (oldField, newField) <- prMatched fields,-             fieldType oldField /= fieldType newField-           ]-    outputChanges =-      [ breaking (wfId newWorkflow) "workflow-output" (wfOutput newWorkflow) WorkflowShapeChanged ("output type changed " <> wfOutput oldWorkflow <> " -> " <> wfOutput newWorkflow <> "; persisted outcomes may no longer decode")-      | wfOutput oldWorkflow /= wfOutput newWorkflow-      ]-    workflowShape field detail = breaking (wfId newWorkflow) "workflow-input" (fieldName field) WorkflowShapeChanged detail--addedWorkflowDiff :: WorkflowNode -> [Change]-addedWorkflowDiff workflow = [additive (wfId workflow) "workflow" (wfId workflow) DeclarationAdded "new workflow"]--removedWorkflowDiff :: WorkflowNode -> [Change]-removedWorkflowDiff workflow = [breaking (wfId workflow) "workflow" (wfId workflow) WorkflowShapeChanged "workflow removed while in-flight journals and outcomes may still require its decoder"]--workflowIdentityDiff :: WorkflowNode -> WorkflowNode -> [Change]-workflowIdentityDiff oldWorkflow newWorkflow =-  [ breaking-      (wfId newWorkflow)-      "workflow-name"-      (wfId newWorkflow)-      WorkflowStableNameChanged-      ("stable name changed '" <> wfStable oldWorkflow <> "' -> '" <> wfStable newWorkflow <> "'; in-flight journals remain under the old stream name")-  | wfStable oldWorkflow /= wfStable newWorkflow-  ]-    ++ [ breaking-           (wfId newWorkflow)-           "derived-identity"-           (wfId newWorkflow)-           DerivedIdentityChanged-           "workflow id source field or derivation changed; journal and deterministic child/step identities no longer coalesce with persisted executions"-       | (wfIdField oldWorkflow, wfIdVia oldWorkflow) /= (wfIdField newWorkflow, wfIdVia newWorkflow)-       ]--intakeDiff :: DiffEnv -> [Change]-intakeDiff env =-  concatMap (uncurry intakePairDiff) (prMatched paired)-    ++ concatMap addedIntakeDiff (prAdded paired)-    ++ concatMap removedIntakeDiff (prRemoved paired)-  where-    paired = pairByName nodeIntake inkName env--intakePairDiff :: IntakeNode -> IntakeNode -> [Change]-intakePairDiff oldIntake newIntake =-  [ breaking-      (inkName newIntake)-      "dedupe-identity"-      (inkName newIntake)-      DedupeIdentityChanged-      "dedupe key or policy changed; redelivered messages no longer match their persisted dedupe record"-  | (inkDedupeKey oldIntake, inkDedupePolicy oldIntake) /= (inkDedupeKey newIntake, inkDedupePolicy newIntake)-  ]-    ++ [ advisory-           (inkName newIntake)-           "decode-posture"-           (inkName newIntake)-           DecodePostureChanged-           "envelope/body decode posture changed; future messages are accepted or rejected differently"-       | inkDecode oldIntake /= inkDecode newIntake-       ]-    ++ [ advisory-           (inkName newIntake)-           "inbox-persistence"-           (inkName newIntake)-           IntakePersistenceChanged-           ("success-path envelope persistence changed " <> renderInkPersist (inkPersist oldIntake) <> " -> " <> renderInkPersist (inkPersist newIntake) <> "; existing rows are unchanged while future successful rows retain a different envelope shape")-       | inkPersist oldIntake /= inkPersist newIntake-       ]--renderInkPersist :: InkPersist -> Text-renderInkPersist InkPersistFull = "full-envelope"-renderInkPersist InkPersistDedupeOnly = "dedupe-only"--addedIntakeDiff :: IntakeNode -> [Change]-addedIntakeDiff intake = [additive (inkName intake) "intake" (inkName intake) DeclarationAdded "new intake"]--removedIntakeDiff :: IntakeNode -> [Change]-removedIntakeDiff intake = [breaking (inkName intake) "dedupe-identity" (inkName intake) DedupeIdentityChanged "intake removed while persisted dedupe records and redeliveries may remain"]--emitDiff :: DiffEnv -> [Change]-emitDiff env =-  concatMap (uncurry emitPairDiff) (prMatched paired)-    ++ concatMap addedEmitDiff (prAdded paired)-    ++ concatMap removedEmitDiff (prRemoved paired)-  where-    paired = pairByName nodeEmit emName env--emitPairDiff :: EmitNode -> EmitNode -> [Change]-emitPairDiff oldEmit newEmit =-  [ breaking-      (emName newEmit)-      "derived-identity"-      "messageId"-      DerivedIdentityChanged-      "messageId derive prefix changed; outbox retries no longer coalesce with persisted messages"-  | emMessageId oldEmit /= emMessageId newEmit-  ]-    ++ [ breaking-           (emName newEmit)-           "derived-identity"-           "idempotencyKey"-           DerivedIdentityChanged-           "idempotencyKey derive prefix changed; downstream dedupe no longer matches persisted messages"-       | emIdempotencyKey oldEmit /= emIdempotencyKey newEmit-       ]-    ++ [ advisory-           (emName newEmit)-           "emit-mapping"-           (emName newEmit)-           EmitMappingChanged-           "emit key, status discriminant, mapping rows, or explicit skip posture changed"-       | emitMapping oldEmit /= emitMapping newEmit-       ]--emitMapping :: EmitNode -> (Name, Name, [EmitMapRow], Bool)-emitMapping emit = (emKey emit, emDiscriminant emit, emMap emit, emSkip emit)--addedEmitDiff :: EmitNode -> [Change]-addedEmitDiff emit = [additive (emName emit) "emit" (emName emit) DeclarationAdded "new emit mapping"]--removedEmitDiff :: EmitNode -> [Change]-removedEmitDiff emit = [breaking (emName emit) "derived-identity" (emName emit) DerivedIdentityChanged "emit removed while persisted outbox identities may still retry"]--publisherDiff :: DiffEnv -> [Change]-publisherDiff env =-  concatMap (uncurry publisherPairDiff) (prMatched paired)-    ++ concatMap addedPublisherDiff (prAdded paired)-    ++ concatMap removedPublisherDiff (prRemoved paired)-  where-    paired = pairByName nodePublisher pubName env--publisherPairDiff :: PublisherNode -> PublisherNode -> [Change]-publisherPairDiff oldPublisher newPublisher =-  -- maxAttempts/backoff are retry tuning, not persisted decode or identity.-  [ breaking-      (pubName newPublisher)-      "derived-identity"-      "outboxId"-      DerivedIdentityChanged-      "stable outbox-id source field changed; retries no longer coalesce with persisted outbox rows"-  | pubOutboxField oldPublisher /= pubOutboxField newPublisher-  ]-    ++ [ advisory-           (pubName newPublisher)-           "publisher-policy"-           (pubName newPublisher)-           PublisherPolicyChanged-           ("ordering changed " <> pubOrdering oldPublisher <> " -> " <> pubOrdering newPublisher)-       | pubOrdering oldPublisher /= pubOrdering newPublisher-       ]--addedPublisherDiff :: PublisherNode -> [Change]-addedPublisherDiff publisher = [additive (pubName publisher) "publisher" (pubName publisher) DeclarationAdded "new publisher"]--removedPublisherDiff :: PublisherNode -> [Change]-removedPublisherDiff publisher = [breaking (pubName publisher) "derived-identity" (pubName publisher) DerivedIdentityChanged "publisher removed while persisted outbox rows may still require its stable identity"]--pgmqDispatchDiff :: DiffEnv -> [Change]-pgmqDispatchDiff env =-  concatMap (uncurry pgmqDispatchPairDiff) (prMatched paired)-    ++ concatMap addedPgmqDispatchDiff (prAdded paired)-    ++ concatMap removedPgmqDispatchDiff (prRemoved paired)-  where-    paired = pairByName nodePgmqDispatch pdName env--pgmqDispatchPairDiff :: PgmqDispatchNode -> PgmqDispatchNode -> [Change]-pgmqDispatchPairDiff oldDispatch newDispatch =-  [ breaking-      (pdName newDispatch)-      "dedupe-identity"-      (pdName newDispatch)-      DedupeIdentityChanged-      "dispatch dedupe key/read-model/queue surface changed; prior enqueue records no longer match"-  | dispatchDedupe oldDispatch /= dispatchDedupe newDispatch-  ]-    ++ [ advisory-           (pdName newDispatch)-           "retarget"-           (pdName newDispatch)-           DispatchRetargeted-           "source read model or target queue changed; future fan-out is routed differently"-       | dispatchTargets oldDispatch /= dispatchTargets newDispatch-       ]--dispatchDedupe :: PgmqDispatchNode -> (Name, Name, Text, Name, Text)-dispatchDedupe dispatch =-  ( pdDedupKey dispatch,-    pdDedupReadModel dispatch,-    pdDedupReadModelField dispatch,-    pdDedupQueue dispatch,-    pdDedupQueueField dispatch-  )--dispatchTargets :: PgmqDispatchNode -> (Name, Name)-dispatchTargets dispatch = (pdSourceReadModel dispatch, pdEnqueueTo dispatch)--addedPgmqDispatchDiff :: PgmqDispatchNode -> [Change]-addedPgmqDispatchDiff dispatch = [additive (pdName dispatch) "dispatch" (pdName dispatch) DeclarationAdded "new pgmq dispatch"]--removedPgmqDispatchDiff :: PgmqDispatchNode -> [Change]-removedPgmqDispatchDiff dispatch = [breaking (pdName dispatch) "dedupe-identity" (pdName dispatch) DedupeIdentityChanged "dispatch removed while persisted queue and read-model dedupe records may remain"]---- | Classify the runtime's sanctioned workflow-evolution mechanisms before--- falling back to the conservative unguarded-body rule.-classifyWorkflowBody :: WorkflowNode -> WorkflowNode -> [Change]-classifyWorkflowBody oldWorkflow newWorkflow-  | oldBody == newBody = []-  | not (null removedPatchIds) = map removedPatch removedPatchIds-  | Just (oldSeedType, newSeedType) <- changedSeed =-      [ breaking nodeName "workflow-continue-as-new" nodeName WorkflowContinueSeedChanged $-          "continueAsNew seed type changed " <> oldSeedType <> " -> " <> newSeedType <> "; the next generation's restoreSeed must decode the seed written by the previous generation"-      ]-  | safeAdditions =-      map addedPatch newPatchIds-        ++ [ additive nodeName "workflow-continue-as-new" seedType WorkflowEvolutionGuardAdded "terminal continueAsNew is additive; old generations carry no rotation marker"-           | Just seedType <- [appendedSeed]-           ]-  | otherwise =-      [ breaking-          nodeName-          "workflow-body"-          nodeName-          WorkflowBodyChanged-          "workflow body labels, kinds, result types, or order changed without a new patch guard; wrap a cross-cutting change in patch, or rename the replay label for one changed step"-      ]-  where-    nodeName = wfId newWorkflow-    oldBody = normaliseWorkflowBody (wfBody oldWorkflow)-    newBody = normaliseWorkflowBody (wfBody newWorkflow)-    oldPatchIds = workflowBodyPatchIds oldBody-    newPatchIdsAll = workflowBodyPatchIds newBody-    newPatchIds = newPatchIdsAll \\ oldPatchIds-    removedPatchIds = oldPatchIds \\ newPatchIdsAll-    oldSeed = terminalContinueSeed oldBody-    newSeed = terminalContinueSeed newBody-    changedSeed = case (oldSeed, newSeed) of-      (Just oldSeedType, Just newSeedType)-        | oldSeedType /= newSeedType -> Just (oldSeedType, newSeedType)-      _ -> Nothing-    appendedSeed = case (oldSeed, newSeed) of-      (Nothing, Just seedType) -> Just seedType-      _ -> Nothing-    strippedNewBody = stripNewPatches newPatchIds newBody-    comparableNewBody = case appendedSeed of-      Just _ -> dropTerminalContinue strippedNewBody-      Nothing -> strippedNewBody-    safeAdditions =-      (not (null newPatchIds) || isJust appendedSeed)-        && comparableNewBody == oldBody-    removedPatch patchId =-      breaking nodeName "workflow-patch" patchId WorkflowPatchRemoved "patch id existed in the old spec but was removed; the differ cannot prove that no workflow generation still replays its journaled branch"-    addedPatch patchId =-      additive nodeName "workflow-patch" patchId WorkflowEvolutionGuardAdded "new patch guard contains the entire body change, so in-flight generations retain their journaled branch"--normaliseWorkflowBody :: [WfBodyItem] -> [WfBodyItem]-normaliseWorkflowBody = map go-  where-    go (WfStep label result _) = WfStep label result noLoc-    go (WfAwait label result _) = WfAwait label result noLoc-    go (WfSleep label delay _) = WfSleep label delay noLoc-    go (WfChild label via result _) = WfChild label via result noLoc-    go (WfPatch patchId items _) = WfPatch patchId (normaliseWorkflowBody items) noLoc-    go (WfContinueAsNew seedType _) = WfContinueAsNew seedType noLoc--workflowBodyPatchIds :: [WfBodyItem] -> [Name]-workflowBodyPatchIds = concatMap go-  where-    go (WfPatch patchId items _) = patchId : workflowBodyPatchIds items-    go _ = []--stripNewPatches :: [Name] -> [WfBodyItem] -> [WfBodyItem]-stripNewPatches newPatchIds = concatMap go-  where-    go (WfPatch patchId _ _) | patchId `elem` newPatchIds = []-    go (WfPatch patchId items loc) = [WfPatch patchId (stripNewPatches newPatchIds items) loc]-    go item = [item]--terminalContinueSeed :: [WfBodyItem] -> Maybe Name-terminalContinueSeed items = case reverse items of-  WfContinueAsNew seedType _ : _ -> Just seedType-  _ -> Nothing--dropTerminalContinue :: [WfBodyItem] -> [WfBodyItem]-dropTerminalContinue items = case reverse items of-  WfContinueAsNew {} : rest -> reverse rest-  _ -> items--additive :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change-additive n facet subj code detail =-  mkChange LabelAdditive (contextFor LabelAdditive n facet subj code) n facet subj code detail--breaking :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change-breaking n facet subj code detail =-  mkChange LabelBreaking (contextFor LabelBreaking n facet subj code) n facet subj code detail--advisory :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change-advisory n facet subj code detail =-  mkChange LabelAdvisory (contextFor LabelAdvisory n facet subj code) n facet subj code detail--advisoryAt :: ChangeContext -> Name -> Text -> Text -> DiagnosticCode -> Text -> Change-advisoryAt context n facet subj code detail =-  mkChange LabelAdvisory context n facet subj code detail--mkChange :: Label -> ChangeContext -> Name -> Text -> Text -> DiagnosticCode -> Text -> Change-mkChange label context n facet subj code detail =-  wrap-    ChangeKind-      { ckNode = n,-        ckFacet = facet,-        ckSubject = subj,-        ckCode = code,-        ckContext = context,-        ckVector = classifyCompatibility context code,-        ckMappedPersistedImpact = case contextKind context of-          ContextQueue -> Just (MappedPersistedImpact (WorkqueueHistory (changeContextRoot context)) VBreaking)-          _ -> Nothing,-        ckMappedConsequences = Set.empty,-        ckPaths = changeContextPaths context,-        ckDetail = detail-      }-  where-    wrap = case label of-      LabelAdditive -> Additive-      LabelAdvisory -> Advisory-      LabelBreaking -> Breaking--contextFor :: Label -> Name -> Text -> Text -> DiagnosticCode -> ChangeContext-contextFor label root facet subject code =-  setLabel $ case () of-    _-      | code `elem` publicCodes -> publicContractContext root paths-      | code `elem` queueCodes -> queueContext root paths-      | code `elem` identityCodes -> persistedIdentityContext root paths-      | code `elem` [OwnershipMoved, WorkspaceAuthorityChanged, GeneratedHaskellNameChanged] -> consumerBuildContext root paths-      | code == AggFoldSurfaceChanged -> snapshotContext root paths-      | code == EnumCtorAdded -> ChangeContext root paths ContextGeneral label-      | code `elem` privateCodes -> privateEventContext root paths-      | otherwise -> ChangeContext root paths ContextGeneral label-  where-    paths = [pathFor root facet subject]-    setLabel context = context {contextOriginalLabel = label}+    changeContextRoot,+    changeContextPaths,+    privateEventContext,+    privateEventAdditionContext,+    snapshotContext,+    queueContext,+    publicContractContext,+    persistedIdentityContext,+    consumerBuildContext,+    advisoryAt,+    classifyCompatibility,+    verdictFor,+    defaultGate,+    gateWith,+    deriveLabel,+    gatedBreaking,+    isBreaking,+    isAdvisory,+    diffSources,+    sourceLanguageChange,+    diffServices,+    mappedSemanticImpact,+    mappedSemanticImpactForServices,+    DiffEnv (..),+    NodeFamily (..),+    familyOf,+    FamilyDiff (..),+    familyRegistry,+    Paired (..),+    pairByName,+    readModelDiff,+    classifyWorkflowBody,+  )+where++import Data.Char (toUpper)+import Data.Foldable (traverse_)+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,+    resolveContractFieldIdentity,+  )+import Keiro.Dsl.FoldFingerprint (FoldSurfaceError, aggregateFoldSurfaceForService)+import Keiro.Dsl.Grammar+import Keiro.Dsl.HaskellName qualified as HaskellName+import Keiro.Dsl.IdDomain (IdDomainContract (..), contractIdDomainContractFor, idDomainContractFor)+import Keiro.Dsl.LanguageVersion (ParsedSource (..), SourceLanguage, declaredLanguageVersionMaybe, languageVersionText, sourceFormText)+import Keiro.Dsl.MappedDiff (MappedFinding (..), diffMapped, renderMappedSubject)+import Keiro.Dsl.PrettyPrint+  ( renderHandleSurface,+    renderResolveSurface,+    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, 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.+data Change+  = Additive ChangeKind+  | Advisory ChangeKind+  | Breaking ChangeKind+  deriving stock (Eq, Show)++-- | The stable headline classification retained by the text interface.+data Label = LabelAdditive | LabelAdvisory | LabelBreaking+  deriving stock (Eq, Show)++-- | Independently gateable compatibility questions for one finding.+data CompatibilitySurface+  = PrivateHistoryRead+  | OldBinaryReadNewEvents+  | SnapshotHydration+  | PublicConsumer+  | PersistedIdentity+  | ConsumerBuild+  deriving stock (Eq, Ord, Show, Enum, Bounded)++-- | A verdict on one surface.  Constructor order is deliberately not policy.+data SurfaceVerdict = VCompatible | VAdvisory | VBreaking | VNotApplicable+  deriving stock (Eq, Show)++-- | Deployment ordering that remains after byte compatibility is classified.+data RolloutConstraint+  = RolloutStopTheWorld+  | RolloutWorkersFirst+  | RolloutDrainRequired+  | RolloutProducerLast+  | RolloutProducerFirst+  deriving stock (Eq, Ord, Show)++-- | The explicit, compile-forcing compatibility result for one finding.+data CompatibilityVector = CompatibilityVector+  { privateHistoryRead :: !SurfaceVerdict,+    oldBinaryReadNewEvents :: !SurfaceVerdict,+    snapshotHydration :: !SurfaceVerdict,+    publicConsumer :: !SurfaceVerdict,+    persistedIdentity :: !SurfaceVerdict,+    consumerBuild :: !SurfaceVerdict,+    rollout :: !(Set RolloutConstraint)+  }+  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+  { surface :: !MappedPersistedSurface,+    verdict :: !SurfaceVerdict+  }+  deriving stock (Eq, Show)++data ContextKind+  = ContextGeneral+  | ContextPrivateEvent+  | ContextPrivateEventAddition+  | ContextSnapshot+  | ContextQueue+  | ContextPublicContract+  | ContextPersistedIdentity+  | ContextConsumerBuild+  deriving stock (Eq, Show)++-- | Facts that select a compatibility row.  The constructor stays private so+-- callers cannot manufacture contradictory ownership and surface claims.+data ChangeContext = ChangeContext+  { root :: !Name,+    paths :: ![Text],+    contextKind :: !ContextKind,+    contextOriginalLabel :: !Label+  }+  deriving stock (Eq, Show)++changeContextRoot :: ChangeContext -> Name+changeContextRoot = (.root)++changeContextPaths :: ChangeContext -> [Text]+changeContextPaths = (.paths)++data ChangeKind = ChangeKind+  { node :: !Name,+    facet :: !Text,+    subject :: !Text,+    code :: !DiagnosticCode,+    context :: !ChangeContext,+    vector :: !CompatibilityVector,+    mappedPersistedImpact :: !(Maybe MappedPersistedImpact),+    mappedConsequences :: !(Set MappedConsequence),+    paths :: ![Text],+    detail :: !Text+  }+  deriving stock (Eq, Show)++privateEventContext :: Name -> [Text] -> ChangeContext+privateEventContext root paths = ChangeContext root paths ContextPrivateEvent LabelBreaking++privateEventAdditionContext :: Name -> [Text] -> ChangeContext+privateEventAdditionContext root paths = ChangeContext root paths ContextPrivateEventAddition LabelAdvisory++snapshotContext :: Name -> [Text] -> ChangeContext+snapshotContext root paths = ChangeContext root paths ContextSnapshot LabelAdvisory++queueContext :: Name -> [Text] -> ChangeContext+queueContext root paths = ChangeContext root paths ContextQueue LabelBreaking++publicContractContext :: Name -> [Text] -> ChangeContext+publicContractContext root paths = ChangeContext root paths ContextPublicContract LabelBreaking++persistedIdentityContext :: Name -> [Text] -> ChangeContext+persistedIdentityContext root paths = ChangeContext root paths ContextPersistedIdentity LabelBreaking++consumerBuildContext :: Name -> [Text] -> ChangeContext+consumerBuildContext root paths = ChangeContext root paths ContextConsumerBuild LabelAdvisory++compatibleVector :: CompatibilityVector+compatibleVector =+  CompatibilityVector+    VCompatible+    VCompatible+    VNotApplicable+    VNotApplicable+    VNotApplicable+    VNotApplicable+    Set.empty++sourceProvenanceVector :: CompatibilityVector+sourceProvenanceVector =+  CompatibilityVector+    VCompatible+    VCompatible+    VCompatible+    VCompatible+    VCompatible+    VCompatible+    Set.empty++privateDecodeBreakingVector :: CompatibilityVector+privateDecodeBreakingVector =+  CompatibilityVector+    VBreaking+    VBreaking+    VAdvisory+    VNotApplicable+    VNotApplicable+    VNotApplicable+    (Set.singleton RolloutStopTheWorld)++persistedIdentityBreakingVector :: CompatibilityVector+persistedIdentityBreakingVector =+  CompatibilityVector+    VNotApplicable+    VNotApplicable+    VNotApplicable+    VNotApplicable+    VBreaking+    VNotApplicable+    Set.empty++publicBreakingVector :: CompatibilityVector+publicBreakingVector =+  CompatibilityVector+    VNotApplicable+    VNotApplicable+    VNotApplicable+    VBreaking+    VNotApplicable+    VNotApplicable+    (Set.singleton RolloutProducerLast)++queueBreakingVector :: CompatibilityVector+queueBreakingVector =+  CompatibilityVector+    VNotApplicable+    VNotApplicable+    VNotApplicable+    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 =+  CompatibilityVector+    { privateHistoryRead = verdict PrivateHistoryRead,+      oldBinaryReadNewEvents = verdict OldBinaryReadNewEvents,+      snapshotHydration = verdict SnapshotHydration,+      publicConsumer = verdict PublicConsumer,+      persistedIdentity = verdict PersistedIdentity,+      consumerBuild = verdict ConsumerBuild,+      rollout+    }+  where+    verdict candidate+      | candidate == surface = VAdvisory+      | otherwise = verdictFor candidate compatibleVector++replaceConsumerBuild :: SurfaceVerdict -> CompatibilityVector -> CompatibilityVector+replaceConsumerBuild consumerBuild vector =+  CompatibilityVector+    vector.privateHistoryRead+    vector.oldBinaryReadNewEvents+    vector.snapshotHydration+    vector.publicConsumer+    vector.persistedIdentity+    consumerBuild+    vector.rollout++replaceSnapshotHydration :: SurfaceVerdict -> CompatibilityVector -> CompatibilityVector+replaceSnapshotHydration snapshotHydration vector =+  CompatibilityVector+    vector.privateHistoryRead+    vector.oldBinaryReadNewEvents+    snapshotHydration+    vector.publicConsumer+    vector.persistedIdentity+    vector.consumerBuild+    vector.rollout++replaceRollout :: Set RolloutConstraint -> CompatibilityVector -> CompatibilityVector+replaceRollout rollout vector =+  CompatibilityVector+    vector.privateHistoryRead+    vector.oldBinaryReadNewEvents+    vector.snapshotHydration+    vector.publicConsumer+    vector.persistedIdentity+    vector.consumerBuild+    rollout++replaceOldBinaryAndRollout :: SurfaceVerdict -> Set RolloutConstraint -> CompatibilityVector -> CompatibilityVector+replaceOldBinaryAndRollout oldBinaryReadNewEvents rollout vector =+  CompatibilityVector+    vector.privateHistoryRead+    oldBinaryReadNewEvents+    vector.snapshotHydration+    vector.publicConsumer+    vector.persistedIdentity+    vector.consumerBuild+    rollout++-- | Classify one code at an explicitly owned use site.  Codes emitted by the+-- differ are grouped by their actual persisted/public surface; the context is+-- load-bearing for codes such as 'EnumCtorAdded' that vary by use site.+classifyCompatibility :: ChangeContext -> DiagnosticCode -> CompatibilityVector+classifyCompatibility context code+  | code == SourceLanguageDeclarationChanged = sourceProvenanceVector+  | code == GeneratedHaskellNameChanged = replaceConsumerBuild VAdvisory sourceProvenanceVector+  | code `elem` [OwnershipMoved, WorkspaceAuthorityChanged] = mappedBuildVector+  | code `elem` [ReadModelQueryInputChanged, ReadModelQueryResultChanged] =+      replaceConsumerBuild VBreaking compatibleVector+  | code == MappedFieldAddedWithDefault = mappedFieldAdditionVector context+  | code `elem` [MappedArmAdded, MappedEnumValueAdded] = mappedDirectionalAdditionVector context+  | code `elem` mappedWireBreakingCodes = mappedWireBreakingVector context+  | code `elem` [MappedHaskellSourceChanged, MappedRecordConstructorChanged, MappedFixturesChanged] = mappedBuildVector+  | code == MappedBindingChanged = mappedBindingVector context+  | code `elem` [MappedInitialChanged, MappedCanonicalTypeChanged] = mappedSnapshotBuildVector context+  | code == NominalFixturesChanged = mappedBuildVector+  | code == NominalBindingChanged = mappedBindingVector context+  | code `elem` [NominalInitialChanged, NominalCanonicalTypeChanged] = mappedSnapshotBuildVector context+  | code == NominalRepresentationChanged = mappedWireBreakingVector context+  | code == NominalIdDecoderTightened =+      replaceConsumerBuild VAdvisory (advisoryVector PrivateHistoryRead Set.empty)+  | code == ContractTypeIdDomainChanged = contractTypeIdDomainVector+  | code == IdDomainContractChanged = idDomainContractVector+  | code == MappedDeclAdded = compatibleVector+  | code `elem` privateDecodeCodes = privateDecodeBreakingVector+  | code `elem` identityCodes = persistedIdentityBreakingVector+  | 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 =+      replaceConsumerBuild VAdvisory (advisoryVector PrivateHistoryRead Set.empty)+  | code == ContractSchemaVersionBumped = advisoryVector PublicConsumer (Set.singleton RolloutProducerLast)+  | code == AggFoldSurfaceChanged =+      replaceSnapshotHydration VAdvisory (advisoryVector PrivateHistoryRead Set.empty)+  | code == AggGuardTightened = advisoryVector PrivateHistoryRead Set.empty+  | code `elem` [RouterDecideSurfaceChanged, ProcessDecideSurfaceChanged] =+      replaceRollout (Set.singleton RolloutDrainRequired) compatibleVector+  | code == ProcessTimerPayloadChanged = advisoryVector PrivateHistoryRead (Set.singleton RolloutProducerLast)+  | code == TimerWindowChanged = advisoryVector PrivateHistoryRead Set.empty+  | code == ProjectionChanged = advisoryVector PersistedIdentity Set.empty+  | code == EmitMappingChanged = advisoryVector PublicConsumer (Set.singleton RolloutProducerLast)+  | code == DecodePostureChanged = advisoryVector PublicConsumer Set.empty+  | code == IntakePersistenceChanged = advisoryVector PrivateHistoryRead Set.empty+  | code `elem` [PublisherPolicyChanged, DispatchRetargeted] = advisoryVector PersistedIdentity Set.empty+  | code `elem` [DeprecatedEventReplayHazard, EventRetirementInProgress] = advisoryVector PrivateHistoryRead Set.empty+  | code == EventUndeprecated = advisoryVector OldBinaryReadNewEvents (Set.singleton RolloutProducerLast)+  | code == EnumCtorAdded = case (.contextKind) context of+      ContextPrivateEventAddition ->+        replaceOldBinaryAndRollout VBreaking (Set.singleton RolloutProducerLast) compatibleVector+      ContextSnapshot -> advisoryVector SnapshotHydration Set.empty+      _ -> compatibleVector+  | code `elem` additiveCodes = compatibleVector+  | otherwise = case (.contextOriginalLabel) context of+      LabelAdditive -> compatibleVector+      LabelAdvisory -> advisoryVector (surfaceForContext context) Set.empty+      LabelBreaking -> breakingVectorForContext context+  where+    privateDecodeCodes =+      [ EvtFieldAddedWithoutBump,+        EvtFieldRemovedSameVersion,+        EvtFieldWireKeyChanged,+        EvtFieldTypeChanged,+        EvtVersionDecreased,+        EvtVersionMissingUpcaster,+        UpcasterChainGap,+        EvtRemovedNotDeprecated,+        EnumCtorRemoved,+        EnumWireSpellingChanged,+        WireSpecChanged,+        ProcessInputChanged,+        WorkflowShapeChanged,+        WorkflowBodyChanged,+        WorkflowPatchRemoved,+        WorkflowContinueSeedChanged+      ]++    identityCodes =+      [ DerivedIdentityChanged,+        IdPrefixChanged,+        DedupeIdentityChanged,+        QueueIdentityChanged,+        RouterStableNameChanged,+        WorkflowStableNameChanged+      ]+    publicBreakingCodes =+      [ ContractEventRemoved,+        ContractFieldChanged,+        ContractDiscriminatorChanged,+        ContractTopicChanged,+        ContractSchemaVersionDecreased+      ]+    queueBreakingCodes = [WqPayloadFieldChanged, WqOrderingChanged, WqProvisionChanged, WqGroupKeyChanged]+    readModelBreakingCodes =+      [ ReadModelVersionDecreased,+        ReadModelShapeChangedWithoutBump,+        ReadModelFeedChanged,+        ReadModelConsistencyWeakened+      ]+    catalogIdentityCodes =+      [ CatalogTargetRemoved,+        CatalogTargetLocationChanged,+        CatalogTargetDependencyChanged,+        CatalogGroupChanged,+        CatalogOwnerRemoved,+        CatalogFeedIdentityChanged,+        CatalogQueryBindingChanged,+        ProjectionDeliveryChanged,+        QueryFreshnessChanged+      ]+    catalogReplayCodes = [CatalogSourceChanged, CatalogReplayPolicyChanged]+    additiveCodes =+      [ DeclarationAdded,+        VersionBumped,+        CompatibilityStrengthened,+        EventRetirementAbandoned,+        ContractEventAdded,+        ContractTopicAdded,+        WorkflowEvolutionGuardAdded+      ]++idDomainContractVector :: CompatibilityVector+idDomainContractVector =+  CompatibilityVector+    { privateHistoryRead = VCompatible,+      oldBinaryReadNewEvents = VCompatible,+      snapshotHydration = VAdvisory,+      publicConsumer = VBreaking,+      persistedIdentity = VCompatible,+      consumerBuild = VAdvisory,+      rollout = Set.singleton RolloutProducerLast+    }++contractTypeIdDomainVector :: CompatibilityVector+contractTypeIdDomainVector =+  CompatibilityVector+    { privateHistoryRead = VNotApplicable,+      oldBinaryReadNewEvents = VNotApplicable,+      snapshotHydration = VNotApplicable,+      publicConsumer = VBreaking,+      persistedIdentity = VNotApplicable,+      consumerBuild = VBreaking,+      rollout = Set.fromList [RolloutDrainRequired, RolloutProducerFirst]+    }++mappedWireBreakingCodes :: [DiagnosticCode]+mappedWireBreakingCodes =+  [ MappedFieldAddedNoDefault,+    MappedFieldRemoved,+    MappedFieldTypeChanged,+    MappedPresenceChanged,+    MappedNullabilityChanged,+    MappedDefaultRemoved,+    MappedDefaultChanged,+    MappedWireKeyChanged,+    MappedUnionEncodingChanged,+    MappedArmRemoved,+    MappedArmTagChanged,+    MappedEnumValueRemoved,+    MappedEnumSpellingChanged,+    MappedOpaqueCodecChanged,+    MappedModeCrossed,+    MappedDeclRemoved+  ]++mappedFieldAdditionVector :: ChangeContext -> CompatibilityVector+mappedFieldAdditionVector context = case (.contextKind) context of+  ContextPrivateEvent ->+    replaceOldBinaryAndRollout oldBinaryVerdict rollout compatibleVector+    where+      rejectsUnknown = (.contextOriginalLabel) context == LabelBreaking+      oldBinaryVerdict = if rejectsUnknown then VBreaking else VCompatible+      rollout = if rejectsUnknown then Set.singleton RolloutProducerLast else Set.empty+  ContextSnapshot -> mappedSnapshotVector+  ContextQueue -> queueBreakingVector+  ContextConsumerBuild -> mappedBuildVector+  _ -> compatibleVector++mappedDirectionalAdditionVector :: ChangeContext -> CompatibilityVector+mappedDirectionalAdditionVector context = case (.contextKind) context of+  ContextPrivateEvent ->+    replaceOldBinaryAndRollout VBreaking (Set.singleton RolloutProducerLast) compatibleVector+  ContextSnapshot -> mappedSnapshotVector+  ContextQueue -> queueBreakingVector+  ContextConsumerBuild -> mappedBuildVector+  _ -> compatibleVector++mappedWireBreakingVector :: ChangeContext -> CompatibilityVector+mappedWireBreakingVector context = case (.contextKind) context of+  ContextPrivateEvent ->+    CompatibilityVector+      VBreaking+      VBreaking+      VNotApplicable+      VNotApplicable+      VNotApplicable+      VNotApplicable+      (Set.singleton RolloutStopTheWorld)+  ContextSnapshot -> mappedSnapshotVector+  ContextQueue -> queueBreakingVector+  ContextConsumerBuild -> mappedBuildVector+  _ -> mappedBuildVector++mappedBuildVector :: CompatibilityVector+mappedBuildVector =+  CompatibilityVector+    VCompatible+    VCompatible+    VNotApplicable+    VNotApplicable+    VNotApplicable+    VAdvisory+    Set.empty++mappedSnapshotVector :: CompatibilityVector+mappedSnapshotVector =+  CompatibilityVector+    VCompatible+    VCompatible+    VAdvisory+    VNotApplicable+    VNotApplicable+    VNotApplicable+    Set.empty++mappedBindingVector :: ChangeContext -> CompatibilityVector+mappedBindingVector context = case (.contextKind) context of+  ContextPrivateEvent ->+    CompatibilityVector+      VAdvisory+      VAdvisory+      VNotApplicable+      VNotApplicable+      VNotApplicable+      VAdvisory+      Set.empty+  ContextSnapshot ->+    replaceConsumerBuild VAdvisory mappedSnapshotVector+  ContextQueue -> queueBreakingVector+  _ -> mappedBuildVector++mappedSnapshotBuildVector :: ChangeContext -> CompatibilityVector+mappedSnapshotBuildVector context = case (.contextKind) context of+  ContextSnapshot -> replaceConsumerBuild VAdvisory mappedSnapshotVector+  _ -> mappedBuildVector++surfaceForContext :: ChangeContext -> CompatibilitySurface+surfaceForContext context = case (.contextKind) context of+  ContextPrivateEvent -> PrivateHistoryRead+  ContextPrivateEventAddition -> OldBinaryReadNewEvents+  ContextSnapshot -> SnapshotHydration+  ContextQueue -> PrivateHistoryRead+  ContextPublicContract -> PublicConsumer+  ContextPersistedIdentity -> PersistedIdentity+  ContextConsumerBuild -> ConsumerBuild+  ContextGeneral -> PrivateHistoryRead++breakingVectorForContext :: ChangeContext -> CompatibilityVector+breakingVectorForContext context = case (.contextKind) context of+  ContextPublicContract -> publicBreakingVector+  ContextPersistedIdentity -> persistedIdentityBreakingVector+  ContextQueue -> queueBreakingVector+  ContextConsumerBuild -> (advisoryVector ConsumerBuild Set.empty) {consumerBuild = VBreaking}+  _ -> privateDecodeBreakingVector++verdictFor :: CompatibilitySurface -> CompatibilityVector -> SurfaceVerdict+verdictFor surface vector = case surface of+  PrivateHistoryRead -> (.privateHistoryRead) vector+  OldBinaryReadNewEvents -> (.oldBinaryReadNewEvents) vector+  SnapshotHydration -> (.snapshotHydration) vector+  PublicConsumer -> (.publicConsumer) vector+  PersistedIdentity -> (.persistedIdentity) vector+  ConsumerBuild -> (.consumerBuild) vector++defaultGate :: Set CompatibilitySurface+defaultGate = Set.delete OldBinaryReadNewEvents (Set.fromList [minBound .. maxBound])++gateWith :: [CompatibilitySurface] -> Set CompatibilitySurface+gateWith surfaces = defaultGate <> Set.fromList surfaces++deriveLabel :: Set CompatibilitySurface -> CompatibilityVector -> Label+deriveLabel gate vector+  | any ((== VBreaking) . (`verdictFor` vector)) (Set.toList gate) = LabelBreaking+  | any (`elem` [VAdvisory, VBreaking]) verdicts || not (Set.null ((.rollout) vector)) = LabelAdvisory+  | otherwise = LabelAdditive+  where+    verdicts = [verdictFor surface vector | surface <- [minBound .. maxBound]]++gatedBreaking :: Set CompatibilitySurface -> Change -> Bool+gatedBreaking gate change = deriveLabel gate ((.vector) (changeKind change)) == LabelBreaking++changeKind :: Change -> ChangeKind+changeKind (Additive kind) = kind+changeKind (Advisory kind) = kind+changeKind (Breaking kind) = kind++isBreaking :: Change -> Bool+isBreaking (Breaking _) = True+isBreaking (Additive _) = False+isBreaking (Advisory _) = False++isAdvisory :: Change -> Bool+isAdvisory (Advisory _) = True+isAdvisory (Additive _) = False+isAdvisory (Breaking _) = False++-- | Both specs supplied to a node-family differ, always old then new.+data DiffEnv = DiffEnv+  { old :: !Spec,+    new :: !Spec+  }+  deriving stock (Eq, Show)++-- | The closed set of node families currently present in 'Node'.+data NodeFamily+  = FamAggregate+  | FamProcess+  | FamRouter+  | FamContract+  | FamIntake+  | FamEmit+  | FamPublisher+  | FamWorkqueue+  | FamPgmqDispatch+  | FamReadModel+  | FamProjectionTarget+  | FamRebuildGroup+  | FamProjectionRevision+  | FamExternalRead+  | FamProjectionOwner+  | FamWorkflow+  | FamOperation+  deriving stock (Eq, Ord, Show, Enum, Bounded)++-- | Total by construction: one explicit arm per 'Node' constructor.+familyOf :: Node -> NodeFamily+familyOf (NAggregate _) = FamAggregate+familyOf (NProcess _) = FamProcess+familyOf (NRouter _) = FamRouter+familyOf (NContract _) = FamContract+familyOf (NIntake _) = FamIntake+familyOf (NEmit _) = FamEmit+familyOf (NPublisher _) = FamPublisher+familyOf (NWorkqueue _) = FamWorkqueue+familyOf (NPgmqDispatch _) = FamPgmqDispatch+familyOf (NReadModel _) = FamReadModel+familyOf (NProjectionTarget _) = FamProjectionTarget+familyOf (NRebuildGroup _) = FamRebuildGroup+familyOf (NProjectionRevision _) = FamProjectionRevision+familyOf (NExternalRead _) = FamExternalRead+familyOf (NProjectionOwner _) = FamProjectionOwner+familyOf (NWorkflow _) = FamWorkflow+familyOf (NOperation _) = FamOperation++-- | A family either has a differ or an explicit reason it is not compared.+data FamilyDiff+  = DiffFamily (DiffEnv -> [Change])+  | OutOfDiffScope Text++-- | Pair the old and new declarations of one node family by stable name.+data Paired n = Paired+  { matched :: ![(n, n)],+    added :: ![n],+    removed :: ![n]+  }+  deriving stock (Eq, Show)++pairByName :: (Node -> Maybe n) -> (n -> Name) -> DiffEnv -> Paired n+pairByName project nameOf env =+  Paired+    { matched =+        [ (oldNode, newNode)+        | newNode <- newNodes,+          Just oldNode <- [find ((== nameOf newNode) . nameOf) oldNodes]+        ],+      added =+        [ newNode+        | newNode <- newNodes,+          isNothing (find ((== nameOf newNode) . nameOf) oldNodes)+        ],+      removed =+        [ oldNode+        | oldNode <- oldNodes,+          isNothing (find ((== nameOf oldNode) . nameOf) newNodes)+        ]+    }+  where+    oldNodes = mapMaybe project ((.nodes) ((.old) env))+    newNodes = mapMaybe project ((.nodes) ((.new) env))++-- | Registry invariant: every 'Node' constructor maps to a family via the+-- total 'familyOf' case, and every family occurs exactly once here.  The unit+-- suite enforces registry coverage and non-empty out-of-scope rationales.+familyRegistry :: [(NodeFamily, FamilyDiff)]+familyRegistry =+  [ (FamAggregate, DiffFamily aggregateDiff),+    (FamProcess, DiffFamily processDiff),+    (FamRouter, DiffFamily routerDiff),+    (FamContract, DiffFamily contractDiff),+    (FamIntake, DiffFamily intakeDiff),+    (FamEmit, DiffFamily emitDiff),+    (FamPublisher, DiffFamily publisherDiff),+    (FamWorkqueue, DiffFamily workqueueDiff),+    (FamPgmqDispatch, DiffFamily pgmqDispatchDiff),+    (FamReadModel, DiffFamily readModelDiff),+    (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")+  ]++-- | Compare two graphs under their effective semantic contracts. The ordinary+-- graph differ runs first; service-aware admission and fold findings then expose+-- semantic-profile changes that leave the normalized graph itself unchanged.+diffServices :: CheckedService -> CheckedService -> Either FoldSurfaceError [Change]+diffServices oldService newService = do+  traverse_ (aggregateFoldSurfaceForService oldService . snd) oldAggregates+  traverse_ (aggregateFoldSurfaceForService newService . snd) newAggregates+  semanticContractFoldChanges <- fmap concat (traverse semanticContractFoldChange oldAggregates)+  pure (diffCheckedSpecs oldSpec newSpec <> idDomainContractChanges <> contractTypeIdDomainChanges <> semanticContractFoldChanges)+  where+    oldSpec = checkedSpec oldService+    newSpec = checkedSpec newService+    oldAggregates = [((.name) aggregate, aggregate) | NAggregate aggregate <- (.nodes) oldSpec]+    newAggregates = [((.name) aggregate, aggregate) | NAggregate aggregate <- (.nodes) newSpec]+    idDomainContractChanges =+      [ breaking+          ((.name) newDeclaration)+          "id-domain-contract"+          ((.name) newDeclaration)+          IdDomainContractChanged+          ( "ID admission contract changed "+              <> renderIdDomainContract oldContract+              <> " -> "+              <> renderIdDomainContract newContract+              <> "; public construction, command decoding, current JSON codecs, and literals use the new contract; historical event replay retains its legacy decoder; old snapshots miss and rebuild from readable events, while rebuilt state that still contains legacy-invalid text remains intentionally uncacheable until overwritten or explicitly migrated"+          )+      | newDeclaration <- (.ids) newSpec,+        Just oldDeclaration <- [find ((== (.name) newDeclaration) . (.name)) ((.ids) oldSpec)],+        let oldContract = idDomainContractFor (checkedLanguageContract oldService) ((.prefix) oldDeclaration),+        let newContract = idDomainContractFor (checkedLanguageContract newService) ((.prefix) newDeclaration),+        oldContract /= newContract+      ]+    contractTypeIdDomainChanges =+      [ breaking+          ((.name) newContract)+          "contract-typeid-domain"+          ((.name) newEvent <> "." <> (.name) newField)+          ContractTypeIdDomainChanged+          ( renderContractIdDomainChange+              ((.valueType) newField)+              oldContract+              newContract'+          )+      | newContract <- [contract | NContract contract <- (.nodes) newSpec],+        Just oldContractNode <- [find ((== (.name) newContract) . (.name)) [contract | NContract contract <- (.nodes) oldSpec]],+        newEvent <- (.events) newContract,+        Just oldEvent <- [find ((== (.name) newEvent) . (.name)) ((.events) oldContractNode)],+        newField <- (.fields) newEvent,+        Just oldField <- [find ((== (.name) newField) . (.name)) ((.fields) oldEvent)],+        (.valueType) oldField == (.valueType) newField,+        let oldContract = contractFieldIdDomain (checkedLanguageContract oldService) oldField,+        let newContract' = contractFieldIdDomain (checkedLanguageContract newService) newField,+        oldContract /= newContract'+      ]+    semanticContractFoldChange (name, oldAggregate) = case lookup name newAggregates of+      Nothing -> pure []+      Just newAggregate -> do+        oldLegacySurface <- aggregateFoldSurfaceForService (legacyCheckedService oldSpec) oldAggregate+        newLegacySurface <- aggregateFoldSurfaceForService (legacyCheckedService newSpec) newAggregate+        oldSurface <- aggregateFoldSurfaceForService oldService oldAggregate+        newSurface <- aggregateFoldSurfaceForService newService newAggregate+        pure+          [ advisory+              name+              "semantic-contract"+              name+              AggFoldSurfaceChanged+              "effective runtime semantics changed the aggregate fold surface even though the normalized graph is unchanged; re-scaffold, redeploy, and audit replay under the candidate contract"+          | oldLegacySurface == newLegacySurface,+            oldSurface /= newSurface+          ]++renderIdDomainContract :: Maybe IdDomainContract -> Text+renderIdDomainContract Nothing = "legacy-unchecked"+renderIdDomainContract (Just contract) =+  idDomainVersion contract <> "(prefix=" <> idDomainPrefix contract <> ",json=" <> idDomainJsonRepresentation contract <> ")"++contractFieldIdDomain :: EffectiveLanguageContract -> ContractField -> Maybe IdDomainContract+contractFieldIdDomain languageContract field = case (.valueType) field of+  CTypeId prefix -> contractIdDomainContractFor languageContract prefix+  _ -> Nothing++renderContractIdDomainChange :: ContractType -> Maybe IdDomainContract -> Maybe IdDomainContract -> Text+renderContractIdDomainChange valueType oldContract newContract =+  "contract TypeID admission changed "+    <> renderIdDomainContract oldContract+    <> " -> "+    <> renderIdDomainContract newContract+    <> representationChange+  where+    prefix = case valueType of+      CTypeId value -> value+      _ -> ""+    representationChange = case (oldContract, newContract) of+      (Nothing, Just _) ->+        "; generated Haskell changes from Text to KindID \""+          <> prefix+          <> "\" while valid JSON stays canonical text; newly generated consumers reject malformed, wrong-prefix, non-canonical, and non-v7 values"+      (Just _, Nothing) ->+        "; generated Haskell changes from KindID \""+          <> prefix+          <> "\" to Text and the generated decoder no longer enforces the frozen TypeID-v7 domain"+      _ -> "; generated contract admission changed while the source field type remained unchanged"++diffCheckedSpecs :: Spec -> Spec -> [Change]+diffCheckedSpecs old new =+  sharedDeclarationDiff env+    ++ concatMap (runFamily env . snd) familyRegistry+  where+    env = DiffEnv old new++-- | Compare provenance first, then delegate semantic graphs to 'diffServices'.+diffSources :: ParsedSource -> ParsedSource -> Either FoldSurfaceError [Change]+diffSources old new = do+  semanticChanges <- diffServices (checkedSource old) (checkedSource new)+  pure+    ( sourceLanguageChange+        ((.context) ((.spec) new))+        "declaration"+        ((.sourceLanguage) old)+        ((.sourceLanguage) new)+        <> semanticChanges+    )++-- | One all-compatible source-provenance finding, reusable per workspace member.+sourceLanguageChange :: Name -> Text -> SourceLanguage -> SourceLanguage -> [Change]+sourceLanguageChange root subject old new+  | old == new = []+  | otherwise =+      [ mkChange+          LabelAdditive+          (ChangeContext root [] ContextGeneral LabelAdditive)+          root+          "source-language"+          subject+          SourceLanguageDeclarationChanged+          ( "source form changed "+              <> renderSourceLanguage old+              <> " -> "+              <> renderSourceLanguage new+              <> if oldRuntime == newRuntime+                then "; normalized runtime semantics are unchanged"+                else "; effective runtime semantics changed " <> oldRuntime <> " -> " <> newRuntime <> "; see the accompanying semantic-contract findings"+          )+      ]+  where+    oldRuntime = effectiveRuntimeSemantics (effectiveLanguageContract old)+    newRuntime = effectiveRuntimeSemantics (effectiveLanguageContract new)+    renderSourceLanguage sourceLanguage =+      sourceFormText sourceLanguage+        <> maybe "" ((" v" <>) . languageVersionText) (declaredLanguageVersionMaybe sourceLanguage)++runFamily :: DiffEnv -> FamilyDiff -> [Change]+runFamily env (DiffFamily f) = f env+runFamily _ (OutOfDiffScope _) = []++-- Rules are outside the decode and persisted-identity axes, but referenced+-- rule bodies are compared as part of each aggregate's replay fold surface.+sharedDeclarationDiff :: DiffEnv -> [Change]+sharedDeclarationDiff env = enumDiff env ++ idDiff env ++ nominalScalarDiff env ++ mappedDeclarationDiff env++mappedDeclarationDiff :: DiffEnv -> [Change]+mappedDeclarationDiff env =+  concatMap+    (\finding -> mappedFindingChanges finding <> mappedProjectionFindingChanges env finding)+    (diffMapped ((.old) env) ((.new) 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 ((.old) env), projectionImpactFor ((.new) 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 ((.declaration) 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 <- (.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 (appendKindDetail suffix kind)+      Advisory kind -> Advisory (appendKindDetail suffix kind)+      Breaking kind -> Breaking (appendKindDetail suffix kind)+    appendKindDetail suffix ChangeKind {node, facet, subject, code, context, vector, mappedPersistedImpact, mappedConsequences, paths, detail} =+      ChangeKind {node, facet, subject, code, context, vector, mappedPersistedImpact, mappedConsequences, paths, detail = detail <> 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 ((.declaration) finding) | finding <- diffMapped oldSpec newSpec]+        relationChanges = map (.declaration) (diffSemanticImpact oldSnapshot newSnapshot)+     in mappedImpactForDeclarations (declarationChanges <> relationChanges) oldSnapshot newSnapshot+  _ -> []+  where+    oldSpec = checkedSpec oldService+    newSpec = checkedSpec newService++mappedFindingChanges :: MappedFinding -> [Change]+mappedFindingChanges finding+  | (.code) finding == MappedDeclAdded = [mappedDeclarationChange LabelAdditive finding]+  | (.code) finding `elem` [MappedHaskellSourceChanged, MappedRecordConstructorChanged, MappedFixturesChanged, GeneratedHaskellNameChanged] =+      [mappedBuildChange finding]+  | (.code) finding `elem` [MappedInitialChanged, MappedCanonicalTypeChanged] =+      mappedBuildChange finding : map (mappedUseChange finding) registerPaths+  | null paths = [mappedBuildChange finding]+  | otherwise = map (mappedUseChange finding) paths+  where+    paths = (.usePaths) finding+    registerPaths = [path | path@UsePath {root = RootRegister {}} <- paths]++mappedBuildChange :: MappedFinding -> Change+mappedBuildChange finding =+  mappedChange context ((.declaration) finding) "mapped-build" subject finding+  where+    subject = declarationSubject finding+    renderedPaths = map (\path -> renderMappedSubject path ((.leaf) finding)) ((.usePaths) finding)+    context = (consumerBuildContext ((.declaration) finding) renderedPaths) {contextOriginalLabel = LabelAdvisory}++mappedDeclarationChange :: Label -> MappedFinding -> Change+mappedDeclarationChange label finding =+  mappedChange context ((.declaration) finding) "mapped-declaration" (declarationSubject finding) finding+  where+    context = ChangeContext ((.declaration) finding) [] ContextGeneral label++mappedUseChange :: MappedFinding -> UsePath -> Change+mappedUseChange finding path =+  withMappedConsequences (mappedUseConsequences path) (mappedChange context root facet subject finding)+  where+    subject = renderMappedSubject path ((.leaf) finding)+    (root, facet, kind) = case (.root) 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 (.root) 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 (replaceMappedConsequences consequences kind)+  Advisory kind -> Advisory (replaceMappedConsequences consequences kind)+  Breaking kind -> Breaking (replaceMappedConsequences consequences kind)++replaceMappedConsequences :: Set MappedConsequence -> ChangeKind -> ChangeKind+replaceMappedConsequences mappedConsequences kind =+  ChangeKind+    { node = kind.node,+      facet = kind.facet,+      subject = kind.subject,+      code = kind.code,+      context = kind.context,+      vector = kind.vector,+      mappedPersistedImpact = kind.mappedPersistedImpact,+      mappedConsequences,+      paths = kind.paths,+      detail = kind.detail+    }++mappedContextHint :: MappedFinding -> ContextKind -> Label+mappedContextHint finding kind = case kind of+  ContextSnapshot -> LabelAdvisory+  ContextQueue -> LabelBreaking+  ContextConsumerBuild -> LabelAdvisory+  ContextPrivateEvent+    | (.code) finding == MappedFieldAddedWithDefault -> case (.oldUnknownFields) finding of+        Just IgnoreUnknown -> LabelAdditive+        _ -> LabelBreaking+    | (.code) finding `elem` [MappedArmAdded, MappedEnumValueAdded] -> LabelAdvisory+    | (.code) finding `elem` [MappedBindingChanged, MappedInitialChanged, MappedCanonicalTypeChanged] -> LabelAdvisory+    | otherwise -> LabelBreaking+  _ -> LabelAdvisory++mappedChange :: ChangeContext -> Name -> Text -> Text -> MappedFinding -> Change+mappedChange context node facet subject finding =+  mkChange label context node facet subject ((.code) finding) renderedDetail+  where+    label = deriveLabel defaultGate (classifyCompatibility context ((.code) finding))+    renderedDetail = case (.contextKind) context of+      ContextQueue ->+        (.detail) finding+          <> "; queued jobs remain schema-version-1 history; drain the queue or supply an application-owned transitional codec before deployment"+      _ -> (.detail) finding++declarationSubject :: MappedFinding -> Text+declarationSubject finding =+  (.declaration) finding <> if T.null ((.leaf) finding) then "" else " " <> (.leaf) finding++nodeAggregate :: Node -> Maybe Aggregate+nodeAggregate (NAggregate a) = Just a+nodeAggregate _ = Nothing++nodeProcess :: Node -> Maybe ProcessNode+nodeProcess (NProcess process) = Just process+nodeProcess _ = Nothing++nodeRouter :: Node -> Maybe RouterNode+nodeRouter (NRouter router) = Just router+nodeRouter _ = Nothing++nodeContract :: Node -> Maybe ContractNode+nodeContract (NContract contract) = Just contract+nodeContract _ = Nothing++nodeIntake :: Node -> Maybe IntakeNode+nodeIntake (NIntake intake) = Just intake+nodeIntake _ = Nothing++nodeEmit :: Node -> Maybe EmitNode+nodeEmit (NEmit emit) = Just emit+nodeEmit _ = Nothing++nodePublisher :: Node -> Maybe PublisherNode+nodePublisher (NPublisher publisher) = Just publisher+nodePublisher _ = Nothing++nodeWorkqueue :: Node -> Maybe WorkqueueNode+nodeWorkqueue (NWorkqueue workqueue) = Just workqueue+nodeWorkqueue _ = Nothing++nodePgmqDispatch :: Node -> Maybe PgmqDispatchNode+nodePgmqDispatch (NPgmqDispatch dispatch) = Just dispatch+nodePgmqDispatch _ = Nothing++nodeReadModel :: Node -> Maybe ReadModelNode+nodeReadModel (NReadModel readModel) = Just readModel+nodeReadModel _ = Nothing++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++-- | Router identity is replay-sensitive: the stable name and key feed every+-- target-keyed dispatch id, and the target selects the persisted stream family.+routerDiff :: DiffEnv -> [Change]+routerDiff env =+  concatMap (uncurry routerPairDiff) ((.matched) paired)+    ++ [additive ((.id) router) "router" ((.id) router) DeclarationAdded "new router declaration" | router <- (.added) paired]+    ++ [breaking ((.id) router) "router-identity" ((.id) router) RouterStableNameChanged "router removed while replayable source events may still derive target-keyed dispatch ids from its stable identity" | router <- (.removed) paired]+  where+    paired = pairByName nodeRouter (.id) env++routerPairDiff :: RouterNode -> RouterNode -> [Change]+routerPairDiff oldRouter newRouter =+  stableName+    ++ keyDerivation+    ++ target+    ++ routerDecideSurfaceDiff oldRouter newRouter+  where+    nodeName = (.id) newRouter+    stableName =+      [ breaking nodeName "router-stable-name" nodeName RouterStableNameChanged $+          "router stable name changed from '" <> (.name) oldRouter <> "' to '" <> (.name) newRouter <> "'; every deterministicRouterCommandId is re-keyed, so redelivery can duplicate the full resolved fan-out"+      | (.name) oldRouter /= (.name) newRouter+      ]+    keyDerivation =+      [ breaking nodeName "router-key" ((.field) ((.key) newRouter)) DerivedIdentityChanged "router key field or derivation changed; replay derives different target dispatch ids"+      | (.key) oldRouter /= (.key) newRouter+      ]+    target =+      [ breaking nodeName "router-target" ((.target) newRouter) DerivedIdentityChanged "router target aggregate changed; replay addresses a different persisted stream family"+      | (.target) oldRouter /= (.target) newRouter+      ]++routerDecideSurfaceDiff :: RouterNode -> RouterNode -> [Change]+routerDecideSurfaceDiff oldRouter newRouter =+  [ advisory+      ((.id) newRouter)+      "router-decide"+      ((.id) newRouter)+      RouterDecideSurfaceChanged+      "router dispatch surface changed: a source event redelivered across the deploy dispatches under the same deterministic ids, so half-old/half-new fan-out merges silently. Drain or pause the router's subscription and replay or discard dead letters before deploying; see docs/user/deploy-ordering.md. Hole-only decide changes are not visible to diff; the same drain rule applies to those too."+  | oldSurface /= newSurface+  ]+  where+    oldSurface =+      ( renderResolveSurface ((.resolve) oldRouter),+        renderRouterDispatchSurface ((.dispatch) oldRouter)+      )+    newSurface =+      ( renderResolveSurface ((.resolve) newRouter),+        renderRouterDispatchSurface ((.dispatch) newRouter)+      )++readModelDiff :: DiffEnv -> [Change]+readModelDiff env =+  concatMap (uncurry (readModelPairDiff env oldSupplies newSupplies)) ((.matched) paired)+    ++ concatMap addedReadModelDiff ((.added) paired)+    ++ concatMap removedReadModelDiff ((.removed) paired)+  where+    paired = pairByName nodeReadModel (.name) env+    oldSupplies = analyzeProjectionSupplies ((.old) env)+    newSupplies = analyzeProjectionSupplies ((.new) env)++readModelPairDiff :: DiffEnv -> ProjectionSupplyAnalysis -> ProjectionSupplyAnalysis -> ReadModelNode -> ReadModelNode -> [Change]+readModelPairDiff env oldSupplies newSupplies oldReadModel newReadModel =+  versionChanges+    ++ shapeChanges+    ++ identityChanges+    ++ policyChanges+    ++ bindingChanges+    ++ queryContractChanges+  where+    nodeName = (.name) newReadModel+    versionChanges+      | (.version) newReadModel < (.version) oldReadModel =+          [ breaking nodeName "read-model-version" nodeName ReadModelVersionDecreased ("version decreased from " <> tInt ((.version) oldReadModel) <> " to " <> tInt ((.version) newReadModel))+          ]+      | (.version) newReadModel > (.version) oldReadModel =+          [ additive nodeName "read-model-version" nodeName VersionBumped ("version increased from " <> tInt ((.version) oldReadModel) <> " to " <> tInt ((.version) newReadModel) <> "; register and rebuild the new shape before serving it")+          ]+      | otherwise = []+    oldShape = ((.columns) oldReadModel, (.shape) oldReadModel)+    newShape = ((.columns) newReadModel, (.shape) newReadModel)+    shapeChanges =+      [ breaking nodeName "read-model-shape" nodeName ReadModelShapeChangedWithoutBump ("declared columns or captured shape hash changed at version " <> tInt ((.version) newReadModel) <> "; bump version and rebuild")+      | oldShape /= newShape,+        (.version) oldReadModel == (.version) newReadModel+      ]+    oldRegistry = registryNameFor ((.context) ((.old) env)) oldReadModel+    newRegistry = registryNameFor ((.context) ((.new) env)) newReadModel+    oldSubscription = subscriptionNameFor ((.context) ((.old) env)) oldReadModel+    newSubscription = subscriptionNameFor ((.context) ((.new) env)) newReadModel+    identityChanges =+      [ breaking nodeName "read-model-identity" nodeName DerivedIdentityChanged ("registry name changed '" <> oldRegistry <> "' -> '" <> newRegistry <> "'; the old registration row is orphaned")+      | oldRegistry /= newRegistry+      ]+        ++ [ breaking nodeName "read-model-table" nodeName DerivedIdentityChanged ("qualified table changed '" <> qualifiedIdentity oldReadModel <> "' -> '" <> qualifiedIdentity newReadModel <> "'; existing data remains under the old identity")+           | ((.schema) oldReadModel, (.table) oldReadModel) /= ((.schema) newReadModel, (.table) newReadModel)+           ]+        ++ [ breaking nodeName "read-model-subscription" nodeName DerivedIdentityChanged ("subscription changed '" <> oldSubscription <> "' -> '" <> newSubscription <> "'; the worker cursor remains under the old identity")+           | oldSubscription /= newSubscription+           ]+    -- 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 ((.supply) oldReadModel, (.supply) newReadModel) of+      (OwnerDerivedSupply, OwnerDerivedSupply) ->+        [ breaking nodeName "query-freshness" nodeName QueryFreshnessChanged ("query freshness changed " <> renderFreshness ((.freshness) oldReadModel) <> " -> " <> renderFreshness ((.freshness) newReadModel) <> "; catalog and owning-group query policy identity changed")+        | (.freshness) oldReadModel /= (.freshness) newReadModel+        ]+      (LegacyReadModelSupply {}, LegacyReadModelSupply {}) ->+        legacyFeedChanges <> legacyConsistencyChanges <> legacyScopeChanges+      _ -> migrationFreshnessChanges+    migrationFreshnessChanges = case ((.freshness) oldReadModel, (.freshness) newReadModel) of+      (oldFreshness, newFreshness)+        | oldFreshness == newFreshness -> []+      (FreshnessWaitForHead _, FreshnessImmediate) ->+        [ breaking nodeName "query-freshness" nodeName QueryFreshnessChanged ("query freshness weakened " <> renderFreshness ((.freshness) 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 ((.freshness) 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+      ]+    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"]+      (Just Eventual, Just Strong) ->+        [additive nodeName "read-model-consistency" nodeName CompatibilityStrengthened "default consistency changed Eventual -> Strong; callers gain a cursor-wait guarantee"]+      _ -> []+    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 =+      ( (.group) readModel,+        Set.fromList ((.observedTargets) readModel),+        resolvedSupplier supplyAnalysis readModel,+        effectiveBacking readModel+      )+    resolvedSupplier supplyAnalysis readModel =+      case [ (.projectionOwner) supply+           | supply <- (.resolvedProjectionSupplies) supplyAnalysis,+             (.queryModel) supply == (.name) readModel+           ] of+        [ownerName] -> Just ownerName+        _ -> Nothing+    effectiveBacking readModel = case (.backingTarget) readModel of+      Just target -> Just target+      Nothing -> case (.observedTargets) 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) ((.matched) paired)+    <> [additive ((.name) target) "projection-target" ((.name) target) CatalogTargetAdded "new application-owned target; consumer DDL is still required" | target <- (.added) paired]+    <> [breaking ((.name) target) "projection-target" ((.name) target) CatalogTargetRemoved "target declaration removed while table data and rebuild evidence may remain" | target <- (.removed) paired]+  where+    paired = pairByName nodeProjectionTarget (.name) env++projectionTargetPairDiff :: ProjectionTargetNode -> ProjectionTargetNode -> [Change]+projectionTargetPairDiff oldTarget newTarget = locationChange <> resetChange <> dependencyChange+  where+    targetName = (.name) newTarget+    locationChange =+      [ breaking targetName "projection-target-location" targetName CatalogTargetLocationChanged $+          "qualified target changed " <> (.schema) oldTarget <> "." <> (.table) oldTarget <> " -> " <> (.schema) newTarget <> "." <> (.table) newTarget <> "; Keiro does not move application data"+      | ((.schema) oldTarget, (.table) oldTarget) /= ((.schema) newTarget, (.table) newTarget)+      ]+    resetChange = case ((.reset) oldTarget, (.reset) 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"+      | (.dependsOn) oldTarget /= (.dependsOn) newTarget+      ]++rebuildGroupDiff :: DiffEnv -> [Change]+rebuildGroupDiff env =+  concatMap (uncurry rebuildGroupPairDiff) ((.matched) paired)+    <> [additive ((.name) groupNode) "rebuild-group" ((.name) groupNode) DeclarationAdded "new rebuild group" | groupNode <- (.added) paired]+    <> [breaking ((.name) groupNode) "rebuild-group" ((.name) groupNode) CatalogGroupChanged "rebuild group removed while lifecycle and run evidence may remain" | groupNode <- (.removed) paired]+  where+    paired = pairByName nodeRebuildGroup (.name) env++rebuildGroupPairDiff :: RebuildGroupNode -> RebuildGroupNode -> [Change]+rebuildGroupPairDiff oldGroup newGroup =+  [ breaking ((.name) newGroup) "rebuild-group-membership-order" ((.name) newGroup) CatalogGroupChanged "target membership or deterministic preparation order changed; abandon any active fingerprint and start a fresh rebuild"+  | ((.targets) oldGroup, (.order) oldGroup) /= ((.targets) newGroup, (.order) newGroup)+  ]++projectionRevisionDiff :: DiffEnv -> [Change]+projectionRevisionDiff env =+  concatMap (uncurry projectionRevisionPairDiff) ((.matched) paired)+    <> [additive ((.name) revision) "projection-revision" ((.name) revision) DeclarationAdded "new projection revision and target-schema contract" | revision <- (.added) paired]+    <> [breaking ((.name) revision) "projection-revision" ((.name) revision) CatalogProjectionRevisionRemoved "projection revision removed while serving, rebuild, or read-contract evidence may still refer to it" | revision <- (.removed) paired]+  where+    paired = pairByName nodeProjectionRevision (.name) env++projectionRevisionPairDiff :: ProjectionRevisionNode -> ProjectionRevisionNode -> [Change]+projectionRevisionPairDiff oldRevision newRevision = groupChange <> schemaChanges <> contractChanges+  where+    revisionName = (.name) newRevision+    oldTargets = Map.fromList [((.target) target, target) | target <- (.targets) oldRevision]+    newTargets = Map.fromList [((.target) target, target) | target <- (.targets) newRevision]+    groupChange =+      [ breaking revisionName "projection-revision-group" revisionName CatalogProjectionRevisionChanged "revision rebuild group changed; persisted revision and generation identity no longer matches"+      | (.group) oldRevision /= (.group) newRevision+      ]+    schemaChanges =+      [ breaking revisionName "target-schema" targetName CatalogTargetSchemaChanged $+          "target schema version changed " <> (.schemaVersion) oldTarget <> " -> " <> (.schemaVersion) newTarget <> "; declare a new projection revision instead of mutating a registered one"+      | (targetName, oldTarget) <- Map.toAscList oldTargets,+        Just newTarget <- [Map.lookup targetName newTargets],+        (.schemaVersion) oldTarget /= (.schemaVersion) 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 ->+        ( (.provisioner) oldTarget,+          (.provisionerVersion) oldTarget,+          (.expectedShape) oldTarget,+          (.validator) oldTarget,+          (.validatorVersion) oldTarget,+          (.promotionObjects) oldTarget+        )+          /= ( (.provisioner) newTarget,+               (.provisionerVersion) newTarget,+               (.expectedShape) newTarget,+               (.validator) newTarget,+               (.validatorVersion) newTarget,+               (.promotionObjects) newTarget+             )++externalReadDiff :: DiffEnv -> [Change]+externalReadDiff env =+  concatMap (uncurry (externalReadPairDiff env)) ((.matched) paired)+    <> [ additive+           (externalReadNodeIdentity externalRead)+           "external-read-version"+           ((.name) externalRead)+           CatalogExternalReadVersionAdded+           "new external read-contract version; grant execute only after its result type and wrapper are deployed"+       | externalRead <- (.added) paired+       ]+    <> [ breaking+           (externalReadNodeIdentity externalRead)+           "external-read-retirement"+           ((.name) externalRead)+           CatalogExternalReadRetired+           "external read-contract version removed; preview dependencies and retire it explicitly before removing the declaration"+       | externalRead <- (.removed) 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" ((.name) newExternalRead) CatalogExternalReadContractChanged "query binding or public result type changed for an existing contract version; publish a new version"+      | ( (.queryModel) oldExternalRead,+          (.resultSchema) oldExternalRead,+          (.resultType) oldExternalRead+        )+          /= ( (.queryModel) newExternalRead,+               (.resultSchema) newExternalRead,+               (.resultType) newExternalRead+             )+      ]+    oldCompatibility = Set.fromList ((.compatibleRevisions) oldExternalRead)+    newCompatibility = Set.fromList ((.compatibleRevisions) newExternalRead)+    compatibilityChanges+      | oldCompatibility == newCompatibility = []+      | oldCompatibility `Set.isSubsetOf` newCompatibility =+          [ additive subject "external-read-compatibility" ((.name) newExternalRead) CatalogExternalReadCompatibilityChanged "compatible projection-revision set widened; deploy the higher surface generation before promoting the added revision"+          ]+      | otherwise =+          [ breaking subject "external-read-compatibility" ((.name) newExternalRead) CatalogExternalReadCompatibilityChanged "compatible projection-revision set narrowed or replaced for an existing contract version"+          ]+    shapeChanges =+      [ breaking subject "external-read-result-shape" ((.name) newExternalRead) CatalogExternalReadResultShapeChanged "checked query result shape changed for an existing contract version; restore compatibility or publish a new version"+      | externalReadShape ((.old) env) oldExternalRead /= externalReadShape ((.new) env) newExternalRead+      ]+    generationChanges+      | (.surfaceGeneration) oldExternalRead == (.surfaceGeneration) newExternalRead = []+      | (.surfaceGeneration) oldExternalRead < (.surfaceGeneration) newExternalRead =+          [ advisory subject "external-read-surface-generation" ((.name) newExternalRead) CatalogExternalReadContractChanged "surface generation increased; roll out the newer declaration before older processes can reconcile"+          ]+      | otherwise =+          [ breaking subject "external-read-surface-generation" ((.name) newExternalRead) CatalogExternalReadContractChanged "surface generation decreased; runtime reconciliation refuses this downgrade"+          ]+    externalReadShape spec externalRead = case [(.shape) readModel | NReadModel readModel <- (.nodes) spec, (.name) readModel == (.queryModel) externalRead] of+      shape : _ -> Just shape+      [] -> Nothing++projectionOwnerDiff :: DiffEnv -> [Change]+projectionOwnerDiff env =+  concatMap (uncurry projectionOwnerPairDiff) ((.matched) paired)+    <> [additive ((.name) owner) "projection-owner" ((.name) owner) DeclarationAdded "new projection owner" | owner <- (.added) paired]+    <> [breaking ((.name) owner) "projection-owner" ((.name) owner) CatalogOwnerRemoved "projection owner removed while targets and replay evidence remain" | owner <- (.removed) paired]+  where+    paired = pairByName nodeProjectionOwner (.name) env++projectionOwnerPairDiff :: ProjectionOwnerNode -> ProjectionOwnerNode -> [Change]+projectionOwnerPairDiff oldOwner newOwner = groupAndTargets <> orderChange <> sourceChange <> feedIdentityChange <> checkpointPolicyChange <> replayChange+  where+    ownerName = (.name) newOwner+    groupAndTargets =+      [ breaking ownerName "projection-owner-group-targets" ownerName CatalogOwnerChanged "rebuild group or owned target set changed"+      | ((.group) oldOwner, Set.fromList ((.targets) oldOwner)) /= ((.group) newOwner, Set.fromList ((.targets) newOwner))+      ]+    orderChange =+      [ advisory ownerName "projection-owner-order" ownerName CatalogHandlerOrderChanged "handler order changed; replay materialization and resume fingerprint change"+      | (.order) oldOwner /= (.order) newOwner+      ]+    sourceChange =+      [ breaking ownerName "projection-owner-sources" ownerName CatalogSourceChanged "source selection changed; historical coverage and active resume fingerprint change"+      | (.sources) oldOwner /= (.sources) newOwner+      ]+    feedIdentityChange =+      [ breaking ownerName "projection-delivery" ownerName ProjectionDeliveryChanged "projection delivery changed; handler lifecycle, cursor, and dedup identity require coordinated review"+      | (.delivery) oldOwner /= (.delivery) newOwner+      ]+        <> [ breaking ownerName "projection-owner-delivery-identity" ownerName CatalogFeedIdentityChanged "subscription or dedup identity changed; cursors or dedup evidence remain under the old identity"+           | ((.subscription) oldOwner, (.dedup) oldOwner) /= ((.subscription) newOwner, (.dedup) 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] <- [(.checkpointOnMissing) oldOwner],+        [newPolicy] <- [(.checkpointOnMissing) 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"+      | (.replay) oldOwner /= (.replay) newOwner+      ]++renderCheckpointOnMissing :: CheckpointOnMissingNode -> Text+renderCheckpointOnMissing CheckpointFromBeginning = "from-beginning"+renderCheckpointOnMissing CheckpointFromCurrentHead = "from-current-head"+renderCheckpointOnMissing CheckpointFail = "fail"++addedReadModelDiff :: ReadModelNode -> [Change]+addedReadModelDiff readModel =+  [additive ((.name) readModel) "read-model" ((.name) readModel) DeclarationAdded "new read model"]++removedReadModelDiff :: ReadModelNode -> [Change]+removedReadModelDiff readModel =+  [breaking ((.name) readModel) "read-model-identity" ((.name) readModel) DerivedIdentityChanged "read model removed while registered metadata, data, subscription cursors, and callers may remain"]++qualifiedIdentity :: ReadModelNode -> Text+qualifiedIdentity readModel = (.schema) readModel <> "." <> (.table) readModel++renderFeed :: RmFeed -> Text+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++scopeStrengthened :: RmScope -> RmScope -> Bool+scopeStrengthened (RmCategory _) RmEntireLog = True+scopeStrengthened _ _ = False++renderScope :: RmScope -> Text+renderScope RmEntireLog = "entire-log"+renderScope (RmCategory categoryName) = "category '" <> categoryName <> "'"++aggregateDiff :: DiffEnv -> [Change]+aggregateDiff env =+  concatMap+    (\(oldAggregate, newAggregate) -> aggregatePairDiff ((.old) env) ((.new) env) oldAggregate newAggregate)+    ((.matched) paired)+    ++ concatMap addedAggregateDiff ((.added) paired)+    ++ concatMap removedAggregateDiff ((.removed) paired)+  where+    paired = pairByName nodeAggregate (.name) env++aggregatePairDiff :: Spec -> Spec -> Aggregate -> Aggregate -> [Change]+aggregatePairDiff oldSpec newSpec oldAgg newAgg =+  commandFieldIdentityDiff oldAgg newAgg+    ++ concatMap (eventDiff oldAgg newAgg) ((.events) newAgg)+    ++ removedEvents oldAgg newAgg+    ++ 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+          ((.name) newAggregate)+          "domain-outcome-types"+          ((.name) newAggregate)+          DomainOutcomeTypesChanged+          ( "domain outcome types changed from '"+              <> renderDeclaration ((.domainOutcomeTypes) oldAggregate)+              <> "' to '"+              <> renderDeclaration ((.domainOutcomeTypes) newAggregate)+              <> "'; generated command result types and callers must be updated, while event history and snapshots remain compatible"+          )+      | canonicalDomainOutcomeTypes ((.domainOutcomeTypes) oldAggregate)+          /= canonicalDomainOutcomeTypes ((.domainOutcomeTypes) newAggregate)+      ]+    transitionChanges =+      [ advisory+          ((.name) newAggregate)+          "transition-domain-outcome"+          (transitionSubject ordinal newTransition)+          DomainTransitionOutcomeChanged+          ( "domain outcome changed from '"+              <> canonicalTransitionOutcome ((.outcome) oldTransition)+              <> "' to '"+              <> canonicalTransitionOutcome ((.outcome) newTransition)+              <> "'; forward command behavior changes, while the selected edge, emitted events, fold, replay, and snapshots remain unchanged"+          )+      | (ordinal, newTransition) <- zip [0 :: Int ..] ((.transitions) newAggregate),+        Just oldTransition <- [find ((== canonicalTransition newTransition) . canonicalTransition) ((.transitions) oldAggregate)],+        canonicalTransitionOutcome ((.outcome) oldTransition) /= canonicalTransitionOutcome ((.outcome) newTransition)+      ]+    renderDeclaration declaration = case canonicalDomainOutcomeTypes declaration of+      "" -> "(disabled)"+      value -> value+    transitionSubject ordinal transition =+      (.source) transition <> " -- " <> (.command) 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]+transitionSurfaceDiff oldSpec newSpec oldAgg newAgg+  | aggregateFoldSurfaceForService (legacyCheckedService oldSpec) oldAgg == aggregateFoldSurfaceForService (legacyCheckedService newSpec) newAgg = []+  | otherwise =+      [ advisory+          ((.name) newAgg)+          "transitions"+          ((.name) newAgg)+          AggFoldSurfaceChanged+          "aggregate fold surface changed: replay now interprets the existing log under the new fold. Old snapshots are invalidated automatically once the regenerated fold fingerprint deploys; if the change is fold-neutral confirm it, otherwise re-scaffold and redeploy, and bump `state-codec version=` for any accompanying Holes-only change."+      ]++-- | Plan 143: guard changes are replay-relevant. Hydration re-inverts each+-- stored event and re-checks the edge guard, so a stored event legally appended+-- under the old guard may no longer satisfy the new one — the next command on+-- any stream containing such an event fails hydration with no inverting edge.+-- The remedy is mechanical, so the tool computes it: the removed region is+-- @old-guard ∧ ¬new-guard@ ('complementExpr' eliminates the negation inside the+-- existing grammar), and the advisory prints a paste-ready replay-only twin+-- carrying that region with the OLD transition's writes\/emits\/goto. Whether+-- history should stay replayable (paste the twin) or be truncated instead is a+-- business decision, so the twin is never auto-applied.+--+-- Detection is conservative: any guard change on a paired live (source,+-- command) transition where the new spec declares a guard and does not already+-- contain a replay-only twin for the pair. A pure loosening also matches; the+-- advisory says how to confirm no stored data is affected (the replay audit,+-- docs/plans/142) rather than guessing.+guardTighteningDiff :: Aggregate -> Aggregate -> [Change]+guardTighteningDiff oldAgg newAgg =+  [ advisory ((.name) newAgg) "transition" subject AggGuardTightened detail+  | newT <- (.transitions) newAgg,+    (.mode) newT == TmLive,+    Just oldT <-+      [ find+          (\o -> (.source) o == (.source) newT && (.command) o == (.command) newT && (.mode) o == TmLive)+          ((.transitions) oldAgg)+      ],+    (.guard) newT /= (.guard) oldT,+    Just newGuard <- [(.guard) newT],+    not (hasReplayOnlyTwin newT),+    let subject = (.source) newT <> " -- " <> (.command) newT,+    let removedRegion =+          maybe (complementExpr newGuard) (\o -> EAnd o (complementExpr newGuard)) ((.guard) oldT),+    let twin = replaceTransitionGuardAndMode (Just removedRegion) TmReplayOnly oldT,+    let detail =+          "guard changed on "+            <> subject+            <> ". Stored events appended under the old guard may no longer invert: "+            <> "the next command on any stream containing one fails hydration with "+            <> "no inverting edge. Either confirm via the replay audit that no stored "+            <> "stream exercises the removed region, or keep history replayable by "+            <> "adding the computed replay-only twin (the removed region with the old "+            <> "transition's writes/emits/goto):\n\n"+            <> renderTransition twin+  ]+  where+    hasReplayOnlyTwin newT =+      any+        (\t -> (.mode) t == TmReplayOnly && (.source) t == (.source) newT && (.command) t == (.command) newT)+        ((.transitions) newAgg)++replaceTransitionGuardAndMode :: Maybe Expr -> TransitionMode -> Transition -> Transition+replaceTransitionGuardAndMode guard mode transition =+  Transition+    { source = transition.source,+      command = transition.command,+      implementation = transition.implementation,+      guard,+      writes = transition.writes,+      emits = transition.emits,+      outcome = transition.outcome,+      outcomeDuplicateLocs = transition.outcomeDuplicateLocs,+      goto = transition.goto,+      mode,+      loc = transition.loc+    }++addedAggregateDiff :: Aggregate -> [Change]+addedAggregateDiff newAgg =+  [ additive ((.name) newAgg) "event" ((.name) e) DeclarationAdded "new event type (new aggregate)"+  | e <- (.events) newAgg+  ]++removedAggregateDiff :: Aggregate -> [Change]+removedAggregateDiff oldAgg =+  [ breaking ((.name) oldAgg) "event" ((.name) e) EvtRemovedNotDeprecated "aggregate removed; its event tags are no longer decodable"+  | e <- (.events) oldAgg+  ]++-- | Per-event classification for an event present in the new aggregate.+eventDiff :: Aggregate -> Aggregate -> Event -> [Change]+eventDiff oldAgg newAgg e =+  case find ((== (.name) e) . (.name)) ((.events) oldAgg) of+    Nothing ->+      [additive ((.name) newAgg) "event" ((.name) e) DeclarationAdded "new event type"]+    Just oldE+      | (.version) e > (.version) oldE ->+          selectorChanges oldE+            ++ if (.version) e == (.version) oldE + 1 && (.upcastFrom) e `hasSource` (.version) oldE+              then+                [additive ((.name) newAgg) "event" ((.name) e) VersionBumped ("new version v" <> tInt ((.version) e) <> " with upcaster from v" <> tInt ((.version) oldE))]+                  ++ [ breaking+                         ((.name) newAgg)+                         "event"+                         ((.name) e)+                         UpcasterChainGap+                         ( "bumping v"+                             <> tInt ((.version) oldE)+                             <> " to v"+                             <> tInt ((.version) e)+                             <> " replaced the 'upcast from v"+                             <> tInt vanishedSource+                             <> "' rung; stored v"+                             <> tInt vanishedSource+                             <> " payloads can no longer decode"+                         )+                     | Just (vanishedSource, _) <- [(.upcastFrom) oldE],+                       not (aggregateHasUpcasterSource newAgg vanishedSource)+                     ]+              else+                [ breaking+                    ((.name) newAgg)+                    "event"+                    ((.name) e)+                    EvtVersionMissingUpcaster+                    ( "version changed from v"+                        <> tInt ((.version) oldE)+                        <> " to v"+                        <> tInt ((.version) e)+                        <> " without the required contiguous upcaster from v"+                        <> tInt ((.version) oldE)+                    )+                ]+      | (.version) e < (.version) oldE ->+          selectorChanges oldE+            ++ [breaking ((.name) newAgg) "event" ((.name) e) EvtVersionDecreased ("version decreased from v" <> tInt ((.version) oldE) <> " to v" <> tInt ((.version) e))]+      | otherwise ->+          selectorChanges oldE ++ sameVersionEventDiff oldAgg newAgg oldE e+  where+    selectorChanges oldEvent = eventFieldSelectorChanges oldAgg newAgg oldEvent e++-- | Events present in the old aggregate but absent in the new one. Removing a+-- tag entirely is breaking; deprecation preserves decoding but needs a retained+-- replay-only emitter to preserve replay.+removedEvents :: Aggregate -> Aggregate -> [Change]+removedEvents oldAgg newAgg =+  [ breaking ((.name) newAgg) "event" ((.name) oldE) EvtRemovedNotDeprecated "event removed entirely; its stored payloads can neither decode nor replay. Deprecating instead restores decode-ability only — replay still fails on live streams unless an equivalent replay-only emitting transition is retained; truncate or terminalize affected streams before deleting it"+  | oldE <- (.events) oldAgg,+    isNothing (find ((== (.name) oldE) . (.name)) ((.events) newAgg))+  ]++hasSource :: Maybe (Int, Hole) -> Int -> Bool+hasSource (Just (m, _)) n = m == n+hasSource Nothing _ = False++aggregateHasUpcasterSource :: Aggregate -> Int -> Bool+aggregateHasUpcasterSource aggregate source =+  any ((== Just source) . fmap fst . (.upcastFrom)) ((.events) aggregate)++hasReplayOnlyEmitter :: Aggregate -> Name -> Bool+hasReplayOnlyEmitter aggregate eventName =+  any+    (\transition -> (.mode) transition == TmReplayOnly && eventName `elem` (.emits) transition)+    ((.transitions) aggregate)++data EventFieldSig = EventFieldSig+  { dslName :: !Name,+    selector :: !Name,+    wireKey :: !Text,+    valueType :: !(Maybe TypeExpr)+  }+  deriving stock (Eq, Show)++eventFieldSigs :: Aggregate -> Event -> [EventFieldSig]+eventFieldSigs agg e = case (.body) e of+  EventFields fs -> map fieldSig fs+  EventFromCommand cn ->+    maybe [] (map fieldSig . (.fields)) (find ((== cn) . (.name)) ((.commands) agg))+  where+    fieldSig field =+      let identity = resolveAggregateFieldIdentity field+       in EventFieldSig+            { dslName = (.dslName) identity,+              selector = (.selector) identity,+              wireKey = (.wireKey) identity,+              valueType = (.valueType) field+            }++eventFieldSelectorChanges :: Aggregate -> Aggregate -> Event -> Event -> [Change]+eventFieldSelectorChanges oldAggregate newAggregate oldEvent newEvent =+  [ fieldSelectorChange+      ((.name) newAggregate)+      "event-field-selector"+      ((.name) newEvent <> "." <> (.dslName) newField)+      ((.selector) oldField)+      ((.selector) newField)+      "event field selector"+  | newField <- eventFieldSigs newAggregate newEvent,+    Just oldField <- [find ((== (.dslName) newField) . (.dslName)) (eventFieldSigs oldAggregate oldEvent)],+    (.selector) oldField /= (.selector) newField+  ]++commandFieldIdentityDiff :: Aggregate -> Aggregate -> [Change]+commandFieldIdentityDiff oldAggregate newAggregate =+  [ fieldSelectorChange+      ((.name) newAggregate)+      "command-field-selector"+      ((.name) newCommand <> "." <> (.name) newField)+      ((.selector) (resolveAggregateFieldIdentity oldField))+      ((.selector) (resolveAggregateFieldIdentity newField))+      "command field selector"+  | newCommand <- (.commands) newAggregate,+    Just oldCommand <- [find ((== (.name) newCommand) . (.name)) ((.commands) oldAggregate)],+    newField <- (.fields) newCommand,+    Just oldField <- [find ((== (.name) newField) . (.name)) ((.fields) oldCommand)],+    (.selector) (resolveAggregateFieldIdentity oldField)+      /= (.selector) (resolveAggregateFieldIdentity newField)+  ]++sameVersionEventDiff :: Aggregate -> Aggregate -> Event -> Event -> [Change]+sameVersionEventDiff oldAgg newAgg oldE newE =+  addedChanges+    ++ removedChanges+    ++ typeChanges+    ++ wireKeyChanges+    ++ deprecationChanges+    ++ retirementChanges+  where+    oldFields = eventFieldSigs oldAgg oldE+    newFields = eventFieldSigs newAgg newE+    oldNames = map (.dslName) oldFields+    newNames = map (.dslName) newFields+    added = newNames \\ oldNames+    removed = oldNames \\ newNames+    changed =+      [ ((.dslName) oldField, (.valueType) oldField, (.valueType) newField)+      | oldField <- oldFields,+        Just newField <- [find ((== (.dslName) oldField) . (.dslName)) newFields],+        (.valueType) oldField /= (.valueType) newField+      ]+    addedChanges =+      [ breaking ((.name) newAgg) "event" ((.name) newE) EvtFieldAddedWithoutBump ("field(s) " <> commas added <> " added at the same version v" <> tInt ((.version) newE) <> " without a version bump or upcaster")+      | not (null added)+      ]+    removedChanges =+      [ breaking ((.name) newAgg) "event" ((.name) newE) EvtFieldRemovedSameVersion ("field(s) " <> commas removed <> " removed at the same version v" <> tInt ((.version) newE))+      | not (null removed)+      ]+    typeChanges =+      [ breaking+          ((.name) newAgg)+          "event-field"+          ((.name) newE <> "." <> field)+          EvtFieldTypeChanged+          ("type changed " <> renderAggregateFieldType oldType <> " -> " <> renderAggregateFieldType newType <> " at the same version v" <> tInt ((.version) newE))+      | (field, oldType, newType) <- changed+      ]+    wireKeyChanges =+      [ breaking+          ((.name) newAgg)+          "event-field-wire-key"+          ((.name) newE <> "." <> (.dslName) newField)+          EvtFieldWireKeyChanged+          ( "wire key changed '"+              <> (.wireKey) oldField+              <> "' -> '"+              <> (.wireKey) newField+              <> "'; restore the old key, or version the event and retain an upcaster"+          )+      | newField <- newFields,+        Just oldField <- [find ((== (.dslName) newField) . (.dslName)) oldFields],+        (.wireKey) oldField /= (.wireKey) newField+      ]+    deprecationChanges+      | not ((.deprecated) oldE) && (.deprecated) newE =+          [ if hasReplayOnlyEmitter newAgg ((.name) newE)+              then+                advisory+                  ((.name) newAgg)+                  "event"+                  ((.name) newE)+                  EventRetirementInProgress+                  "event deprecated and removed from the live write path, while an equivalent replay-only transition preserves hydration. Retain that transition until every affected stream is terminal, truncated, or passes the replay audit"+              else+                advisory+                  ((.name) newAgg)+                  "event"+                  ((.name) newE)+                  DeprecatedEventReplayHazard+                  ( "event deprecated: old payloads remain decodable but are no longer replayable — hydration of live streams containing them fails at the first command (HydrationNoInvertingEdge). Add an equivalent replay-only emitting transition or confirm every affected stream is terminal or truncated before deploying"+                      <> if (.retiring) oldE then "" else "; consider a 'retiring event' stage first"+                  )+          ]+      | (.deprecated) oldE && not ((.deprecated) newE) && not ((.retiring) newE) =+          [advisory ((.name) newAgg) "event" ((.name) newE) EventUndeprecated "event returned to the write surface; old payloads remain decodable but new writes resume"]+      | otherwise = []+    retirementChanges+      | not ((.retiring) oldE) && (.retiring) newE =+          [advisory ((.name) newAgg) "event" ((.name) newE) EventRetirementInProgress "retirement started; keep the live emitting transition until affected streams are terminal or truncated, then cut over to deprecated plus an equivalent replay-only emitting transition"]+      | (.retiring) oldE && not ((.retiring) newE) && not ((.deprecated) newE) =+          [additive ((.name) newAgg) "event" ((.name) newE) EventRetirementAbandoned "event retirement abandoned; ordinary live writes continue"]+      | otherwise = []++renderAggregateFieldType :: Maybe TypeExpr -> Text+renderAggregateFieldType Nothing = "(declared)"+renderAggregateFieldType (Just expression) = typeExprCanonicalName expression++renderFieldType :: Maybe Name -> Text+renderFieldType Nothing = "(declared)"+renderFieldType (Just name) = name++wireDiff :: Aggregate -> Aggregate -> [Change]+wireDiff oldAgg newAgg+  | effectiveWire ((.wire) oldAgg) == effectiveWire ((.wire) newAgg) = []+  | otherwise =+      [ breaking+          ((.name) newAgg)+          "wire"+          ((.name) newAgg)+          WireSpecChanged+          ("effective wire convention changed " <> renderWire (effectiveWire ((.wire) oldAgg)) <> " -> " <> renderWire (effectiveWire ((.wire) newAgg)))+      ]++effectiveWire :: Maybe WireSpec -> (Text, Text)+effectiveWire Nothing = ("ctorName", "camelCase")+effectiveWire (Just w) = ((.kind) w, (.fields) w)++renderWire :: (Text, Text) -> Text+renderWire (kindName, fieldNames) = "kind=" <> kindName <> ", fields=" <> fieldNames++projectionDiff :: Aggregate -> Aggregate -> [Change]+projectionDiff oldAggregate newAggregate+  | projectionSurface ((.projection) oldAggregate) == projectionSurface ((.projection) newAggregate) = []+  | otherwise =+      [ advisory+          ((.name) newAggregate)+          "projection"+          ((.name) newAggregate)+          ProjectionChanged+          "projection table, consistency, key, or status mapping changed; coordinate the read-model migration"+      ]++projectionSurface :: Maybe ProjectionSpec -> Maybe (Name, Maybe Consistency, Name, Maybe Mapping)+projectionSurface projection = do+  value <- projection+  pure ((.table) value, (.consistency) value, (.key) value, (.statusMap) value)++idDiff :: DiffEnv -> [Change]+idDiff env =+  concatMap (uncurry (idPairDiff ((.old) env))) ((.matched) paired)+    ++ concatMap addedIdDiff ((.added) paired)+    ++ concatMap removedIdDiff ((.removed) paired)+  where+    paired = pairDeclarations (.name) ((.ids) ((.old) env)) ((.ids) ((.new) env))++idPairDiff :: Spec -> IdDecl -> IdDecl -> [Change]+idPairDiff oldSpec oldId newId =+  [ breaking ((.name) newId) "id-prefix" ((.name) newId) IdPrefixChanged ("prefix changed '" <> (.prefix) oldId <> "' -> '" <> (.prefix) newId <> "'; stored and newly minted ids no longer share an identity domain")+  | (.prefix) oldId /= (.prefix) newId+  ]+    <> nominalBindingDeclDiff oldSpec "id" ((.name) newId) ((.binding) oldId) ((.binding) newId)+    <> [ nominalUseChange+           use+           NominalIdDecoderTightened+           "adopting a checked KindID binding tightens historical decoding; keep a committed valid old-payload fixture and run the targeted real-log audit for this event"+       | (.binding) oldId == Nothing,+         isJust ((.binding) newId),+         use@NominalEventUse {} <- nominalUses oldSpec ((.name) oldId)+       ]++addedIdDiff :: IdDecl -> [Change]+addedIdDiff declaration = [additive ((.name) declaration) "id-prefix" ((.name) declaration) DeclarationAdded "new id declaration"]++removedIdDiff :: IdDecl -> [Change]+removedIdDiff declaration = [breaking ((.name) declaration) "id-prefix" ((.name) declaration) IdPrefixChanged "id declaration removed; persisted ids still use its prefix"]++enumDiff :: DiffEnv -> [Change]+enumDiff env =+  concatMap (uncurry (enumPairDiff ((.old) env))) ((.matched) paired)+    ++ concatMap addedEnumDiff ((.added) paired)+    ++ concatMap (removedEnumDiff ((.old) env)) ((.removed) paired)+  where+    paired = pairDeclarations (.name) ((.enums) ((.old) env)) ((.enums) ((.new) env))++enumPairDiff :: Spec -> EnumDecl -> EnumDecl -> [Change]+enumPairDiff oldSpec oldEnum newEnum =+  [ breaking ((.name) newEnum) "enum-constructor" ctor EnumCtorRemoved ("constructor removed; stored wire value '" <> wire <> "' no longer decodes" <> enumUsageSuffix oldSpec ((.name) oldEnum))+  | (ctor, wire) <- (.ctors) oldEnum,+    isNothing (lookup ctor ((.ctors) newEnum))+  ]+    ++ [ breaking ((.name) newEnum) "enum-constructor" ctor EnumWireSpellingChanged ("wire spelling changed '" <> oldWire <> "' -> '" <> newWire <> "'; stored values using the old spelling no longer decode" <> enumUsageSuffix oldSpec ((.name) oldEnum))+       | (ctor, oldWire) <- (.ctors) oldEnum,+         Just newWire <- [lookup ctor ((.ctors) newEnum)],+         oldWire /= newWire+       ]+    ++ concat+      [ enumAdditionDiff oldSpec newEnum ctor wire+      | (ctor, wire) <- (.ctors) newEnum,+        isNothing (lookup ctor ((.ctors) oldEnum))+      ]+      <> nominalBindingDeclDiff oldSpec "enum" ((.name) newEnum) ((.binding) oldEnum) ((.binding) newEnum)++nominalScalarDiff :: DiffEnv -> [Change]+nominalScalarDiff env =+  concatMap (uncurry scalarPairDiff) ((.matched) paired)+    <> [nominalDeclarationChange ((.name) declaration) DeclarationAdded "new nominal scalar declaration" | declaration <- (.added) paired]+    <> [nominalDeclarationChange ((.name) declaration) NominalRepresentationChanged "nominal scalar declaration removed while persisted uses may remain" | declaration <- (.removed) paired]+  where+    paired = pairDeclarations (.name) ((.nominalScalars) ((.old) env)) ((.nominalScalars) ((.new) env))+    scalarPairDiff oldDeclaration newDeclaration =+      [ nominalDeclarationChange+          ((.name) newDeclaration)+          NominalRepresentationChanged+          ( "nominal scalar representation changed '"+              <> (.representation) oldDeclaration+              <> "' -> '"+              <> (.representation) newDeclaration+              <> "'"+          )+      | (.representation) oldDeclaration /= (.representation) newDeclaration+      ]+        <> nominalBindingDeclDiff+          ((.old) env)+          "scalar"+          ((.name) newDeclaration)+          (Just ((.binding) oldDeclaration))+          (Just ((.binding) newDeclaration))++data NominalUse+  = NominalCommandUse !Name !Name !Name+  | NominalEventUse !Name !Name !Name+  | NominalRegisterUse !Name !Name++nominalUses :: Spec -> Name -> [NominalUse]+nominalUses spec target = concatMap usesInAggregate [aggregate | NAggregate aggregate <- (.nodes) spec]+  where+    usesInAggregate aggregate =+      [ NominalCommandUse ((.name) aggregate) ((.name) command) ((.name) field)+      | command <- (.commands) aggregate,+        field <- (.fields) command,+        fieldReferences target field+      ]+        <> [ NominalEventUse ((.name) aggregate) ((.name) event) ((.name) field)+           | event <- (.events) aggregate,+             field <- eventFields aggregate event,+             fieldReferences target field+           ]+        <> [ NominalRegisterUse ((.name) aggregate) ((.name) register)+           | register <- (.regs) aggregate,+             (.valueType) register == TRef target+           ]+    eventFields aggregate event = case (.body) event of+      EventFields fields -> fields+      EventFromCommand commandName -> concat [(.fields) command | command <- (.commands) aggregate, (.name) command == commandName]+    fieldReferences targetName field = case (.valueType) field of+      Just (TRef typeName) -> typeName == targetName+      Just _ -> False+      Nothing -> pascalName ((.name) field) == targetName+    pascalName value = case T.uncons value of+      Nothing -> value+      Just (initialChar, rest) -> T.cons (toUpper initialChar) rest++nominalBindingDeclDiff :: Spec -> Text -> Name -> Maybe NominalBindingDecl -> Maybe NominalBindingDecl -> [Change]+nominalBindingDeclDiff oldSpec category name oldBinding newBinding =+  concat+    [ nominalFinding NominalBindingChanged "binding source, symbol, or version changed; rebuild every consumer use and audit persisted event uses because hand-written conversion behavior is opaque"+    | bindingRuntimeFacts oldBinding /= bindingRuntimeFacts newBinding+    ]+    <> concat+      [ nominalFinding NominalFixturesChanged "fixture symbol changed; rerun nominal conformance without claiming runtime wire behavior changed"+      | ((\binding -> binding.fixtures) =<< oldBinding) /= ((\binding -> binding.fixtures) =<< newBinding)+      ]+    <> concat+      [ nominalFinding NominalCanonicalTypeChanged "canonical nominal identity changed; rebuild consumers and invalidate snapshot caches at register uses"+      | ((\binding -> binding.canonicalType) =<< oldBinding) /= ((\binding -> binding.canonicalType) =<< newBinding)+      ]+    <> concat+      [ nominalFinding NominalInitialChanged "consumer-owned initial value symbol changed; rebuild and invalidate snapshot-bearing register streams"+      | ((\binding -> binding.initial) =<< oldBinding) /= ((\binding -> binding.initial) =<< newBinding)+      ]+  where+    bindingRuntimeFacts declaration =+      ( (\binding -> binding.haskell) =<< declaration,+        (\binding -> binding.binding) =<< declaration,+        (\binding -> binding.bindingVersion) =<< declaration+      )+    nominalFinding code detail =+      nominalDeclarationChange name code (category <> " " <> detail)+        : [nominalUseChange use code detail | use <- nominalUses oldSpec name, includeUse code use]+    includeUse NominalFixturesChanged _ = False+    includeUse NominalCanonicalTypeChanged NominalRegisterUse {} = True+    includeUse NominalCanonicalTypeChanged _ = False+    includeUse NominalInitialChanged NominalRegisterUse {} = True+    includeUse NominalInitialChanged _ = False+    includeUse _ NominalCommandUse {} = False+    includeUse _ _ = True++nominalDeclarationChange :: Name -> DiagnosticCode -> Text -> Change+nominalDeclarationChange name code detail =+  mkChange+    (deriveLabel defaultGate vector)+    context+    name+    "nominal-build"+    name+    code+    detail+  where+    context = (consumerBuildContext name [name]) {contextOriginalLabel = LabelAdvisory}+    vector = classifyCompatibility context code++nominalUseChange :: NominalUse -> DiagnosticCode -> Text -> Change+nominalUseChange use code detail =+  mkChange (deriveLabel defaultGate vector) context root facet subject code detail+  where+    (root, facet, subject, kind) = case use of+      NominalCommandUse aggregate command field -> (aggregate, "nominal-command", aggregate <> " command " <> command <> " ." <> field, ContextConsumerBuild)+      NominalEventUse aggregate event field -> (aggregate, "nominal-event", aggregate <> " event " <> event <> " ." <> field, ContextPrivateEvent)+      NominalRegisterUse aggregate register -> (aggregate, "nominal-register", aggregate <> " register " <> register, ContextSnapshot)+    context = ChangeContext root [subject] kind LabelAdvisory+    vector = classifyCompatibility context code++addedEnumDiff :: EnumDecl -> [Change]+addedEnumDiff enumDecl =+  [additive ((.name) enumDecl) "enum-constructor" ctor EnumCtorAdded ("new enum constructor with wire spelling '" <> wire <> "'") | (ctor, wire) <- (.ctors) enumDecl]++enumAdditionDiff :: Spec -> EnumDecl -> Name -> Text -> [Change]+enumAdditionDiff oldSpec enumDecl ctor wire = case enumUsages oldSpec ((.name) enumDecl) of+  [] ->+    [ additive+        ((.name) enumDecl)+        "enum-constructor"+        ctor+        EnumCtorAdded+        ("new constructor with wire spelling '" <> wire <> "'")+    ]+  usages -> map finding usages+  where+    finding usage+      | ".reg." `T.isInfixOf` usage =+          advisoryAt+            (snapshotContext ((.name) enumDecl) [usage])+            ((.name) enumDecl)+            "enum-constructor"+            ctor+            EnumCtorAdded+            ("new constructor with wire spelling '" <> wire <> "' is used by " <> usage <> "; invalidate or rebuild snapshots before values using the new arm hydrate")+      | otherwise =+          advisoryAt+            (privateEventAdditionContext ((.name) enumDecl) [usage])+            ((.name) enumDecl)+            "enum-constructor"+            ctor+            EnumCtorAdded+            ("new constructor with wire spelling '" <> wire <> "' is used by " <> usage <> "; deploy consumers before producers emit the new arm")++removedEnumDiff :: Spec -> EnumDecl -> [Change]+removedEnumDiff oldSpec enumDecl =+  [ breaking ((.name) enumDecl) "enum-constructor" ctor EnumCtorRemoved ("enum removed; stored wire value '" <> wire <> "' no longer decodes" <> enumUsageSuffix oldSpec ((.name) enumDecl))+  | (ctor, wire) <- (.ctors) enumDecl+  ]++enumUsageSuffix :: Spec -> Name -> Text+enumUsageSuffix spec enumType = case enumUsages spec enumType of+  [] -> ""+  usages -> "; used by " <> commas usages++enumUsages :: Spec -> Name -> [Text]+enumUsages spec enumType =+  [(.name) agg <> ".reg." <> (.name) reg | agg <- aggregates, reg <- (.regs) agg, (.valueType) reg == TRef enumType]+    ++ [ (.name) agg <> ".event." <> (.name) event <> "." <> (.dslName) field+       | agg <- aggregates,+         event <- (.events) agg,+         field <- eventFieldSigs agg event,+         Just fieldTypeName <- [(.valueType) field],+         fieldTypeName == TRef enumType+       ]+  where+    aggregates = [agg | NAggregate agg <- (.nodes) spec]++pairDeclarations :: (n -> Name) -> [n] -> [n] -> Paired n+pairDeclarations nameOf oldNodes newNodes =+  Paired+    { matched =+        [ (oldNode, newNode)+        | newNode <- newNodes,+          Just oldNode <- [find ((== nameOf newNode) . nameOf) oldNodes]+        ],+      added = [newNode | newNode <- newNodes, isNothing (find ((== nameOf newNode) . nameOf) oldNodes)],+      removed = [oldNode | oldNode <- oldNodes, isNothing (find ((== nameOf oldNode) . nameOf) newNodes)]+    }++contractDiff :: DiffEnv -> [Change]+contractDiff env =+  concatMap (uncurry contractPairDiff) ((.matched) paired)+    ++ concatMap addedContractDiff ((.added) paired)+    ++ concatMap removedContractDiff ((.removed) paired)+  where+    paired = pairByName nodeContract (.name) env++contractPairDiff :: ContractNode -> ContractNode -> [Change]+contractPairDiff oldContract newContract =+  schemaChanges+    ++ discriminatorChanges+    ++ topicChanges+    ++ concatMap eventPairChanges matchedEvents+    ++ concatMap addedEventChanges addedEvents+    ++ concatMap removedEventChanges removedEvents'+  where+    schemaChanges =+      [ breaking+          ((.name) newContract)+          "schema-version"+          ((.name) newContract)+          ContractSchemaVersionDecreased+          ("schemaVersion decreased from " <> tInt ((.schemaVersion) oldContract) <> " to " <> tInt ((.schemaVersion) newContract))+      | (.schemaVersion) newContract < (.schemaVersion) oldContract+      ]+    discriminatorChanges =+      [ breaking+          ((.name) newContract)+          "discriminator"+          ((.name) newContract)+          ContractDiscriminatorChanged+          ("discriminator changed " <> (.discriminator) oldContract <> " -> " <> (.discriminator) newContract)+      | (.discriminator) oldContract /= (.discriminator) newContract+      ]+    topicChanges = contractTopicDiff oldContract newContract+    eventPairs = pairDeclarations (.name) ((.events) oldContract) ((.events) newContract)+    matchedEvents = (.matched) eventPairs+    addedEvents = (.added) eventPairs+    removedEvents' = (.removed) eventPairs+    eventPairChanges (oldEvent, newEvent) = contractEventDiff oldContract newContract oldEvent newEvent+    addedEventChanges event =+      [additive ((.name) newContract) "contract-event" ((.name) event) ContractEventAdded "new contract event"]+    removedEventChanges event =+      [breaking ((.name) newContract) "contract-event" ((.name) event) ContractEventRemoved "contract event removed; existing cross-service payloads no longer have a declared decoder"]++addedContractDiff :: ContractNode -> [Change]+addedContractDiff contract =+  [additive ((.name) contract) "contract-event" ((.name) event) ContractEventAdded "new event in a new contract" | event <- (.events) contract]++removedContractDiff :: ContractNode -> [Change]+removedContractDiff contract =+  [breaking ((.name) contract) "contract-event" ((.name) event) ContractEventRemoved "contract removed; its cross-service event decoder is no longer declared" | event <- (.events) contract]++contractTopicDiff :: ContractNode -> ContractNode -> [Change]+contractTopicDiff oldContract newContract =+  [ breaking+      ((.name) newContract)+      "contract-topic"+      alias+      ContractTopicChanged+      ("topic alias removed; previous topic was '" <> oldTopic <> "'")+  | (alias, oldTopic) <- (.topics) oldContract,+    isNothing (lookup alias ((.topics) newContract))+  ]+    ++ [ breaking+           ((.name) newContract)+           "contract-topic"+           alias+           ContractTopicChanged+           ("real topic changed '" <> oldTopic <> "' -> '" <> newTopic <> "'")+       | (alias, oldTopic) <- (.topics) oldContract,+         Just newTopic <- [lookup alias ((.topics) newContract)],+         oldTopic /= newTopic+       ]+    ++ [ additive ((.name) newContract) "contract-topic" alias ContractTopicAdded ("new topic alias for '" <> topic <> "'")+       | (alias, topic) <- (.topics) newContract,+         isNothing (lookup alias ((.topics) oldContract))+       ]++contractEventDiff :: ContractNode -> ContractNode -> ContractEvent -> ContractEvent -> [Change]+contractEventDiff oldContract newContract oldEvent newEvent =+  topicAliasChange+    ++ removedFieldChanges+    ++ changedFieldChanges+    ++ selectorFieldChanges+    ++ wireKeyFieldChanges+    ++ addedFieldChanges+  where+    fieldPairs = pairDeclarations (.name) ((.fields) oldEvent) ((.fields) newEvent)+    topicAliasChange =+      [ breaking+          ((.name) newContract)+          "contract-topic"+          ((.name) newEvent)+          ContractTopicChanged+          ("event topic alias changed " <> (.topic) oldEvent <> " -> " <> (.topic) newEvent)+      | (.topic) oldEvent /= (.topic) newEvent+      ]+    removedFieldChanges =+      [ breaking ((.name) newContract) "contract-field" ((.name) newEvent <> "." <> (.name) field) ContractFieldChanged "field removed; existing messages still carry the old contract shape"+      | field <- (.removed) fieldPairs+      ]+    changedFieldChanges =+      [ breaking+          ((.name) newContract)+          "contract-field"+          ((.name) newEvent <> "." <> (.name) newField)+          ContractFieldChanged+          ("field type changed " <> renderContractType ((.valueType) oldField) <> " -> " <> renderContractType ((.valueType) newField))+      | (oldField, newField) <- (.matched) fieldPairs,+        (.valueType) oldField /= (.valueType) newField+      ]+    selectorFieldChanges =+      [ fieldSelectorChange+          ((.name) newContract)+          "contract-field-selector"+          ((.name) newEvent <> "." <> (.name) newField)+          ((.selector) (resolveContractFieldIdentity oldField))+          ((.selector) (resolveContractFieldIdentity newField))+          "contract field selector"+      | (oldField, newField) <- (.matched) fieldPairs,+        (.selector) (resolveContractFieldIdentity oldField)+          /= (.selector) (resolveContractFieldIdentity newField)+      ]+    wireKeyFieldChanges =+      [ breaking+          ((.name) newContract)+          "contract-field"+          ((.name) newEvent <> "." <> (.name) newField)+          ContractFieldChanged+          ( "wire key changed '"+              <> (.wireKey) (resolveContractFieldIdentity oldField)+              <> "' -> '"+              <> (.wireKey) (resolveContractFieldIdentity newField)+              <> "'; restore the old key or revise the public contract with a consumer-first rollout"+          )+      | (oldField, newField) <- (.matched) fieldPairs,+        (.wireKey) (resolveContractFieldIdentity oldField)+          /= (.wireKey) (resolveContractFieldIdentity newField)+      ]+    addedFieldChanges =+      [ if (.schemaVersion) newContract > (.schemaVersion) oldContract+          then advisory ((.name) newContract) "contract-field" subject ContractSchemaVersionBumped ("field added with schemaVersion bump " <> tInt ((.schemaVersion) oldContract) <> " -> " <> tInt ((.schemaVersion) newContract) <> "; coordinate the cross-service rollout")+          else breaking ((.name) newContract) "contract-field" subject ContractFieldChanged "field added without a schemaVersion bump; older in-flight messages do not contain it"+      | field <- (.added) fieldPairs,+        let subject = (.name) newEvent <> "." <> (.name) field+      ]++renderContractType :: ContractType -> Text+renderContractType (CTypeId prefix) = "typeid '" <> prefix <> "'"+renderContractType CText = "text"+renderContractType CInt = "int"++workqueueDiff :: DiffEnv -> [Change]+workqueueDiff env =+  concatMap (uncurry workqueuePairDiff) ((.matched) paired)+    ++ concatMap addedWorkqueueDiff ((.added) paired)+    ++ concatMap removedWorkqueueDiff ((.removed) paired)+  where+    paired = pairWorkqueues env++-- | Prefer source identity, then pair a uniquely renamed queue by its complete+-- explicit runtime identity. This permits a generated module-segment rename to+-- remain a build-only finding without guessing when an external identity is+-- ambiguous.+pairWorkqueues :: DiffEnv -> Paired WorkqueueNode+pairWorkqueues env =+  Paired+    { matched = exact <> fallback,+      added = [queue | queue <- unmatchedNew, queue `notElem` map snd fallback],+      removed = [queue | queue <- unmatchedOld, queue `notElem` map fst fallback]+    }+  where+    oldQueues = mapMaybe nodeWorkqueue ((.nodes) ((.old) env))+    newQueues = mapMaybe nodeWorkqueue ((.nodes) ((.new) env))+    exact =+      [ (oldQueue, newQueue)+      | newQueue <- newQueues,+        Just oldQueue <- [find ((== (.name) newQueue) . (.name)) oldQueues]+      ]+    exactOldNames = map ((.name) . fst) exact+    exactNewNames = map ((.name) . snd) exact+    unmatchedOld = [queue | queue <- oldQueues, (.name) queue `notElem` exactOldNames]+    unmatchedNew = [queue | queue <- newQueues, (.name) queue `notElem` exactNewNames]+    fallback =+      [ (oldQueue, newQueue)+      | newQueue <- unmatchedNew,+        let matchingOld = [queue | queue <- unmatchedOld, queueIdentity queue == queueIdentity newQueue],+        [oldQueue] <- [matchingOld],+        length [queue | queue <- unmatchedNew, queueIdentity queue == queueIdentity newQueue] == 1+      ]++workqueuePairDiff :: WorkqueueNode -> WorkqueueNode -> [Change]+workqueuePairDiff oldQueue newQueue =+  generatedNameChanges+    ++ concatMap pairedFieldDiff ((.matched) fields)+    ++ concatMap addedFieldDiff ((.added) fields)+    ++ concatMap removedFieldDiff ((.removed) fields)+    ++ queueIdentityDiff oldQueue newQueue+    ++ queuePolicyDiff oldQueue newQueue+  where+    generatedNameChanges =+      [ generatedNameChange+          ((.name) newQueue)+          "workqueue-module"+          ((.name) newQueue)+          ((.name) oldQueue)+          ((.name) newQueue)+          "workqueue module segment"+      | (.name) oldQueue /= (.name) newQueue,+        normalizedGeneratedUpper ((.name) oldQueue) /= normalizedGeneratedUpper ((.name) newQueue)+      ]+        ++ [ generatedNameChange+               ((.name) newQueue)+               "workqueue-payload-type"+               ((.payloadName) newQueue)+               ((.payloadName) oldQueue)+               ((.payloadName) newQueue)+               "workqueue payload type"+           | (.payloadName) oldQueue /= (.payloadName) newQueue,+             normalizedGeneratedUpper ((.payloadName) oldQueue) /= normalizedGeneratedUpper ((.payloadName) newQueue)+           ]+    fields = pairDeclarations (.name) ((.payload) oldQueue) ((.payload) newQueue)+    pairedFieldDiff (oldField, newField)+      | (.wire) oldField /= (.wire) newField = [payloadBreaking newField ("wire name changed '" <> (.wire) oldField <> "' -> '" <> (.wire) newField <> "'")]+      | (.valueType) oldField /= (.valueType) newField = [payloadBreaking newField ("type changed " <> renderQueuePayloadType ((.valueType) oldField) <> " -> " <> renderQueuePayloadType ((.valueType) 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 =+      withMappedConsequences+        (Set.fromList [MappedConsumerBuild consumer, MappedWorkqueueHistory ((.name) newQueue)])+        (breaking ((.name) newQueue) "payload-field" ((.name) field) WqPayloadFieldChanged detail)+      where+        consumer = WorkqueueConsumer ((.name) newQueue)++addedWorkqueueDiff :: WorkqueueNode -> [Change]+addedWorkqueueDiff queue =+  [additive ((.name) queue) "payload-field" ((.name) field) DeclarationAdded "field belongs to a new workqueue payload" | field <- (.payload) queue]++removedWorkqueueDiff :: WorkqueueNode -> [Change]+removedWorkqueueDiff queue =+  [breaking ((.name) queue) "payload-field" ((.name) field) WqPayloadFieldChanged "workqueue removed while persisted jobs may still carry this payload" | field <- (.payload) queue]+    ++ [breaking ((.name) queue) "queue-identity" ((.name) queue) QueueIdentityChanged "workqueue removed; its physical queue, DLQ, and pgmq table may still hold state"]++queueIdentityDiff :: WorkqueueNode -> WorkqueueNode -> [Change]+queueIdentityDiff oldQueue newQueue =+  [ breaking+      ((.name) newQueue)+      "queue-identity"+      ((.name) newQueue)+      QueueIdentityChanged+      "logical, physical, DLQ, or table name changed; queued jobs and dispatch dedupe records remain under the old identity"+  | queueIdentity oldQueue /= queueIdentity newQueue+  ]++queueIdentity :: WorkqueueNode -> (Text, Text, Text, Text)+queueIdentity queue = ((.logical) queue, (.physical) queue, (.dlq) queue, (.table) queue)++generatedNameChange :: Name -> Text -> Text -> Text -> Text -> Text -> Change+generatedNameChange node facet subject oldLogical newLogical occurrenceKind =+  advisory+    node+    facet+    subject+    GeneratedHaskellNameChanged+    ( occurrenceKind+        <> " changed '"+        <> normalizedGeneratedUpper oldLogical+        <> "' -> '"+        <> normalizedGeneratedUpper newLogical+        <> "' while wire, SQL, queue, registry, subscription, and persisted runtime identities remain unchanged; re-scaffold and recompile consumers"+    )++fieldSelectorChange :: Name -> Text -> Text -> Text -> Text -> Text -> Change+fieldSelectorChange node facet subject oldSelector newSelector occurrenceKind =+  advisory+    node+    facet+    subject+    GeneratedHaskellNameChanged+    ( occurrenceKind+        <> " changed '"+        <> oldSelector+        <> "' -> '"+        <> newSelector+        <> "' while DSL and wire identities remain unchanged; re-scaffold and recompile consumers"+    )++normalizedGeneratedUpper :: Text -> Text+normalizedGeneratedUpper logicalName =+  case HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site of+    Right derived -> HaskellName.renderUpperCamelName ((.upperCamel) derived)+    Left _ -> logicalName+  where+    site =+      HaskellName.NameSite+        { HaskellName.kind = HaskellName.GeneratedTypeSite,+          HaskellName.logicalName = logicalName,+          HaskellName.owner = "diff",+          HaskellName.line = 0+        }++queuePolicyDiff :: WorkqueueNode -> WorkqueueNode -> [Change]+queuePolicyDiff oldQueue newQueue = ordering ++ provision ++ groupKey+  where+    nodeName = (.name) newQueue+    ordering =+      [ breaking nodeName "queue-ordering" nodeName WqOrderingChanged $+          "ordering changed " <> renderWqOrdering ((.ordering) oldQueue) <> " -> " <> renderWqOrdering ((.ordering) newQueue) <> "; consumers were written against the old delivery-order contract"+      | (.ordering) oldQueue /= (.ordering) newQueue+      ]+    provision =+      [ breaking nodeName "queue-provision" nodeName WqProvisionChanged $+          "provision changed " <> renderWqProvision ((.provision) oldQueue) <> " -> " <> renderWqProvision ((.provision) newQueue) <> "; provisioning is create-time only, so migrate the existing queue operationally before changing the spec"+      | (.provision) oldQueue /= (.provision) newQueue+      ]+    groupKey =+      [ breaking nodeName "queue-group-key" nodeName WqGroupKeyChanged $+          "group key derivation changed " <> renderWqGroupKey ((.groupKey) oldQueue) <> " -> " <> renderWqGroupKey ((.groupKey) newQueue) <> "; FIFO messages are re-partitioned across durable ordering groups"+      | (.groupKey) oldQueue /= (.groupKey) newQueue+      ]++renderWqOrdering :: WqOrdering -> Text+renderWqOrdering WqUnordered = "unordered"+renderWqOrdering WqFifoThroughput = "fifo-throughput"+renderWqOrdering WqFifoRoundRobin = "fifo-roundrobin"++renderWqProvision :: WqProvision -> Text+renderWqProvision WqStandard = "standard"+renderWqProvision WqUnlogged = "unlogged"+renderWqProvision (WqPartitioned interval duration) = "partitioned(interval=" <> interval <> ", retention=" <> duration <> ")"++renderWqGroupKey :: Maybe WqGroupKey -> Text+renderWqGroupKey Nothing = "none"+renderWqGroupKey (Just groupKey) =+  (.field) groupKey+    <> " via "+    <> (.via) groupKey+    <> maybe "" (" fixture " <>) ((.fixture) groupKey)++processDiff :: DiffEnv -> [Change]+processDiff env =+  concatMap (uncurry processPairDiff) ((.matched) paired)+    ++ concatMap addedProcessDiff ((.added) paired)+    ++ concatMap removedProcessDiff ((.removed) paired)+  where+    paired = pairByName nodeProcess (.id) env++processPairDiff :: ProcessNode -> ProcessNode -> [Change]+processPairDiff oldProcess newProcess =+  concatMap pairedFieldDiff ((.matched) fields)+    ++ map (fieldChange "field added; source events at the old shape cannot populate it") ((.added) fields)+    ++ map (fieldChange "field removed; the generated process input decoder changed") ((.removed) fields)+    ++ processIdentityDiff oldProcess newProcess+    ++ processTimerWindowDiff oldProcess newProcess+    ++ processDecideSurfaceDiff oldProcess newProcess+    ++ processTimerPayloadDiff oldProcess newProcess+  where+    -- inName is a generated Haskell type name; the wire shape is inFields.+    fields = pairDeclarations (.name) ((.fields) ((.input) oldProcess)) ((.fields) ((.input) newProcess))+    pairedFieldDiff (oldField, newField)+      | (.valueType) oldField /= (.valueType) newField = [fieldChange ("type changed " <> renderFieldType ((.valueType) oldField) <> " -> " <> renderFieldType ((.valueType) newField)) newField]+      | otherwise = []+    fieldChange detail field = breaking ((.id) newProcess) "input-field" ((.name) field) ProcessInputChanged (detail <> "; version the source event before changing process input")++addedProcessDiff :: ProcessNode -> [Change]+addedProcessDiff process =+  [additive ((.id) process) "input-field" ((.name) field) DeclarationAdded "field belongs to a new process input" | field <- (.fields) ((.input) process)]++removedProcessDiff :: ProcessNode -> [Change]+removedProcessDiff process =+  [breaking ((.id) process) "input-field" ((.name) field) ProcessInputChanged "process removed while persisted source events may still require this input decoder" | field <- (.fields) ((.input) process)]+    ++ [breaking ((.id) process) "derived-identity" ((.id) process) DerivedIdentityChanged "process removed while persisted saga, dispatch, and timer identities may still exist"]++processIdentityDiff :: ProcessNode -> ProcessNode -> [Change]+processIdentityDiff oldProcess newProcess =+  [ breaking+      ((.id) newProcess)+      "derived-identity"+      ((.id) newProcess)+      DerivedIdentityChanged+      "process name, correlation derivation, saga stream category, timer id expression, or fired-event-id expression changed; replays and retries no longer derive the persisted identity"+  | processIdentity oldProcess /= processIdentity newProcess+  ]++processIdentity :: ProcessNode -> (Text, Name, Name, Text, Text, Name, Text, Name)+processIdentity process =+  ( (.name) process,+    (.field) ((.correlate) process),+    (.via) ((.correlate) process),+    (.category) ((.saga) process),+    (.prefix) ((.id) ((.timer) process)),+    (.field) ((.id) ((.timer) process)),+    (.prefix) ((.firedEventId) ((.fire) ((.timer) process))),+    (.field) ((.firedEventId) ((.fire) ((.timer) process)))+  )++processTimerWindowDiff :: ProcessNode -> ProcessNode -> [Change]+processTimerWindowDiff oldProcess newProcess =+  [ advisory+      ((.id) newProcess)+      "timer"+      ((.name) ((.timer) newProcess))+      TimerWindowChanged+      ( "fireAt source/window changed "+          <> renderFireAt ((.fireAt) ((.timer) oldProcess))+          <> " -> "+          <> renderFireAt ((.fireAt) ((.timer) newProcess))+          <> "; already-scheduled timers keep their persisted deadline"+      )+  | (.fireAt) ((.timer) oldProcess) /= (.fireAt) ((.timer) newProcess)+  ]++processDecideSurfaceDiff :: ProcessNode -> ProcessNode -> [Change]+processDecideSurfaceDiff oldProcess newProcess =+  [ advisory+      ((.id) newProcess)+      "process-decide"+      ((.id) newProcess)+      ProcessDecideSurfaceChanged+      "process dispatch surface changed: a source event redelivered across the deploy dispatches under the same deterministic ids, so half-old/half-new fan-out merges silently. Drain or pause the process subscription and replay or discard dead letters before deploying; see docs/user/deploy-ordering.md. Hole-only decide changes are not visible to diff; the same drain rule applies to those too."+  | renderHandleSurface ((.handle) oldProcess)+      /= renderHandleSurface ((.handle) newProcess)+  ]++processTimerPayloadDiff :: ProcessNode -> ProcessNode -> [Change]+processTimerPayloadDiff oldProcess newProcess =+  [ advisory+      ((.id) newProcess)+      "timer-payload"+      ((.name) ((.timer) newProcess))+      ProcessTimerPayloadChanged+      "timer payload shape changed: rows scheduled before the deploy carry the old shape, unversioned, and fire under new code — the fire decoder must accept every historically scheduled shape or the timer dead-letters after maxAttempts. Hole-only timer-decoder changes are not visible to diff; the same drain rule applies to those too."+  | renderTimerPayloadSurface ((.timer) oldProcess)+      /= renderTimerPayloadSurface ((.timer) newProcess)+  ]++renderFireAt :: FireAtExpr -> Text+renderFireAt expression = "input." <> (.field) expression <> " + " <> (.window) expression++workflowDiff :: DiffEnv -> [Change]+workflowDiff env =+  concatMap (uncurry workflowPairDiff) ((.matched) paired)+    ++ concatMap addedWorkflowDiff ((.added) paired)+    ++ concatMap removedWorkflowDiff ((.removed) paired)+  where+    paired = pairByName nodeWorkflow (.id) env++workflowPairDiff :: WorkflowNode -> WorkflowNode -> [Change]+workflowPairDiff oldWorkflow newWorkflow =+  inputChanges+    ++ outputChanges+    ++ classifyWorkflowBody oldWorkflow newWorkflow+    ++ workflowIdentityDiff oldWorkflow newWorkflow+  where+    fields = pairDeclarations (.name) ((.inputFields) oldWorkflow) ((.inputFields) newWorkflow)+    inputChanges =+      [workflowShape field "input field added; journaled inputs at the old shape do not contain it" | field <- (.added) fields]+        ++ [workflowShape field "input field removed; journaled inputs still contain the old shape" | field <- (.removed) fields]+        ++ [ workflowShape newField ("input field type changed " <> renderFieldType ((.valueType) oldField) <> " -> " <> renderFieldType ((.valueType) newField))+           | (oldField, newField) <- (.matched) fields,+             (.valueType) oldField /= (.valueType) newField+           ]+    outputChanges =+      [ breaking ((.id) newWorkflow) "workflow-output" ((.output) newWorkflow) WorkflowShapeChanged ("output type changed " <> (.output) oldWorkflow <> " -> " <> (.output) newWorkflow <> "; persisted outcomes may no longer decode")+      | (.output) oldWorkflow /= (.output) newWorkflow+      ]+    workflowShape field detail = breaking ((.id) newWorkflow) "workflow-input" ((.name) field) WorkflowShapeChanged detail++addedWorkflowDiff :: WorkflowNode -> [Change]+addedWorkflowDiff workflow = [additive ((.id) workflow) "workflow" ((.id) workflow) DeclarationAdded "new workflow"]++removedWorkflowDiff :: WorkflowNode -> [Change]+removedWorkflowDiff workflow = [breaking ((.id) workflow) "workflow" ((.id) workflow) WorkflowShapeChanged "workflow removed while in-flight journals and outcomes may still require its decoder"]++workflowIdentityDiff :: WorkflowNode -> WorkflowNode -> [Change]+workflowIdentityDiff oldWorkflow newWorkflow =+  [ breaking+      ((.id) newWorkflow)+      "workflow-name"+      ((.id) newWorkflow)+      WorkflowStableNameChanged+      ("stable name changed '" <> (.stable) oldWorkflow <> "' -> '" <> (.stable) newWorkflow <> "'; in-flight journals remain under the old stream name")+  | (.stable) oldWorkflow /= (.stable) newWorkflow+  ]+    ++ [ breaking+           ((.id) newWorkflow)+           "derived-identity"+           ((.id) newWorkflow)+           DerivedIdentityChanged+           "workflow id source field or derivation changed; journal and deterministic child/step identities no longer coalesce with persisted executions"+       | ((.idField) oldWorkflow, (.idVia) oldWorkflow) /= ((.idField) newWorkflow, (.idVia) newWorkflow)+       ]++intakeDiff :: DiffEnv -> [Change]+intakeDiff env =+  concatMap (uncurry intakePairDiff) ((.matched) paired)+    ++ concatMap addedIntakeDiff ((.added) paired)+    ++ concatMap removedIntakeDiff ((.removed) paired)+  where+    paired = pairByName nodeIntake (.name) env++intakePairDiff :: IntakeNode -> IntakeNode -> [Change]+intakePairDiff oldIntake newIntake =+  [ breaking+      ((.name) newIntake)+      "dedupe-identity"+      ((.name) newIntake)+      DedupeIdentityChanged+      "dedupe key or policy changed; redelivered messages no longer match their persisted dedupe record"+  | ((.dedupeKey) oldIntake, (.dedupePolicy) oldIntake) /= ((.dedupeKey) newIntake, (.dedupePolicy) newIntake)+  ]+    ++ [ advisory+           ((.name) newIntake)+           "decode-posture"+           ((.name) newIntake)+           DecodePostureChanged+           "envelope/body decode posture changed; future messages are accepted or rejected differently"+       | (.decode) oldIntake /= (.decode) newIntake+       ]+    ++ [ advisory+           ((.name) newIntake)+           "inbox-persistence"+           ((.name) newIntake)+           IntakePersistenceChanged+           ("success-path envelope persistence changed " <> renderInkPersist ((.persist) oldIntake) <> " -> " <> renderInkPersist ((.persist) newIntake) <> "; existing rows are unchanged while future successful rows retain a different envelope shape")+       | (.persist) oldIntake /= (.persist) newIntake+       ]++renderInkPersist :: InkPersist -> Text+renderInkPersist InkPersistFull = "full-envelope"+renderInkPersist InkPersistDedupeOnly = "dedupe-only"++addedIntakeDiff :: IntakeNode -> [Change]+addedIntakeDiff intake = [additive ((.name) intake) "intake" ((.name) intake) DeclarationAdded "new intake"]++removedIntakeDiff :: IntakeNode -> [Change]+removedIntakeDiff intake = [breaking ((.name) intake) "dedupe-identity" ((.name) intake) DedupeIdentityChanged "intake removed while persisted dedupe records and redeliveries may remain"]++emitDiff :: DiffEnv -> [Change]+emitDiff env =+  concatMap (uncurry emitPairDiff) ((.matched) paired)+    ++ concatMap addedEmitDiff ((.added) paired)+    ++ concatMap removedEmitDiff ((.removed) paired)+  where+    paired = pairByName nodeEmit (.name) env++emitPairDiff :: EmitNode -> EmitNode -> [Change]+emitPairDiff oldEmit newEmit =+  [ breaking+      ((.name) newEmit)+      "derived-identity"+      "messageId"+      DerivedIdentityChanged+      "messageId derive prefix changed; outbox retries no longer coalesce with persisted messages"+  | (.messageId) oldEmit /= (.messageId) newEmit+  ]+    ++ [ breaking+           ((.name) newEmit)+           "derived-identity"+           "idempotencyKey"+           DerivedIdentityChanged+           "idempotencyKey derive prefix changed; downstream dedupe no longer matches persisted messages"+       | (.idempotencyKey) oldEmit /= (.idempotencyKey) newEmit+       ]+    ++ [ advisory+           ((.name) newEmit)+           "emit-mapping"+           ((.name) newEmit)+           EmitMappingChanged+           "emit key, status discriminant, mapping rows, or explicit skip posture changed"+       | emitMapping oldEmit /= emitMapping newEmit+       ]++emitMapping :: EmitNode -> (Name, Name, [EmitMapRow], Bool)+emitMapping emit = ((.key) emit, (.discriminant) emit, (.map) emit, (.skip) emit)++addedEmitDiff :: EmitNode -> [Change]+addedEmitDiff emit = [additive ((.name) emit) "emit" ((.name) emit) DeclarationAdded "new emit mapping"]++removedEmitDiff :: EmitNode -> [Change]+removedEmitDiff emit = [breaking ((.name) emit) "derived-identity" ((.name) emit) DerivedIdentityChanged "emit removed while persisted outbox identities may still retry"]++publisherDiff :: DiffEnv -> [Change]+publisherDiff env =+  concatMap (uncurry publisherPairDiff) ((.matched) paired)+    ++ concatMap addedPublisherDiff ((.added) paired)+    ++ concatMap removedPublisherDiff ((.removed) paired)+  where+    paired = pairByName nodePublisher (.name) env++publisherPairDiff :: PublisherNode -> PublisherNode -> [Change]+publisherPairDiff oldPublisher newPublisher =+  -- maxAttempts/backoff are retry tuning, not persisted decode or identity.+  [ breaking+      ((.name) newPublisher)+      "derived-identity"+      "outboxId"+      DerivedIdentityChanged+      "stable outbox-id source field changed; retries no longer coalesce with persisted outbox rows"+  | (.outboxField) oldPublisher /= (.outboxField) newPublisher+  ]+    ++ [ advisory+           ((.name) newPublisher)+           "publisher-policy"+           ((.name) newPublisher)+           PublisherPolicyChanged+           ("ordering changed " <> (.ordering) oldPublisher <> " -> " <> (.ordering) newPublisher)+       | (.ordering) oldPublisher /= (.ordering) newPublisher+       ]++addedPublisherDiff :: PublisherNode -> [Change]+addedPublisherDiff publisher = [additive ((.name) publisher) "publisher" ((.name) publisher) DeclarationAdded "new publisher"]++removedPublisherDiff :: PublisherNode -> [Change]+removedPublisherDiff publisher = [breaking ((.name) publisher) "derived-identity" ((.name) publisher) DerivedIdentityChanged "publisher removed while persisted outbox rows may still require its stable identity"]++pgmqDispatchDiff :: DiffEnv -> [Change]+pgmqDispatchDiff env =+  concatMap (uncurry pgmqDispatchPairDiff) ((.matched) paired)+    ++ concatMap addedPgmqDispatchDiff ((.added) paired)+    ++ concatMap removedPgmqDispatchDiff ((.removed) paired)+  where+    paired = pairByName nodePgmqDispatch (.name) env++pgmqDispatchPairDiff :: PgmqDispatchNode -> PgmqDispatchNode -> [Change]+pgmqDispatchPairDiff oldDispatch newDispatch =+  [ breaking+      ((.name) newDispatch)+      "dedupe-identity"+      ((.name) newDispatch)+      DedupeIdentityChanged+      "dispatch dedupe key/read-model/queue surface changed; prior enqueue records no longer match"+  | dispatchDedupe oldDispatch /= dispatchDedupe newDispatch+  ]+    ++ [ advisory+           ((.name) newDispatch)+           "retarget"+           ((.name) newDispatch)+           DispatchRetargeted+           "source read model or target queue changed; future fan-out is routed differently"+       | dispatchTargets oldDispatch /= dispatchTargets newDispatch+       ]++dispatchDedupe :: PgmqDispatchNode -> (Name, Name, Text, Name, Text)+dispatchDedupe dispatch =+  ( (.dedupKey) dispatch,+    (.dedupReadModel) dispatch,+    (.dedupReadModelField) dispatch,+    (.dedupQueue) dispatch,+    (.dedupQueueField) dispatch+  )++dispatchTargets :: PgmqDispatchNode -> (Name, Name)+dispatchTargets dispatch = ((.sourceReadModel) dispatch, (.enqueueTo) dispatch)++addedPgmqDispatchDiff :: PgmqDispatchNode -> [Change]+addedPgmqDispatchDiff dispatch = [additive ((.name) dispatch) "dispatch" ((.name) dispatch) DeclarationAdded "new pgmq dispatch"]++removedPgmqDispatchDiff :: PgmqDispatchNode -> [Change]+removedPgmqDispatchDiff dispatch = [breaking ((.name) dispatch) "dedupe-identity" ((.name) dispatch) DedupeIdentityChanged "dispatch removed while persisted queue and read-model dedupe records may remain"]++-- | Classify the runtime's sanctioned workflow-evolution mechanisms before+-- falling back to the conservative unguarded-body rule.+classifyWorkflowBody :: WorkflowNode -> WorkflowNode -> [Change]+classifyWorkflowBody oldWorkflow newWorkflow+  | oldBody == newBody = []+  | not (null removedPatchIds) = map removedPatch removedPatchIds+  | Just (oldSeedType, newSeedType) <- changedSeed =+      [ breaking nodeName "workflow-continue-as-new" nodeName WorkflowContinueSeedChanged $+          "continueAsNew seed type changed " <> oldSeedType <> " -> " <> newSeedType <> "; the next generation's restoreSeed must decode the seed written by the previous generation"+      ]+  | safeAdditions =+      map addedPatch newPatchIds+        ++ [ additive nodeName "workflow-continue-as-new" seedType WorkflowEvolutionGuardAdded "terminal continueAsNew is additive; old generations carry no rotation marker"+           | Just seedType <- [appendedSeed]+           ]+  | otherwise =+      [ breaking+          nodeName+          "workflow-body"+          nodeName+          WorkflowBodyChanged+          "workflow body labels, kinds, result types, or order changed without a new patch guard; wrap a cross-cutting change in patch, or rename the replay label for one changed step"+      ]+  where+    nodeName = (.id) newWorkflow+    oldBody = normaliseWorkflowBody ((.body) oldWorkflow)+    newBody = normaliseWorkflowBody ((.body) newWorkflow)+    oldPatchIds = workflowBodyPatchIds oldBody+    newPatchIdsAll = workflowBodyPatchIds newBody+    newPatchIds = newPatchIdsAll \\ oldPatchIds+    removedPatchIds = oldPatchIds \\ newPatchIdsAll+    oldSeed = terminalContinueSeed oldBody+    newSeed = terminalContinueSeed newBody+    changedSeed = case (oldSeed, newSeed) of+      (Just oldSeedType, Just newSeedType)+        | oldSeedType /= newSeedType -> Just (oldSeedType, newSeedType)+      _ -> Nothing+    appendedSeed = case (oldSeed, newSeed) of+      (Nothing, Just seedType) -> Just seedType+      _ -> Nothing+    strippedNewBody = stripNewPatches newPatchIds newBody+    comparableNewBody = case appendedSeed of+      Just _ -> dropTerminalContinue strippedNewBody+      Nothing -> strippedNewBody+    safeAdditions =+      (not (null newPatchIds) || isJust appendedSeed)+        && comparableNewBody == oldBody+    removedPatch patchId =+      breaking nodeName "workflow-patch" patchId WorkflowPatchRemoved "patch id existed in the old spec but was removed; the differ cannot prove that no workflow generation still replays its journaled branch"+    addedPatch patchId =+      additive nodeName "workflow-patch" patchId WorkflowEvolutionGuardAdded "new patch guard contains the entire body change, so in-flight generations retain their journaled branch"++normaliseWorkflowBody :: [WfBodyItem] -> [WfBodyItem]+normaliseWorkflowBody = map go+  where+    go (WfStep label result _) = WfStep label result noLoc+    go (WfAwait label result _) = WfAwait label result noLoc+    go (WfSleep label delay _) = WfSleep label delay noLoc+    go (WfChild label via result _) = WfChild label via result noLoc+    go (WfPatch patchId items _) = WfPatch patchId (normaliseWorkflowBody items) noLoc+    go (WfContinueAsNew seedType _) = WfContinueAsNew seedType noLoc++workflowBodyPatchIds :: [WfBodyItem] -> [Name]+workflowBodyPatchIds = concatMap go+  where+    go (WfPatch patchId items _) = patchId : workflowBodyPatchIds items+    go _ = []++stripNewPatches :: [Name] -> [WfBodyItem] -> [WfBodyItem]+stripNewPatches newPatchIds = concatMap go+  where+    go (WfPatch patchId _ _) | patchId `elem` newPatchIds = []+    go (WfPatch patchId items loc) = [WfPatch patchId (stripNewPatches newPatchIds items) loc]+    go item = [item]++terminalContinueSeed :: [WfBodyItem] -> Maybe Name+terminalContinueSeed items = case reverse items of+  WfContinueAsNew seedType _ : _ -> Just seedType+  _ -> Nothing++dropTerminalContinue :: [WfBodyItem] -> [WfBodyItem]+dropTerminalContinue items = case reverse items of+  WfContinueAsNew {} : rest -> reverse rest+  _ -> items++additive :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change+additive n facet subj code detail =+  mkChange LabelAdditive (contextFor LabelAdditive n facet subj code) n facet subj code detail++breaking :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change+breaking n facet subj code detail =+  mkChange LabelBreaking (contextFor LabelBreaking n facet subj code) n facet subj code detail++advisory :: Name -> Text -> Text -> DiagnosticCode -> Text -> Change+advisory n facet subj code detail =+  mkChange LabelAdvisory (contextFor LabelAdvisory n facet subj code) n facet subj code detail++advisoryAt :: ChangeContext -> Name -> Text -> Text -> DiagnosticCode -> Text -> Change+advisoryAt context n facet subj code detail =+  mkChange LabelAdvisory context n facet subj code detail++mkChange :: Label -> ChangeContext -> Name -> Text -> Text -> DiagnosticCode -> Text -> Change+mkChange label context n facet subj code detail =+  wrap+    ChangeKind+      { node = n,+        facet = facet,+        subject = subj,+        code = code,+        context = context,+        vector = classifyCompatibility context code,+        mappedPersistedImpact = case (.contextKind) context of+          ContextQueue -> Just (MappedPersistedImpact (WorkqueueHistory ((.root) context)) VBreaking)+          _ -> Nothing,+        mappedConsequences = Set.empty,+        paths = (.paths) context,+        detail = detail+      }+  where+    wrap = case label of+      LabelAdditive -> Additive+      LabelAdvisory -> Advisory+      LabelBreaking -> Breaking++contextFor :: Label -> Name -> Text -> Text -> DiagnosticCode -> ChangeContext+contextFor label root facet subject code =+  setLabel $ case () of+    _+      | code `elem` publicCodes -> publicContractContext root paths+      | code `elem` queueCodes -> queueContext root paths+      | code `elem` identityCodes -> persistedIdentityContext root paths+      | code `elem` [OwnershipMoved, WorkspaceAuthorityChanged, GeneratedHaskellNameChanged] -> consumerBuildContext root paths+      | code == AggFoldSurfaceChanged -> snapshotContext root paths+      | code == EnumCtorAdded -> ChangeContext root paths ContextGeneral label+      | code `elem` privateCodes -> privateEventContext root paths+      | otherwise -> ChangeContext root paths ContextGeneral label+  where+    paths = [pathFor root facet subject]+    setLabel context = ChangeContext context.root context.paths context.contextKind label     publicCodes =       [ ContractEventRemoved,         ContractFieldChanged,

src/Keiro/Dsl/DiffReport.hs view

@@ -71,10 +71,10 @@   deriving stock (Eq, Show)  data DiffReport = DiffReport-  { reportGate :: !(Set CompatibilitySurface),-    reportFindings :: ![Change],-    reportSemanticImpact :: !(Maybe [MappedImpactDelta]),-    reportCoordinationImpact :: !(Maybe [CoordinationImpact])+  { gate :: !(Set CompatibilitySurface),+    findings :: ![Change],+    semanticImpact :: !(Maybe [MappedImpactDelta]),+    coordinationImpact :: !(Maybe [CoordinationImpact])   }   deriving stock (Eq, Show) @@ -94,36 +94,36 @@  -- | One source location from a composed workspace's ownership index. data OwnedSite = OwnedSite-  { osFile :: !FilePath,-    osLine :: !Int+  { file :: !FilePath,+    line :: !Int   }   deriving stock (Eq, Show)  -- | A merged-graph finding enriched with declaration and use-site ownership. data WorkspaceChange = WorkspaceChange-  { wcChange :: !Change,-    wcDeclarationSite :: !(Maybe OwnedSite),-    wcUseSites :: ![(Text, Maybe OwnedSite)]+  { change :: !Change,+    declarationSite :: !(Maybe OwnedSite),+    useSites :: ![(Text, Maybe OwnedSite)]   }   deriving stock (Eq, Show)  -- | Provenance for the two workspace graphs compared by one command. data WorkspaceMeta = WorkspaceMeta-  { wmIdentity :: !Text,-    wmManifest :: !FilePath,-    wmSince :: !Text,-    wmMembersOld :: ![FilePath],-    wmMembersNew :: ![FilePath],-    wmAdoptionBaseline :: !Bool+  { identity :: !Text,+    manifest :: !FilePath,+    since :: !Text,+    membersOld :: ![FilePath],+    membersNew :: ![FilePath],+    adoptionBaseline :: !Bool   }   deriving stock (Eq, Show)  data WorkspaceDiffReport = WorkspaceDiffReport-  { workspaceReportMeta :: !WorkspaceMeta,-    workspaceReportGate :: !(Set CompatibilitySurface),-    workspaceReportFindings :: ![WorkspaceChange],-    workspaceReportSemanticImpact :: !(Maybe [MappedImpactDelta]),-    workspaceReportCoordinationImpact :: !(Maybe [CoordinationImpact])+  { meta :: !WorkspaceMeta,+    gate :: !(Set CompatibilitySurface),+    findings :: ![WorkspaceChange],+    semanticImpact :: !(Maybe [MappedImpactDelta]),+    coordinationImpact :: !(Maybe [CoordinationImpact])   }   deriving stock (Eq, Show) @@ -143,30 +143,30 @@   toJSON report =     object $       [ "schema" .= ("keiro-dsl/diff-report/1" :: Text),-        "gate" .= map surfaceName (Set.toAscList (reportGate report)),-        "breaking" .= (any (gatedBreaking (reportGate report)) (reportFindings report) || coordinationBreaking (reportCoordinationImpact report)),-        "findings" .= map (findingValue (reportGate report)) (reportFindings report)+        "gate" .= map surfaceName (Set.toAscList ((.gate) report)),+        "breaking" .= (any (gatedBreaking ((.gate) report)) ((.findings) report) || coordinationBreaking ((.coordinationImpact) report)),+        "findings" .= map (findingValue ((.gate) report)) ((.findings) report)       ]-        <> ["semanticImpact" .= semanticImpactValue impact | Just impact <- [reportSemanticImpact report]]-        <> ["coordinationImpact" .= impact | Just impact <- [reportCoordinationImpact report]]+        <> ["semanticImpact" .= semanticImpactValue impact | Just impact <- [(.semanticImpact) report]]+        <> ["coordinationImpact" .= impact | Just impact <- [(.coordinationImpact) report]]  instance ToJSON WorkspaceDiffReport where   toJSON report =     object $       [ "schema" .= ("keiro-dsl/diff-report/1" :: Text),-        "gate" .= map surfaceName (Set.toAscList (workspaceReportGate report)),-        "breaking" .= (any (gatedBreaking (workspaceReportGate report) . wcChange) (workspaceReportFindings report) || coordinationBreaking (workspaceReportCoordinationImpact report)),-        "findings" .= map (workspaceFindingValue (workspaceReportGate report)) (workspaceReportFindings report),-        "workspace" .= workspaceMetaValue (workspaceReportMeta report)+        "gate" .= map surfaceName (Set.toAscList ((.gate) report)),+        "breaking" .= (any (gatedBreaking ((.gate) report) . (.change)) ((.findings) report) || coordinationBreaking ((.coordinationImpact) report)),+        "findings" .= map (workspaceFindingValue ((.gate) report)) ((.findings) report),+        "workspace" .= workspaceMetaValue ((.meta) report)       ]-        <> ["semanticImpact" .= semanticImpactValue impact | Just impact <- [workspaceReportSemanticImpact report]]-        <> ["coordinationImpact" .= impact | Just impact <- [workspaceReportCoordinationImpact report]]+        <> ["semanticImpact" .= semanticImpactValue impact | Just impact <- [(.semanticImpact) report]]+        <> ["coordinationImpact" .= impact | Just impact <- [(.coordinationImpact) report]]  semanticImpactValue :: [MappedImpactDelta] -> Value semanticImpactValue impact = object ["declarations" .= impact]  coordinationBreaking :: Maybe [CoordinationImpact] -> Bool-coordinationBreaking = maybe False (any ((== CoordinationBreaking) . coordinationSeverity))+coordinationBreaking = maybe False (any ((== CoordinationBreaking) . (.severity)))  -- | Human-facing semantic dependency summary, kept separate from ordinary -- compatibility findings and generated-file evidence.@@ -175,14 +175,14 @@ 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"+      [ "  " <> (.unMappedKey) ((.declaration) delta),+        "    previous aggregate consumers: " <> renderBaseline ((.previousEvidence) delta) (renderConsumers ((.previousConsumers) delta)),+        "    current aggregate consumers:  " <> renderConsumers ((.currentConsumers) delta),+        "    previous roots: " <> maybe "baseline unavailable" renderEvidence ((.previousEvidence) delta),+        "    current roots:  " <> maybe "baseline unavailable" renderEvidence ((.currentEvidence) delta),+        "    previous consequences: " <> maybe "baseline unavailable" renderConsequences ((.previousConsequences) delta),+        "    current consequences:  " <> maybe "baseline unavailable" renderConsequences ((.currentConsequences) delta),+        "    service-conformance: " <> if (.serviceConformance) delta then "impacted" else "unchanged"       ]     renderConsumers aggregateConsumers = case map consumerName (Set.toAscList aggregateConsumers) of       [] -> "(none)"@@ -192,8 +192,8 @@     renderBaseline (Just _) value = value     renderEvidence values = renderSet renderRoot values     renderRoot evidence =-      T.intercalate "|" [mappedRootKindIdentity (evidenceRootKind evidence), mappedConsumerIdentity (evidenceConsumer evidence), evidencePath evidence]-        <> maybe "" ("|" <>) (evidenceOperation evidence)+      T.intercalate "|" [mappedRootKindIdentity ((.rootKind) evidence), mappedConsumerIdentity ((.consumer) evidence), (.path) evidence]+        <> maybe "" ("|" <>) ((.operation) evidence)     renderConsequences = renderSet mappedConsequenceIdentity     renderSet render values = case map render (Set.toAscList values) of       [] -> "(none)"@@ -205,43 +205,43 @@ workspaceFindingValue :: Set CompatibilitySurface -> WorkspaceChange -> Value workspaceFindingValue gate workspaceChange =   object-    ( findingPairs gate (wcChange workspaceChange)-        <> maybe [] (\site -> ["declaration" .= ownedSiteValue site]) (wcDeclarationSite workspaceChange)-        <> ["useSites" .= map useSiteValue (wcUseSites workspaceChange) | not (null (wcUseSites workspaceChange))]+    ( findingPairs gate ((.change) workspaceChange)+        <> maybe [] (\site -> ["declaration" .= ownedSiteValue site]) ((.declarationSite) workspaceChange)+        <> ["useSites" .= map useSiteValue ((.useSites) workspaceChange) | not (null ((.useSites) workspaceChange))]     )  findingPairs :: Set CompatibilitySurface -> Change -> [Pair] findingPairs gate change =-  [ "label" .= labelName (deriveLabel gate (ckVector kind)),-    "node" .= ckNode kind,-    "facet" .= ckFacet kind,-    "subject" .= ckSubject kind,-    "code" .= T.pack (show (ckCode kind)),-    "paths" .= ckPaths kind,-    "vector" .= vectorValue (ckVector kind),-    "detail" .= ckDetail kind,-    "remedies" .= map renderRemedy (NonEmpty.toList (remediationFor (ckContext kind) (ckCode kind)))+  [ "label" .= labelName (deriveLabel gate ((.vector) kind)),+    "node" .= (.node) kind,+    "facet" .= (.facet) kind,+    "subject" .= (.subject) kind,+    "code" .= T.pack (show ((.code) kind)),+    "paths" .= (.paths) kind,+    "vector" .= vectorValue ((.vector) kind),+    "detail" .= (.detail) kind,+    "remedies" .= map renderRemedy (NonEmpty.toList (remediationFor ((.context) kind) ((.code) kind)))   ]-    <> ["mappedPersistedSurface" .= mappedPersistedImpactValue impact | Just impact <- [ckMappedPersistedImpact kind]]-    <> ["mappedConsequences" .= map mappedConsequenceIdentity (Set.toAscList (ckMappedConsequences kind)) | not (Set.null (ckMappedConsequences kind))]+    <> ["mappedPersistedSurface" .= mappedPersistedImpactValue impact | Just impact <- [(.mappedPersistedImpact) kind]]+    <> ["mappedConsequences" .= map mappedConsequenceIdentity (Set.toAscList ((.mappedConsequences) kind)) | not (Set.null ((.mappedConsequences) kind))]   where     kind = changeKind change  ownedSiteValue :: OwnedSite -> Value-ownedSiteValue site = object ["file" .= osFile site, "line" .= osLine site]+ownedSiteValue site = object ["file" .= (.file) site, "line" .= (.line) site]  useSiteValue :: (Text, Maybe OwnedSite) -> Value useSiteValue (path, site) =   object     ( ["path" .= path]-        <> maybe [] (\owned -> ["file" .= osFile owned, "line" .= osLine owned]) site+        <> maybe [] (\owned -> ["file" .= (.file) owned, "line" .= (.line) owned]) site     )  mappedPersistedImpactValue :: MappedPersistedImpact -> Value mappedPersistedImpactValue impact =   object-    [ "surface" .= persistedSurfaceName (mappedPersistedSurface impact),-      "verdict" .= verdictName (mappedPersistedVerdict impact)+    [ "surface" .= persistedSurfaceName ((.surface) impact),+      "verdict" .= verdictName ((.verdict) impact)     ]  persistedSurfaceName :: MappedPersistedSurface -> Text@@ -252,24 +252,24 @@ workspaceMetaValue :: WorkspaceMeta -> Value workspaceMetaValue meta =   object-    [ "identity" .= wmIdentity meta,-      "manifest" .= wmManifest meta,-      "since" .= wmSince meta,-      "membersOld" .= wmMembersOld meta,-      "membersNew" .= wmMembersNew meta,-      "adoptionBaseline" .= wmAdoptionBaseline meta+    [ "identity" .= (.identity) meta,+      "manifest" .= (.manifest) meta,+      "since" .= (.since) meta,+      "membersOld" .= (.membersOld) meta,+      "membersNew" .= (.membersNew) meta,+      "adoptionBaseline" .= (.adoptionBaseline) meta     ]  vectorValue :: CompatibilityVector -> Value vectorValue vector =   object-    [ "private-history-read" .= verdictName (cvPrivateHistoryRead vector),-      "old-binary-read-new-events" .= verdictName (cvOldBinaryReadNewEvents vector),-      "snapshot-hydration" .= verdictName (cvSnapshotHydration vector),-      "public-consumer" .= verdictName (cvPublicConsumer vector),-      "persisted-identity" .= verdictName (cvPersistedIdentity vector),-      "consumer-build" .= verdictName (cvConsumerBuild vector),-      "rollout" .= map rolloutName (Set.toAscList (cvRollout vector))+    [ "private-history-read" .= verdictName ((.privateHistoryRead) vector),+      "old-binary-read-new-events" .= verdictName ((.oldBinaryReadNewEvents) vector),+      "snapshot-hydration" .= verdictName ((.snapshotHydration) vector),+      "public-consumer" .= verdictName ((.publicConsumer) vector),+      "persisted-identity" .= verdictName ((.persistedIdentity) vector),+      "consumer-build" .= verdictName ((.consumerBuild) vector),+      "rollout" .= map rolloutName (Set.toAscList ((.rollout) vector))     ]  remediationFor :: ChangeContext -> DiagnosticCode -> NonEmpty Remedy@@ -308,45 +308,45 @@       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+  | code == EnumCtorAdded = case Set.toAscList ((.rollout) vector) of       rollout : _ -> RemedyDeploymentOrder rollout :| [snapshotRemedy]       [] -> snapshotRemedy :| []-  | cvConsumerBuild vector `elem` [VAdvisory, VBreaking] =+  | (.consumerBuild) vector `elem` [VAdvisory, VBreaking] =       RemedyRecompileConsumers :| [RemedyRunConformance]   | Just rollout <- firstRollout = RemedyDeploymentOrder rollout :| [RemedyRunConformance]-  | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance]+  | (.snapshotHydration) vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance]   | otherwise = RemedyRunConformance :| []   where     vector = classifyCompatibility context code-    firstRollout = case Set.toAscList (cvRollout vector) of+    firstRollout = case Set.toAscList ((.rollout) vector) of       rollout : _ -> Just rollout       [] -> Nothing     snapshotRemedy-      | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump+      | (.snapshotHydration) vector == VAdvisory = RemedyStateCodecBump       | otherwise = RemedyRunConformance     mappedWireRemedy-      | Set.member RolloutDrainRequired (cvRollout vector) = queueMappedRemedy-      | cvPrivateHistoryRead vector == VBreaking =+      | Set.member RolloutDrainRequired ((.rollout) vector) = queueMappedRemedy+      | (.privateHistoryRead) vector == VBreaking =           RemedyVersionBump :| [RemedyUpcaster, RemedyDeploymentOrder RolloutStopTheWorld]-      | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance]+      | (.snapshotHydration) vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance]       | otherwise = RemedyRecompileConsumers :| [RemedyRunConformance]     mappedAdditionRemedy-      | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance]-      | Set.member RolloutDrainRequired (cvRollout vector) = queueMappedRemedy+      | (.snapshotHydration) vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance]+      | Set.member RolloutDrainRequired ((.rollout) vector) = queueMappedRemedy       | Just rollout <- firstRollout = RemedyDeploymentOrder rollout :| [RemedyRunConformance]       | otherwise = RemedyRunConformance :| []     mappedConformanceRemedy-      | cvSnapshotHydration vector == VAdvisory = RemedyRunConformance :| [RemedyStateCodecBump]-      | Set.member RolloutDrainRequired (cvRollout vector) = queueMappedRemedy+      | (.snapshotHydration) vector == VAdvisory = RemedyRunConformance :| [RemedyStateCodecBump]+      | Set.member RolloutDrainRequired ((.rollout) vector) = queueMappedRemedy       | otherwise = RemedyRunConformance :| []     queueMappedRemedy =       RemedyDeploymentOrder RolloutWorkersFirst         :| [RemedyDrainWorkqueue, RemedyTransitionalQueueCodec, RemedyRecompileConsumers, RemedyRunConformance]     mappedSnapshotConformanceRemedy-      | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance]+      | (.snapshotHydration) vector == VAdvisory = RemedyStateCodecBump :| [RemedyRunConformance]       | otherwise = RemedyRunConformance :| []     mappedCanonicalRemedy-      | cvSnapshotHydration vector == VAdvisory = RemedyStateCodecBump :| [RemedyRecompileConsumers, RemedyRunConformance]+      | (.snapshotHydration) vector == VAdvisory = RemedyStateCodecBump :| [RemedyRecompileConsumers, RemedyRunConformance]       | otherwise = RemedyRecompileConsumers :| [RemedyRunConformance]     mappedWireCodes =       [ MappedFieldAddedNoDefault,@@ -437,29 +437,29 @@     headline =       headlineName change         <> ": "-        <> ckNode kind+        <> (.node) kind         <> " "-        <> ckFacet kind+        <> (.facet) kind         <> " "-        <> ckSubject kind+        <> (.subject) kind         <> ": "-        <> ckDetail kind+        <> (.detail) kind         <> codeSuffix change kind     vectorDetail-      | vectorIsUniform (ckVector kind) = ""-      | otherwise = "\n" <> renderVectorLine (ckVector kind)-    persistedDetail = case ckMappedPersistedImpact kind of+      | vectorIsUniform ((.vector) kind) = ""+      | otherwise = "\n" <> renderVectorLine ((.vector) kind)+    persistedDetail = case (.mappedPersistedImpact) kind of       Nothing -> ""       Just impact ->         "\n    mapped-persisted-surface: "-          <> persistedSurfaceName (mappedPersistedSurface impact)+          <> persistedSurfaceName ((.surface) impact)           <> "="-          <> verdictName (mappedPersistedVerdict impact)+          <> verdictName ((.verdict) impact)     consequenceDetail-      | Set.null (ckMappedConsequences kind) = ""+      | Set.null ((.mappedConsequences) kind) = ""       | otherwise =           "\n    mapped-consequences: "-            <> T.intercalate ", " (map mappedConsequenceIdentity (Set.toAscList (ckMappedConsequences kind)))+            <> T.intercalate ", " (map mappedConsequenceIdentity (Set.toAscList ((.mappedConsequences) kind)))  renderVectorLine :: CompatibilityVector -> Text renderVectorLine vector =@@ -470,27 +470,27 @@           let verdict = verdictFor surface vector,           verdict /= VNotApplicable         ]-          <> ["rollout=" <> T.intercalate "," (map rolloutName (Set.toAscList (cvRollout vector))) | not (Set.null (cvRollout vector))]+          <> ["rollout=" <> T.intercalate "," (map rolloutName (Set.toAscList ((.rollout) vector))) | not (Set.null ((.rollout) vector))]       )  renderExplainBlock :: Change -> Text renderExplainBlock change =   "explain ["-    <> T.pack (show (ckCode kind))+    <> T.pack (show ((.code) kind))     <> "]\n"-    <> T.unlines ["  path: " <> path | path <- ckPaths kind]+    <> T.unlines ["  path: " <> path | path <- (.paths) kind]     <> T.unlines (map ("  direction: " <>) directions)     <> T.unlines ["  remedy: " <> renderRemedy remedy | remedy <- NonEmpty.toList remedies]   where     kind = changeKind change-    vector = ckVector kind+    vector = (.vector) kind     directions =       [ surfaceName surface <> " is " <> verdictName verdict <> "; " <> directionMeaning surface verdict       | surface <- [minBound .. maxBound],         let verdict = verdictFor surface vector,         verdict `elem` [VAdvisory, VBreaking]       ]-    remedies = remediationFor (ckContext kind) (ckCode kind)+    remedies = remediationFor ((.context) kind) ((.code) kind)  surfaceName :: CompatibilitySurface -> Text surfaceName surface = case surface of@@ -540,7 +540,7 @@  codeSuffix :: Change -> ChangeKind -> Text codeSuffix Additive {} _ = ""-codeSuffix _ kind = " [" <> T.pack (show (ckCode kind)) <> "]"+codeSuffix _ kind = " [" <> T.pack (show ((.code) kind)) <> "]"  changeKind :: Change -> ChangeKind changeKind (Additive kind) = kind@@ -549,7 +549,7 @@  vectorIsUniform :: CompatibilityVector -> Bool vectorIsUniform vector =-  Set.null (cvRollout vector)+  Set.null ((.rollout) vector)     && all (`elem` [VCompatible, VNotApplicable]) [verdictFor surface vector | surface <- [minBound .. maxBound]]  directionMeaning :: CompatibilitySurface -> SurfaceVerdict -> Text

src/Keiro/Dsl/EventOutput.hs view

@@ -10,6 +10,7 @@ module Keiro.Dsl.EventOutput   ( CheckedFieldCopy (..),     OutputObligationKey (..),+    unOutputObligationKey,     EventOutputMapping (..),     EventOutputError (..),     eventOutputMapping,@@ -42,14 +43,17 @@ newtype OutputObligationKey = OutputObligationKey {unOutputObligationKey :: Text}   deriving stock (Eq, Ord, Show) +unOutputObligationKey :: OutputObligationKey -> Text+unOutputObligationKey (OutputObligationKey value) = value+ -- | Exclusive ownership of one event term emitted by one transition. data EventOutputMapping   = GeneratedCommandIdentity-      { outputSourceCommand :: !Name,-        outputFields :: ![CheckedFieldCopy]+      { sourceCommand :: !Name,+        fields :: ![CheckedFieldCopy]       }   | HandOwnedEventOutput-      { outputObligation :: !OutputObligationKey+      { obligation :: !OutputObligationKey       }   deriving stock (Eq, Ord, Show) @@ -76,43 +80,43 @@  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+  event <- maybe (Left (OutputEventMissing eventName)) Right (find ((== eventName) . (.name)) ((.events) aggregate))+  case ((.implementation) transition, (.body) event) of     (LegacyHoleImplementation, _) -> pure handOwned     (_, EventFields _) -> pure handOwned     (_, EventFromCommand sourceCommand)-      | sourceCommand /= tCommand transition ->+      | sourceCommand /= (.command) transition ->           Left             OutputCommandMismatch               { declaredSourceCommand = sourceCommand,-                consumingTransitionCommand = tCommand transition,+                consumingTransitionCommand = (.command) transition,                 emittedEventName = eventName               }       | otherwise -> do-          command <- maybe (Left (OutputSourceCommandMissing sourceCommand)) Right (find ((== sourceCommand) . cmdName) (aggCommands aggregate))-          fields <- traverse checkedCopy (cmdFields command)+          command <- maybe (Left (OutputSourceCommandMissing sourceCommand)) Right (find ((== sourceCommand) . (.name)) ((.commands) aggregate))+          fields <- traverse checkedCopy ((.fields) command)           pure             GeneratedCommandIdentity-              { outputSourceCommand = sourceCommand,-                outputFields = fields+              { sourceCommand = sourceCommand,+                fields = fields               }   where     symbols = aggregateSymbolsFromGraphResult typeGraphResult spec     handOwned =       HandOwnedEventOutput-        { outputObligation =+        { obligation =             OutputObligationKey               ( T.intercalate                   "/"                   [ "event-output-v1",-                    aggName aggregate,-                    transitionModeName (tMode transition),-                    tSource transition,-                    tCommand transition,-                    maybe "unguarded" renderExpr (tGuard transition),-                    T.intercalate ";" [register <> ":=" <> renderExpr expression | (register, expression) <- tWrites transition],-                    T.intercalate "," (tEmits transition),-                    tGoto transition,+                    (.name) aggregate,+                    transitionModeName ((.mode) transition),+                    (.source) transition,+                    (.command) transition,+                    maybe "unguarded" renderExpr ((.guard) transition),+                    T.intercalate ";" [register <> ":=" <> renderExpr expression | (register, expression) <- (.writes) transition],+                    T.intercalate "," ((.emits) transition),+                    (.goto) transition,                     T.pack (show emitIndex),                     eventName                   ]@@ -125,11 +129,11 @@         then           pure             CheckedFieldCopy-              { outputSelector = aggregateFieldName field,-                outputWireName = aggregateFieldName field,+              { outputSelector = (.name) field,+                outputWireName = (.name) field,                 outputFieldType = commandType               }-        else Left (OutputFieldTypeMismatch (aggregateFieldName field) commandType eventType)+        else Left (OutputFieldTypeMismatch ((.name) field) commandType eventType)  -- | Canonical ownership text used by fold and behavior fingerprints. eventOutputCanonical :: EventOutputMapping -> Text@@ -140,11 +144,11 @@       <> "["       <> T.intercalate         ","-        [ outputSelector field+        [ (.outputSelector) field             <> "="-            <> outputWireName field+            <> (.outputWireName) field             <> ":"-            <> aggregateCanonicalName (outputFieldType field)+            <> aggregateCanonicalName ((.outputFieldType) field)         | field <- fields         ]       <> "]"

src/Keiro/Dsl/ExplainBindings.hs view

@@ -42,28 +42,28 @@   deriving stock (Eq, Ord, Show)  data BindingObligation = BindingObligation-  { obligationMappedName :: !Name,-    obligationPackage :: !Text,-    obligationModule :: !Text,-    obligationSymbol :: !Text,-    obligationKind :: !BindingObligationKind,-    obligationSignature :: !Text,-    obligationUseSites :: ![Text],-    obligationBindingVersion :: !(Maybe Text),-    obligationCanonicalType :: !(Maybe Text),-    obligationEqualityContract :: !(Maybe Text),-    obligationIdDomainContract :: !(Maybe Text),-    obligationCategory :: !Text+  { mappedName :: !Name,+    package :: !Text,+    moduleName :: !Text,+    symbol :: !Text,+    kind :: !BindingObligationKind,+    signature :: !Text,+    useSites :: ![Text],+    bindingVersion :: !(Maybe Text),+    canonicalType :: !(Maybe Text),+    equalityContract :: !(Maybe Text),+    idDomainContract :: !(Maybe Text),+    category :: !Text   }   deriving stock (Eq, Ord, Show)  data BindingHole = BindingHole-  { holeMappedName :: !Name,-    holeModule :: !Text,-    holeSymbol :: !Text,-    holeKind :: !BindingObligationKind,-    holePath :: !(Maybe Text),-    holeSignature :: !Text+  { mappedName :: !Name,+    moduleName :: !Text,+    symbol :: !Text,+    kind :: !BindingObligationKind,+    path :: !(Maybe Text),+    signature :: !Text   }   deriving stock (Eq, Ord, Show) @@ -71,18 +71,18 @@   toJSON obligation =     object       [ "schema" .= (1 :: Int),-        "mappedName" .= obligationMappedName obligation,-        "package" .= obligationPackage obligation,-        "module" .= obligationModule obligation,-        "symbol" .= obligationSymbol obligation,-        "kind" .= renderKind (obligationKind obligation),-        "signature" .= obligationSignature obligation,-        "useSites" .= obligationUseSites obligation,-        "bindingVersion" .= obligationBindingVersion obligation,-        "canonicalType" .= obligationCanonicalType obligation,-        "equalityContract" .= obligationEqualityContract obligation,-        "idDomainContract" .= obligationIdDomainContract obligation,-        "category" .= obligationCategory obligation+        "mappedName" .= (.mappedName) obligation,+        "package" .= (.package) obligation,+        "module" .= (.moduleName) obligation,+        "symbol" .= (.symbol) obligation,+        "kind" .= renderKind ((.kind) obligation),+        "signature" .= (.signature) obligation,+        "useSites" .= (.useSites) obligation,+        "bindingVersion" .= (.bindingVersion) obligation,+        "canonicalType" .= (.canonicalType) obligation,+        "equalityContract" .= (.equalityContract) obligation,+        "idDomainContract" .= (.idDomainContract) obligation,+        "category" .= (.category) obligation       ]  instance FromJSON BindingObligation where@@ -111,12 +111,12 @@   toJSON hole =     object       [ "schema" .= (1 :: Int),-        "mappedName" .= holeMappedName hole,-        "module" .= holeModule hole,-        "symbol" .= holeSymbol hole,-        "kind" .= renderKind (holeKind hole),-        "path" .= holePath hole,-        "signature" .= holeSignature hole+        "mappedName" .= (.mappedName) hole,+        "module" .= (.moduleName) hole,+        "symbol" .= (.symbol) hole,+        "kind" .= renderKind ((.kind) hole),+        "path" .= (.path) hole,+        "signature" .= (.signature) hole       ]  instance FromJSON BindingHole where@@ -145,7 +145,7 @@   pure . sortOn obligationSortKey $     concat       [ obligationsFor graph declaration-      | ResolvedStructural declaration _ <- Map.elems (tgDeclarations graph)+      | ResolvedStructural declaration _ <- Map.elems ((.declarations) graph)       ]       <> concatMap (nominalObligationsFor service) (Map.elems (nominalTypes nominalRegistry))   where@@ -161,61 +161,61 @@   pure . sortOn holeSortKey $     concat       [ holesFor graph declaration shape obligations-      | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph)+      | ResolvedStructural declaration shape <- Map.elems ((.declarations) graph)       ]       <> [ BindingHole-             { holeMappedName = obligationMappedName obligation,-               holeModule = obligationModule obligation,-               holeSymbol = obligationSymbol obligation,-               holeKind = obligationKind obligation,-               holePath = Nothing,-               holeSignature = obligationSignature obligation+             { mappedName = (.mappedName) obligation,+               moduleName = (.moduleName) obligation,+               symbol = (.symbol) obligation,+               kind = (.kind) obligation,+               path = Nothing,+               signature = (.signature) obligation              }          | obligation <- obligations,-           obligationCategory obligation /= "structural"+           (.category) obligation /= "structural"          ]  holesFor :: TypeGraph -> StructuralDecl -> ResolvedMappedShape -> [BindingObligation] -> [BindingHole] holesFor _graph declaration shape obligations = bindingEntries <> auxiliaryEntries   where-    own = filter ((== sdName declaration) . obligationMappedName) obligations+    own = filter ((== (.name) declaration) . (.mappedName)) obligations     binding = onlyKind BindingValue     bindingEntries = case binding of       Nothing -> []       Just obligation -> map (bindingHole obligation) (shapeHolePaths shape)     auxiliaryEntries =       [ BindingHole-          { holeMappedName = obligationMappedName obligation,-            holeModule = obligationModule obligation,-            holeSymbol = obligationSymbol obligation,-            holeKind = obligationKind obligation,-            holePath = Nothing,-            holeSignature = obligationSignature obligation+          { mappedName = (.mappedName) obligation,+            moduleName = (.moduleName) obligation,+            symbol = (.symbol) obligation,+            kind = (.kind) obligation,+            path = Nothing,+            signature = (.signature) obligation           }       | obligation <- own,-        obligationKind obligation /= BindingValue+        (.kind) obligation /= BindingValue       ]-    onlyKind wanted = case filter ((== wanted) . obligationKind) own of+    onlyKind wanted = case filter ((== wanted) . (.kind)) own of       entry : _ -> Just entry       [] -> Nothing     bindingHole obligation (path, expectedType) =       BindingHole-        { holeMappedName = obligationMappedName obligation,-          holeModule = obligationModule obligation,-          holeSymbol = obligationSymbol obligation,-          holeKind = BindingValue,-          holePath = Just path,-          holeSignature = obligationSymbol obligation <> "." <> path <> " :: " <> expectedType+        { mappedName = (.mappedName) obligation,+          moduleName = (.moduleName) obligation,+          symbol = (.symbol) obligation,+          kind = BindingValue,+          path = Just path,+          signature = (.symbol) obligation <> "." <> path <> " :: " <> expectedType         }  shapeHolePaths :: ResolvedMappedShape -> [(Text, Text)] shapeHolePaths =   foldMappedShape     MappedShapeAlgebra-      { onRecord = \_ _ fields -> [(rwfHaskell field, renderExprType (rwfType field)) | field <- fields],-        onEnum = \entries -> [(weCtor entry, "constructor case") | entry <- entries],+      { onRecord = \_ _ fields -> [((.haskell) field, renderExprType ((.valueType) field)) | field <- fields],+        onEnum = \entries -> [((.ctor) entry, "constructor case") | entry <- entries],         onUnion = \_ arms ->-          [ (rwaCtor arm, maybe "constructor case" renderExprType (rwaPayload arm))+          [ ((.ctor) arm, maybe "constructor case" renderExprType ((.payload) arm))           | arm <- arms           ]       }@@ -240,73 +240,73 @@ obligationsFor :: TypeGraph -> StructuralDecl -> [BindingObligation] obligationsFor graph declaration = bindingEntry : fixtureEntry : initialEntries   where-    source = sdHaskell declaration-    consumerType = hsModule source <> "." <> hsType source-    shapeType = sdName declaration <> "Shape"-    paths = map renderUsePath (usePaths graph (sdName declaration))+    source = (.haskell) declaration+    consumerType = (.moduleName) source <> "." <> (.valueType) source+    shapeType = (.name) declaration <> "Shape"+    paths = map renderUsePath (usePaths graph ((.name) declaration))     registerPaths =       [ renderUsePath path-      | path@UsePath {upRoot = RootRegister {}} <- usePaths graph (sdName declaration)+      | path@UsePath {root = RootRegister {}} <- usePaths graph ((.name) declaration)       ]     bindingEntry =       obligationFor         declaration-        (sdBinding declaration)+        ((.binding) declaration)         BindingValue         ("StructuralBinding " <> consumerType <> " " <> shapeType)         paths-        (Just (unBindingVersion (sdBindingVersion declaration)))-        (Just (unCanonicalTypeId (sdCanonical declaration)))+        (Just (unBindingVersion ((.bindingVersion) declaration)))+        (Just (unCanonicalTypeId ((.canonical) declaration)))     fixtureEntry =       obligationFor         declaration-        (sdFixtures declaration)+        ((.fixtures) declaration)         FixtureValue         ("FixtureCases " <> consumerType)         paths         Nothing-        (Just (unCanonicalTypeId (sdCanonical declaration)))-    initialEntries = case (registerPaths, sdInitial declaration) of+        (Just (unCanonicalTypeId ((.canonical) declaration)))+    initialEntries = case (registerPaths, (.initial) declaration) of       ([], _) -> []       (_, Nothing) -> []       (_, Just initialValue) ->-        [ obligationFor declaration initialValue InitialValue consumerType registerPaths Nothing (Just (unCanonicalTypeId (sdCanonical declaration)))+        [ obligationFor declaration initialValue InitialValue consumerType registerPaths Nothing (Just (unCanonicalTypeId ((.canonical) declaration)))         ]  obligationFor :: StructuralDecl -> QualifiedValueName -> BindingObligationKind -> Text -> [Text] -> Maybe Text -> Maybe Text -> BindingObligation obligationFor declaration qualified kindValue signature paths version canonical =   BindingObligation-    { obligationMappedName = sdName declaration,-      obligationPackage = hsPackage (sdHaskell declaration),-      obligationModule = ownerModule,-      obligationSymbol = symbol,-      obligationKind = kindValue,-      obligationSignature = symbol <> " :: " <> signature,-      obligationUseSites = paths,-      obligationBindingVersion = version,-      obligationCanonicalType = canonical,-      obligationEqualityContract = Nothing,-      obligationIdDomainContract = Nothing,-      obligationCategory = "structural"+    { mappedName = (.name) declaration,+      package = (.package) ((.haskell) declaration),+      moduleName = ownerModule,+      symbol = symbol,+      kind = kindValue,+      signature = symbol <> " :: " <> signature,+      useSites = paths,+      bindingVersion = version,+      canonicalType = canonical,+      equalityContract = Nothing,+      idDomainContract = Nothing,+      category = "structural"     }   where     (ownerModule, symbol) = splitQualified (unQualifiedValueName qualified)  nominalObligationsFor :: CheckedService -> ResolvedNominalType -> [BindingObligation]-nominalObligationsFor service nominal = case resolvedNominalOwnership nominal of+nominalObligationsFor service nominal = case (.ownership) nominal of   GeneratedNominal -> []   ConsumerNominal binding -> bindingEntry : fixtureEntry : initialEntries     where-      name = resolvedNominalName nominal-      source = consumerNominalHaskell binding-      consumerType = hsModule source <> "." <> hsType source-      paths = nominalUseSites spec name+      name = (.name) nominal+      source = (.haskell) binding+      consumerType = (.moduleName) source <> "." <> (.valueType) source+      paths = useSites spec name       registerPaths = [path | path <- paths, " register " `T.isInfixOf` path]-      category = case resolvedNominalRepresentation nominal of+      category = case (.representation) nominal of         IdRepresentation {} -> "nominal-id"         EnumRepresentation {} -> "nominal-enum"         ScalarRepresentation {} -> "nominal-scalar"-      representation = case resolvedNominalRepresentation nominal of+      representation = case (.representation) nominal of         IdRepresentation prefix -> "(KindID " <> quoted prefix <> ")"         EnumRepresentation {} -> nominalEnumRepresentationModule spec name <> "." <> name <> "Representation"         ScalarRepresentation NominalText -> "Text"@@ -314,14 +314,14 @@         ScalarRepresentation NominalNatural -> "Natural"         ScalarRepresentation NominalBool -> "Bool"         ScalarRepresentation NominalTime -> "UTCTime"-      canonical = Just (unCanonicalTypeId (consumerNominalCanonical binding))+      canonical = Just (unCanonicalTypeId ((.canonical) binding))       equalityContract = nominalEqualityIdentityForService (checkedLanguageContract service) nominal-      idContract = case resolvedNominalRepresentation nominal of+      idContract = case (.representation) nominal of         IdRepresentation prefix -> idDomainVersion <$> idDomainContractFor (checkedLanguageContract service) prefix         _ -> Nothing-      bindingEntry = nominalObligation name binding category (consumerNominalBinding binding) BindingValue ("NominalBinding " <> consumerType <> " " <> representation) paths (Just (unBindingVersion (consumerNominalBindingVersion binding))) canonical equalityContract idContract-      fixtureEntry = nominalObligation name binding category (consumerNominalFixtures binding) FixtureValue ("NominalFixtureCases " <> consumerType) paths Nothing canonical Nothing Nothing-      initialEntries = case (registerPaths, consumerNominalInitial binding) of+      bindingEntry = nominalObligation name binding category ((.binding) binding) BindingValue ("NominalBinding " <> consumerType <> " " <> representation) paths (Just (unBindingVersion ((.bindingVersion) binding))) canonical equalityContract idContract+      fixtureEntry = nominalObligation name binding category ((.fixtures) binding) FixtureValue ("NominalFixtureCases " <> consumerType) paths Nothing canonical Nothing Nothing+      initialEntries = case (registerPaths, (.initial) binding) of         ([], _) -> []         (_, Nothing) -> []         (_, Just initialValue) -> [nominalObligation name binding category initialValue InitialValue consumerType registerPaths Nothing canonical Nothing Nothing]@@ -332,61 +332,61 @@ nominalObligation :: Name -> ConsumerNominalBinding -> Text -> QualifiedValueName -> BindingObligationKind -> Text -> [Text] -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> BindingObligation nominalObligation name binding category qualified kindValue signature paths version canonical equalityContract idDomainContract =   BindingObligation-    { obligationMappedName = name,-      obligationPackage = hsPackage (consumerNominalHaskell binding),-      obligationModule = ownerModule,-      obligationSymbol = symbol,-      obligationKind = kindValue,-      obligationSignature = symbol <> " :: " <> signature,-      obligationUseSites = paths,-      obligationBindingVersion = version,-      obligationCanonicalType = canonical,-      obligationEqualityContract = equalityContract,-      obligationIdDomainContract = idDomainContract,-      obligationCategory = category+    { mappedName = name,+      package = (.package) ((.haskell) binding),+      moduleName = ownerModule,+      symbol = symbol,+      kind = kindValue,+      signature = symbol <> " :: " <> signature,+      useSites = paths,+      bindingVersion = version,+      canonicalType = canonical,+      equalityContract = equalityContract,+      idDomainContract = idDomainContract,+      category = category     }   where     (ownerModule, symbol) = splitQualified (unQualifiedValueName qualified) -nominalUseSites :: Spec -> Name -> [Text]-nominalUseSites spec target = concatMap aggregatePaths [aggregate | NAggregate aggregate <- specNodes spec]+useSites :: Spec -> Name -> [Text]+useSites spec target = concatMap aggregatePaths [aggregate | NAggregate aggregate <- (.nodes) spec]   where     aggregatePaths aggregate =-      [ aggName aggregate <> " command " <> cmdName command <> " ." <> aggregateFieldName field <> " : " <> target-      | command <- aggCommands aggregate,-        field <- cmdFields command,+      [ (.name) aggregate <> " command " <> (.name) command <> " ." <> (.name) field <> " : " <> target+      | command <- (.commands) aggregate,+        field <- (.fields) command,         fieldUses field       ]-        <> [ aggName aggregate <> " event " <> evName event <> " ." <> aggregateFieldName field <> " : " <> target-           | event <- aggEvents aggregate,+        <> [ (.name) aggregate <> " event " <> (.name) event <> " ." <> (.name) field <> " : " <> target+           | event <- (.events) aggregate,              field <- eventFields aggregate event,              fieldUses field            ]-        <> [ aggName aggregate <> " register " <> regName register <> " : " <> target-           | register <- aggRegs aggregate,-             regType register == TRef target+        <> [ (.name) aggregate <> " register " <> (.name) register <> " : " <> target+           | register <- (.regs) aggregate,+             (.valueType) register == TRef target            ]-    eventFields aggregate event = case evBody event of+    eventFields aggregate event = case (.body) event of       EventFields fields -> fields-      EventFromCommand commandName -> concat [cmdFields command | command <- aggCommands aggregate, cmdName command == commandName]-    fieldUses field = aggregateFieldType field == Just (TRef target)+      EventFromCommand commandName -> concat [(.fields) command | command <- (.commands) aggregate, (.name) command == commandName]+    fieldUses field = (.valueType) field == Just (TRef target)  nominalEnumRepresentationModule :: Spec -> Name -> Text-nominalEnumRepresentationModule spec name = case maybe GeneratedPrefix id (specLayout spec) of-  GeneratedPrefix -> root <> "Generated." <> contextName <> ".Nominal.Shape." <> name-  CollocatedLeaf -> root <> contextName <> ".Nominal.Shape." <> name <> ".Generated"+nominalEnumRepresentationModule spec nominalName = case maybe GeneratedPrefix id ((.layout) spec) of+  GeneratedPrefix -> root <> "Generated." <> contextModuleName <> ".Nominal.Shape." <> nominalName+  CollocatedLeaf -> root <> contextModuleName <> ".Nominal.Shape." <> nominalName <> ".Generated"   where-    root = maybe "" (<> ".") (specModuleRoot spec)-    contextName =+    root = maybe "" (<> ".") ((.moduleRoot) spec)+    contextModuleName =       case HaskellName.deriveHaskellName HaskellName.LogicalWireWord site of-        Right derived -> HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)-        Left _ -> specContext spec+        Right derived -> HaskellName.renderUpperCamelName ((.upperCamel) derived)+        Left _ -> (.context) spec     site =       HaskellName.NameSite-        { HaskellName.siteKind = HaskellName.ContextModuleSite,-          HaskellName.siteLogicalName = specContext spec,-          HaskellName.siteOwner = "binding-obligation-context",-          HaskellName.siteLine = 0+        { HaskellName.kind = HaskellName.ContextModuleSite,+          HaskellName.logicalName = (.context) spec,+          HaskellName.owner = "binding-obligation-context",+          HaskellName.line = 0         }  renderBindingObligations :: Text -> [BindingObligation] -> Text@@ -401,35 +401,35 @@     sameOwner left right = ownerKey left == ownerKey right     renderGroup [] = []     renderGroup entries@(firstEntry : _) =-      ("  " <> obligationModule firstEntry <> " (package " <> obligationPackage firstEntry <> ")")+      ("  " <> (.moduleName) firstEntry <> " (package " <> (.package) firstEntry <> ")")         : concatMap renderEntry entries     renderEntry obligation =-      [ "    " <> obligationSignature obligation,-        "      reason: " <> renderKind (obligationKind obligation) <> " — " <> obligationCategory obligation <> " type " <> obligationMappedName obligation <> renderPaths (obligationUseSites obligation)+      [ "    " <> (.signature) obligation,+        "      reason: " <> renderKind ((.kind) obligation) <> " — " <> (.category) obligation <> " type " <> (.mappedName) obligation <> renderPaths ((.useSites) obligation)       ]-        <> maybe [] (\version -> ["      provenance: binding-version " <> quoted version]) (obligationBindingVersion obligation)-        <> maybe [] (\canonical -> ["      canonical-type: " <> quoted canonical]) (obligationCanonicalType obligation)-        <> maybe [] (\contract -> ["      equality-contract: " <> quoted contract]) (obligationEqualityContract obligation)-        <> maybe [] (\contract -> ["      id-domain-contract: " <> quoted contract]) (obligationIdDomainContract obligation)+        <> maybe [] (\version -> ["      provenance: binding-version " <> quoted version]) ((.bindingVersion) obligation)+        <> maybe [] (\canonical -> ["      canonical-type: " <> quoted canonical]) ((.canonicalType) obligation)+        <> maybe [] (\contract -> ["      equality-contract: " <> quoted contract]) ((.equalityContract) obligation)+        <> maybe [] (\contract -> ["      id-domain-contract: " <> quoted contract]) ((.idDomainContract) obligation)     renderPaths [] = " (not currently used by an aggregate root)"     renderPaths paths = " (" <> T.intercalate "; " paths <> ")"     quoted value = T.pack (show value)  obligationSortKey :: BindingObligation -> (Text, Text, Text, BindingObligationKind, Text) obligationSortKey obligation =-  ( obligationPackage obligation,-    obligationModule obligation,-    obligationMappedName obligation,-    obligationKind obligation,-    obligationSymbol obligation+  ( (.package) obligation,+    (.moduleName) obligation,+    (.mappedName) obligation,+    (.kind) obligation,+    (.symbol) obligation   )  ownerKey :: BindingObligation -> (Text, Text)-ownerKey obligation = (obligationPackage obligation, obligationModule obligation)+ownerKey obligation = ((.package) obligation, (.moduleName) obligation)  holeSortKey :: BindingHole -> (Text, Name, BindingObligationKind, Maybe Text, Text) holeSortKey hole =-  (holeModule hole, holeMappedName hole, holeKind hole, holePath hole, holeSymbol hole)+  ((.moduleName) hole, (.mappedName) hole, (.kind) hole, (.path) hole, (.symbol) hole)  renderKind :: BindingObligationKind -> Text renderKind BindingValue = "binding"

src/Keiro/Dsl/Expression.hs view

@@ -42,11 +42,11 @@ import Keiro.Dsl.TypeGraph  data ExpressionEnvironment = ExpressionEnvironment-  { environmentSpec :: !Spec,-    environmentAggregate :: !Aggregate,-    environmentTransition :: !Transition,-    environmentSymbols :: !AggregateSymbols,-    environmentTypeGraph :: !(Maybe TypeGraph)+  { spec :: !Spec,+    aggregate :: !Aggregate,+    transition :: !Transition,+    symbols :: !AggregateSymbols,+    typeGraph :: !(Maybe TypeGraph)   }  expressionEnvironment :: Spec -> Aggregate -> Transition -> ExpressionEnvironment@@ -67,11 +67,11 @@ expressionEnvironmentWith :: AggregateSymbols -> Maybe TypeGraph -> Spec -> Aggregate -> Transition -> ExpressionEnvironment expressionEnvironmentWith symbols graph spec aggregate transition =   ExpressionEnvironment-    { environmentSpec = spec,-      environmentAggregate = aggregate,-      environmentTransition = transition,-      environmentSymbols = symbols,-      environmentTypeGraph = graph+    { spec = spec,+      aggregate = aggregate,+      transition = transition,+      symbols = symbols,+      typeGraph = graph     }  data ExpectedScalarType@@ -85,9 +85,9 @@   deriving stock (Eq, Show)  data ResolvedScalarProjection = ResolvedScalarProjection-  { scalarProjectionOwner :: !MappedKey,-    scalarProjectionPointer :: !Text,-    scalarProjectionFields :: ![Name]+  { owner :: !MappedKey,+    pointer :: !Text,+    fields :: ![Name]   }   deriving stock (Eq, Show) @@ -122,9 +122,9 @@   deriving stock (Eq, Show)  data TypedScalarExpr = TypedScalarExpr-  { typedScalarType :: !ResolvedAggregateType,-    typedScalarLoc :: !Loc,-    typedScalarNode :: !TypedScalarNode+  { valueType :: !ResolvedAggregateType,+    loc :: !Loc,+    node :: !TypedScalarNode   }   deriving stock (Eq, Show) @@ -144,9 +144,9 @@   deriving stock (Eq, Ord, Show)  data ExpressionDiagnostic = ExpressionDiagnostic-  { expressionDiagnosticLoc :: !Loc,-    expressionDiagnosticCode :: !ExpressionDiagnosticCode,-    expressionDiagnosticMessage :: !Text+  { loc :: !Loc,+    code :: !ExpressionDiagnosticCode,+    message :: !Text   }   deriving stock (Eq, Show) @@ -170,9 +170,9 @@       (resolvedLeft, resolvedRight) <- resolveBoth (resolve left (ExpectScalarType AggregateBool)) (resolve right (ExpectScalarType AggregateBool))       pure         TypedScalarExpr-          { typedScalarType = AggregateBool,-            typedScalarLoc = expressionLoc left right,-            typedScalarNode = constructor resolvedLeft resolvedRight+          { valueType = AggregateBool,+            loc = expressionLoc left right,+            node = constructor resolvedLeft resolvedRight           }      resolveComparison operator left right = do@@ -181,9 +181,9 @@       requireComparisonCapability operator resolvedLeft       pure         TypedScalarExpr-          { typedScalarType = AggregateBool,-            typedScalarLoc = expressionLoc left right,-            typedScalarNode = case operator of+          { valueType = AggregateBool,+            loc = expressionLoc left right,+            node = case operator of               OpEq -> TypedEqual resolvedLeft resolvedRight               OpNeq -> TypedNotEqual resolvedLeft resolvedRight               OpLt -> TypedCompare OpLt resolvedLeft resolvedRight@@ -200,30 +200,30 @@         _ -> resolvePair left right       let (resolvedLeft, resolvedRight) = pair       requireSameType resolvedLeft resolvedRight-      evidence <- arithmeticEvidence loc (typedScalarType resolvedLeft)+      evidence <- arithmeticEvidence loc ((.valueType) resolvedLeft)       pure         TypedScalarExpr-          { typedScalarType = typedScalarType resolvedLeft,-            typedScalarLoc = loc,-            typedScalarNode = constructor evidence resolvedLeft resolvedRight+          { valueType = (.valueType) resolvedLeft,+            loc = loc,+            node = constructor evidence resolvedLeft resolvedRight           }      resolvePair left right       | contextualLiteral left && not (contextualLiteral right) = do           resolvedRight <- resolve right InferScalarType-          resolvedLeft <- resolve left (ExpectScalarType (typedScalarType resolvedRight))+          resolvedLeft <- resolve left (ExpectScalarType ((.valueType) resolvedRight))           pure (resolvedLeft, resolvedRight)       | contextualLiteral right && not (contextualLiteral left) = do           resolvedLeft <- resolve left InferScalarType-          resolvedRight <- resolve right (ExpectScalarType (typedScalarType resolvedLeft))+          resolvedRight <- resolve right (ExpectScalarType ((.valueType) resolvedLeft))           pure (resolvedLeft, resolvedRight)       | otherwise = case (resolve left InferScalarType, resolve right InferScalarType) of           (Right resolvedLeft, Right resolvedRight) -> Right (resolvedLeft, resolvedRight)           (Left _, Right resolvedRight) -> do-            resolvedLeft <- resolve left (ExpectScalarType (typedScalarType resolvedRight))+            resolvedLeft <- resolve left (ExpectScalarType ((.valueType) resolvedRight))             pure (resolvedLeft, resolvedRight)           (Right resolvedLeft, Left _) -> do-            resolvedRight <- resolve right (ExpectScalarType (typedScalarType resolvedLeft))+            resolvedRight <- resolve right (ExpectScalarType ((.valueType) resolvedLeft))             pure (resolvedLeft, resolvedRight)           (Left leftErrors, Left rightErrors) -> Left (leftErrors <> rightErrors) @@ -234,15 +234,15 @@       (_, Left errors) -> Left errors      requireSameType left right-      | typedScalarType left == typedScalarType right = Right ()+      | (.valueType) left == (.valueType) right = Right ()       | otherwise =           failure-            (typedScalarLoc right)+            ((.loc) right)             ScalarOperandTypeMismatch             ( "expression operands have different scalar types '"-                <> aggregateCanonicalName (typedScalarType left)+                <> aggregateCanonicalName ((.valueType) left)                 <> "' and '"-                <> aggregateCanonicalName (typedScalarType right)+                <> aggregateCanonicalName ((.valueType) right)                 <> "'; numeric coercion is not supported"             ) @@ -254,37 +254,37 @@             OpLe -> OrderingGuardUse             OpGt -> OrderingGuardUse             OpGe -> OrderingGuardUse-       in case aggregateCapability useSite (typedScalarType operand) of+       in case aggregateCapability useSite ((.valueType) operand) of             SolverVisible -> Right ()             OpaqueOnly -> unsupported useSite             Unsupported -> unsupported useSite       where         unsupported useSite =           failure-            (typedScalarLoc operand)+            ((.loc) operand)             ScalarOperatorUnsupported             ( renderUseSite useSite                 <> " is unsupported for scalar type '"-                <> aggregateCanonicalName (typedScalarType operand)+                <> aggregateCanonicalName ((.valueType) operand)                 <> "'"             )      checkExpected InferScalarType resolved = Right resolved     checkExpected (ExpectScalarType wanted) resolved-      | wanted == typedScalarType resolved = Right resolved+      | wanted == (.valueType) resolved = Right resolved       | wanted == AggregateBool =           failure-            (typedScalarLoc resolved)+            ((.loc) resolved)             ScalarBooleanOperandRequired-            ("Boolean expression requires Bool, found '" <> aggregateCanonicalName (typedScalarType resolved) <> "'")+            ("Boolean expression requires Bool, found '" <> aggregateCanonicalName ((.valueType) resolved) <> "'")       | otherwise =           failure-            (typedScalarLoc resolved)+            ((.loc) resolved)             ScalarOperandTypeMismatch             ( "expected scalar type '"                 <> aggregateCanonicalName wanted                 <> "', found '"-                <> aggregateCanonicalName (typedScalarType resolved)+                <> aggregateCanonicalName ((.valueType) resolved)                 <> "'"             ) @@ -292,14 +292,14 @@ resolveGuardExpr environment expression =   case resolveScalarExpr environment (ExpectScalarType AggregateBool) expression of     Left diagnostics-      | all ((== ScalarBooleanOperandRequired) . expressionDiagnosticCode) (NE.toList diagnostics) ->+      | all ((== ScalarBooleanOperandRequired) . (.code)) (NE.toList diagnostics) ->           Left             ( fmap                 ( \diagnostic ->-                    diagnostic-                      { expressionDiagnosticCode = ScalarGuardBoolRequired,-                        expressionDiagnosticMessage = "aggregate guard must resolve to Bool; " <> expressionDiagnosticMessage diagnostic-                      }+                    replaceExpressionDiagnostic+                      ScalarGuardBoolRequired+                      ("aggregate guard must resolve to Bool; " <> diagnostic.message)+                      diagnostic                 )                 diagnostics             )@@ -307,40 +307,48 @@  resolveWriteExpr :: ExpressionEnvironment -> Name -> Expr -> Either (NonEmpty ExpressionDiagnostic) TypedScalarExpr resolveWriteExpr environment registerName expression =-  case find ((== registerName) . regName) (aggRegs (environmentAggregate environment)) of+  case find ((== registerName) . (.name)) ((.regs) ((.aggregate) environment)) of     Nothing ->       failure         (exprLoc expression)         ScalarWriteTargetUnknown         ("write target '" <> registerName <> "' is not an aggregate register")-    Just register -> case resolveAggregateType (environmentSymbols environment) (regLoc register) RegisterUse (regType register) of+    Just register -> case resolveAggregateType ((.symbols) environment) ((.loc) register) RegisterUse ((.valueType) register) of       Left _ -> Right unresolvedSentinel       Right expected -> case resolveScalarExpr environment (ExpectScalarType expected) expression of         Left diagnostics -> Left (fmap writeDiagnostic diagnostics)         Right resolved           | predicateValued resolved ->               failure-                (typedScalarLoc resolved)+                ((.loc) resolved)                 ScalarOperatorUnsupported                 "comparison and Boolean operators are guard predicates and cannot be written as scalar terms"           | otherwise -> Right resolved         where           writeDiagnostic diagnostic-            | expressionDiagnosticCode diagnostic == ScalarOperandTypeMismatch =-                diagnostic-                  { expressionDiagnosticCode = ScalarWriteTypeMismatch,-                    expressionDiagnosticMessage =-                      "write to register '"-                        <> registerName-                        <> "' has the wrong scalar type; "-                        <> expressionDiagnosticMessage diagnostic-                  }+            | (.code) diagnostic == ScalarOperandTypeMismatch =+                replaceExpressionDiagnostic+                  ScalarWriteTypeMismatch+                  ( "write to register '"+                      <> registerName+                      <> "' has the wrong scalar type; "+                      <> diagnostic.message+                  )+                  diagnostic             | otherwise = diagnostic   where     -- The aggregate type validator reports the primary type error first. This     -- value is never scaffolded because any error prevents generation.     unresolvedSentinel = TypedScalarExpr AggregateBool noLoc (TypedLiteral (ScalarBoolValue False)) +replaceExpressionDiagnostic :: ExpressionDiagnosticCode -> Text -> ExpressionDiagnostic -> ExpressionDiagnostic+replaceExpressionDiagnostic code message diagnostic =+  ExpressionDiagnostic+    { loc = diagnostic.loc,+      code,+      message+    }+ resolvePath :: ExpressionEnvironment -> Loc -> ExprRoot -> [Name] -> Either (NonEmpty ExpressionDiagnostic) TypedScalarExpr resolvePath environment loc root path = case path of   [] -> failure loc ScalarRootUnknown "scalar path is empty"@@ -364,15 +372,15 @@     (Nothing, Just value) -> Right (commandRoot value)     (Nothing, Nothing) -> unknown   where-    aggregate = environmentAggregate environment-    transition = environmentTransition environment-    symbols = environmentSymbols environment-    register = find ((== name) . regName) (aggRegs aggregate)+    aggregate = (.aggregate) environment+    transition = (.transition) environment+    symbols = (.symbols) environment+    register = find ((== name) . (.name)) ((.regs) aggregate)     commandField = do-      command <- find ((== tCommand transition) . cmdName) (aggCommands aggregate)-      find ((== name) . aggregateFieldName) (cmdFields command)+      matchedCommand <- find ((== (.command) transition) . (.name)) ((.commands) aggregate)+      find ((== name) . (.name)) ((.fields) matchedCommand)     registerRoot value =-      ScalarRegisterRoot name (resolvedOrUnknown (resolveAggregateType symbols (regLoc value) RegisterUse (regType value)))+      ScalarRegisterRoot name (resolvedOrUnknown (resolveAggregateType symbols ((.loc) value) RegisterUse ((.valueType) value)))     commandRoot value =       ScalarCommandRoot name (resolvedOrUnknown (inferAggregateFieldType symbols aggregate CommandFieldUse value))     resolvedOrUnknown = either (const (AggregateMapped (MappedKey "<invalid>"))) id@@ -383,7 +391,7 @@         ( "scalar root '"             <> name             <> "' resolves to no register or field of command '"-            <> tCommand transition+            <> (.command) transition             <> "'; qualify enum values as Type.Constructor"         ) @@ -396,21 +404,21 @@         loc         ScalarPathInvalid         ("cannot project fields through scalar type '" <> aggregateCanonicalName other <> "'")-  graph <- maybe (failure loc ScalarPathUnsupported "mapped structural graph is unavailable") Right (environmentTypeGraph environment)+  graph <- maybe (failure loc ScalarPathUnsupported "mapped structural graph is unavailable") Right ((.typeGraph) environment)   (resolvedType, wireKeys) <- walk graph owner fields   if scalarLeaf resolvedType     then       pure         TypedScalarExpr-          { typedScalarType = resolvedType,-            typedScalarLoc = loc,-            typedScalarNode =+          { valueType = resolvedType,+            loc = loc,+            node =               TypedProject                 provenance                 ResolvedScalarProjection-                  { scalarProjectionOwner = owner,-                    scalarProjectionPointer = T.concat ["/" <> escapePointer key | key <- wireKeys],-                    scalarProjectionFields = fields+                  { owner = owner,+                    pointer = T.concat ["/" <> escapePointer key | key <- wireKeys],+                    fields = fields                   }           }     else@@ -419,22 +427,22 @@         ScalarPathUnsupported         ("path ends at unsupported non-scalar type '" <> aggregateCanonicalName resolvedType <> "'")   where-    walk graph ownerKey remaining = case Map.lookup ownerKey (tgDeclarations graph) of+    walk graph ownerKey remaining = case Map.lookup ownerKey ((.declarations) graph) of       Just (ResolvedStructural _ (RRecord _ _ recordFields)) -> selectField graph recordFields remaining       Just ResolvedStructural {} -> failure loc ScalarPathUnsupported "scalar paths may cross required structural records only"       Just ResolvedOpaque {} -> failure loc ScalarPathUnsupported "scalar paths cannot cross an opaque mapped declaration"       Nothing -> failure loc ScalarPathInvalid ("unknown mapped path owner '" <> unMappedKey ownerKey <> "'")      selectField _ _ [] = failure loc ScalarPathInvalid "scalar path is empty"-    selectField graph recordFields (fieldName : rest) = case find ((== fieldName) . rwfHaskell) recordFields of-      Nothing -> failure loc ScalarPathInvalid ("required structural field '" <> fieldName <> "' does not exist")+    selectField graph recordFields (name : rest) = case find ((== name) . (.haskell)) recordFields of+      Nothing -> failure loc ScalarPathInvalid ("required structural field '" <> name <> "' does not exist")       Just field-        | rwfPresence field /= PRequired -> failure loc ScalarPathUnsupported ("field '" <> fieldName <> "' is optional; scalar paths must be total")-        | null rest -> (,[rwfKey field]) <$> resolvedLeaf (rwfType field)-        | RRef nextOwner <- rwfType field -> do+        | (.presence) field /= PRequired -> failure loc ScalarPathUnsupported ("field '" <> name <> "' is optional; scalar paths must be total")+        | null rest -> (,[(.key) field]) <$> resolvedLeaf ((.valueType) field)+        | RRef nextOwner <- (.valueType) field -> do             (leafType, keys) <- walk graph nextOwner rest-            pure (leafType, rwfKey field : keys)-        | otherwise -> failure loc ScalarPathUnsupported ("field '" <> fieldName <> "' is not a required structural record")+            pure (leafType, (.key) field : keys)+        | otherwise -> failure loc ScalarPathUnsupported ("field '" <> name <> "' is not a required structural record")      resolvedLeaf = \case       RText -> Right AggregateText@@ -482,17 +490,17 @@         (syntax <> " literal cannot inhabit scalar type '" <> aggregateCanonicalName other <> "'")  resolveEnumLiteral :: ExpressionEnvironment -> Loc -> ExpectedScalarType -> Name -> Name -> Either (NonEmpty ExpressionDiagnostic) TypedScalarExpr-resolveEnumLiteral environment loc expected typeName constructor = case find ((== typeName) . enumName) (specEnums (environmentSpec environment)) of+resolveEnumLiteral environment loc expected typeName constructor = case find ((== typeName) . (.name)) ((.enums) ((.spec) environment)) of   Nothing -> failure loc ScalarLiteralInvalid ("unknown enum literal type '" <> typeName <> "'")   Just declaration-    | constructor `notElem` map fst (enumCtors declaration) ->+    | constructor `notElem` map fst ((.ctors) declaration) ->         failure loc ScalarLiteralInvalid ("enum '" <> typeName <> "' has no constructor '" <> constructor <> "'")     | otherwise -> do         resolved <- resolveDeclared typeName         requireExpected resolved         pure (literalExpr loc resolved (ScalarEnumValue typeName constructor))   where-    resolveDeclared name = case resolveAggregateType (environmentSymbols environment) loc WholeValueWriteUse (TRef name) of+    resolveDeclared name = case resolveAggregateType ((.symbols) environment) loc WholeValueWriteUse (TRef name) of       Left _ -> failure loc ScalarLiteralInvalid ("enum type '" <> name <> "' is not available at this aggregate use")       Right resolved -> Right resolved     requireExpected resolved = case expected of@@ -502,15 +510,15 @@         | otherwise -> failure loc ScalarOperandTypeMismatch ("enum literal has type '" <> aggregateCanonicalName resolved <> "', expected '" <> aggregateCanonicalName wanted <> "'")  resolveIdLiteral :: ExpressionEnvironment -> Loc -> ExpectedScalarType -> Name -> Text -> Either (NonEmpty ExpressionDiagnostic) TypedScalarExpr-resolveIdLiteral environment loc expected typeName value = case find ((== typeName) . idName) (specIds (environmentSpec environment)) of+resolveIdLiteral environment loc expected typeName value = case find ((== typeName) . (.name)) ((.ids) ((.spec) environment)) of   Nothing -> failure loc ScalarLiteralInvalid ("unknown ID literal type '" <> typeName <> "'")   Just declaration -> case TypeID.parseText value of     Left parseError -> failure loc ScalarLiteralInvalid ("invalid " <> typeName <> " literal: " <> T.pack (show parseError))     Right parsed-      | TypeID.getPrefix parsed /= idPrefix declaration ->-          failure loc ScalarLiteralInvalid ("ID literal prefix must be '" <> idPrefix declaration <> "'")+      | TypeID.getPrefix parsed /= (.prefix) declaration ->+          failure loc ScalarLiteralInvalid ("ID literal prefix must be '" <> (.prefix) declaration <> "'")       | otherwise -> do-          resolved <- case resolveAggregateType (environmentSymbols environment) loc WholeValueWriteUse (TRef typeName) of+          resolved <- case resolveAggregateType ((.symbols) environment) loc WholeValueWriteUse (TRef typeName) of             Left _ -> failure loc ScalarLiteralInvalid ("ID type '" <> typeName <> "' is not available at this aggregate use")             Right valueType -> Right valueType           case expected of@@ -555,7 +563,7 @@   AggregateMapped {} -> False  predicateValued :: TypedScalarExpr -> Bool-predicateValued expression = case typedScalarNode expression of+predicateValued expression = case (.node) expression of   TypedEqual {} -> True   TypedNotEqual {} -> True   TypedCompare {} -> True@@ -599,9 +607,9 @@ failure loc diagnosticCode diagnosticMessage =   Left     ( ExpressionDiagnostic-        { expressionDiagnosticLoc = loc,-          expressionDiagnosticCode = diagnosticCode,-          expressionDiagnosticMessage = diagnosticMessage+        { loc = loc,+          code = diagnosticCode,+          message = diagnosticMessage         }         :| []     )

src/Keiro/Dsl/FieldIdentity.hs view

@@ -15,27 +15,27 @@ import Keiro.Dsl.Grammar  data ResolvedFieldIdentity = ResolvedFieldIdentity-  { fieldDslName :: !Name,-    fieldSelector :: !Text,-    fieldWireKey :: !Text,-    fieldLoc :: !Loc+  { dslName :: !Name,+    selector :: !Text,+    wireKey :: !Text,+    loc :: !Loc   }   deriving stock (Eq, Show)  resolveAggregateFieldIdentity :: AggregateField -> ResolvedFieldIdentity resolveAggregateFieldIdentity field =   ResolvedFieldIdentity-    { fieldDslName = aggregateFieldName field,-      fieldSelector = maybe (aggregateFieldName field) id (aggregateFieldSelector field),-      fieldWireKey = maybe (aggregateFieldName field) id (aggregateFieldWireKey field),-      fieldLoc = aggregateFieldLoc field+    { dslName = (.name) field,+      selector = maybe ((.name) field) id ((.selector) field),+      wireKey = maybe ((.name) field) id ((.wireKey) field),+      loc = (.loc) field     }  resolveContractFieldIdentity :: ContractField -> ResolvedFieldIdentity resolveContractFieldIdentity field =   ResolvedFieldIdentity-    { fieldDslName = cfName field,-      fieldSelector = maybe (cfName field) id (cfSelector field),-      fieldWireKey = maybe (cfName field) id (cfWireKey field),-      fieldLoc = cfLoc field+    { dslName = (.name) field,+      selector = maybe ((.name) field) id ((.selector) field),+      wireKey = maybe ((.name) field) id ((.wireKey) field),+      loc = (.loc) field     }

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, checkedLanguageContract, checkedSpec, checkedTypeGraph, effectiveRuntimeProfile, runtimeSemanticsFingerprintSegments)+import Keiro.Dsl.SemanticContract (CheckedService, EffectiveLanguageContract (..), checkedLanguageContract, checkedSpec, checkedTypeGraph, runtimeSemanticsFingerprintSegments) import Keiro.Dsl.TypeGraph  -- | A checked service can retain language provenance before semantic@@ -72,14 +72,14 @@   graph <- mapLeft (FoldTypeGraphResolutionFailed . showText) (checkedTypeGraph service)   let symbols = aggregateSymbolsFromGraph graph spec   nominalRegistry <- mapLeft (FoldNominalResolutionFailed . showText) (resolveNominalTypes spec)-  registerSegments <- traverse (registerSegment symbols) (aggRegs aggregate)+  registerSegments <- traverse (registerSegment symbols) ((.regs) aggregate)   equalityUses <- nominalEqualityUses graph service aggregate-  transitionSegments <- traverse (transitionSegment graph spec aggregate) (aggTransitions aggregate)+  transitionSegments <- traverse (transitionSegment graph spec aggregate) ((.transitions) aggregate)   pure     ( T.intercalate         "\n"         ( runtimeSemanticsFingerprintSegments (checkedLanguageContract service)-            ++ map stateSegment (aggStates aggregate)+            ++ map stateSegment ((.states) aggregate)             ++ registerSegments             ++ mappedRegisterSegments graph             ++ nominalSegments nominalRegistry@@ -92,20 +92,20 @@     spec = checkedSpec service     referencedRules =       [ rule-      | rule <- specRules spec,-        ruleName rule `Set.member` referencedRuleNames spec aggregate+      | rule <- (.rules) spec,+        (.name) rule `Set.member` referencedRuleNames spec aggregate       ]     mappedRegisterSegments graph =       [ mappedRegisterSegment graph declaration-      | register <- aggRegs aggregate,-        TRef typeName <- [regType register],-        Just declaration <- [Map.lookup (MappedKey typeName) (tgDeclarations graph)]+      | register <- (.regs) aggregate,+        TRef typeName <- [(.valueType) register],+        Just declaration <- [Map.lookup (MappedKey typeName) ((.declarations) graph)]       ]     nominalSegments registry =       [ nominalUseSegment useSite nominal binding       | (useSite, typeName) <- nominalUseNames aggregate,         Just nominal <- [lookupNominalType typeName registry],-        ConsumerNominal binding <- [resolvedNominalOwnership nominal]+        ConsumerNominal binding <- [(.ownership) nominal]       ]  -- | Equality representation belongs in the fold identity only when a guard@@ -114,26 +114,26 @@ -- retain the old fold fingerprint. 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))+  if runtimeProfileHasCapability ((.runtimeProfile) (checkedLanguageContract service)) NominalEqualityV2+    then fmap (Set.fromList . concat) (traverse transitionIdentities ((.transitions) aggregate))     else       Right         ( Set.fromList             [ identity-            | transition <- aggTransitions aggregate,-              guardSyntax <- maybeToList (tGuard transition),+            | transition <- (.transitions) aggregate,+              guardSyntax <- maybeToList ((.guard) transition),               Right guardExpression <- [resolveGuardExpr (expressionEnvironmentFromGraph graph spec aggregate transition) guardSyntax],               identity <- equalityIdentities (checkedLanguageContract service) guardExpression             ]         )   where     spec = checkedSpec service-    transitionIdentities transition = case tGuard transition of+    transitionIdentities transition = case (.guard) transition of       Nothing -> Right []       Just guardSyntax -> do         guardExpression <-           mapLeft-            (FoldGuardResolutionFailed (aggName aggregate) (tCommand transition) . showText)+            (FoldGuardResolutionFailed ((.name) aggregate) ((.command) transition) . showText)             (resolveGuardExpr (expressionEnvironmentFromGraph graph spec aggregate transition) guardSyntax)         pure (equalityIdentities (checkedLanguageContract service) guardExpression) @@ -141,14 +141,14 @@ equalityIdentities languageContract expression =   current <> children   where-    current = case typedScalarNode expression of+    current = case (.node) expression of       TypedEqual left _ -> equalityIdentity left       TypedNotEqual left _ -> equalityIdentity left       _ -> []-    equalityIdentity operand = case typedScalarType operand of+    equalityIdentity operand = case (.valueType) operand of       AggregateNominal nominal -> maybeToList (nominalEqualityIdentityForService languageContract nominal)       _ -> []-    children = case typedScalarNode expression of+    children = case (.node) expression of       TypedLiteral {} -> []       TypedRoot {} -> []       TypedProject {} -> []@@ -164,31 +164,31 @@  nominalUseNames :: Aggregate -> [(Text, Name)] nominalUseNames aggregate =-  [ ("register:" <> regName register, typeName)-  | register <- aggRegs aggregate,-    TRef typeName <- [regType register]+  [ ("register:" <> (.name) register, typeName)+  | register <- (.regs) aggregate,+    TRef typeName <- [(.valueType) register]   ]-    <> [ ("event:" <> evName event <> "." <> aggregateFieldName field, typeName)-       | event <- aggEvents aggregate,+    <> [ ("event:" <> (.name) event <> "." <> (.name) field, typeName)+       | event <- (.events) aggregate,          field <- eventFields event,-         TRef typeName <- maybe [] pure (aggregateFieldType field)+         TRef typeName <- maybe [] pure ((.valueType) field)        ]   where-    eventFields event = case evBody event of+    eventFields event = case (.body) event of       EventFields fields -> fields-      EventFromCommand commandName -> concat [cmdFields command | command <- aggCommands aggregate, cmdName command == commandName]+      EventFromCommand commandName -> concat [(.fields) command | command <- (.commands) aggregate, (.name) command == commandName]  nominalUseSegment :: Text -> ResolvedNominalType -> ConsumerNominalBinding -> Text nominalUseSegment useSite nominal binding =   T.intercalate     "|"     [ "nominal-use:" <> useSite,-      "name=" <> resolvedNominalName nominal,-      "representation=" <> nominalRepresentationSegment (resolvedNominalRepresentation nominal),-      "canonical=" <> unCanonicalTypeId (consumerNominalCanonical binding),-      "binding=" <> unQualifiedValueName (consumerNominalBinding binding),-      "binding-version=" <> unBindingVersion (consumerNominalBindingVersion binding),-      "initial=" <> maybe "(none)" unQualifiedValueName (consumerNominalInitial binding)+      "name=" <> (.name) nominal,+      "representation=" <> nominalRepresentationSegment ((.representation) nominal),+      "canonical=" <> unCanonicalTypeId ((.canonical) binding),+      "binding=" <> unQualifiedValueName ((.binding) binding),+      "binding-version=" <> unBindingVersion ((.bindingVersion) binding),+      "initial=" <> maybe "(none)" unQualifiedValueName ((.initial) binding)     ]  nominalRepresentationSegment :: NominalRepresentation -> Text@@ -206,80 +206,80 @@ mappedRegisterSegment graph (ResolvedStructural declaration _) =   T.intercalate     "|"-    [ "mapped-register:" <> sdName declaration,-      "wire=" <> wireFingerprint graph (sdName declaration),-      "canonical=" <> unCanonicalTypeId (sdCanonical declaration),-      "binding=" <> unQualifiedValueName (sdBinding declaration),-      "binding-version=" <> unBindingVersion (sdBindingVersion declaration),-      "initial=" <> maybe "(missing)" unQualifiedValueName (sdInitial declaration)+    [ "mapped-register:" <> (.name) declaration,+      "wire=" <> wireFingerprint graph ((.name) declaration),+      "canonical=" <> unCanonicalTypeId ((.canonical) declaration),+      "binding=" <> unQualifiedValueName ((.binding) declaration),+      "binding-version=" <> unBindingVersion ((.bindingVersion) declaration),+      "initial=" <> maybe "(missing)" unQualifiedValueName ((.initial) declaration)     ] mappedRegisterSegment _ (ResolvedOpaque declaration) =   T.intercalate     "|"-    [ "mapped-register:" <> odName declaration,-      "codec=" <> unCodecIdentity (odCodecIdentity declaration),-      "codec-version=" <> unCodecVersion (odCodecVersion declaration),-      "initial=" <> maybe "(missing)" unQualifiedValueName (odInitial declaration)+    [ "mapped-register:" <> (.name) declaration,+      "codec=" <> unCodecIdentity ((.codecIdentity) declaration),+      "codec-version=" <> unCodecVersion ((.codecVersion) declaration),+      "initial=" <> maybe "(missing)" unQualifiedValueName ((.initial) declaration)     ]  stateSegment :: StateDecl -> Text stateSegment state =   "state:"-    <> stName state+    <> (.name) state     <> "|terminal="-    <> if stTerminal state then "true" else "false"+    <> if (.terminal) state then "true" else "false"  registerSegment :: AggregateSymbols -> RegDecl -> Either FoldSurfaceError Text registerSegment symbols register = do   resolvedType <-     mapLeft-      (FoldRegisterTypeResolutionFailed (regName register) . showText)-      (resolveAggregateType symbols (regLoc register) RegisterUse (regType register))+      (FoldRegisterTypeResolutionFailed ((.name) register) . showText)+      (resolveAggregateType symbols ((.loc) register) RegisterUse ((.valueType) register))   resolvedInitial <-     mapLeft-      (FoldRegisterInitialResolutionFailed (regName register) . showText)-      (resolveRegisterInitial symbols (regLoc register) resolvedType (regInitial register))+      (FoldRegisterInitialResolutionFailed ((.name) register) . showText)+      (resolveRegisterInitial symbols ((.loc) register) resolvedType ((.initial) register))   pure     ( "reg:"-        <> regName register+        <> (.name) register         <> ":"-        <> typeExprCanonicalName (regType register)+        <> typeExprCanonicalName ((.valueType) register)         <> "="         <> registerInitialCanonicalName resolvedInitial     )  transitionSegment :: TypeGraph -> Spec -> Aggregate -> Transition -> Either FoldSurfaceError Text transitionSegment graph spec aggregate transition = do-  outputOwnershipSegment <- case tImplementation transition of+  outputOwnershipSegment <- case (.implementation) transition of     LegacyHoleImplementation -> Right []     GeneratedImplementation -> fmap (pure . ("outputs=" <>) . T.intercalate ",") outputSegments     HoleImplementation -> fmap (pure . ("outputs=" <>) . T.intercalate ",") outputSegments   pure     ( T.intercalate         "|"-        ( [ "transition:" <> renderMode (tMode transition),-            tSource transition,-            tCommand transition+        ( [ "transition:" <> renderMode ((.mode) transition),+            (.source) transition,+            (.command) transition           ]             ++ implementationSegment-            ++ [ "guard=" <> maybe "" canonicalExpr (tGuard transition),-                 "writes=" <> T.intercalate ";" (map renderWrite (tWrites transition)),-                 "emits=" <> T.intercalate "," (tEmits transition)+            ++ [ "guard=" <> maybe "" canonicalExpr ((.guard) transition),+                 "writes=" <> T.intercalate ";" (map renderWrite ((.writes) transition)),+                 "emits=" <> T.intercalate "," ((.emits) transition)                ]             ++ outputOwnershipSegment-            ++ ["goto=" <> tGoto transition]+            ++ ["goto=" <> (.goto) transition]         )     )   where     renderWrite (registerName, expression) = registerName <> ":=" <> canonicalExpr expression-    outputSegments = traverse (uncurry outputSegment) (zip [1 ..] (tEmits transition))+    outputSegments = traverse (uncurry outputSegment) (zip [1 ..] ((.emits) transition))     outputSegment emitIndex eventName = do       mapping <-         mapLeft-          (FoldEventOutputResolutionFailed (aggName aggregate) (tCommand transition) eventName . showText)+          (FoldEventOutputResolutionFailed ((.name) aggregate) ((.command) transition) eventName . showText)           (eventOutputMappingFromGraph graph spec aggregate transition emitIndex eventName)       pure (eventName <> "=" <> eventOutputCanonical mapping)-    implementationSegment = case tImplementation transition of+    implementationSegment = case (.implementation) transition of       LegacyHoleImplementation -> []       GeneratedImplementation -> ["implementation=generated"]       HoleImplementation -> ["implementation=hole"]@@ -292,10 +292,10 @@ ruleSegment rule =   T.intercalate     "|"-    [ "rule:" <> ruleName rule,-      ruleDomain rule,-      ruleCodomain rule,-      "cases=" <> T.intercalate ";" (map renderCase (ruleCases rule))+    [ "rule:" <> (.name) rule,+      (.domain) rule,+      (.codomain) rule,+      "cases=" <> T.intercalate ";" (map renderCase ((.cases) rule))     ]   where     renderCase (constructorName, expression) = constructorName <> "=>" <> canonicalExpr expression@@ -303,20 +303,20 @@ referencedRuleNames :: Spec -> Aggregate -> Set Name referencedRuleNames spec aggregate = close directNames   where-    rules = specRules spec+    rules = (.rules) spec     directNames =       Set.unions         [ exprNames expression-        | transition <- aggTransitions aggregate,-          expression <- maybeToList (tGuard transition) ++ map snd (tWrites transition)+        | transition <- (.transitions) aggregate,+          expression <- maybeToList ((.guard) transition) ++ map snd ((.writes) transition)         ]     close names =       let expanded =             Set.unions               ( names-                  : [ Set.unions (map (exprNames . snd) (ruleCases rule))+                  : [ Set.unions (map (exprNames . snd) ((.cases) rule))                     | name <- Set.toList names,-                      Just rule <- [find ((== name) . ruleName) rules]+                      Just rule <- [find ((== name) . (.name)) rules]                     ]               )        in if expanded == names then names else close expanded

src/Keiro/Dsl/Frontend/Internal.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE NoFieldSelectors #-}- -- | Shared implementation behind the public frontend and parser compatibility -- facade. This module is intentionally not exposed by the package. module Keiro.Dsl.Frontend.Internal@@ -32,7 +30,7 @@ import GHC.Generics (Generic) import Keiro.Dsl.Grammar import Keiro.Dsl.LanguageVersion-  ( LanguageDefinition,+  ( LanguageDefinition (..),     LanguageFeature,     LanguageVersion,     ParseFailure (..),@@ -40,7 +38,6 @@     SourceLanguage,     SourceLanguageDiagnostic (..),     SourceLanguageErrorCode,-    definitionVersion,     languageSupportsFeature,     renderParseFailure,     sourceLanguageDiagnosticMessage,@@ -62,7 +59,7 @@   deriving stock (Eq, Show, Generic)  frontendLanguageVersion :: FrontendContext -> LanguageVersion-frontendLanguageVersion FrontendContext {definition} = definitionVersion definition+frontendLanguageVersion FrontendContext {definition} = (.version) definition  frontendSupportsFeature :: FrontendContext -> LanguageFeature -> Bool frontendSupportsFeature context feature = languageSupportsFeature (frontendLanguageVersion context) feature@@ -111,11 +108,11 @@ frontendFailureFromSourceDiagnostic phase span supportedOverride diagnostic =   FrontendFailure     { phase,-      code = SourceLanguageError (sourceLanguageErrorCode diagnostic),+      code = SourceLanguageError ((.errorCode) diagnostic),       span,       message = sourceLanguageDiagnosticMessage diagnostic,       expected = [],-      supportedVersions = fromMaybe (NE.toList (sourceLanguageSupportedVersions diagnostic)) supportedOverride,+      supportedVersions = fromMaybe (NE.toList ((.supportedVersions) diagnostic)) supportedOverride,       compatibility = SourceLanguageFailure diagnostic     } @@ -189,13 +186,13 @@       Right       ( exactSemanticSourceIndex           (case surfaceSource of SurfaceSource {source} -> source)-          (semanticSourceSubjects (parsedSpec parsedSource))+          (semanticSourceSubjects ((.spec) parsedSource))           (surfaceSourceEntries surfaceSource)       )   pure     ParsedSourceDocument-      { documentParsedSource = parsedSource,-        documentSourceIndex = sourceIndex+      { parsedSource = parsedSource,+        sourceIndex = sourceIndex       }  -- | Compatibility lowering for syntax-valid semantic graphs, including graphs@@ -206,8 +203,8 @@   validateSurfaceSource surfaceSource   pure     ParsedSource-      { parsedSourceLanguage = language,-        parsedSpec = lowerSpec locatedSpec+      { sourceLanguage = language,+        spec = lowerSpec locatedSpec       }  surfaceSourceEntries :: SurfaceSource -> [(SourceSubject, SourceSpan)]@@ -223,11 +220,11 @@       SurfaceExpression {} -> []  sourceIndexLoweringFailure :: SourceSpan -> SourceIndexFailure -> LoweringFailure-sourceIndexLoweringFailure fallback SourceIndexFailure {failureCode = indexCode, failureSpan, failureMessage} =+sourceIndexLoweringFailure fallback SourceIndexFailure {code = indexCode, span, message} =   LoweringFailure     { code = SemanticSourceIndexInvalid indexCode,-      span = maybe fallback id failureSpan,-      message = failureMessage+      span = maybe fallback id span,+      message = message     }  lowerSpec :: Located SurfaceSpec -> Spec@@ -235,22 +232,22 @@   Located     { value =         SurfaceSpec-          { context = Located {value = contextName},+          { context = Located {value = name},             moduleRoot,             layout,             items           }     } =     Spec-      { specContext = contextName,-        specModuleRoot = locatedValue <$> moduleRoot,-        specLayout = locatedValue <$> layout,-        specIds = [declaration | Located {span, value = SurfaceId value} <- items, let declaration = value {idLoc = spanLoc span}],-        specEnums = [declaration | Located {span, value = SurfaceEnum value} <- items, let declaration = value {enumLoc = spanLoc span}],-        specRules = [declaration | Located {span, value = SurfaceRule value} <- items, let declaration = value {ruleLoc = spanLoc span}],-        specNominalScalars = [declaration | Located {span, value = SurfaceNominalScalar value} <- items, let declaration = value {nominalScalarLoc = spanLoc span}],-        specMapped = [declaration | Located {span, value = SurfaceMapped value} <- items, let declaration = setMappedLoc (spanLoc span) value],-        specNodes = [node | Located {span, value = SurfaceNode value} <- items, let node = setNodeLoc (spanLoc span) value]+      { context = name,+        moduleRoot = locatedValue <$> moduleRoot,+        layout = locatedValue <$> layout,+        ids = [setIdLoc (spanLoc span) value | Located {span, value = SurfaceId value} <- items],+        enums = [setEnumLoc (spanLoc span) value | Located {span, value = SurfaceEnum value} <- items],+        rules = [setRuleLoc (spanLoc span) value | Located {span, value = SurfaceRule value} <- items],+        nominalScalars = [setNominalScalarLoc (spanLoc span) value | Located {span, value = SurfaceNominalScalar value} <- items],+        mapped = [declaration | Located {span, value = SurfaceMapped value} <- items, let declaration = setMappedLoc (spanLoc span) value],+        nodes = [node | Located {span, value = SurfaceNode value} <- items, let node = setNodeLoc (spanLoc span) value]       }  locatedValue :: Located a -> a@@ -259,64 +256,73 @@ spanLoc :: SourceSpan -> Loc spanLoc sourceSpan = Loc (startLine sourceSpan) +setIdLoc :: Loc -> IdDecl -> IdDecl+setIdLoc loc IdDecl {name, prefix, binding} = IdDecl {name, prefix, binding, loc}++setEnumLoc :: Loc -> EnumDecl -> EnumDecl+setEnumLoc loc EnumDecl {name, ctors, binding} = EnumDecl {name, ctors, binding, loc}++setRuleLoc :: Loc -> RuleDecl -> RuleDecl+setRuleLoc loc RuleDecl {name, domain, codomain, cases} = RuleDecl {name, domain, codomain, cases, loc}++setNominalScalarLoc :: Loc -> NominalScalarDecl -> NominalScalarDecl+setNominalScalarLoc loc NominalScalarDecl {name, representation, binding} =+  NominalScalarDecl {name, representation, binding, loc}+ setMappedLoc :: Loc -> MappedDecl -> MappedDecl-setMappedLoc loc value@MappedStructural {} = value {msLoc = loc}-setMappedLoc loc value@MappedOpaque {} = value {moLoc = loc}+setMappedLoc loc (MappedStructural name haskell binding bindingVersion canonical fixtures initial shape _) =+  MappedStructural name haskell binding bindingVersion canonical fixtures initial shape loc+setMappedLoc loc (MappedOpaque name haskell codecId codecVersion fixtures initial _) =+  MappedOpaque name haskell codecId codecVersion fixtures initial loc  setNodeLoc :: Loc -> Node -> Node setNodeLoc loc = \case-  NAggregate value -> NAggregate value {aggLoc = loc}-  NProcess value -> NProcess value {procLoc = loc}-  NRouter value -> NRouter value {rtLoc = loc}-  NContract value -> NContract value {ctrLoc = loc}-  NIntake value -> NIntake value {inkLoc = loc}-  NEmit value -> NEmit value {emLoc = loc}-  NPublisher value -> NPublisher value {pubLoc = loc}-  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,-        wfStable,-        wfInput,-        wfInputFields,-        wfOutput,-        wfIdField,-        wfIdVia,-        wfBody-      } ->-      NWorkflow-        WorkflowNode-          { wfId,-            wfStable,-            wfInput,-            wfInputFields,-            wfOutput,-            wfIdField,-            wfIdVia,-            wfBody,-            wfLoc = loc-          }-  NOperation value -> NOperation value {opLoc = loc}+  NAggregate (Aggregate name regs states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot _) ->+    NAggregate (Aggregate name regs states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc)+  NProcess (ProcessNode nodeId name input correlate saga target projections handle rejected poison timer _) ->+    NProcess (ProcessNode nodeId name input correlate saga target projections handle rejected poison timer loc)+  NRouter (RouterNode nodeId name input key resolve target projections dispatch rejected poison _) ->+    NRouter (RouterNode nodeId name input key resolve target projections dispatch rejected poison loc)+  NContract (ContractNode name schemaVersion discriminator topics events _) ->+    NContract (ContractNode name schemaVersion discriminator topics events loc)+  NIntake (IntakeNode name contract topic accept binds dedupeKey dedupePolicy persist decode disposition _) ->+    NIntake (IntakeNode name contract topic accept binds dedupeKey dedupePolicy persist decode disposition loc)+  NEmit (EmitNode name contract topic source key discriminant mapping skip messageId idempotencyKey _) ->+    NEmit (EmitNode name contract topic source key discriminant mapping skip messageId idempotencyKey loc)+  NPublisher (PublisherNode name emit ordering maxAttempts backoff outboxField _) ->+    NPublisher (PublisherNode name emit ordering maxAttempts backoff outboxField loc)+  NWorkqueue (WorkqueueNode name logical physical dlq table ordering groupKey provision payloadName payload maxRetries delay dlqOn disposition _) ->+    NWorkqueue (WorkqueueNode name logical physical dlq table ordering groupKey provision payloadName payload maxRetries delay dlqOn disposition loc)+  NPgmqDispatch PgmqDispatchNode {name, sourceReadModel, sourceKey, fanoutBody, dedupKey, dedupReadModel, dedupReadModelField, dedupQueue, dedupQueueField, enqueueTo} ->+    NPgmqDispatch PgmqDispatchNode {name, sourceReadModel, sourceKey, fanoutBody, dedupKey, dedupReadModel, dedupReadModelField, dedupQueue, dedupQueueField, enqueueTo, loc}+  NReadModel (ReadModelNode name table schema columns version shape freshness supply group observedTargets backingTarget queryTypes _) ->+    NReadModel (ReadModelNode name table schema columns version shape freshness supply group observedTargets backingTarget queryTypes loc)+  NProjectionTarget ProjectionTargetNode {name, schema, table, reset, dependsOn} ->+    NProjectionTarget ProjectionTargetNode {name, schema, table, reset, dependsOn, loc}+  NRebuildGroup RebuildGroupNode {name, targets, order} ->+    NRebuildGroup RebuildGroupNode {name, targets, order, loc}+  NProjectionRevision (ProjectionRevisionNode name group targets _) ->+    NProjectionRevision (ProjectionRevisionNode name group targets loc)+  NExternalRead ExternalReadNode {name, version, queryModel, resultSchema, resultType, compatibleRevisions, surfaceGeneration} ->+    NExternalRead ExternalReadNode {name, version, queryModel, resultSchema, resultType, compatibleRevisions, surfaceGeneration, loc}+  NProjectionOwner ProjectionOwnerNode {name, sources, delivery, group, targets, order, subscription, dedup, checkpointOnMissing, replay} ->+    NProjectionOwner ProjectionOwnerNode {name, sources, delivery, group, targets, order, subscription, dedup, checkpointOnMissing, replay, loc}+  NWorkflow (WorkflowNode nodeId stable input inputFields output idField idVia body _) ->+    NWorkflow (WorkflowNode nodeId stable input inputFields output idField idVia body loc)+  NOperation (OperationNode name shape _) -> NOperation (OperationNode name shape loc)  validateSurfaceSource :: SurfaceSource -> Either LoweringFailure () validateSurfaceSource   SurfaceSource     { source = sourceName,       preamble,-      spec = Located {span = specSpan, value = surfaceSpec}+      spec = Located {span = specSpan, value = spec}     } = do     traverse_ (validateOwnedSpan sourceName) allSpans     traverse_ (validateContained specSpan) bodySpans-    validateOrder (surfaceItemSpans surfaceSpec)+    validateOrder (surfaceItemSpans spec)     where-      bodySpans = surfaceSpecSpans surfaceSpec+      bodySpans = surfaceSpecSpans spec       allSpans = specSpan : maybe [] (\Located {span} -> [span]) preamble <> bodySpans       validateOwnedSpan expected sourceSpan@SourceSpan {source}         | not (validSourceSpan sourceSpan) =

− src/Keiro/Dsl/GeneratedHaskellLanguage.hs

@@ -1,48 +0,0 @@--- | The Haskell language contract for overwriteable generated modules.------ The manifest and conformance build profile publish the shared baseline.--- Syntax outside that baseline must be requested through the closed extension--- type and rendered as a module-local pragma.-module Keiro.Dsl.GeneratedHaskellLanguage-  ( GeneratedHaskellExtension (..),-    generatedHaskellDefaultLanguage,-    generatedHaskellDefaultExtensions,-    renderGeneratedLanguagePragmas,-  )-where--import Data.List (nub, sort)-import Data.Text (Text)--data GeneratedHaskellExtension-  = ExtBlockArguments-  | ExtDeriveAnyClass-  | ExtDuplicateRecordFields-  | ExtOverloadedLabels-  | ExtOverloadedRecordDot-  | ExtQualifiedDo-  | ExtTemplateHaskell-  | ExtTypeFamilies-  deriving (Eq, Ord, Show)--generatedHaskellDefaultLanguage :: Text-generatedHaskellDefaultLanguage = "GHC2024"--generatedHaskellDefaultExtensions :: [Text]-generatedHaskellDefaultExtensions = ["OverloadedStrings"]--renderGeneratedLanguagePragmas :: [GeneratedHaskellExtension] -> [Text]-renderGeneratedLanguagePragmas = map renderPragma . sort . nub . map extensionName-  where-    renderPragma name = "{-# LANGUAGE " <> name <> " #-}"--extensionName :: GeneratedHaskellExtension -> Text-extensionName extension = case extension of-  ExtBlockArguments -> "BlockArguments"-  ExtDeriveAnyClass -> "DeriveAnyClass"-  ExtDuplicateRecordFields -> "DuplicateRecordFields"-  ExtOverloadedLabels -> "OverloadedLabels"-  ExtOverloadedRecordDot -> "OverloadedRecordDot"-  ExtQualifiedDo -> "QualifiedDo"-  ExtTemplateHaskell -> "TemplateHaskell"-  ExtTypeFamilies -> "TypeFamilies"

src/Keiro/Dsl/Goldens.hs view

@@ -27,7 +27,7 @@ import Data.Text.IO qualified as TIO import Data.Text.Lazy qualified as TL import Keiro.Dsl.AggregateType-import Keiro.Dsl.FieldIdentity (fieldWireKey)+import Keiro.Dsl.FieldIdentity (ResolvedFieldIdentity (..)) import Keiro.Dsl.Grammar import Keiro.Dsl.NominalType import Keiro.Dsl.Scaffold (Agg (..), ResolvedCtor (..), defaultContext, resolveAgg)@@ -39,12 +39,12 @@   deriving stock (Eq, Show)  data GoldenPayload = GoldenPayload-  { goldenContext :: !Text,-    goldenAggregate :: !Text,-    goldenEvent :: !Text,-    goldenVersion :: !Int,-    goldenJson :: !Text,-    goldenEvidence :: !GoldenEvidence+  { context :: !Text,+    aggregate :: !Text,+    event :: !Text,+    version :: !Int,+    json :: !Text,+    evidence :: !GoldenEvidence   }   deriving stock (Eq, Show) @@ -53,23 +53,23 @@ goldensForDiff :: Spec -> Spec -> [GoldenPayload] goldensForDiff oldSpec newSpec =   [ GoldenPayload-      { goldenContext = specContext oldSpec,-        goldenAggregate = aggName oldAggregate,-        goldenEvent = evName oldEvent,-        goldenVersion = evVersion oldEvent,-        goldenJson = renderGolden oldSpec oldResolved oldResolvedEvent,-        goldenEvidence = SynthesizedWeakStandIn+      { context = (.context) oldSpec,+        aggregate = (.name) oldAggregate,+        event = (.name) oldEvent,+        version = (.version) oldEvent,+        json = renderGolden oldSpec oldResolved oldResolvedEvent,+        evidence = SynthesizedWeakStandIn       }   | oldAggregate <- aggregates oldSpec,-    Just newAggregate <- [find ((== aggName oldAggregate) . aggName) (aggregates newSpec)],-    let oldResolved = resolveAgg (defaultContext (specContext oldSpec)) oldSpec oldAggregate,-    oldEvent <- aggEvents oldAggregate,-    Just newEvent <- [find ((== evName oldEvent) . evName) (aggEvents newAggregate)],-    evVersion newEvent > evVersion oldEvent,-    Just oldResolvedEvent <- [find ((== evName oldEvent) . rcName) (aEvents oldResolved)]+    Just newAggregate <- [find ((== (.name) oldAggregate) . (.name)) (aggregates newSpec)],+    let oldResolved = resolveAgg (defaultContext ((.context) oldSpec)) oldSpec oldAggregate,+    oldEvent <- (.events) oldAggregate,+    Just newEvent <- [find ((== (.name) oldEvent) . (.name)) ((.events) newAggregate)],+    (.version) newEvent > (.version) oldEvent,+    Just oldResolvedEvent <- [find ((== (.name) oldEvent) . (.name)) ((.events) oldResolved)]   ]   where-    aggregates spec = [aggregate | NAggregate aggregate <- specNodes spec]+    aggregates spec = [aggregate | NAggregate aggregate <- (.nodes) spec]  -- | Write newly synthesized fixtures below -- @<root>/<context>/<aggregate>/<event>.v<version>.json@. Existing files are@@ -85,62 +85,72 @@         then pure []         else do           createDirectoryIfMissing True (takeDirectory path)-          TIO.writeFile path (goldenJson golden)+          TIO.writeFile path ((.json) golden)           pure [path]  -- | Load only the fixtures relevant to declared upcasters in @spec@. -- @root@ may name the global golden root or its context child directory. loadGoldenPayloads :: FilePath -> Spec -> IO [GoldenPayload] loadGoldenPayloads root spec = do-  contextRoot <- resolveContextRoot root (T.unpack (specContext spec))+  contextRoot <- resolveContextRoot root (T.unpack ((.context) spec))   fmap concat . traverse (loadAggregate contextRoot) $ aggregates spec   where-    aggregates current = [aggregate | NAggregate aggregate <- specNodes current]+    aggregates current = [aggregate | NAggregate aggregate <- (.nodes) current]      loadAggregate contextRoot aggregate =-      fmap concat . traverse (loadEvent contextRoot aggregate) $ aggEvents aggregate+      fmap concat . traverse (loadEvent contextRoot aggregate) $ (.events) aggregate -    loadEvent contextRoot aggregate event = case evUpcastFrom event of+    loadEvent contextRoot aggregate event = case (.upcastFrom) event of       Nothing -> pure []       Just (sourceVersion, _) -> do         let golden =               GoldenPayload-                { goldenContext = specContext spec,-                  goldenAggregate = aggName aggregate,-                  goldenEvent = evName event,-                  goldenVersion = sourceVersion,-                  goldenJson = "",-                  goldenEvidence = FileOwnedFixture+                { context = (.context) spec,+                  aggregate = (.name) aggregate,+                  event = (.name) event,+                  version = sourceVersion,+                  json = "",+                  evidence = FileOwnedFixture                 }             path = contextRoot </> aggregateRelativePath golden         exists <- doesFileExist path         if exists           then do             contents <- TIO.readFile path-            pure [golden {goldenJson = contents}]+            pure [goldenWithJson contents golden]           else pure [] +    goldenWithJson json golden =+      GoldenPayload+        { context = golden.context,+          aggregate = golden.aggregate,+          event = golden.event,+          version = golden.version,+          json,+          evidence = golden.evidence+        }+ goldenRelativePath :: GoldenPayload -> FilePath goldenRelativePath golden =-  T.unpack (goldenContext golden) </> aggregateRelativePath golden+  T.unpack ((.context) golden) </> aggregateRelativePath golden  aggregateRelativePath :: GoldenPayload -> FilePath aggregateRelativePath golden =-  T.unpack (goldenAggregate golden)-    </> T.unpack (goldenEvent golden)+  T.unpack ((.aggregate) golden)+    </> T.unpack ((.event) golden)       <> ".v"-      <> show (goldenVersion golden)+      <> show ((.version) golden)       <> ".json"  resolveContextRoot :: FilePath -> FilePath -> IO FilePath-resolveContextRoot root contextName = do-  let nested = root </> contextName+resolveContextRoot root name = do+  let nested = root </> name   nestedExists <- doesDirectoryExist nested   pure $     if nestedExists       then nested       else-        if takeFileName (dropTrailingPathSeparator root) == contextName+        if takeFileName (dropTrailingPathSeparator root) == name           then root           else nested @@ -150,13 +160,13 @@   where     graph = either (const Nothing) Just (resolveTypeGraph spec)     entries =-      (Key.fromText "kind", String (rcName event))-        : [(Key.fromText (fieldWireKey identity), sampleValue graph spec aggregate fieldType) | (identity, fieldType) <- rcFields event]+      (Key.fromText "kind", String ((.name) event))+        : [(Key.fromText ((.wireKey) identity), sampleValue graph spec aggregate valueType) | (identity, valueType) <- (.fields) event]  sampleValue :: Maybe TypeGraph -> Spec -> Agg -> ResolvedAggregateType -> Value sampleValue graph spec _aggregate resolvedType =   case resolvedType of-    AggregateNominal nominal -> case resolvedNominalRepresentation nominal of+    AggregateNominal nominal -> case (.representation) nominal of       IdRepresentation prefix -> String (prefix <> "_01hzy3v7q2e8kaw2m5x0d41n9c")       EnumRepresentation constructors -> String (snd (NE.head constructors))       ScalarRepresentation NominalText -> String "sample"@@ -168,15 +178,15 @@       String         ( fromMaybe             "sample"-            ( stName-                <$> ( find ((== vertexType) . (<> "Vertex") . aggName) aggregates-                        >>= listToMaybe . aggStates+            ( (.name)+                <$> ( find ((== vertexType) . (<> "Vertex") . (.name)) aggregates+                        >>= listToMaybe . (.states)                     )             )         )     AggregateMapped key       | Just resolved <- graph,-        Just declaration <- Map.lookup key (tgDeclarations resolved) ->+        Just declaration <- Map.lookup key ((.declarations) resolved) ->           sampleMappedDeclaration resolved declaration       | otherwise -> emptyObject     AggregateInt -> Number 1@@ -186,7 +196,7 @@     AggregateTime -> String "2026-01-02T03:04:05.123456789012Z"     AggregateText -> String "sample"   where-    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]+    aggregates = [aggregate | NAggregate aggregate <- (.nodes) spec]  sampleMappedDeclaration :: TypeGraph -> ResolvedMappedDecl -> Value sampleMappedDeclaration graph =@@ -202,26 +212,26 @@     MappedShapeAlgebra       { onRecord = \_ _ fields ->           Object . KeyMap.fromList $-            [ (Key.fromText (rwfKey field), sampleMappedExpression graph (rwfType field))+            [ (Key.fromText ((.key) field), sampleMappedExpression graph ((.valueType) field))             | field <- fields,               includeField field             ],         onEnum = \entries -> case entries of-          firstEntry : _ -> String (weTag firstEntry)+          firstEntry : _ -> String ((.tag) firstEntry)           [] -> String "sample",         onUnion = \encoding arms -> case arms of           firstArm : _ ->             Object . KeyMap.fromList $-              [(Key.fromText (ueTagField encoding), String (rwaTag firstArm))]-                <> [ (Key.fromText (ueContentsField encoding), sampleMappedExpression graph payload)-                   | payload <- maybeToList (rwaPayload firstArm)+              [(Key.fromText ((.tagField) encoding), String ((.tag) firstArm))]+                <> [ (Key.fromText ((.contentsField) encoding), sampleMappedExpression graph payload)+                   | payload <- maybeToList ((.payload) firstArm)                    ]           [] -> emptyObject       }   where-    includeField field = case rwfPresence field of+    includeField field = case (.presence) field of       PRequired -> True-      POptional -> isNothingValue (rwfOnMissing field)+      POptional -> isNothingValue ((.onMissing) field)  sampleMappedExpression :: TypeGraph -> ResolvedTypeExpr -> Value sampleMappedExpression graph =@@ -237,7 +247,7 @@         onOptional = id,         onList = \value -> Array (pure value),         onMap = \value -> Object (KeyMap.singleton (Key.fromText "sample") value),-        onRef = \key -> maybe emptyObject (sampleMappedDeclaration graph) (Map.lookup key (tgDeclarations graph))+        onRef = \key -> maybe emptyObject (sampleMappedDeclaration graph) (Map.lookup key ((.declarations) graph))       }  emptyObject :: Value

src/Keiro/Dsl/Grammar.hs view

@@ -7,6 +7,7 @@   ( -- * Names and source locations     Name,     Loc (..),+    unLoc,     noLoc,      -- * Shared declarations@@ -187,6 +188,9 @@ newtype Loc = Loc {unLoc :: Int}   deriving stock (Show) +unLoc :: Loc -> Int+unLoc (Loc value) = value+ instance Eq Loc where   _ == _ = True @@ -197,20 +201,20 @@ -- | @id TransferReservationId prefix=rsv@ — declares an id newtype over 'Text' -- and its prefix tag. data IdDecl = IdDecl-  { idName :: !Name,-    idPrefix :: !Text,-    idBinding :: !(Maybe NominalBindingDecl),-    idLoc :: !Loc+  { name :: !Name,+    prefix :: !Text,+    binding :: !(Maybe NominalBindingDecl),+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  -- | @enum PatientAcuity { RedTag=red … }@ — a closed enumeration; each -- constructor carries its wire spelling (the right-hand side of @=@). data EnumDecl = EnumDecl-  { enumName :: !Name,-    enumCtors :: ![(Name, Text)],-    enumBinding :: !(Maybe NominalBindingDecl),-    enumLoc :: !Loc+  { name :: !Name,+    ctors :: ![(Name, Text)],+    binding :: !(Maybe NominalBindingDecl),+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -218,11 +222,11 @@ -- @Ctor => bool ; …@ — a total function from an enum to a value, used as a -- derived atom inside guards. data RuleDecl = RuleDecl-  { ruleName :: !Name,-    ruleDomain :: !Name,-    ruleCodomain :: !Name,-    ruleCases :: ![(Name, Expr)],-    ruleLoc :: !Loc+  { name :: !Name,+    domain :: !Name,+    codomain :: !Name,+    cases :: ![(Name, Expr)],+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -262,37 +266,37 @@   deriving stock (Eq, Show, Generic)  data WireField = WireField-  { wfHaskell :: !Name,-    wfKey :: !Text,-    wfType :: !TypeExpr,-    wfPresence :: !Presence,-    wfOnMissing :: !(Maybe OnMissing),-    wfLoc :: !Loc+  { haskell :: !Name,+    key :: !Text,+    valueType :: !TypeExpr,+    presence :: !Presence,+    onMissing :: !(Maybe OnMissing),+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  wireFieldLoc :: WireField -> Loc-wireFieldLoc WireField {wfLoc = loc} = loc+wireFieldLoc WireField {loc} = loc  data UnionEncoding = TaggedObject-  { ueTagField :: !Text,-    ueContentsField :: !Text,-    ueUnknownFields :: !UnknownFields+  { tagField :: !Text,+    contentsField :: !Text,+    unknownFields :: !UnknownFields   }   deriving stock (Eq, Show, Generic)  data WireEnum = WireEnum-  { weCtor :: !Name,-    weTag :: !Text,-    weLoc :: !Loc+  { ctor :: !Name,+    tag :: !Text,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  data WireArm = WireArm-  { waCtor :: !Name,-    waTag :: !Text,-    waPayload :: !(Maybe TypeExpr),-    waLoc :: !Loc+  { ctor :: !Name,+    tag :: !Text,+    payload :: !(Maybe TypeExpr),+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -303,9 +307,9 @@   deriving stock (Eq, Show, Generic)  data HaskellSource = HaskellSource-  { hsPackage :: !Text,-    hsModule :: !Text,-    hsType :: !Name+  { package :: !Text,+    moduleName :: !Text,+    valueType :: !Name   }   deriving stock (Eq, Ord, Show, Generic) @@ -314,13 +318,13 @@ -- The fields remain optional only so validation can report every missing fact at -- the owning declaration. Downstream code consumes the checked nominal registry. data NominalBindingDecl = NominalBindingDecl-  { nominalHaskell :: !(Maybe HaskellSource),-    nominalBinding :: !(Maybe Text),-    nominalBindingVersion :: !(Maybe Text),-    nominalCanonicalType :: !(Maybe Text),-    nominalFixtures :: !(Maybe Text),-    nominalInitial :: !(Maybe Text),-    nominalLoc :: !Loc+  { haskell :: !(Maybe HaskellSource),+    binding :: !(Maybe Text),+    bindingVersion :: !(Maybe Text),+    canonicalType :: !(Maybe Text),+    fixtures :: !(Maybe Text),+    initial :: !(Maybe Text),+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -329,10 +333,10 @@ -- The raw representation name is retained so @keiro-dsl check@ owns the stable -- unsupported-representation diagnostic instead of the low-level parser. data NominalScalarDecl = NominalScalarDecl-  { nominalScalarName :: !Name,-    nominalScalarRepresentation :: !Name,-    nominalScalarBinding :: !NominalBindingDecl,-    nominalScalarLoc :: !Loc+  { name :: !Name,+    representation :: !Name,+    binding :: !NominalBindingDecl,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -363,8 +367,8 @@ -- (e.g. an event name → projection status). @mapPartial@ records whether the -- spec author explicitly marked the table partial over its domain. data Mapping = Mapping-  { mapPairs :: ![(Name, Name)],-    mapPartial :: !Bool+  { pairs :: ![(Name, Name)],+    partial :: !Bool   }   deriving stock (Eq, Show, Generic) @@ -474,10 +478,10 @@   deriving stock (Eq, Show, Generic)  data RegDecl = RegDecl-  { regName :: !Name,-    regType :: !TypeExpr,-    regInitial :: !RegInitial,-    regLoc :: !Loc+  { name :: !Name,+    valueType :: !TypeExpr,+    initial :: !RegInitial,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -485,9 +489,9 @@ -- trailing @!@ (no outgoing transitions allowed). The first 'StateDecl' in an -- aggregate's list is its initial state. data StateDecl = StateDecl-  { stName :: !Name,-    stTerminal :: !Bool,-    stLoc :: !Loc+  { name :: !Name,+    terminal :: !Bool,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -498,27 +502,27 @@ -- the complete 'TypeExpr' grammar so semantic validation can reject unsupported -- direct shapes with a located diagnostic. data AggregateField = AggregateField-  { aggregateFieldName :: !Name,-    aggregateFieldSelector :: !(Maybe Name),-    aggregateFieldWireKey :: !(Maybe Text),-    aggregateFieldType :: !(Maybe TypeExpr),-    aggregateFieldLoc :: !Loc+  { name :: !Name,+    selector :: !(Maybe Name),+    wireKey :: !(Maybe Text),+    valueType :: !(Maybe TypeExpr),+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  -- | A generic field used by process and router nodes. Aggregate fields are -- kept separate so widening aggregate syntax does not widen those node families. data Field = Field-  { fieldName :: !Name,-    fieldType :: !(Maybe Name)+  { name :: !Name,+    valueType :: !(Maybe Name)   }   deriving stock (Eq, Show, Generic)  -- | @command Name { field … }@ — a command constructor. data Command = Command-  { cmdName :: !Name,-    cmdFields :: ![AggregateField],-    cmdLoc :: !Loc+  { name :: !Name,+    fields :: ![AggregateField],+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -528,23 +532,23 @@ -- reproducing the EP-1 surface. These fields live on the shared 'Event' so every -- node family's events inherit schema-versioning for free. data Event = Event-  { evName :: !Name,-    evBody :: !EventBody,+  { name :: !Name,+    body :: !EventBody,     -- | The schema version of this event shape. Default 1; written @vN@ for N>1.-    evVersion :: !Int,+    version :: !Int,     -- | The source version this shape migrates /from/, paired with the upcaster     --     hole. @Just (n-1, …)@ for a @vN@ shape; 'Nothing' for v1.-    evUpcastFrom :: !(Maybe (Int, Hole)),+    upcastFrom :: !(Maybe (Int, Hole)),     -- | Retirement is in progress. The event must keep at least one live     --     emitting transition while operators terminalize or truncate affected     --     streams; cut over to @deprecated@ plus a replay-only emitting transition     --     afterwards.-    evRetiring :: !Bool,+    retiring :: !Bool,     -- | Retired from the write path (no live transition may @emit@ it) but     --     still decodable from the log. A replay-only emitting transition must remain     --     while live streams can still contain the event.-    evDeprecated :: !Bool,-    evLoc :: !Loc+    deprecated :: !Bool,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -584,19 +588,19 @@ -- | A transition @Src -- Command --> clauses@. Clauses may be written -- indentation-stacked or @;@-separated on one line. data Transition = Transition-  { tSource :: !Name,-    tCommand :: !Name,-    tImplementation :: !TransitionImplementation,-    tGuard :: !(Maybe Expr),-    tWrites :: ![(Name, Expr)],-    tEmits :: ![Name],-    tOutcome :: !(Maybe TransitionOutcome),+  { source :: !Name,+    command :: !Name,+    implementation :: !TransitionImplementation,+    guard :: !(Maybe Expr),+    writes :: ![(Name, Expr)],+    emits :: ![Name],+    outcome :: !(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+    outcomeDuplicateLocs :: ![Loc],+    goto :: !Name,+    mode :: !TransitionMode,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -624,20 +628,20 @@ -- | @wire kind=ctorName fields=camelCase schemaVersion=1@ — how events -- serialize. data WireSpec = WireSpec-  { wireKind :: !Text,-    wireFields :: !Text,-    wireSchemaVersion :: !Int+  { kind :: !Text,+    fields :: !Text,+    schemaVersion :: !Int   }   deriving stock (Eq, Show, Generic)  -- | @projection table consistency=… key=… status-map { … }@ — the read-model -- projection and its event→status 'Mapping' (hole-kind 3). data ProjectionSpec = ProjectionSpec-  { projTable :: !Name,-    projConsistency :: !(Maybe Consistency),-    projKey :: !Name,-    projStatusMap :: !(Maybe Mapping),-    projLoc :: !Loc+  { table :: !Name,+    consistency :: !(Maybe Consistency),+    key :: !Name,+    statusMap :: !(Maybe Mapping),+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -650,30 +654,30 @@  -- | Snapshot policy plus the captured live state-codec identity. data SnapshotSpec = SnapshotSpec-  { snapPolicy :: !SnapPolicy,-    snapCodecVersion :: !Int,-    snapShapeHash :: !Text,-    snapLoc :: !Loc+  { policy :: !SnapPolicy,+    codecVersion :: !Int,+    shapeHash :: !Text,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  -- | An @aggregate@ node: a consistency boundary whose state is rebuilt by -- replaying events. data Aggregate = Aggregate-  { aggName :: !Name,-    aggRegs :: ![RegDecl],-    aggStates :: ![StateDecl],-    aggCommands :: ![Command],-    aggEvents :: ![Event],-    aggTransitions :: ![Transition],-    aggDomainOutcomeTypes :: !(Maybe DomainOutcomeTypes),+  { name :: !Name,+    regs :: ![RegDecl],+    states :: ![StateDecl],+    commands :: ![Command],+    events :: ![Event],+    transitions :: ![Transition],+    domainOutcomeTypes :: !(Maybe DomainOutcomeTypes),     -- | Locations of declarations after the first; see     -- 'tOutcomeDuplicateLocs'.-    aggDomainOutcomeDuplicateLocs :: ![Loc],-    aggWire :: !(Maybe WireSpec),-    aggProjection :: !(Maybe ProjectionSpec),-    aggSnapshot :: !(Maybe SnapshotSpec),-    aggLoc :: !Loc+    domainOutcomeDuplicateLocs :: ![Loc],+    wire :: !(Maybe WireSpec),+    projection :: !(Maybe ProjectionSpec),+    snapshot :: !(Maybe SnapshotSpec),+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -683,26 +687,26 @@ -- A bare field reuses the input field of the same name; @name=value@ binds it to -- an expression (kept as raw text, e.g. @timerId=timer.id@). data FieldBinding = FieldBinding-  { fbName :: !Name,-    fbValue :: !(Maybe Text)+  { name :: !Name,+    value :: !(Maybe Text)   }   deriving stock (Eq, Show, Generic)  -- | @input SurgeInput { hospitalId … observedAt:Time }@ — the process's incoming -- event shape (one field must be a @:Time@ field used by the timer deadline). data InputDecl = InputDecl-  { inName :: !Name,-    inFields :: ![Field],-    inType :: !(Maybe TypeExpr),-    inLoc :: !Loc+  { name :: !Name,+    fields :: ![Field],+    valueType :: !(Maybe TypeExpr),+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  -- | @correlate input.hospitalId via idText@ — the correlation key (hole-kind 1 -- derivation + hole-kind 4 field-source). data CorrelateDecl = CorrelateDecl-  { corrField :: !Name,-    corrVia :: !Name+  { field :: !Name,+    via :: !Name   }   deriving stock (Eq, Show, Generic) @@ -710,8 +714,8 @@ -- the validated stream category used with @Keiro.Stream.entityStream@.  For a -- correlation id @c@, the saga stream is @<category>-<c>@. data SagaRef = SagaRef-  { sagaAgg :: !Name,-    sagaCategory :: !Text+  { agg :: !Name,+    category :: !Text   }   deriving stock (Eq, Show, Generic) @@ -737,30 +741,30 @@  -- | @dispatch Hospital\@input.hospitalId ActivateSurge { … } on-appended … on-duplicate … on-failed …@. data DispatchNode = DispatchNode-  { dispTarget :: !Name,-    dispKey :: !Text,-    dispCommand :: !Name,-    dispFields :: ![FieldBinding],-    dispDisposition :: !DispatchDisposition,-    dispLoc :: !Loc+  { target :: !Name,+    key :: !Text,+    command :: !Name,+    fields :: ![FieldBinding],+    disposition :: !DispatchDisposition,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  -- | The @on <Input>@ reaction: a self-advance, zero or more dispatches, and a -- @schedule@ of the timer. data HandleNode = HandleNode-  { hOn :: !Name,-    hAdvance :: !AdvanceNode,-    hDispatch :: ![DispatchNode],-    hSchedule :: !Name+  { on :: !Name,+    advance :: !AdvanceNode,+    dispatch :: ![DispatchNode],+    schedule :: !Name   }   deriving stock (Eq, Show, Generic)  -- | A deterministic id derivation: @uuidv5 \"prefix:\" <> correlationId@. data IdExpr = IdExpr-  { ideStrategy :: !IdStrategy,-    idePrefix :: !Text,-    ideField :: !Name+  { strategy :: !IdStrategy,+    prefix :: !Text,+    field :: !Name   }   deriving stock (Eq, Show, Generic) @@ -771,8 +775,8 @@ -- There is no clock-sampling constructor, so the no-wall-clock rule holds by -- construction. data FireAtExpr = FireAtExpr-  { faField :: !Name,-    faWindow :: !Text+  { field :: !Name,+    window :: !Text   }   deriving stock (Eq, Show, Generic) @@ -792,26 +796,26 @@  -- | @fire dispatch Surge\@correlationId MarkSurgeTimerFired { … } fired-event-id … on-ok …@. data FireNode = FireNode-  { fireTarget :: !Name,-    fireKey :: !Text,-    fireCommand :: !Name,-    fireFields :: ![FieldBinding],-    fireFiredEventId :: !IdExpr,-    fireDisposition :: !FireDisposition+  { target :: !Name,+    key :: !Text,+    command :: !Name,+    fields :: ![FieldBinding],+    firedEventId :: !IdExpr,+    disposition :: !FireDisposition   }   deriving stock (Eq, Show, Generic)  -- | A nested @timer@ sub-node of a process. data TimerNode = TimerNode-  { tmName :: !Name,-    tmId :: !IdExpr,-    tmFireAt :: !FireAtExpr,-    tmPayload :: ![FieldBinding],-    tmFire :: !FireNode,-    tmDecodeUnknown :: !Name,-    tmMaxAttempts :: !Int,-    tmDeadLetter :: !Text,-    tmLoc :: !Loc+  { name :: !Name,+    id :: !IdExpr,+    fireAt :: !FireAtExpr,+    payload :: ![FieldBinding],+    fire :: !FireNode,+    decodeUnknown :: !Name,+    maxAttempts :: !Int,+    deadLetter :: !Text,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -823,19 +827,19 @@ -- (runtime-owned uuidv5), so it is implicit in the AST and always rendered. data ProcessNode = ProcessNode   { -- | The block identifier (@process HospitalSurge@), used for module names.-    procId :: !Name,+    id :: !Name,     -- | The define-once ProcessManager @name@ (@name \"hospital-surge\"@).-    procName :: !Text,-    procInput :: !InputDecl,-    procCorrelate :: !CorrelateDecl,-    procSaga :: !SagaRef,-    procTarget :: !Name,-    procProjections :: ![Name],-    procHandle :: !HandleNode,-    procRejected :: !PolicyChoice,-    procPoison :: !PolicyChoice,-    procTimer :: !TimerNode,-    procLoc :: !Loc+    name :: !Text,+    input :: !InputDecl,+    correlate :: !CorrelateDecl,+    saga :: !SagaRef,+    target :: !Name,+    projections :: ![Name],+    handle :: !HandleNode,+    rejected :: !PolicyChoice,+    poison :: !PolicyChoice,+    timer :: !TimerNode,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -852,30 +856,30 @@ -- 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+  { identity :: !Text,+    identityLoc :: !Loc,+    version :: !Natural,+    versionLoc :: !Loc,+    query :: !Name,+    queryLoc :: !Loc,+    queryInput :: !Name,+    queryInputLoc :: !Loc,+    predicate :: !Expr,+    recipient :: !Expr,+    limit :: !(Maybe (Natural, Loc)),+    order :: !Name,+    orderLoc :: !Loc,+    dedupe :: !Name,+    dedupeLoc :: !Loc,+    emptyPolicy :: !SelectionDispositionSyntax,+    emptyPolicyLoc :: !Loc,+    failurePolicy :: !SelectionDispositionSyntax,+    failurePolicyLoc :: !Loc,+    redelivery :: !Name,+    redeliveryLoc :: !Loc,+    partial :: !Name,+    partialLoc :: !Loc,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -886,17 +890,17 @@   deriving stock (Eq, Show, Generic)  data ResolveDecl = ResolveDecl-  { rvSource :: !ResolveSource,-    rvRow :: ![Name],-    rvLoc :: !Loc+  { source :: !ResolveSource,+    row :: ![Name],+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  data RouterDispatchNode = RouterDispatchNode-  { rdCommand :: !Name,-    rdFields :: ![FieldBinding],-    rdDisposition :: !DispatchDisposition,-    rdLoc :: !Loc+  { command :: !Name,+    fields :: ![FieldBinding],+    disposition :: !DispatchDisposition,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -904,17 +908,17 @@ -- the mandatory @stable@ token on the resolve clause is an author acknowledgement -- that retry attempts accumulate the union of resolved target identities. data RouterNode = RouterNode-  { rtId :: !Name,-    rtName :: !Text,-    rtInput :: !InputDecl,-    rtKey :: !CorrelateDecl,-    rtResolve :: !ResolveDecl,-    rtTarget :: !Name,-    rtProjections :: ![Name],-    rtDispatch :: !RouterDispatchNode,-    rtRejected :: !PolicyChoice,-    rtPoison :: !PolicyChoice,-    rtLoc :: !Loc+  { id :: !Name,+    name :: !Text,+    input :: !InputDecl,+    key :: !CorrelateDecl,+    resolve :: !ResolveDecl,+    target :: !Name,+    projections :: ![Name],+    dispatch :: !RouterDispatchNode,+    rejected :: !PolicyChoice,+    poison :: !PolicyChoice,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -925,19 +929,19 @@   deriving stock (Eq, Show, Generic)  data ContractField = ContractField-  { cfName :: !Name,-    cfSelector :: !(Maybe Name),-    cfWireKey :: !(Maybe Text),-    cfType :: !ContractType,-    cfLoc :: !Loc+  { name :: !Name,+    selector :: !(Maybe Name),+    wireKey :: !(Maybe Text),+    valueType :: !ContractType,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  -- | @event <Name> on <topicAlias> { field: type … }@ within a contract. data ContractEvent = ContractEvent-  { ceName :: !Name,-    ceTopic :: !Name,-    ceFields :: ![ContractField]+  { name :: !Name,+    topic :: !Name,+    fields :: ![ContractField]   }   deriving stock (Eq, Show, Generic) @@ -945,13 +949,13 @@ -- and referenced by both producer (@emit@) and consumer (@intake@). EP-5's -- pgmq @dispatch@ also couples to it. data ContractNode = ContractNode-  { ctrName :: !Name,-    ctrSchemaVersion :: !Int,-    ctrDiscriminator :: !Name,+  { name :: !Name,+    schemaVersion :: !Int,+    discriminator :: !Name,     -- | (topic alias, real Kafka topic string)-    ctrTopics :: ![(Name, Text)],-    ctrEvents :: ![ContractEvent],-    ctrLoc :: !Loc+    topics :: ![(Name, Text)],+    events :: ![ContractEvent],+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -967,10 +971,10 @@  -- | One envelope-binding row: @bind <field> from <source> [required] [cross-check body]@. data BindRow = BindRow-  { brField :: !Name,-    brSource :: !WireSource,-    brRequired :: !Bool,-    brCrossCheck :: !Bool+  { field :: !Name,+    source :: !WireSource,+    required :: !Bool,+    crossCheck :: !Bool   }   deriving stock (Eq, Show, Generic) @@ -986,18 +990,18 @@  -- | One row of the mandatory, complete inbox disposition table. data DispositionRow = DispositionRow-  { drOutcome :: !Name,-    drAction :: !InboxAction,-    drLoc :: !Loc+  { outcome :: !Name,+    action :: !InboxAction,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  -- | The body decode-strictness decision (hole-kind 6). data DecodeSpec = DecodeSpec   { -- | the envelope policy text, e.g. @strict-required lenient-optional@-    decEnvelope :: !Text,-    decBodyStrict :: !Bool,-    decBodySchemaVersion :: !Int+    envelope :: !Text,+    bodyStrict :: !Bool,+    bodySchemaVersion :: !Int   }   deriving stock (Eq, Show, Generic) @@ -1009,17 +1013,17 @@ -- block (brokers/groupId/offsetReset) is hole-kind 8, delegated to deployment -- and not modelled here. data IntakeNode = IntakeNode-  { inkName :: !Name,-    inkContract :: !Name,-    inkTopic :: !Name,-    inkAccept :: ![Name],-    inkBinds :: ![BindRow],-    inkDedupeKey :: !Name,-    inkDedupePolicy :: !Name,-    inkPersist :: !InkPersist,-    inkDecode :: !DecodeSpec,-    inkDisposition :: ![DispositionRow],-    inkLoc :: !Loc+  { name :: !Name,+    contract :: !Name,+    topic :: !Name,+    accept :: ![Name],+    binds :: ![BindRow],+    dedupeKey :: !Name,+    dedupePolicy :: !Name,+    persist :: !InkPersist,+    decode :: !DecodeSpec,+    disposition :: ![DispositionRow],+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -1031,49 +1035,49 @@  -- | One @\"value\" => EventType@ row of an emit's status mapping. data EmitMapRow = EmitMapRow-  { emrValue :: !Text,-    emrEvent :: !Name,-    emrLoc :: !Loc+  { value :: !Text,+    event :: !Name,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  -- | An @emit@ (outbox) node: maps a private status discriminant to contract -- event types, with a mandatory explicit @_ => skip@ catch-all. data EmitNode = EmitNode-  { emName :: !Name,-    emContract :: !Name,-    emTopic :: !Name,-    emSource :: !Text,-    emKey :: !Name,-    emDiscriminant :: !Name,-    emMap :: ![EmitMapRow],+  { name :: !Name,+    contract :: !Name,+    topic :: !Name,+    source :: !Text,+    key :: !Name,+    discriminant :: !Name,+    map :: ![EmitMapRow],     -- | whether the explicit @_ => skip@ catch-all is present-    emSkip :: !Bool,-    emMessageId :: !DeriveSpec,-    emIdempotencyKey :: !DeriveSpec,-    emLoc :: !Loc+    skip :: !Bool,+    messageId :: !DeriveSpec,+    idempotencyKey :: !DeriveSpec,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  -- | @backoff <kind> <window>@, e.g. @backoff constant 2s@. data BackoffSpec = BackoffSpec-  { boKind :: !Name,-    boWindow :: !Text,-    boMax :: !(Maybe Text),-    boMultiplier :: !(Maybe Text)+  { kind :: !Name,+    window :: !Text,+    max :: !(Maybe Text),+    multiplier :: !(Maybe Text)   }   deriving stock (Eq, Show, Generic)  -- | A @publisher@ node: the at-least-once publishing policy for an emit's topic. data PublisherNode = PublisherNode-  { pubName :: !Name,-    pubEmit :: !Name,-    pubOrdering :: !Name,-    pubMaxAttempts :: !Int,-    pubBackoff :: !BackoffSpec,+  { name :: !Name,+    emit :: !Name,+    ordering :: !Name,+    maxAttempts :: !Int,+    backoff :: !BackoffSpec,     -- | @outboxId stable from <field>@: retries coalesce on (source, this field)-    pubOutboxField :: !Name,-    pubLoc :: !Loc+    outboxField :: !Name,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -1103,19 +1107,19 @@  -- | One @field -> \"wire_name\" type required@ row of a workqueue payload. data WqField = WqField-  { wqfName :: !Name,-    wqfWire :: !Text,-    wqfType :: !QueuePayloadType,-    wqfLoc :: !Loc+  { name :: !Name,+    wire :: !Text,+    valueType :: !QueuePayloadType,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  -- | One row of a workqueue's consumer @JobOutcome@ disposition (reusing -- 'InboxAction': @retry <window>@ \/ @deadLetter@). data WqDispRow = WqDispRow-  { wqdOutcome :: !Name,-    wqdAction :: !InboxAction,-    wqdLoc :: !Loc+  { outcome :: !Name,+    action :: !InboxAction,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -1125,9 +1129,9 @@  -- | A FIFO message-group key derived from one payload field. data WqGroupKey = WqGroupKey-  { gkField :: !Name,-    gkVia :: !Name,-    gkFixture :: !(Maybe Text)+  { field :: !Name,+    via :: !Name,+    fixture :: !(Maybe Text)   }   deriving stock (Eq, Show, Generic) @@ -1142,38 +1146,38 @@ -- /captured fixture/ (hole-kind 1): the validator re-derives the physical name -- from @logical@ and flags any divergence (the drift hazard at the dedup site). data WorkqueueNode = WorkqueueNode-  { wqName :: !Name,-    wqLogical :: !Text,-    wqPhysical :: !Text,-    wqDlq :: !Text,-    wqTable :: !Text,-    wqOrdering :: !WqOrdering,-    wqGroupKey :: !(Maybe WqGroupKey),-    wqProvision :: !WqProvision,-    wqPayloadName :: !Name,-    wqPayload :: ![WqField],-    wqMaxRetries :: !Int,-    wqDelay :: !Text,-    wqDlqOn :: !Bool,-    wqDisposition :: ![WqDispRow],-    wqLoc :: !Loc+  { name :: !Name,+    logical :: !Text,+    physical :: !Text,+    dlq :: !Text,+    table :: !Text,+    ordering :: !WqOrdering,+    groupKey :: !(Maybe WqGroupKey),+    provision :: !WqProvision,+    payloadName :: !Name,+    payload :: ![WqField],+    maxRetries :: !Int,+    delay :: !Text,+    dlqOn :: !Bool,+    disposition :: ![WqDispRow],+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  -- | A pgmq @dispatch@ node: a read-model→enqueue coupling with a fan-out hole -- and a dedup check (one arm of which is a raw-SQL hole). data PgmqDispatchNode = PgmqDispatchNode-  { pdName :: !Name,-    pdSourceReadModel :: !Name,-    pdSourceKey :: !Name,-    pdFanoutBody :: !Name,-    pdDedupKey :: !Name,-    pdDedupReadModel :: !Name,-    pdDedupReadModelField :: !Text,-    pdDedupQueue :: !Name,-    pdDedupQueueField :: !Text,-    pdEnqueueTo :: !Name,-    pdLoc :: !Loc+  { name :: !Name,+    sourceReadModel :: !Name,+    sourceKey :: !Name,+    fanoutBody :: !Name,+    dedupKey :: !Name,+    dedupReadModel :: !Name,+    dedupReadModelField :: !Text,+    dedupQueue :: !Name,+    dedupQueueField :: !Text,+    enqueueTo :: !Name,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -1233,39 +1237,39 @@ -- | 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-  { rmName :: !Name,-    rmTable :: !Text,-    rmSchema :: !Text,-    rmColumns :: ![RmColumn],-    rmVersion :: !Int,-    rmShape :: !Text,-    rmFreshness :: !QueryFreshnessNode,-    rmSupply :: !ReadModelSupply,-    rmGroup :: !(Maybe Name),-    rmObservedTargets :: ![Name],-    rmBackingTarget :: !(Maybe Name),+  { name :: !Name,+    table :: !Text,+    schema :: !Text,+    columns :: ![RmColumn],+    version :: !Int,+    shape :: !Text,+    freshness :: !QueryFreshnessNode,+    supply :: !ReadModelSupply,+    group :: !(Maybe Name),+    observedTargets :: ![Name],+    backingTarget :: !(Maybe Name),     queryTypes :: !(Maybe ReadModelQueryTypes),-    rmLoc :: !Loc+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  legacyReadModelConsistency :: ReadModelNode -> Maybe Consistency-legacyReadModelConsistency readModel = case rmSupply readModel of+legacyReadModelConsistency readModel = case (.supply) readModel of   LegacyReadModelSupply {legacyConsistency} -> Just legacyConsistency   OwnerDerivedSupply -> Nothing  legacyReadModelScope :: ReadModelNode -> Maybe RmScope-legacyReadModelScope readModel = case rmSupply readModel of+legacyReadModelScope readModel = case (.supply) readModel of   LegacyReadModelSupply {legacyScope} -> legacyScope   OwnerDerivedSupply -> Nothing  legacyReadModelFeed :: ReadModelNode -> Maybe RmFeed-legacyReadModelFeed readModel = case rmSupply readModel of+legacyReadModelFeed readModel = case (.supply) readModel of   LegacyReadModelSupply {legacyFeed} -> Just legacyFeed   OwnerDerivedSupply -> Nothing  legacyReadModelSubscription :: ReadModelNode -> Maybe Text-legacyReadModelSubscription readModel = case rmSupply readModel of+legacyReadModelSubscription readModel = case (.supply) readModel of   LegacyReadModelSupply {legacySubscription} -> legacySubscription   OwnerDerivedSupply -> Nothing @@ -1276,21 +1280,21 @@  -- | 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+  { name :: !Name,+    schema :: !Text,+    table :: !Text,+    reset :: !TargetResetPolicy,+    dependsOn :: ![Name],+    loc :: !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+  { name :: !Name,+    targets :: ![Name],+    order :: ![Name],+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -1301,31 +1305,31 @@   deriving stock (Eq, Ord, Show, Generic)  data PromotionObjectNode = PromotionObjectNode-  { rpoKind :: !PromotionObjectKindNode,-    rpoGenerationName :: !Text,-    rpoCanonicalName :: !Text+  { kind :: !PromotionObjectKindNode,+    generationName :: !Text,+    canonicalName :: !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]+  { target :: !Name,+    schemaVersion :: !Text,+    provisioner :: !Text,+    provisionerVersion :: !Int,+    expectedShape :: !Text,+    validator :: !Text,+    validatorVersion :: !Int,+    promotionObjects :: ![PromotionObjectNode]   }   deriving stock (Eq, Show, Generic)  data ProjectionRevisionNode = ProjectionRevisionNode-  { prvName :: !Name,-    prvGroup :: !Name,-    prvTargets :: ![RevisionTargetNode],-    prvLoc :: !Loc+  { name :: !Name,+    group :: !Name,+    targets :: ![RevisionTargetNode],+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -1333,14 +1337,14 @@ -- 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+  { name :: !Name,+    version :: !Int,+    queryModel :: !Name,+    resultSchema :: !Text,+    resultType :: !Text,+    compatibleRevisions :: ![Name],+    surfaceGeneration :: !Int,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -1348,7 +1352,7 @@ -- so source-level duplicate detection keys by contract and version together. externalReadNodeIdentity :: ExternalReadNode -> Name externalReadNodeIdentity externalRead =-  erName externalRead <> "_v" <> T.pack (show (erVersion externalRead))+  (.name) externalRead <> "_v" <> T.pack (show ((.version) externalRead))  -- | A replay source selected by a projection owner. data CatalogSource@@ -1375,17 +1379,17 @@  -- | 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+  { name :: !Name,+    sources :: ![CatalogSource],+    delivery :: !ProjectionDelivery,+    group :: !Name,+    targets :: ![Name],+    order :: !Int,+    subscription :: !(Maybe Text),+    dedup :: !(Maybe Text),+    checkpointOnMissing :: ![CheckpointOnMissingNode],+    replay :: !ProjectionReplayPolicy,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -1411,22 +1415,22 @@ -- | A durable @workflow@ node. data WorkflowNode = WorkflowNode   { -- | block identifier (e.g. @HospitalTransferReservation@)-    wfId :: !Name,+    id :: !Name,     -- | the stable @name "…"@ (journal stream + every deterministic id)-    wfStable :: !Text,-    wfInput :: !Name,-    wfInputFields :: ![Field],-    wfOutput :: !Name,+    stable :: !Text,+    input :: !Name,+    inputFields :: ![Field],+    output :: !Name,     -- | @id from input.<field>@; 'Nothing' for @id from input@-    wfIdField :: !(Maybe Name),-    wfIdVia :: !Name,-    wfBody :: ![WfBodyItem],-    wfLoc :: !Loc+    idField :: !(Maybe Name),+    idVia :: !Name,+    body :: ![WfBodyItem],+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  workflowNodeLoc :: WorkflowNode -> Loc-workflowNodeLoc WorkflowNode {wfLoc = loc} = loc+workflowNodeLoc WorkflowNode {loc = loc} = loc  -- | The four operation shapes. data OperationShape@@ -1441,9 +1445,9 @@   deriving stock (Eq, Show, Generic)  data OperationNode = OperationNode-  { opName :: !Name,-    opShape :: !OperationShape,-    opLoc :: !Loc+  { name :: !Name,+    shape :: !OperationShape,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -1489,14 +1493,14 @@ -- and the list of nodes. 'specModuleRoot' and 'specLayout' are 'Nothing' when the -- spec omits the clauses, reproducing the historical default. data Spec = Spec-  { specContext :: !Name,-    specModuleRoot :: !(Maybe Text),-    specLayout :: !(Maybe Placement),-    specIds :: ![IdDecl],-    specEnums :: ![EnumDecl],-    specRules :: ![RuleDecl],-    specNominalScalars :: ![NominalScalarDecl],-    specMapped :: ![MappedDecl],-    specNodes :: ![Node]+  { context :: !Name,+    moduleRoot :: !(Maybe Text),+    layout :: !(Maybe Placement),+    ids :: ![IdDecl],+    enums :: ![EnumDecl],+    rules :: ![RuleDecl],+    nominalScalars :: ![NominalScalarDecl],+    mapped :: ![MappedDecl],+    nodes :: ![Node]   }   deriving stock (Eq, Show, Generic)

src/Keiro/Dsl/Harness.hs view

@@ -89,10 +89,10 @@ harnessForCheckedWithGoldens :: [GoldenPayload] -> Context -> CheckedService -> Aggregate -> [ScaffoldModule] harnessForCheckedWithGoldens goldens ctx service agg =   [ ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" (aGenPrefix a) <> "/Harness.hs"),-        moduleText = emitHarness relevantGoldens a,+      { path = T.unpack (T.replace "." "/" ((.genPrefix) a) <> "/Harness.hs"),+        text = emitHarness relevantGoldens a,         kind = Generated,-        origin = "aggregate " <> aggName agg <> locSuffix (aggLoc agg)+        origin = "aggregate " <> (.name) agg <> locSuffix ((.loc) agg)       }   ]   where@@ -101,8 +101,8 @@     relevantGoldens =       [ golden       | golden <- goldens,-        goldenContext golden == specContext spec,-        goldenAggregate golden == aggName agg+        (.context) golden == (.context) spec,+        (.aggregate) golden == (.name) agg       ]  -- | Emit a self-contained, firewall-clean facts harness for a process manager,@@ -116,14 +116,14 @@ harnessProcess :: Context -> ProcessNode -> [ScaffoldModule] harnessProcess ctx p =   [ ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/ProcessHarness.hs"),-        moduleText = emitProcessHarness genPrefix p,+      { path = T.unpack (T.replace "." "/" genPrefix <> "/ProcessHarness.hs"),+        text = emitProcessHarness genPrefix p,         kind = Generated,-        origin = "process " <> procId p <> locSuffix (procLoc p)+        origin = "process " <> (.id) p <> locSuffix ((.loc) p)       }   ]   where-    genPrefix = genPrefixFor ctx (procId p)+    genPrefix = genPrefixFor ctx ((.id) p)  -- | Emit runtime-free facts for a router's identity, resolution, dispatch, -- and worker-policy decisions. A hand-written conformance driver owns the@@ -131,30 +131,30 @@ harnessRouter :: Context -> RouterNode -> [ScaffoldModule] harnessRouter ctx router =   [ ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/RouterHarness.hs"),-        moduleText = emitRouterHarness genPrefix router,+      { path = T.unpack (T.replace "." "/" genPrefix <> "/RouterHarness.hs"),+        text = emitRouterHarness genPrefix router,         kind = Generated,-        origin = "router " <> rtId router <> locSuffix (rtLoc router)+        origin = "router " <> (.id) router <> locSuffix ((.loc) router)       }   ]   where-    genPrefix = genPrefixFor ctx (rtId router)+    genPrefix = genPrefixFor ctx ((.id) 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+harnessRouterForService ctx service router = case (.source) ((.resolve) router) of   ResolveDeclarative {} ->     [ ScaffoldModule-        { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/RouterHarness.hs"),-          moduleText = emitRouterHarnessWithFacts genPrefix (routerHarnessFactValuesForService service router),+        { path = T.unpack (T.replace "." "/" genPrefix <> "/RouterHarness.hs"),+          text = emitRouterHarnessWithFacts genPrefix (routerHarnessFactValuesForService service router),           kind = Generated,-          origin = "router " <> rtId router <> locSuffix (rtLoc router)+          origin = "router " <> (.id) router <> locSuffix ((.loc) router)         }     ]   _ -> harnessRouter ctx router   where-    genPrefix = genPrefixFor ctx (rtId router)+    genPrefix = genPrefixFor ctx ((.id) router)  emitRouterHarness :: Text -> RouterNode -> Text emitRouterHarness genPrefix router = emitRouterHarnessWithFacts genPrefix (routerHarnessFactValues router)@@ -172,39 +172,39 @@  routerHarnessFactValues :: RouterNode -> [(Text, Text)] routerHarnessFactValues router =-  [ ("routerName", rtName router),-    ("keyField", corrField (rtKey router)),+  [ ("routerName", (.name) router),+    ("keyField", (.field) ((.key) router)),     ("resolveSource", resolveSource),-    ("resolveRow", T.intercalate "," (rvRow (rtResolve router))),-    ("dispatchCommand", rdCommand dispatch),+    ("resolveRow", T.intercalate "," ((.row) ((.resolve) router))),+    ("dispatchCommand", (.command) dispatch),     ("dispatchIdInputs", "(name, key, sourceEventId, targetStreamName, occurrence)"),-    ("onDuplicate", showDisp (onDuplicate disposition)),-    ("onFailed", showDisp (onFailed disposition)),-    ("rejectedPolicy", showPolicy (rtRejected router)),-    ("poisonPolicy", showPolicy (rtPoison router))+    ("onDuplicate", showDisp ((.onDuplicate) disposition)),+    ("onFailed", showDisp ((.onFailed) disposition)),+    ("rejectedPolicy", showPolicy ((.rejected) router)),+    ("poisonPolicy", showPolicy ((.poison) router))   ]   where-    dispatch = rtDispatch router-    disposition = rdDisposition dispatch-    resolveSource = case rvSource (rtResolve router) of+    dispatch = (.dispatch) router+    disposition = (.disposition) dispatch+    resolveSource = case (.source) ((.resolve) router) of       ResolveReadModel name -> "read-model " <> name       ResolveHole -> "hole"-      ResolveDeclarative selection -> "declarative " <> rsIdentity selection+      ResolveDeclarative selection -> "declarative " <> (.identity) selection  routerHarnessFactValuesForService :: CheckedService -> RouterNode -> [(Text, Text)]-routerHarnessFactValuesForService service router = case rvSource (rtResolve router) of+routerHarnessFactValuesForService service router = case (.source) ((.resolve) 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))),+           ("queryIdentity", (.name) ((.query) selection)),+           ("selectionIdentity", (.identity) selection),+           ("selectionVersion", T.pack (show ((.version) selection))),+           ("selectionFingerprint", (.fingerprint) selection),+           ("maxRecipients", T.pack (show ((.limit) selection))),            ("selectionOrder", "target-stream"),            ("selectionDedupe", "target-stream"),-           ("emptyPolicy", checkedEmptyPolicyText (checkedEmptyPolicy selection)),-           ("failurePolicy", checkedFailurePolicyText (checkedFailurePolicy selection)),+           ("emptyPolicy", checkedEmptyPolicyText ((.emptyPolicy) selection)),+           ("failurePolicy", checkedFailurePolicyText ((.failurePolicy) selection)),            ("redeliveryPolicy", "stable-union"),            ("partialPolicy", "retain-successes")          ]@@ -234,14 +234,14 @@ harnessReadModelForService :: Context -> CheckedService -> ReadModelNode -> [ScaffoldModule] harnessReadModelForService ctx service readModel =   [ ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/ReadModelHarness.hs"),-        moduleText = emitReadModelHarness genPrefix ctx (checkedSpec service) (checkedProjectionSupplies service) readModel,+      { path = T.unpack (T.replace "." "/" genPrefix <> "/ReadModelHarness.hs"),+        text = emitReadModelHarness genPrefix ctx (checkedSpec service) (checkedProjectionSupplies service) readModel,         kind = Generated,-        origin = "readmodel " <> rmName readModel <> locSuffix (rmLoc readModel)+        origin = "readmodel " <> (.name) readModel <> locSuffix ((.loc) readModel)       }   ]   where-    genPrefix = genPrefixFor ctx (pascal (rmName readModel))+    genPrefix = genPrefixFor ctx (pascal ((.name) readModel))  emitReadModelHarness :: Text -> Context -> Spec -> ProjectionSupplyAnalysis -> ReadModelNode -> Text emitReadModelHarness genPrefix ctx spec supplyAnalysis readModel =@@ -280,13 +280,13 @@            "  pure (null failures)"          ]   where-    stem = lowerFirst (pascal (rmName readModel))+    stem = lowerFirst (pascal ((.name) readModel))     readModelName = stem <> "ReadModel"     asyncProjectionName = stem <> "AsyncProjection"     readModelImports = readModelName : [asyncProjectionName | emitsLegacyAsync]     moduleExports = ["readModelFacts", "readModelFactResults", "runReadModelFacts"] <> ["catalogFactsAgainst" | catalogManaged]-    expectedRegistry = registryNameFor (contextName ctx) readModel-    ownerDerived = rmSupply readModel == OwnerDerivedSupply+    expectedRegistry = registryNameFor ((.name) ctx) readModel+    ownerDerived = (.supply) readModel == OwnerDerivedSupply     expectedSubscription = case legacyReadModelSubscription readModel of       Just name -> name       Nothing -> expectedRegistry <> "-sub"@@ -296,7 +296,7 @@     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+    catalogManaged = (.group) readModel /= Nothing     emitsLegacyAsync = not ownerDerived && not catalogManaged && legacyReadModelFeed readModel == Just RmSubscription     runtimeImports       | ownerDerived = "ReadModel (..), readModelCursorAuthority, readModelDefaultFreshness"@@ -304,12 +304,12 @@     baseFactRows       | ownerDerived =           [ "  [ (\"registryName\", " <> tshow expectedRegistry <> ", T.unpack " <> readModelName <> ".name)",-            "  , (\"shapeHash\", " <> tshow (rmShape readModel) <> ", T.unpack " <> readModelName <> ".shapeHash)"+            "  , (\"shapeHash\", " <> tshow ((.shape) 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)"+            "  , (\"shapeHash\", " <> tshow ((.shape) readModel) <> ", T.unpack " <> readModelName <> ".shapeHash)"           ]     policyFactRows       | ownerDerived =@@ -337,48 +337,48 @@       | otherwise = []     supply =       find-        ((== rmName readModel) . supplyQueryModel)-        (resolvedProjectionSupplies supplyAnalysis)+        ((== (.name) readModel) . (.queryModel))+        ((.resolvedProjectionSupplies) supplyAnalysis)     resolvedOwner = do       resolved <- supply       find-        ((== supplyProjectionOwner resolved) . poName)-        [owner | NProjectionOwner owner <- specNodes spec]+        ((== (.projectionOwner) resolved) . (.name))+        [owner | NProjectionOwner owner <- (.nodes) spec]     expectedCursor = case resolvedOwner of       Just owner-        | poDelivery owner == DeliverySubscription,-          Just subscription <- poSubscription owner ->+        | (.delivery) owner == DeliverySubscription,+          Just subscription <- (.subscription) owner ->             "DurableQueryCursor " <> T.pack (show subscription)       _ -> "NoQueryCursor"-    expectedFreshness = case rmFreshness readModel of+    expectedFreshness = case (.freshness) readModel of       FreshnessImmediate -> "Immediate"       FreshnessWaitForHead RmEntireLog -> "WaitForHead EntireVisibleLog"       FreshnessWaitForHead (RmCategory categoryName) -> "WaitForHead (CategoryVisibleHead " <> T.pack (show categoryName) <> ")"     feedingOwners =       sortOn-        poOrder+        (.order)         [ owner         | Just resolved <- [supply],-          NProjectionOwner owner <- specNodes spec,-          poName owner == supplyProjectionOwner resolved,-          poDelivery owner == DeliverySubscription+          NProjectionOwner owner <- (.nodes) spec,+          (.name) owner == (.projectionOwner) resolved,+          (.delivery) owner == DeliverySubscription         ]     expectedCatalogRegistration =       T.intercalate         "|"         [ expectedRegistry,-          T.pack (show (rmVersion readModel)),-          rmShape readModel,-          fromMaybe "" (rmGroup readModel)+          T.pack (show ((.version) readModel)),+          (.shape) readModel,+          fromMaybe "" ((.group) readModel)         ]     expectedCatalogSupply = case supply of       Nothing -> "missing"       Just resolved ->         T.intercalate           "|"-          [ supplyProjectionOwner resolved,-            supplyRebuildGroup resolved,-            T.intercalate "," (NE.toList (supplyObservedTargets resolved))+          [ (.projectionOwner) resolved,+            (.rebuildGroup) resolved,+            T.intercalate "," (NE.toList ((.observedTargets) resolved))           ]     catalogHelpers       | not catalogManaged = []@@ -421,31 +421,31 @@       [ "  [ (\"catalogRegistration\", "           <> tshow expectedCatalogRegistration           <> ", renderRegistration [entry | entry <- registrations, Catalog.queryModelIdText entry.queryModelId == "-          <> tshow (rmName readModel)+          <> tshow ((.name) readModel)           <> "])",         "  , (\"querySupply\", "           <> tshow expectedCatalogSupply           <> ", renderSupply [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "-          <> tshow (rmName readModel)+          <> tshow ((.name) readModel)           <> "])",         "  , (\"projectionDelivery\", "           <> tshow expectedDelivery           <> ", renderDelivery [entry | entry <- supplies, Catalog.queryModelIdText entry.resolvedQueryModelId == "-          <> tshow (rmName readModel)+          <> tshow ((.name) readModel)           <> "])"       ]         <> [ "  , (\"asyncRegistration:"-               <> poName owner+               <> (.name) owner                <> "\", "-               <> tshow (T.intercalate "|" [fromMaybe "" (poSubscription owner), fromMaybe "" (poDedup owner)])+               <> tshow (T.intercalate "|" [fromMaybe "" ((.subscription) owner), fromMaybe "" ((.dedup) owner)])                <> ", renderAsync [entry | entry <- asyncRegistrations, Catalog.projectionIdText entry.projectionId == "-               <> tshow (poName owner)+               <> tshow ((.name) owner)                <> "])"            | owner <- feedingOwners            ]         <> ["  ]"]     expectedDelivery = case resolvedOwner of-      Just owner -> case poDelivery owner of+      Just owner -> case (.delivery) owner of         DeliveryInline -> "inline"         DeliverySubscription -> "subscription"       Nothing -> "missing"@@ -476,25 +476,25 @@  processHarnessFactValues :: ProcessNode -> [(Text, Text)] processHarnessFactValues p =-  [ ("fireAtField", faField (tmFireAt timer)),-    ("timerIdPrefix", idePrefix (tmId timer)),-    ("firedEventIdPrefix", idePrefix (fireFiredEventId timer')),+  [ ("fireAtField", (.field) ((.fireAt) timer)),+    ("timerIdPrefix", (.prefix) ((.id) timer)),+    ("firedEventIdPrefix", (.prefix) ((.firedEventId) timer')),     ("dispatchIdUserField", "none"),-    ("onReject", showFireOutcome (onReject fd)),-    ("onAmbiguous", showFireOutcome (onAmbiguous fd)),-    ("onFailed", showDisp (onFailed (firstDispDisposition p))),-    ("rejectedPolicy", showPolicy (procRejected p)),-    ("poisonPolicy", showPolicy (procPoison p)),-    ("maxAttempts", tInt (tmMaxAttempts timer))+    ("onReject", showFireOutcome ((.onReject) fd)),+    ("onAmbiguous", showFireOutcome ((.onAmbiguous) fd)),+    ("onFailed", showDisp ((.onFailed) (firstDispDisposition p))),+    ("rejectedPolicy", showPolicy ((.rejected) p)),+    ("poisonPolicy", showPolicy ((.poison) p)),+    ("maxAttempts", tInt ((.maxAttempts) timer))   ]   where-    timer = procTimer p-    timer' = tmFire timer-    fd = fireDisposition timer'+    timer = (.timer) p+    timer' = (.fire) timer+    fd = (.disposition) timer'  firstDispDisposition :: ProcessNode -> DispatchDisposition-firstDispDisposition p = case hDispatch (procHandle p) of-  (d : _) -> dispDisposition d+firstDispDisposition p = case (.dispatch) ((.handle) p) of+  (d : _) -> (.disposition) d   [] -> DispatchDisposition DAckOk DAckOk DRetry  showFireOutcome :: FireOutcome -> Text@@ -523,20 +523,20 @@ harnessWorkflow :: Context -> WorkflowNode -> [ScaffoldModule] harnessWorkflow ctx w =   [ ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/WorkflowFacts.hs"),-        moduleText = emitWorkflowFacts genPrefix w,+      { path = T.unpack (T.replace "." "/" genPrefix <> "/WorkflowFacts.hs"),+        text = emitWorkflowFacts genPrefix w,         kind = Generated,-        origin = "workflow " <> wfId w <> locSuffix (workflowNodeLoc w)+        origin = "workflow " <> (.id) w <> locSuffix (workflowNodeLoc w)       },     ScaffoldModule-      { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/WorkflowRuntime.hs"),-        moduleText = emitWorkflowRuntime genPrefix w,+      { path = T.unpack (T.replace "." "/" genPrefix <> "/WorkflowRuntime.hs"),+        text = emitWorkflowRuntime genPrefix w,         kind = Generated,-        origin = "workflow " <> wfId w <> locSuffix (workflowNodeLoc w)+        origin = "workflow " <> (.id) w <> locSuffix (workflowNodeLoc w)       }   ]   where-    genPrefix = genPrefixFor ctx (wfId w)+    genPrefix = genPrefixFor ctx ((.id) w)  locSuffix :: Loc -> Text locSuffix loc = case unLoc loc of@@ -565,23 +565,23 @@       "workflowFacts :: WorkflowFacts",       "workflowFacts =",       "  WorkflowFacts",-      "    { workflowFactName = " <> hs (wfStable w),-      "    , workflowFactIdVia = " <> hs (wfIdVia w),-      "    , workflowFactIdField = " <> hs (maybe "input" id (wfIdField w)),-      "    , workflowFactBody = " <> stringList (map bodyTag (wfBody w)),-      "    , workflowFactAwaitLabels = " <> stringList (workflowAwaitLabels (wfBody w)),-      "    , workflowFactPatchIds = " <> stringList (workflowPatchIds (wfBody w)),+      "    { workflowFactName = " <> hs ((.stable) w),+      "    , workflowFactIdVia = " <> hs ((.idVia) w),+      "    , workflowFactIdField = " <> hs (maybe "input" id ((.idField) w)),+      "    , workflowFactBody = " <> stringList (map bodyTag ((.body) w)),+      "    , workflowFactAwaitLabels = " <> stringList (workflowAwaitLabels ((.body) w)),+      "    , workflowFactPatchIds = " <> stringList (workflowPatchIds ((.body) w)),       "    }",       "",       "-- | Base-library projection used by the service-level conformance facade.",       "workflowFactValues :: [(String, String)]",       "workflowFactValues =",-      "  [ (\"name\", workflowFactName workflowFacts)",-      "  , (\"idVia\", workflowFactIdVia workflowFacts)",-      "  , (\"idField\", workflowFactIdField workflowFacts)",-      "  , (\"body\", show (workflowFactBody workflowFacts))",-      "  , (\"awaits\", show (workflowFactAwaitLabels workflowFacts))",-      "  , (\"patches\", show (workflowFactPatchIds workflowFacts))",+      "  [ (\"name\", workflowFacts.workflowFactName)",+      "  , (\"idVia\", workflowFacts.workflowFactIdVia)",+      "  , (\"idField\", workflowFacts.workflowFactIdField)",+      "  , (\"body\", show workflowFacts.workflowFactBody)",+      "  , (\"awaits\", show workflowFacts.workflowFactAwaitLabels)",+      "  , (\"patches\", show workflowFacts.workflowFactPatchIds)",       "  ]"     ]   where@@ -596,12 +596,12 @@  workflowHarnessFactValues :: WorkflowNode -> [(Text, Text)] workflowHarnessFactValues workflow =-  [ ("name", wfStable workflow),-    ("idVia", wfIdVia workflow),-    ("idField", maybe "input" id (wfIdField workflow)),-    ("body", T.pack (show (map (T.unpack . bodyTag) (wfBody workflow)))),-    ("awaits", T.pack (show (map T.unpack (workflowAwaitLabels (wfBody workflow))))),-    ("patches", T.pack (show (map T.unpack (workflowPatchIds (wfBody workflow)))))+  [ ("name", (.stable) workflow),+    ("idVia", (.idVia) workflow),+    ("idField", maybe "input" id ((.idField) workflow)),+    ("body", T.pack (show (map (T.unpack . bodyTag) ((.body) workflow)))),+    ("awaits", T.pack (show (map T.unpack (workflowAwaitLabels ((.body) workflow))))),+    ("patches", T.pack (show (map T.unpack (workflowPatchIds ((.body) workflow)))))   ]   where     bodyTag (WfStep label _ _) = "step:" <> label@@ -648,7 +648,7 @@            "import Kiroku.Store.Effect (Store)",            "",            "workflowName :: WorkflowName",-           "workflowName = WorkflowName " <> tshow (wfStable w),+           "workflowName = WorkflowName " <> tshow ((.stable) w),            "",            "-- | A declared await label. The constructor stays private so consumers",            "-- can allocate only labels that exist in the source workflow.",@@ -663,10 +663,10 @@          ]       ++ concatMap emitBinding awaitBindings       ++ [ "awaitLabels :: [Text]",-           "awaitLabels = [" <> T.intercalate ", " (map tshow (workflowAwaitLabels (wfBody w))) <> "]",+           "awaitLabels = [" <> T.intercalate ", " (map tshow (workflowAwaitLabels ((.body) w))) <> "]",            "",            "declaredPatches :: Set PatchId",-           "declaredPatches = Set.fromList [" <> T.intercalate ", " ["PatchId " <> tshow patchId | patchId <- workflowPatchIds (wfBody w)] <> "]",+           "declaredPatches = Set.fromList [" <> T.intercalate ", " ["PatchId " <> tshow patchId | patchId <- workflowPatchIds ((.body) w)] <> "]",            "",            "-- The journal keys the runtime records patch decisions under.",            "declaredPatchStepNames :: [Text]",@@ -679,7 +679,7 @@   where     awaitBindings =       [ (workflowAwaitBindingName w label loc, label)-      | (label, loc) <- workflowAwaits (wfBody w)+      | (label, loc) <- workflowAwaits ((.body) w)       ]     emitBinding (bindingName, label) =       [ bindingName <> " :: AwaitBinding",@@ -695,10 +695,10 @@   where     site =       HaskellName.NameSite-        { HaskellName.siteKind = HaskellName.GeneratedValueSite,-          HaskellName.siteLogicalName = label,-          HaskellName.siteOwner = "workflow:" <> wfId workflow <> ":await:" <> label,-          HaskellName.siteLine = unLoc loc+        { HaskellName.kind = HaskellName.GeneratedValueSite,+          HaskellName.logicalName = label,+          HaskellName.owner = "workflow:" <> (.id) workflow <> ":await:" <> label,+          HaskellName.line = unLoc loc         }  workflowAwaits :: [WfBodyItem] -> [(Name, Loc)]@@ -724,9 +724,9 @@ emitHarness :: [GoldenPayload] -> Agg -> Text emitHarness goldens a =   nl $-    renderGeneratedLanguagePragmas [ExtOverloadedLabels | not (null replayTransitions) && not (null (aRegs a))]+    renderGeneratedLanguagePragmas [ExtOverloadedLabels | not (null replayTransitions) && not (null ((.regs) a))]       ++ [ generatedBanner,-           "module " <> aGenPrefix a <> ".Harness (harnessAssertions) where",+           "module " <> (.genPrefix) a <> ".Harness (harnessAssertions) where",            ""          ]       ++ harnessImports@@ -739,17 +739,17 @@            "  [ (\"validateTransducer is empty\", null (validateTransducer defaultValidationOptions " <> lowerFirst nm <> "Transducer))"          ]       ++ clockFreeRows-      ++ [ "  , (\"golden round-trip: " <> rcName e <> "\", roundTrips sampleEvent" <> rcName e <> ")"-         | e <- aEvents a+      ++ [ "  , (\"golden round-trip: " <> (.name) e <> "\", roundTrips sampleEvent" <> (.name) e <> ")"+         | e <- (.events) a          ]-      ++ [ "  , (\"accepts " <> tCommand t <> " from " <> initialVertex a <> "\", accept" <> tCommand t <> ")"-         | t <- map layoutTransition (initialLiveTransitionEntries a)+      ++ [ "  , (\"accepts " <> (.command) t <> " from " <> initialVertex a <> "\", accept" <> (.command) t <> ")"+         | t <- map (.transition) (initialLiveTransitionEntries a)          ]       ++ [ "  ]"          ]       ++ ["  ++ mappedConformanceAssertions" | hasMappedHarness a]       ++ ["  ++ nominalConformanceAssertions" | hasNominalHarness a]-      ++ [ "  ++ forwardReplay" <> tCommand t+      ++ [ "  ++ forwardReplay" <> (.command) t          | t <- replayTransitions          ]       ++ ( if null upcastEvents@@ -764,34 +764,34 @@            "roundTrips e = parse" <> nm <> "Event (eventType " <> lowerFirst nm <> "Codec e) (encode" <> nm <> "Event e) == Right e"          ]       ++ harnessSampleDeclarations a-      ++ concatMap (sampleEventDecl a) (aEvents a)-      ++ concatMap (acceptDecl a . layoutTransition) (initialLiveTransitionEntries a)+      ++ concatMap (sampleEventDecl a) ((.events) a)+      ++ concatMap (acceptDecl a . (.transition)) (initialLiveTransitionEntries a)       ++ concatMap (forwardReplayDecl a) replayTransitions       ++ concatMap (upcastDecl goldens a) upcastEvents       ++ mappedHarnessDeclarations a       ++ nominalHarnessDeclarations a   where-    nm = aName a+    nm = (.name) a     clockFreeRows =       if specIsClockFree a         then ["  -- clock-free: spec samples no wall clock (verified at scaffold time)"]         else ["  , (\"clock-free: spec samples no wall clock\", False)"]-    upcastEvents = [e | e <- aEvents a, rcUpcastFrom e /= Nothing]+    upcastEvents = [e | e <- (.events) a, (.upcastFrom) e /= Nothing]     replayTransitions =       [ t       | entry <- initialLiveTransitionEntries a,-        let t = layoutTransition entry,-        not (null (tEmits t))+        let t = (.transition) entry,+        not (null ((.emits) t))       ]     coreImports =       ["applyEventsEither" | not (null replayTransitions)]         ++ ["defaultValidationOptions", "step", "validateTransducer"]         ++ ["fieldWitnessAgrees" | not (null (nominalScalarHarnessTypes a)) || not (null (enforcedConsumerNominalIdHarnessTypes a))]-        ++ ["(!)" | not (null replayTransitions) && not (null (aRegs a))]+        ++ ["(!)" | not (null replayTransitions) && not (null ((.regs) a))]     upcastAssertions =-      [ "(" <> tshow (upcastLabel e m) <> ", upcasts" <> rcName e <> ")"+      [ "(" <> tshow (upcastLabel e m) <> ", upcasts" <> (.name) e <> ")"       | e <- upcastEvents,-        Just m <- [rcUpcastFrom e]+        Just m <- [(.upcastFrom) e]       ]     codecValueImport = ", " <> lowerFirst nm <> "Codec"     codecDecodeRawImport =@@ -807,13 +807,13 @@         else []     harnessImports =       unique $-        [ "import " <> aGenPrefix a <> ".Domain",-          "import " <> aGenPrefix a <> ".Codec (encode" <> nm <> "Event, parse" <> nm <> "Event" <> codecValueImport <> mappedCodecHarnessExports a <> ")",+        [ "import " <> (.genPrefix) a <> ".Domain",+          "import " <> (.genPrefix) a <> ".Codec (encode" <> nm <> "Event, parse" <> nm <> "Event" <> codecValueImport <> mappedCodecHarnessExports a <> ")",           transducerImport a,           "import Keiki.Core (" <> T.intercalate ", " coreImports <> ")",           codecDecodeRawImport         ]-          ++ generatedNominalTypeImportsForService (aggregateCheckedService a) (aContext a) (generatedNominalHarnessTypes a)+          ++ generatedNominalTypeImportsForService (aggregateCheckedService a) ((.context) a) (generatedNominalHarnessTypes a)           ++ mappedHarnessImports a           ++ nominalHarnessImports a           ++ aggregateHarnessImports a@@ -822,52 +822,52 @@      upcastLabel event source =       case goldenFor goldens event of-        Just _ -> "golden " <> rcName event <> ".v" <> tInt source <> " decodes"+        Just _ -> "golden " <> (.name) event <> ".v" <> tInt source <> " decodes"         Nothing ->           "upcast "-            <> rcName event+            <> (.name) event             <> " chain wired (current-shape stand-in; add a golden payload)"  transducerImport :: Agg -> Text transducerImport aggregate   | usesGeneratedTransducer aggregate =       "import "-        <> aGenPrefix aggregate+        <> (.genPrefix) aggregate         <> ".Transducer ("-        <> lowerFirst (aName aggregate)+        <> lowerFirst ((.name) aggregate)         <> "Transducer)"   | otherwise =       "import "-        <> aHolePrefix aggregate+        <> (.holePrefix) aggregate         <> ".Holes ("-        <> lowerFirst (aName aggregate)+        <> lowerFirst ((.name) aggregate)         <> "Transducer)"  usesGeneratedTransducer :: Agg -> Bool-usesGeneratedTransducer = any ((/= LegacyHoleImplementation) . tImplementation) . aTransitions+usesGeneratedTransducer = any ((/= LegacyHoleImplementation) . (.implementation)) . (.transitions)  -- | Decode a genuine embedded old payload when available. Without a golden, -- retain the weaker current-shape wiring assertion and label it honestly. upcastDecl :: [GoldenPayload] -> Agg -> ResolvedCtor -> [Text]-upcastDecl goldens a e = case rcUpcastFrom e of+upcastDecl goldens a e = case (.upcastFrom) e of   Nothing -> []   Just m -> case goldenFor goldens e of     Just golden ->       [ "",-        "upcasts" <> rcName e <> " :: Bool",-        "upcasts" <> rcName e <> " =",-        "  case eitherDecodeStrict (encodeUtf8 " <> tshow (goldenJson golden) <> ") of",+        "upcasts" <> (.name) e <> " :: Bool",+        "upcasts" <> (.name) e <> " =",+        "  case eitherDecodeStrict (encodeUtf8 " <> tshow ((.json) golden) <> ") of",         "    Left _ -> False",         "    Right payload ->",         "      either (const False) (const True)",-        "        (decodeRaw " <> lowerFirst (aName a) <> "Codec (EventType " <> tshow (rcName e) <> ") " <> tInt m <> " payload)"+        "        (decodeRaw " <> lowerFirst ((.name) a) <> "Codec (EventType " <> tshow ((.name) e) <> ") " <> tInt m <> " payload)"       ]     Nothing ->       [ "",-        "upcasts" <> rcName e <> " :: Bool",-        "upcasts" <> rcName e <> " =",+        "upcasts" <> (.name) e <> " :: Bool",+        "upcasts" <> (.name) e <> " =",         "  either (const False) (const True)",-        "    (decodeRaw " <> lowerFirst (aName a) <> "Codec (EventType " <> tshow (rcName e) <> ") " <> tInt m <> " (encode" <> aName a <> "Event sampleEvent" <> rcName e <> "))"+        "    (decodeRaw " <> lowerFirst ((.name) a) <> "Codec (EventType " <> tshow ((.name) e) <> ") " <> tInt m <> " (encode" <> (.name) a <> "Event sampleEvent" <> (.name) e <> "))"       ]  hasGolden :: [GoldenPayload] -> ResolvedCtor -> Bool@@ -877,9 +877,9 @@  goldenFor :: [GoldenPayload] -> ResolvedCtor -> Maybe GoldenPayload goldenFor goldens event = do-  source <- rcUpcastFrom event+  source <- (.upcastFrom) event   find-    (\golden -> goldenEvent golden == rcName event && goldenVersion golden == source)+    (\golden -> (.event) golden == (.name) event && (.version) golden == source)     goldens  tInt :: Int -> Text@@ -893,11 +893,11 @@ nl = T.intercalate "\n"  specIsClockFree :: Agg -> Bool-specIsClockFree a = not (any transitionSamplesClock (aTransitions a))+specIsClockFree a = not (any transitionSamplesClock ((.transitions) a))   where     clockAtoms = ["now", "currentTime", "wallClock", "today", "utcNow"]     transitionSamplesClock t =-      let exprs = maybe [] pure (tGuard t) ++ map snd (tWrites t)+      let exprs = maybe [] pure ((.guard) t) ++ map snd ((.writes) t)        in any (\e -> any (`elem` clockAtoms) (exprNames e)) exprs  exprNames :: Expr -> [Text]@@ -914,11 +914,11 @@ exprNames (EAtom (ABool _)) = []  initialLiveTransitionEntries :: Agg -> [TransitionLayoutEntry]-initialLiveTransitionEntries a = case map stName (aStates a) of+initialLiveTransitionEntries a = case map (.name) ((.states) a) of   (s0 : _) ->     [ entry-    | entry <- transitionLayoutForSource s0 (transitionLayout (aTransitions a)),-      tMode (layoutTransition entry) == TmLive+    | entry <- transitionLayoutForSource s0 (transitionLayout ((.transitions) a)),+      (.mode) ((.transition) entry) == TmLive     ]   [] -> [] @@ -928,8 +928,8 @@ sampleEventDecl :: Agg -> ResolvedCtor -> [Text] sampleEventDecl a e =   [ "",-    "sampleEvent" <> rcName e <> " :: " <> aName a <> "Event",-    "sampleEvent" <> rcName e <> " = " <> ctorExpr a e+    "sampleEvent" <> (.name) e <> " :: " <> (.name) a <> "Event",+    "sampleEvent" <> (.name) e <> " = " <> ctorExpr a e   ]  harnessSampleDeclarations :: Agg -> [Text]@@ -939,13 +939,13 @@     generatedIds =       [ nominal       | nominal <- generatedNominalHarnessTypes aggregate,-        IdRepresentation prefix <- [resolvedNominalRepresentation nominal],-        idDomainContractFor (aLanguageContract aggregate) prefix /= Nothing+        IdRepresentation prefix <- [(.representation) nominal],+        idDomainContractFor ((.languageContract) aggregate) prefix /= Nothing       ]-    generatedIdDeclaration nominal = case resolvedNominalRepresentation nominal of-      IdRepresentation prefix -> case idDomainContractFor (aLanguageContract aggregate) prefix of+    generatedIdDeclaration nominal = case (.representation) nominal of+      IdRepresentation prefix -> case idDomainContractFor ((.languageContract) aggregate) prefix of         Just contract ->-          let typeName = resolvedNominalName nominal+          let typeName = (.name) nominal               constantName = generatedIdSampleName nominal            in [ "",                 constantName <> " :: " <> typeName,@@ -967,14 +967,14 @@ acceptDecl :: Agg -> Transition -> [Text] acceptDecl a t =   [ "",-    "accept" <> tCommand t <> " :: Bool",-    "accept" <> tCommand t <> " =",-    "  case step " <> lowerFirst (aName a) <> "Transducer (" <> initialVertex a <> ", initial" <> aName a <> "Regs) " <> cmdSample <> " of",-    "    Just (v, _, _) -> v == " <> vertexCtor a (tGoto t),+    "accept" <> (.command) t <> " :: Bool",+    "accept" <> (.command) t <> " =",+    "  case step " <> lowerFirst ((.name) a) <> "Transducer (" <> initialVertex a <> ", initial" <> (.name) a <> "Regs) " <> cmdSample <> " of",+    "    Just (v, _, _) -> v == " <> vertexCtor a ((.goto) t),     "    Nothing -> False"   ]   where-    cmdSample = case [c | c <- aCommands a, rcName c == tCommand t] of+    cmdSample = case [c | c <- (.commands) a, (.name) c == (.command) t] of       (c : _) -> "(" <> commandCtorExpr a t c <> ")"       [] -> "(error \"no command\")" @@ -996,32 +996,32 @@     "            Right (replayVertex, " <> replayRegsName <> ") ->",     "              [ (prefix <> \"final vertex\", replayVertex == forwardVertex)"   ]-    ++ [ "              , (prefix <> \"register " <> rrName reg <> "\", (replayRegs ! #" <> rrName reg <> ") == (forwardRegs ! #" <> rrName reg <> "))"-       | reg <- aRegs a+    ++ [ "              , (prefix <> \"register " <> (.name) reg <> "\", (replayRegs ! #" <> (.name) reg <> ") == (forwardRegs ! #" <> (.name) reg <> "))"+       | reg <- (.regs) a        ]     ++ [ "              ]",          "  where",-         "    prefix = \"forward/replay equality: " <> tCommand t <> " from " <> initial <> " -- \""+         "    prefix = \"forward/replay equality: " <> (.command) t <> " from " <> initial <> " -- \""        ]   where-    nm = aName a-    helperName = "forwardReplay" <> tCommand t+    nm = (.name) a+    helperName = "forwardReplay" <> (.command) t     transducer = lowerFirst nm <> "Transducer"     codec = lowerFirst nm <> "Codec"     initial = initialVertex a     initialRegs = "initial" <> nm <> "Regs"-    forwardRegsName = if null (aRegs a) then "_forwardRegs" else "forwardRegs"-    replayRegsName = if null (aRegs a) then "_replayRegs" else "replayRegs"-    cmdSample = case [c | c <- aCommands a, rcName c == tCommand t] of+    forwardRegsName = if null ((.regs) a) then "_forwardRegs" else "forwardRegs"+    replayRegsName = if null ((.regs) a) then "_replayRegs" else "replayRegs"+    cmdSample = case [c | c <- (.commands) a, (.name) c == (.command) t] of       (c : _) -> "(" <> commandCtorExpr a t c <> ")"       [] -> "(error \"no command\")"  -- | @(<Ctor> (<Ctor>Data v1 v2 …))@ with positional sample field values. ctorExpr :: Agg -> ResolvedCtor -> Text ctorExpr a rc =-  rcName rc <> " (" <> rcName rc <> "Data" <> args <> ")"+  (.name) rc <> " (" <> (.name) rc <> "Data" <> args <> ")"   where-    args = T.concat [" " <> sampleValue a (fieldDslName identity) ty | (identity, ty) <- rcFields rc]+    args = T.concat [" " <> sampleValue a ((.dslName) identity) ty | (identity, ty) <- (.fields) rc]  -- | A transition command sample prefers the initial value of a same-named, -- same-typed register only when the guard explicitly equates those two paths.@@ -1029,34 +1029,34 @@ -- not accidentally inherit a forbidden @Free@ register initial value. commandCtorExpr :: Agg -> Transition -> ResolvedCtor -> Text commandCtorExpr a transition rc =-  rcName rc <> " (" <> rcName rc <> "Data" <> args <> ")"+  (.name) rc <> " (" <> (.name) rc <> "Data" <> args <> ")"   where-    args = T.concat [" " <> commandSampleValue a transition (fieldDslName identity) ty | (identity, ty) <- rcFields rc]+    args = T.concat [" " <> commandSampleValue a transition ((.dslName) identity) ty | (identity, ty) <- (.fields) rc]  commandSampleValue :: Agg -> Transition -> Text -> ResolvedAggregateType -> Text-commandSampleValue aggregate transition fieldName fieldType = case fieldType of+commandSampleValue aggregate transition name valueType = case valueType of   AggregateNominal _-    | guardEquatesCommandAndRegister transition fieldName -> case find matchesRegister (aRegs aggregate) of+    | guardEquatesCommandAndRegister transition name -> case find matchesRegister ((.regs) aggregate) of         Just register -> regInitialValueForHarness aggregate register         Nothing -> fallback   _ -> fallback   where-    fallback = sampleValue aggregate fieldName fieldType-    matchesRegister register = rrName register == fieldName && rrType register == fieldType-    regInitialValueForHarness owner register = case rrInitial register of+    fallback = sampleValue aggregate name valueType+    matchesRegister register = (.name) register == name && (.valueType) register == valueType+    regInitialValueForHarness owner register = case (.initial) register of       InitialNominal _ value -> renderHarnessReference owner (harnessQualifiedValueReference value)       InitialMapped _ value -> renderHarnessReference owner (harnessQualifiedValueReference value)-      _ -> case rrType register of-        AggregateNominal nominal -> case resolvedNominalOwnership nominal of-          ConsumerNominal {} -> renderRegisterInitial (rrInitial register)+      _ -> case (.valueType) register of+        AggregateNominal nominal -> case (.ownership) nominal of+          ConsumerNominal {} -> renderRegisterInitial ((.initial) register)           GeneratedNominal ->             fromMaybe-              (renderRegisterInitial (rrInitial register))+              (renderRegisterInitial ((.initial) register))               (generatedIdSampleName nominal <$ generatedIdSampleHaskell owner nominal)-        _ -> renderRegisterInitial (rrInitial register)+        _ -> renderRegisterInitial ((.initial) register)  guardEquatesCommandAndRegister :: Transition -> Text -> Bool-guardEquatesCommandAndRegister transition fieldName = maybe False containsEquality (tGuard transition)+guardEquatesCommandAndRegister transition name = maybe False containsEquality ((.guard) transition)   where     containsEquality = \case       EOr left right -> containsEquality left || containsEquality right@@ -1064,46 +1064,46 @@       ECmp OpEq left right -> matchingPaths left right || matchingPaths right left       _ -> False     matchingPaths (EPath _ CommandRoot [commandField]) (EPath _ RegisterRoot [registerField]) =-      commandField == fieldName && registerField == fieldName+      commandField == name && registerField == name     matchingPaths _ _ = False  sampleValue :: Agg -> Text -> ResolvedAggregateType -> Text-sampleValue a fieldName ty = case ty of+sampleValue a name ty = case ty of   AggregateNominal nominal-    | GeneratedNominal <- resolvedNominalOwnership nominal,+    | GeneratedNominal <- (.ownership) nominal,       Just _ <- generatedIdSampleHaskell a nominal ->         generatedIdSampleName nominal   AggregateNominal nominal-    | ConsumerNominal binding <- resolvedNominalOwnership nominal ->+    | ConsumerNominal binding <- (.ownership) nominal ->         "(nominalFixtureDomain (NonEmpty.head (nominalFixtureCases "-          <> renderHarnessReference a (harnessQualifiedValueReference (consumerNominalFixtures binding))+          <> renderHarnessReference a (harnessQualifiedValueReference ((.fixtures) binding))           <> ")))"   AggregateTime -> harnessTimeSampleName a   _ -> fallback   where     fallback = case fieldCat a ty of-      IdCat -> aggregateSampleHaskell (aSymbols a) fieldName ty-      EnumCat -> aggregateSampleHaskell (aSymbols a) fieldName ty-      MappedStructuralCat declaration _ -> fixtureSample a (sdFixtures declaration)-      MappedOpaqueCat declaration -> fixtureSample a (odFixtures declaration)+      IdCat -> aggregateSampleHaskell ((.symbols) a) name ty+      EnumCat -> aggregateSampleHaskell ((.symbols) a) name ty+      MappedStructuralCat declaration _ -> fixtureSample a ((.fixtures) declaration)+      MappedOpaqueCat declaration -> fixtureSample a ((.fixtures) declaration)       OtherCat -> case ty of         AggregateVertex vertexType-          | vertexType == aVertexType a -> initialVertex a-        _ -> aggregateSampleHaskell (aSymbols a) fieldName ty+          | vertexType == (.vertexType) a -> initialVertex a+        _ -> aggregateSampleHaskell ((.symbols) a) name ty  generatedIdSampleName :: ResolvedNominalType -> Text-generatedIdSampleName nominal = "sample" <> resolvedNominalName nominal+generatedIdSampleName nominal = "sample" <> (.name) nominal  harnessUsesTime :: Agg -> Bool harnessUsesTime aggregate =-  any ((== AggregateTime) . snd) (concatMap rcFields (aCommands aggregate <> aEvents aggregate))+  any ((== AggregateTime) . snd) (concatMap (.fields) ((.commands) aggregate <> (.events) aggregate))  harnessTimeSampleName :: Agg -> Text harnessTimeSampleName aggregate-  | any isObservedAtTime (concatMap rcFields (aCommands aggregate <> aEvents aggregate)) = "sampleObservedAt"+  | any isObservedAtTime (concatMap (.fields) ((.commands) aggregate <> (.events) aggregate)) = "sampleObservedAt"   | otherwise = "sampleTime"   where-    isObservedAtTime (identity, resolvedType) = fieldDslName identity == "observedAt" && resolvedType == AggregateTime+    isObservedAtTime (identity, resolvedType) = (.dslName) identity == "observedAt" && resolvedType == AggregateTime  aggregateHarnessImports :: Agg -> [Text] aggregateHarnessImports aggregate@@ -1124,7 +1124,7 @@                then []                else ["import Data.KindID qualified as KindID", "import Data.Text qualified as T", "import Keiro.Codec.IdDomain (typeIdV7Domain, validateIdDomainText)"]            )-        <> ["import " <> nominalProjectionModule (aContext aggregate) <> " qualified as NominalProjections" | not (null (nominalScalarHarnessTypes aggregate)) || not (null enforcedIds)]+        <> ["import " <> nominalProjectionModule ((.context) aggregate) <> " qualified as NominalProjections" | not (null (nominalScalarHarnessTypes aggregate)) || not (null enforcedIds)]   where     nominals = consumerNominalHarnessTypes aggregate     enforcedIds = enforcedConsumerNominalIdHarnessTypes aggregate@@ -1135,30 +1135,30 @@ consumerNominalHarnessTypes :: Agg -> [ResolvedNominalType] consumerNominalHarnessTypes aggregate =   Map.elems . Map.fromList $-    [ (resolvedNominalName nominal, nominal)-    | resolvedType <- map snd (concatMap rcFields (aCommands aggregate <> aEvents aggregate)) <> map rrType (aRegs aggregate),+    [ ((.name) nominal, nominal)+    | resolvedType <- map snd (concatMap (.fields) ((.commands) aggregate <> (.events) aggregate)) <> map (.valueType) ((.regs) aggregate),       AggregateNominal nominal <- [resolvedType],-      ConsumerNominal {} <- [resolvedNominalOwnership nominal]+      ConsumerNominal {} <- [(.ownership) nominal]     ]  generatedNominalHarnessTypes :: Agg -> [ResolvedNominalType] generatedNominalHarnessTypes aggregate =   generatedNominalsInTypes-    (map snd (concatMap rcFields (aCommands aggregate <> aEvents aggregate)))+    (map snd (concatMap (.fields) ((.commands) aggregate <> (.events) aggregate)))  nominalScalarHarnessTypes :: Agg -> [ResolvedNominalType] nominalScalarHarnessTypes aggregate =   [ nominal   | nominal <- consumerNominalHarnessTypes aggregate,-    ScalarRepresentation {} <- [resolvedNominalRepresentation nominal]+    ScalarRepresentation {} <- [(.representation) nominal]   ]  enforcedConsumerNominalIdHarnessTypes :: Agg -> [ResolvedNominalType] enforcedConsumerNominalIdHarnessTypes aggregate =   [ nominal   | nominal <- consumerNominalHarnessTypes aggregate,-    IdRepresentation prefix <- [resolvedNominalRepresentation nominal],-    idDomainContractFor (aLanguageContract aggregate) prefix /= Nothing+    IdRepresentation prefix <- [(.representation) nominal],+    idDomainContractFor ((.languageContract) aggregate) prefix /= Nothing   ]  nominalHarnessDeclarations :: Agg -> [Text]@@ -1173,7 +1173,7 @@   where     nominals = consumerNominalHarnessTypes aggregate     assertions = concatMap assertionsFor nominals-    assertionsFor nominal = case resolvedNominalOwnership nominal of+    assertionsFor nominal = case (.ownership) nominal of       GeneratedNominal -> []       ConsumerNominal binding ->         [ ( "nominal domain law: " <> name,@@ -1191,17 +1191,17 @@                    <> ") (nominalFixtureDomain fixture)) "                    <> fixtures                )-             | ScalarRepresentation {} <- [resolvedNominalRepresentation nominal]+             | ScalarRepresentation {} <- [(.representation) nominal]              ]           <> idDomainAssertions name bindingName fixtures nominal         where-          name = resolvedNominalName nominal-          bindingName = renderHarnessReference aggregate (harnessQualifiedValueReference (consumerNominalBinding binding))-          fixtureName = renderHarnessReference aggregate (harnessQualifiedValueReference (consumerNominalFixtures binding))+          name = (.name) nominal+          bindingName = renderHarnessReference aggregate (harnessQualifiedValueReference ((.binding) binding))+          fixtureName = renderHarnessReference aggregate (harnessQualifiedValueReference ((.fixtures) binding))           fixtures = "(NonEmpty.toList (nominalFixtureCases " <> fixtureName <> "))"-    idDomainAssertions name bindingName fixtures nominal = case resolvedNominalRepresentation nominal of+    idDomainAssertions name bindingName fixtures nominal = case (.representation) nominal of       IdRepresentation prefix-        | Just contract <- idDomainContractFor (aLanguageContract aggregate) prefix ->+        | Just contract <- idDomainContractFor ((.languageContract) aggregate) prefix ->             let firstSample = idDomainSampleText contract                 samples = [firstSample, T.dropEnd 1 firstSample <> "r"]                 wrongPrefix = "wrong_" <> T.drop (T.length prefix + 1) firstSample@@ -1275,7 +1275,7 @@ mappedCodecHarnessExports :: Agg -> Text mappedCodecHarnessExports aggregate =   T.concat-    [ ", encode" <> sdName declaration <> "Mapped, decode" <> sdName declaration <> "Mapped"+    [ ", encode" <> (.name) declaration <> "Mapped, decode" <> (.name) declaration <> "Mapped"     | ResolvedStructural declaration _ <- codecMappedDeclarations aggregate     ] @@ -1295,13 +1295,13 @@     id     ( planHaskellImports         ImportEnvironment-          { targetModule = aGenPrefix aggregate <> ".Harness",+          { targetModule = (.genPrefix) aggregate <> ".Harness",             localNames =               Set.fromList-                [ aName aggregate <> "Command",-                  aName aggregate <> "Event",-                  aName aggregate <> "Regs",-                  aVertexType aggregate+                [ (.name) aggregate <> "Command",+                  (.name) aggregate <> "Event",+                  (.name) aggregate <> "Regs",+                  (.vertexType) aggregate                 ],             reservedQualifiers = harnessReservedQualifiers           }@@ -1312,13 +1312,13 @@       Set.fromList         [ reference         | nominal <- consumerNominalHarnessTypes aggregate,-          ConsumerNominal binding <- [resolvedNominalOwnership nominal],+          ConsumerNominal binding <- [(.ownership) nominal],           reference <-             map               harnessQualifiedValueReference-              ( consumerNominalBinding binding-                  : consumerNominalFixtures binding-                  : maybeToListHarness (consumerNominalInitial binding)+              ( (.binding) binding+                  : (.fixtures) binding+                  : maybeToListHarness ((.initial) binding)               )         ]     mappedReferences =@@ -1329,11 +1329,11 @@             ResolvedStructural structural _ ->               map                 harnessQualifiedValueReference-                (sdFixtures structural : maybeToListHarness (sdInitial structural))+                ((.fixtures) structural : maybeToListHarness ((.initial) structural))             ResolvedOpaque opaque ->               map                 harnessQualifiedValueReference-                (odFixtures opaque : maybeToListHarness (odInitial opaque))+                ((.fixtures) opaque : maybeToListHarness ((.initial) opaque))         ]     references = consumerNominalReferences <> mappedReferences @@ -1374,20 +1374,20 @@   not (null (mappedEventFields aggregate)) || not (null (structuralWireDeclarations aggregate))  mappedHarnessDeclarationsResolved :: Agg -> [ResolvedMappedDecl]-mappedHarnessDeclarationsResolved aggregate = case aTypeGraph aggregate of+mappedHarnessDeclarationsResolved aggregate = case (.typeGraph) aggregate of   Nothing -> []   Just graph ->     [ declaration-    | key <- aggregateMappedClosure (semanticImpact graph) (aName aggregate),-      Just declaration <- [Map.lookup key (tgDeclarations graph)]+    | key <- aggregateMappedClosure (semanticImpact graph) ((.name) aggregate),+      Just declaration <- [Map.lookup key ((.declarations) graph)]     ]  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)+  [ (event, (.dslName) identity, valueType, declaration)+  | event <- (.events) aggregate,+    (identity, valueType) <- (.fields) event,+    declaration <- maybeToListHarness (mappedDeclaration aggregate valueType)   ]  structuralWireDeclarations :: Agg -> [(StructuralDecl, ResolvedMappedShape)]@@ -1412,8 +1412,8 @@     structuralWire = structuralWireDeclarations aggregate     eventFields = mappedEventFields aggregate     assertionLists =-      [ mappedEventAssertionName event fieldName <> "Assertions"-      | (event, fieldName, _, _) <- eventFields+      [ mappedEventAssertionName event name <> "Assertions"+      | (event, name, _, _) <- eventFields       ]         <> ["structuralWirePolicyAssertions" | not (null structuralWire)] @@ -1422,25 +1422,25 @@   key <- case resolvedType of     AggregateMapped mappedKey -> Just mappedKey     _ -> Nothing-  graph <- aTypeGraph aggregate-  Map.lookup key (tgDeclarations graph)+  graph <- (.typeGraph) aggregate+  Map.lookup key ((.declarations) graph)  mappedEventAssertionDecl :: Agg -> (ResolvedCtor, Text, ResolvedAggregateType, ResolvedMappedDecl) -> [Text]-mappedEventAssertionDecl aggregate (event, fieldName, _fieldType, declaration) =+mappedEventAssertionDecl aggregate (event, name, _fieldType, declaration) =   [ "",     valueName <> "Assertions :: [(String, Bool)]",     valueName <> "Assertions =",-    "  [ (\"mapped codec round-trip: " <> rcName event <> "/" <> fieldName <> "/\" <> T.unpack label, roundTrips " <> eventExpression <> ")",+    "  [ (\"mapped codec round-trip: " <> (.name) event <> "/" <> name <> "/\" <> T.unpack label, roundTrips " <> eventExpression <> ")",     "  | (label, mappedValue) <- NonEmpty.toList (fixtureCases " <> fixtures <> ")",     "  ]"   ]   where-    valueName = mappedEventAssertionName event fieldName+    valueName = mappedEventAssertionName event name     fixtures = renderHarnessReference aggregate (harnessQualifiedValueReference (mappedFixtures declaration))-    eventExpression = ctorExprWithOverride aggregate event fieldName "mappedValue"+    eventExpression = ctorExprWithOverride aggregate event name "mappedValue"  mappedEventAssertionName :: ResolvedCtor -> Text -> Text-mappedEventAssertionName event fieldName = lowerFirst (rcName event) <> pascal fieldName+mappedEventAssertionName event name = lowerFirst ((.name) event) <> pascal name  wirePolicyAssertionDecls :: Agg -> [(StructuralDecl, ResolvedMappedShape)] -> [Text] wirePolicyAssertionDecls _aggregate [] = []@@ -1457,28 +1457,28 @@ wirePolicyAssertions :: Agg -> (StructuralDecl, ResolvedMappedShape) -> [Text] wirePolicyAssertions aggregate (declaration, shape) = case shape of   RRecord _ unknownFields fields ->-    concatMap (recordMissingAssertions aggregate declaration) [field | field <- fields, rwfPresence field == POptional]+    concatMap (recordMissingAssertions aggregate declaration) [field | field <- fields, (.presence) field == POptional]       <> [unknownFieldAssertion aggregate declaration unknownFields]   REnum entries -> map (enumArmAssertion aggregate declaration) entries <> [enumUnknownAssertion declaration]   RUnion encoding arms ->     map (unionArmAssertion aggregate declaration encoding) arms-      <> [unknownFieldAssertion aggregate declaration (ueUnknownFields encoding)]+      <> [unknownFieldAssertion aggregate declaration ((.unknownFields) encoding)]  wirePoliciesUseIsLeft :: [(StructuralDecl, ResolvedMappedShape)] -> Bool wirePoliciesUseIsLeft = any $ \(_, shape) -> case shape of   RRecord _ unknownFields fields ->     unknownFields == RejectUnknown-      || any (\field -> rwfPresence field == POptional && not (isOptionalType (rwfType field))) fields+      || any (\field -> (.presence) field == POptional && not (isOptionalType ((.valueType) field))) fields   REnum {} -> True-  RUnion encoding _ -> ueUnknownFields encoding == RejectUnknown+  RUnion encoding _ -> (.unknownFields) encoding == RejectUnknown  wirePoliciesUseIsRight :: [(StructuralDecl, ResolvedMappedShape)] -> Bool wirePoliciesUseIsRight = any $ \(_, shape) -> case shape of   RRecord _ unknownFields fields ->     unknownFields == IgnoreUnknown-      || any (\field -> rwfPresence field == POptional && isOptionalType (rwfType field)) fields+      || any (\field -> (.presence) field == POptional && isOptionalType ((.valueType) field)) fields   REnum {} -> False-  RUnion encoding _ -> ueUnknownFields encoding == IgnoreUnknown+  RUnion encoding _ -> (.unknownFields) encoding == IgnoreUnknown  isOptionalType :: ResolvedTypeExpr -> Bool isOptionalType ROptional {} = True@@ -1489,15 +1489,15 @@   [ "(\"wire policy missing default: "       <> canonical       <> "/"-      <> rwfKey field+      <> (.key) field       <> "\", case "       <> decoder       <> " (deleteObjectField "-      <> tshow (rwfKey field)+      <> tshow ((.key) field)       <> " ("       <> encodedSample       <> ")) of Left _ -> False; Right decoded -> objectField "-      <> tshow (rwfKey field)+      <> tshow ((.key) field)       <> " ("       <> encoder       <> " decoded) == Just ("@@ -1506,39 +1506,39 @@     "(\"wire policy explicit null: "       <> canonical       <> "/"-      <> rwfKey field+      <> (.key) field       <> "\", "       <> nullExpectation       <> " ("       <> decoder       <> " (insertObjectField "-      <> tshow (rwfKey field)+      <> tshow ((.key) field)       <> " Aeson.Null ("       <> encodedSample       <> "))))"   ]   where-    canonical = unCanonicalTypeId (sdCanonical declaration)-    encoder = "encode" <> sdName declaration <> "Mapped"-    decoder = "decode" <> sdName declaration <> "Mapped"-    fixtures = renderHarnessReference aggregate (harnessQualifiedValueReference (sdFixtures declaration))+    canonical = unCanonicalTypeId ((.canonical) declaration)+    encoder = "encode" <> (.name) declaration <> "Mapped"+    decoder = "decode" <> (.name) declaration <> "Mapped"+    fixtures = renderHarnessReference aggregate (harnessQualifiedValueReference ((.fixtures) declaration))     encodedSample = encoder <> " (snd (NonEmpty.head (fixtureCases " <> fixtures <> ")))"-    nullExpectation = case rwfType field of+    nullExpectation = case (.valueType) field of       ROptional _ -> "isRight"       _ -> "isLeft"  missingExpectedValue :: Agg -> ResolvedWireField -> Text-missingExpectedValue aggregate field = case rwfOnMissing field of+missingExpectedValue aggregate field = case (.onMissing) field of   Just OmNull -> "Aeson.Null"   Just (OmText value) -> "Aeson.String " <> tshow value   Just (OmInt value) -> "Aeson.toJSON (" <> T.pack (show value) <> " :: Int)"   Just (OmBool value) -> if value then "Aeson.Bool True" else "Aeson.Bool False"   Just OmEmptyList -> "Aeson.toJSON ([] :: [Aeson.Value])"   Just OmEmptyMap -> "Aeson.Object mempty"-  Just (OmCtor constructor) -> case (aTypeGraph aggregate, rwfType field) of-    (Just graph, RRef key) -> case Map.lookup key (tgDeclarations graph) of-      Just (ResolvedStructural _ (REnum entries)) -> case find ((== constructor) . weCtor) entries of-        Just entry -> "Aeson.String " <> tshow (weTag entry)+  Just (OmCtor constructor) -> case ((.typeGraph) aggregate, (.valueType) field) of+    (Just graph, RRef key) -> case Map.lookup key ((.declarations) graph) of+      Just (ResolvedStructural _ (REnum entries)) -> case find ((== constructor) . (.ctor)) entries of+        Just entry -> "Aeson.String " <> tshow ((.tag) entry)         Nothing -> "error \"missing enum default constructor\""       _ -> "error \"non-enum constructor default\""     _ -> "error \"non-reference constructor default\""@@ -1547,15 +1547,15 @@ unknownFieldAssertion :: Agg -> StructuralDecl -> UnknownFields -> Text unknownFieldAssertion aggregate declaration policy =   "(\"wire policy unknown fields: "-    <> unCanonicalTypeId (sdCanonical declaration)+    <> unCanonicalTypeId ((.canonical) declaration)     <> "\", all (\\(_, value) -> "     <> expectation     <> " (decode"-    <> sdName declaration+    <> (.name) declaration     <> "Mapped (insertObjectField \"__keiro_unknown\" (Aeson.Bool True) (encode"-    <> sdName declaration+    <> (.name) declaration     <> "Mapped value)))) (NonEmpty.toList (fixtureCases "-    <> renderHarnessReference aggregate (harnessQualifiedValueReference (sdFixtures declaration))+    <> renderHarnessReference aggregate (harnessQualifiedValueReference ((.fixtures) declaration))     <> ")))"   where     expectation = case policy of@@ -1565,47 +1565,47 @@ enumArmAssertion :: Agg -> StructuralDecl -> WireEnum -> Text enumArmAssertion aggregate declaration entry =   "(\"wire enum arm: "-    <> unCanonicalTypeId (sdCanonical declaration)+    <> unCanonicalTypeId ((.canonical) declaration)     <> "/"-    <> weTag entry+    <> (.tag) entry     <> "\", any (\\(_, value) -> encode"-    <> sdName declaration+    <> (.name) declaration     <> "Mapped value == Aeson.String "-    <> tshow (weTag entry)+    <> tshow ((.tag) entry)     <> " && decode"-    <> sdName declaration+    <> (.name) declaration     <> "Mapped (Aeson.String "-    <> tshow (weTag entry)+    <> tshow ((.tag) entry)     <> ") == Right value) (NonEmpty.toList (fixtureCases "-    <> renderHarnessReference aggregate (harnessQualifiedValueReference (sdFixtures declaration))+    <> renderHarnessReference aggregate (harnessQualifiedValueReference ((.fixtures) declaration))     <> ")))"  enumUnknownAssertion :: StructuralDecl -> Text enumUnknownAssertion declaration =   "(\"wire enum unknown tag: "-    <> unCanonicalTypeId (sdCanonical declaration)+    <> unCanonicalTypeId ((.canonical) declaration)     <> "\", isLeft (decode"-    <> sdName declaration+    <> (.name) declaration     <> "Mapped (Aeson.String \"__keiro_unknown\")))"  unionArmAssertion :: Agg -> StructuralDecl -> UnionEncoding -> ResolvedWireArm -> Text unionArmAssertion aggregate declaration encoding arm =   "(\"wire union arm: "-    <> unCanonicalTypeId (sdCanonical declaration)+    <> unCanonicalTypeId ((.canonical) declaration)     <> "/"-    <> rwaTag arm+    <> (.tag) arm     <> "\", any (\\(_, value) -> objectField "-    <> tshow (ueTagField encoding)+    <> tshow ((.tagField) encoding)     <> " (encode"-    <> sdName declaration+    <> (.name) declaration     <> "Mapped value) == Just (Aeson.String "-    <> tshow (rwaTag arm)+    <> tshow ((.tag) arm)     <> ") && decode"-    <> sdName declaration+    <> (.name) declaration     <> "Mapped (encode"-    <> sdName declaration+    <> (.name) declaration     <> "Mapped value) == Right value) (NonEmpty.toList (fixtureCases "-    <> renderHarnessReference aggregate (harnessQualifiedValueReference (sdFixtures declaration))+    <> renderHarnessReference aggregate (harnessQualifiedValueReference ((.fixtures) declaration))     <> ")))"  wirePolicyHelpers :: [(StructuralDecl, ResolvedMappedShape)] -> [Text]@@ -1637,23 +1637,23 @@   where     usesDelete = any hasOptionalRecordField declarations     usesObjectField = usesDelete || any isUnion declarations-    hasOptionalRecordField (_, RRecord _ _ fields) = any ((== POptional) . rwfPresence) fields+    hasOptionalRecordField (_, RRecord _ _ fields) = any ((== POptional) . (.presence)) fields     hasOptionalRecordField _ = False     isUnion (_, RUnion {}) = True     isUnion _ = False  mappedFixtures :: ResolvedMappedDecl -> QualifiedValueName-mappedFixtures (ResolvedStructural declaration _) = sdFixtures declaration-mappedFixtures (ResolvedOpaque declaration) = odFixtures declaration+mappedFixtures (ResolvedStructural declaration _) = (.fixtures) declaration+mappedFixtures (ResolvedOpaque declaration) = (.fixtures) declaration  ctorExprWithOverride :: Agg -> ResolvedCtor -> Text -> Text -> Text ctorExprWithOverride aggregate constructor target replacement =-  "(" <> rcName constructor <> " (" <> rcName constructor <> "Data" <> arguments <> "))"+  "(" <> (.name) constructor <> " (" <> (.name) constructor <> "Data" <> arguments <> "))"   where     arguments =       T.concat-        [ " " <> if fieldDslName identity == target then replacement else sampleValue aggregate (fieldDslName identity) fieldType-        | (identity, fieldType) <- rcFields constructor+        [ " " <> if (.dslName) identity == target then replacement else sampleValue aggregate ((.dslName) identity) valueType+        | (identity, valueType) <- (.fields) constructor         ]  maybeToListHarness :: Maybe value -> [value]

src/Keiro/Dsl/HaskellImport.hs view

@@ -38,10 +38,10 @@   deriving stock (Eq, Ord, Show)  data HaskellReference = HaskellReference-  { referenceModule :: !Text,-    referenceName :: !Text,-    referenceNamespace :: !HaskellNamespace,-    referenceQualification :: !QualificationPreference+  { moduleName :: !Text,+    name :: !Text,+    namespace :: !HaskellNamespace,+    qualification :: !QualificationPreference   }   deriving stock (Eq, Ord, Show) @@ -61,9 +61,9 @@   deriving stock (Eq, Show)  data HaskellImportPlan = HaskellImportPlan-  { importPlanTargetModule :: !Text,-    importPlanDeclarations :: !(Set Text),-    importPlanReferences :: !(Map HaskellReference Text)+  { targetModule :: !Text,+    declarations :: !(Set Text),+    references :: !(Map HaskellReference Text)   }  planHaskellImports :: ImportEnvironment -> Set HaskellReference -> Either HaskellImportError HaskellImportPlan@@ -74,35 +74,35 @@   plannedReferences <- Map.fromList <$> traverse (renderReference aliases) orderedReferences   pure     HaskellImportPlan-      { importPlanTargetModule = target,-        importPlanDeclarations = explicitDeclarations <> qualifiedDeclarations aliases,-        importPlanReferences = plannedReferences+      { targetModule = target,+        declarations = explicitDeclarations <> qualifiedDeclarations aliases,+        references = plannedReferences       }   where-    target = targetModule environment+    target = (.targetModule) environment     orderedReferences = Set.toAscList references     occurrenceOwners =       Map.fromListWith         (<>)-        [ (referenceName reference, Set.singleton (referenceModule reference, referenceName reference))+        [ ((.name) reference, Set.singleton ((.moduleName) reference, (.name) reference))         | reference <- orderedReferences,-          referenceNamespace reference == TypeNamespace,-          referenceQualification reference == PreferUnqualified+          (.namespace) reference == TypeNamespace,+          (.qualification) reference == PreferUnqualified         ]     unqualified reference =-      referenceNamespace reference == TypeNamespace-        && referenceQualification reference == PreferUnqualified-        && Set.notMember (referenceName reference) (localNames environment)-        && Set.notMember (referenceName reference) (reservedQualifiers environment)-        && maybe False ((== 1) . Set.size) (Map.lookup (referenceName reference) occurrenceOwners)+      (.namespace) reference == TypeNamespace+        && (.qualification) reference == PreferUnqualified+        && Set.notMember ((.name) reference) ((.localNames) environment)+        && Set.notMember ((.name) reference) ((.reservedQualifiers) environment)+        && maybe False ((== 1) . Set.size) (Map.lookup ((.name) reference) occurrenceOwners)     unqualifiedReferences = Set.filter unqualified references-    unqualifiedNames = Set.map referenceName unqualifiedReferences+    unqualifiedNames = Set.map (.name) unqualifiedReferences     qualifiedModules =-      Set.map referenceModule (references `Set.difference` unqualifiedReferences)+      Set.map (.moduleName) (references `Set.difference` unqualifiedReferences)     explicitImports =       Map.fromListWith         (<>)-        [ (referenceModule reference, Set.singleton (referenceName reference))+        [ ((.moduleName) reference, Set.singleton ((.name) reference))         | reference <- Set.toAscList unqualifiedReferences         ]     explicitDeclarations =@@ -116,20 +116,20 @@         | (moduleName, alias) <- Map.toAscList aliases         ]     renderReference aliases reference-      | Set.member reference unqualifiedReferences = pure (reference, referenceName reference)-      | otherwise = case Map.lookup (referenceModule reference) aliases of-          Nothing -> Left (ImpossibleHaskellAlias target (Set.singleton (referenceModule reference)))-          Just alias -> pure (reference, alias <> "." <> referenceName reference)+      | Set.member reference unqualifiedReferences = pure (reference, (.name) reference)+      | otherwise = case Map.lookup ((.moduleName) reference) aliases of+          Nothing -> Left (ImpossibleHaskellAlias target (Set.singleton ((.moduleName) reference)))+          Just alias -> pure (reference, alias <> "." <> (.name) reference)  renderPlannedImports :: HaskellImportPlan -> Text-renderPlannedImports = T.intercalate "\n" . Set.toAscList . importPlanDeclarations+renderPlannedImports = T.intercalate "\n" . Set.toAscList . (.declarations)  renderPlannedReference :: HaskellImportPlan -> HaskellReference -> Either HaskellImportError Text renderPlannedReference plan reference =   maybe-    (Left (MissingHaskellReference (importPlanTargetModule plan) reference))+    (Left (MissingHaskellReference ((.targetModule) plan) reference))     Right-    (Map.lookup reference (importPlanReferences plan))+    (Map.lookup reference ((.references) plan))  allocateAliases :: ImportEnvironment -> Set Text -> Set Text -> Either HaskellImportError (Map Text Text) allocateAliases environment unqualifiedNames modules = do@@ -141,7 +141,7 @@           | (moduleName, candidates) <- Map.toAscList moduleCandidates,             candidate <- candidates           ]-      occupied = reservedQualifiers environment <> localNames environment <> unqualifiedNames+      occupied = (.reservedQualifiers) environment <> (.localNames) environment <> unqualifiedNames       choose moduleName candidates =         case find (isAvailable moduleName candidateOwners occupied) candidates of           Just candidate -> candidate@@ -161,7 +161,7 @@           ]   if Set.null impossibleModules     then pure aliases-    else Left (ImpossibleHaskellAlias (targetModule environment) impossibleModules)+    else Left (ImpossibleHaskellAlias ((.targetModule) environment) impossibleModules)  isAvailable :: Text -> Map Text (Set Text) -> Set Text -> Text -> Bool isAvailable moduleName candidateOwners occupied candidate =@@ -183,13 +183,13 @@  validateReference :: Text -> HaskellReference -> Either HaskellImportError () validateReference target reference = do-  validateModuleName target (referenceModule reference)-  if referenceModule reference == target+  validateModuleName target ((.moduleName) reference)+  if (.moduleName) reference == target     then Left (HaskellSelfImport target)     else pure ()-  if validOccurrence (referenceNamespace reference) (referenceName reference)+  if validOccurrence ((.namespace) reference) ((.name) reference)     then pure ()-    else Left (InvalidHaskellOccurrence target (referenceNamespace reference) (referenceName reference))+    else Left (InvalidHaskellOccurrence target ((.namespace) reference) ((.name) reference))  validateModuleName :: Text -> Text -> Either HaskellImportError () validateModuleName target candidate

src/Keiro/Dsl/HaskellName.hs view

@@ -93,10 +93,10 @@ -- | The source declaration responsible for a generated occurrence.  The -- owner and kind form a stable identity; the line is evidence, not identity. data NameSite = NameSite-  { siteKind :: !NameSiteKind,-    siteLogicalName :: !Text,-    siteOwner :: !Text,-    siteLine :: !Int+  { kind :: !NameSiteKind,+    logicalName :: !Text,+    owner :: !Text,+    line :: !Int   }   deriving stock (Eq, Ord, Show) @@ -105,16 +105,16 @@ -- normally empty; record fields use their owning record so -- DuplicateRecordFields can keep identical selectors on different records. data HaskellOccurrenceKey = HaskellOccurrenceKey-  { occurrenceModule :: !Text,-    occurrenceSpace :: !HaskellOccurrenceSpace,-    occurrenceScope :: !Text,-    occurrenceName :: !Text+  { moduleName :: !Text,+    space :: !HaskellOccurrenceSpace,+    scope :: !Text,+    name :: !Text   }   deriving stock (Eq, Ord, Show)  data PlannedOccurrence = PlannedOccurrence-  { plannedOccurrenceKey :: !HaskellOccurrenceKey,-    plannedOccurrenceSite :: !NameSite+  { key :: !HaskellOccurrenceKey,+    site :: !NameSite   }   deriving stock (Eq, Ord, Show) @@ -129,20 +129,23 @@ data GeneratedHaskellNamingEdition   = LegacyNamingV1   | IdiomaticNamingV1+  | IdiomaticNamingV2   deriving stock (Eq, Ord, Show)  currentGeneratedHaskellNamingEdition :: GeneratedHaskellNamingEdition-currentGeneratedHaskellNamingEdition = IdiomaticNamingV1+currentGeneratedHaskellNamingEdition = IdiomaticNamingV2  renderGeneratedHaskellNamingEdition :: GeneratedHaskellNamingEdition -> Text renderGeneratedHaskellNamingEdition = \case   LegacyNamingV1 -> "legacy-v1"   IdiomaticNamingV1 -> "idiomatic-v1"+  IdiomaticNamingV2 -> "idiomatic-v2"  parseGeneratedHaskellNamingEdition :: Text -> Maybe GeneratedHaskellNamingEdition parseGeneratedHaskellNamingEdition = \case   "legacy-v1" -> Just LegacyNamingV1   "idiomatic-v1" -> Just IdiomaticNamingV1+  "idiomatic-v2" -> Just IdiomaticNamingV2   _ -> Nothing  renderUpperCamelName :: UpperCamelName -> Text@@ -162,7 +165,7 @@ -- below and are intentionally never re-cased here. deriveHaskellName :: NameSourceKind -> NameSite -> Either HaskellNameError DerivedHaskellName deriveHaskellName source site-  | source == ExplicitHaskellName = Left (InvalidExplicitHaskellName site (siteLogicalName site))+  | source == ExplicitHaskellName = Left (InvalidExplicitHaskellName site ((.logicalName) site))   | otherwise = do       words' <- segmentLogicalName (source == LogicalWireWord) site       case words' of@@ -181,7 +184,7 @@ deriveLowerHelperName :: NameSourceKind -> Text -> NameSite -> Either HaskellNameError LowerCamelName deriveLowerHelperName source suffix site = do   derived <- deriveHaskellName source site-  checkedLowerOccurrence site (renderLowerCamelName (lowerCamel derived) <> suffix)+  checkedLowerOccurrence site (renderLowerCamelName ((.lowerCamel) derived) <> suffix)  checkedModuleSegment :: NameSite -> Text -> Either HaskellNameError HaskellModuleSegment checkedModuleSegment site candidate@@ -212,16 +215,16 @@ plannedOccurrence :: Text -> HaskellOccurrenceSpace -> Text -> Text -> NameSite -> PlannedOccurrence plannedOccurrence targetModule space scope rendered site =   PlannedOccurrence-    { plannedOccurrenceKey =+    { key =         HaskellOccurrenceKey-          { occurrenceModule = T.toCaseFold targetModule,-            occurrenceSpace = space,-            occurrenceScope = T.toCaseFold scope,-            occurrenceName = case space of+          { moduleName = T.toCaseFold targetModule,+            space = space,+            scope = T.toCaseFold scope,+            name = case space of               ModuleSpace -> T.toCaseFold rendered               _ -> rendered           },-      plannedOccurrenceSite = site+      site = site     }  -- | Report deterministic collisions independently of declaration traversal@@ -238,8 +241,8 @@       Map.filter ((> 1) . Set.size) $         Map.fromListWith           Set.union-          [ (plannedOccurrenceKey occurrence, Set.singleton (plannedOccurrenceSite occurrence))-          | occurrence <- sortOn plannedOccurrenceKey occurrences+          [ ((.key) occurrence, Set.singleton ((.site) occurrence))+          | occurrence <- sortOn (.key) occurrences           ]  segmentLogicalName :: Bool -> NameSite -> Either HaskellNameError [Text]@@ -251,7 +254,7 @@   | any T.null separated = Left (EmptyNameSegment site)   | otherwise = Right (concatMap splitCamelWord separated)   where-    raw = siteLogicalName site+    raw = (.logicalName) site     badUnderscore =       T.isPrefixOf "_" raw         || T.isSuffixOf "_" raw

src/Keiro/Dsl/HaskellSourceMove.hs view

@@ -21,24 +21,24 @@ import Data.Text.Encoding qualified as TE import Data.Word (Word64, Word8) import Keiro.Dsl.HaskellName qualified as HaskellName-import Keiro.Dsl.Scaffold (ModuleKind, ModuleRole, ScaffoldModule, modulePath, moduleRole)+import Keiro.Dsl.Scaffold (ModuleKind, ModuleRole, ScaffoldModule (..), moduleRole) import Numeric (showHex)  data SourceMove = SourceMove-  { moveRole :: !ModuleRole,-    moveKind :: !ModuleKind,-    moveOldModule :: !Text,-    moveNewModule :: !Text,-    moveOldPath :: !FilePath,-    moveNewPath :: !FilePath,-    moveBackupPath :: !FilePath,+  { role :: !ModuleRole,+    kind :: !ModuleKind,+    oldModule :: !Text,+    newModule :: !Text,+    oldPath :: !FilePath,+    newPath :: !FilePath,+    backupPath :: !FilePath,     -- | Digest of the exact legacy bytes.  Planning cannot populate it because     -- it is pure and filesystem-independent; the complete migration preflight     -- hydrates it before a move is reported or applied.-    moveContentDigest :: !(Maybe Text),+    contentDigest :: !(Maybe Text),     -- | Digest of the token-aware transformed bytes, used with the durable     -- migration state to recognize an installed or prepared crash state.-    moveTransformedDigest :: !(Maybe Text)+    transformedDigest :: !(Maybe Text)   }   deriving stock (Eq, Show) @@ -58,10 +58,10 @@ planSourceMoves previous current =   case errors of     first : rest -> Left (first :| rest)-    [] -> Right (sortOn moveOldPath moves)+    [] -> Right (sortOn (.oldPath) moves)   where     currentByRole = Map.fromListWith (<>) [(moduleRole scaffoldModule, [scaffoldModule]) | scaffoldModule <- current]-    currentByModule = Map.fromListWith (<>) [(moduleNameFromPath (modulePath scaffoldModule), [scaffoldModule]) | scaffoldModule <- current]+    currentByModule = Map.fromListWith (<>) [(moduleNameFromPath ((.path) scaffoldModule), [scaffoldModule]) | scaffoldModule <- current]     planned = map pair previous     errors = [err | Left err <- planned]     moves = [move | Right (Just move) <- planned]@@ -75,28 +75,28 @@       case candidate of         Nothing -> Right Nothing         Just currentModule-          | modulePath currentModule == previousPath -> Right Nothing-          | normalizeLegacyModuleName (moduleNameFromPath previousPath) /= moduleNameFromPath (modulePath currentModule) -> Right Nothing+          | (.path) currentModule == previousPath -> Right Nothing+          | normalizeLegacyModuleName (moduleNameFromPath previousPath) /= moduleNameFromPath ((.path) currentModule) -> Right Nothing           | otherwise ->               Right . Just $                 SourceMove-                  { moveRole = moduleRole currentModule,-                    moveKind = previousKind,-                    moveOldModule = moduleNameFromPath previousPath,-                    moveNewModule = moduleNameFromPath (modulePath currentModule),-                    moveOldPath = previousPath,-                    moveNewPath = modulePath currentModule,-                    moveBackupPath = ".keiro-dsl-name-migrations/legacy-v1-to-idiomatic-v1/" <> previousPath,-                    moveContentDigest = Nothing,-                    moveTransformedDigest = Nothing+                  { role = moduleRole currentModule,+                    kind = previousKind,+                    oldModule = moduleNameFromPath previousPath,+                    newModule = moduleNameFromPath ((.path) currentModule),+                    oldPath = previousPath,+                    newPath = (.path) currentModule,+                    backupPath = ".keiro-dsl-name-migrations/legacy-v1-to-idiomatic-v1/" <> previousPath,+                    contentDigest = Nothing,+                    transformedDigest = Nothing                   }      uniqueRole _ [] = Right Nothing     uniqueRole _ [candidate] = Right (Just candidate)-    uniqueRole role candidates = Left (AmbiguousModuleRole role (map modulePath candidates))+    uniqueRole role candidates = Left (AmbiguousModuleRole role (map (.path) candidates))     uniqueLegacy _ [] = Right Nothing     uniqueLegacy _ [candidate] = Right (Just candidate)-    uniqueLegacy path candidates = Left (AmbiguousLegacyModule path (map modulePath candidates))+    uniqueLegacy path candidates = Left (AmbiguousLegacyModule path (map (.path) candidates))  moduleNameFromPath :: FilePath -> Text moduleNameFromPath = T.replace "/" "." . T.dropEnd 3 . T.pack@@ -106,15 +106,15 @@   where     normalizeSegment segment =       case HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site of-        Right derived -> HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)+        Right derived -> HaskellName.renderUpperCamelName ((.upperCamel) derived)         Left _ -> segment       where         site =           HaskellName.NameSite-            { HaskellName.siteKind = HaskellName.NodeModuleSite,-              HaskellName.siteLogicalName = segment,-              HaskellName.siteOwner = "legacy-module-segment",-              HaskellName.siteLine = 0+            { HaskellName.kind = HaskellName.NodeModuleSite,+              HaskellName.logicalName = segment,+              HaskellName.owner = "legacy-module-segment",+              HaskellName.line = 0             }  data LexState

src/Keiro/Dsl/IdDomain.hs view

@@ -20,14 +20,14 @@ 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, checkedLanguageContract, checkedSpec, effectiveRuntimeProfile)+import Keiro.Dsl.SemanticContract (CheckedService, EffectiveLanguageContract (..), checkedLanguageContract, checkedSpec)  -- | Versions 1 and 2 intentionally return 'Nothing': their generated IDs -- admitted arbitrary text. Runtime-semantics generation 2 is the first -- enforcing contract. idDomainContractFor :: EffectiveLanguageContract -> Text -> Maybe IdDomainContract idDomainContractFor languageContract prefix-  | runtimeProfileHasCapability (effectiveRuntimeProfile languageContract) GeneratedIdDomainTypeIdV7 =+  | runtimeProfileHasCapability ((.runtimeProfile) languageContract) GeneratedIdDomainTypeIdV7 =       Just (typeIdV7Domain prefix)   | otherwise = Nothing @@ -35,7 +35,7 @@ -- in runtime semantics 3. Aggregate IDs retain the independent selector above. contractIdDomainContractFor :: EffectiveLanguageContract -> Text -> Maybe IdDomainContract contractIdDomainContractFor languageContract prefix-  | runtimeProfileHasCapability (effectiveRuntimeProfile languageContract) ContractIdDomainTypeIdV7 = Just (typeIdV7Domain prefix)+  | runtimeProfileHasCapability ((.runtimeProfile) languageContract) ContractIdDomainTypeIdV7 = Just (typeIdV7Domain prefix)   | otherwise = Nothing  -- | Durable identity for the runtime admission domain of one declaration.@@ -60,15 +60,15 @@     spec = checkedSpec service     languageContract = checkedLanguageContract service     aggregateIdentities =-      [ idDomainIdentity (idName declaration) contract-      | declaration <- specIds spec,-        Just contract <- [idDomainContractFor languageContract (idPrefix declaration)]+      [ idDomainIdentity ((.name) declaration) contract+      | declaration <- (.ids) spec,+        Just contract <- [idDomainContractFor languageContract ((.prefix) declaration)]       ]     contractIdentities =-      [ idDomainIdentity ("contract:" <> ctrName contractNode <> "." <> ceName event <> "." <> cfName field) contract-      | NContract contractNode <- specNodes spec,-        event <- ctrEvents contractNode,-        field <- ceFields event,-        CTypeId prefix <- [cfType field],+      [ idDomainIdentity ("contract:" <> (.name) contractNode <> "." <> (.name) event <> "." <> (.name) field) contract+      | NContract contractNode <- (.nodes) spec,+        event <- (.events) contractNode,+        field <- (.fields) event,+        CTypeId prefix <- [(.valueType) field],         Just contract <- [contractIdDomainContractFor languageContract prefix]       ]

src/Keiro/Dsl/LanguageVersion.hs view

@@ -117,16 +117,16 @@ -- Constructors stay private so a released profile can only be selected from -- the authoritative registry rather than widened ad hoc by parser callers. data SyntaxProfile = SyntaxProfile-  { profileIdentifier :: !Text,-    profileFeatures :: !(Set LanguageFeature)+  { identifier :: !Text,+    features :: !(Set LanguageFeature)   }   deriving stock (Eq, Show, Generic)  syntaxProfileIdentifier :: SyntaxProfile -> Text-syntaxProfileIdentifier SyntaxProfile {profileIdentifier} = profileIdentifier+syntaxProfileIdentifier SyntaxProfile {identifier} = identifier  syntaxProfileSupportsFeature :: SyntaxProfile -> LanguageFeature -> Bool-syntaxProfileSupportsFeature SyntaxProfile {profileFeatures} feature = Set.member feature profileFeatures+syntaxProfileSupportsFeature SyntaxProfile {features} feature = Set.member feature features  -- | One independently selectable runtime behavior in a registered language -- contract. Constructors shipped in a release are append-only; the active@@ -147,17 +147,17 @@ -- constructor stays private so callers select only an authoritative registry -- profile rather than widening runtime behavior ad hoc. data RuntimeSemanticsProfile = RuntimeSemanticsProfile-  { runtimeSemanticsIdentifier :: !Text,-    runtimeSemanticsCapabilities :: !(Set RuntimeCapability)+  { identifier :: !Text,+    capabilities :: !(Set RuntimeCapability)   }   deriving stock (Eq, Ord, Show, Generic)  runtimeProfileIdentifier :: RuntimeSemanticsProfile -> Text-runtimeProfileIdentifier RuntimeSemanticsProfile {runtimeSemanticsIdentifier} = runtimeSemanticsIdentifier+runtimeProfileIdentifier RuntimeSemanticsProfile {identifier} = identifier  runtimeProfileHasCapability :: RuntimeSemanticsProfile -> RuntimeCapability -> Bool-runtimeProfileHasCapability RuntimeSemanticsProfile {runtimeSemanticsCapabilities} capability =-  Set.member capability runtimeSemanticsCapabilities+runtimeProfileHasCapability RuntimeSemanticsProfile {capabilities} capability =+  Set.member capability capabilities  -- | Optional replay-fold identity contributed by one capability.  Duplicate -- tokens intentionally collapse at the profile boundary so the two coupled@@ -172,11 +172,11 @@ capabilityFoldSegment SeparatedProjectionQueryPolicy = Nothing  runtimeProfileFoldSegments :: RuntimeSemanticsProfile -> [Text]-runtimeProfileFoldSegments RuntimeSemanticsProfile {runtimeSemanticsCapabilities} =+runtimeProfileFoldSegments RuntimeSemanticsProfile {capabilities} =   Set.toAscList     ( Set.fromList         [ segment-        | capability <- Set.toAscList runtimeSemanticsCapabilities,+        | capability <- Set.toAscList capabilities,           Just segment <- [capabilityFoldSegment capability]         ]     )@@ -205,22 +205,22 @@ -- | 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),+  { version :: !LanguageVersion,+    predecessor :: !(Maybe LanguageVersion),     -- | Compatibility projection retained for the 0.7 public API. Parser     -- dispatch uses 'definitionSyntaxProfile', never this historical tag.-    definitionBodyParser :: !LanguageBodyParser,-    definitionSyntaxProfile :: !SyntaxProfile,-    definitionRuntimeSemanticsProfile :: !RuntimeSemanticsProfile,-    definitionSupport :: !LanguageSupport,-    definitionMaturity :: !LanguageMaturity+    bodyParser :: !LanguageBodyParser,+    syntaxProfile :: !SyntaxProfile,+    runtimeSemanticsProfile :: !RuntimeSemanticsProfile,+    support :: !LanguageSupport,+    maturity :: !LanguageMaturity   }   deriving stock (Eq, Show, Generic)  -- | Stable compatibility projection used by serialized records and diagnostic -- text.  Runtime behavior must query 'definitionRuntimeSemanticsProfile'. definitionRuntimeSemantics :: LanguageDefinition -> Text-definitionRuntimeSemantics = runtimeProfileIdentifier . definitionRuntimeSemanticsProfile+definitionRuntimeSemantics = runtimeProfileIdentifier . (.runtimeSemanticsProfile)  version1 :: LanguageVersion version1 = LanguageVersion 1@@ -269,7 +269,7 @@     "keiro-dsl/syntax-profile/3"     ( Set.insert         FieldAliasSyntax-        (profileFeatures profileV2)+        ((.features) profileV2)     )  profileV4 :: SyntaxProfile@@ -284,7 +284,7 @@                 DomainCommandOutcomeSyntax                 ( Set.insert                     MappedConsumerSurfaceSyntax-                    (Set.insert ExternalReadContractSyntax (Set.insert ProjectionCatalogSyntax (profileFeatures profileV3)))+                    (Set.insert ExternalReadContractSyntax (Set.insert ProjectionCatalogSyntax ((.features) profileV3)))                 )             )         )@@ -320,17 +320,17 @@     "keiro-dsl/runtime-semantics/4"     ( Set.insert         SeparatedProjectionQueryPolicy-        (Set.insert TypedDomainCommandOutcomes (Set.insert ProjectionCatalogRuntime (runtimeSemanticsCapabilities runtimeProfileV3)))+        (Set.insert TypedDomainCommandOutcomes (Set.insert ProjectionCatalogRuntime ((.capabilities) runtimeProfileV3)))     )  -- | Supported versions, derived from 'languageRegistry'. supportedLanguageVersions :: NonEmpty LanguageVersion-supportedLanguageVersions = definitionVersion <$> languageRegistry+supportedLanguageVersions = (.version) <$> languageRegistry  -- | The one published registry entry recommended for stable sources. currentStableLanguageVersion :: LanguageVersion currentStableLanguageVersion =-  case [definitionVersion definition | definition <- NE.toList languageRegistry, definitionSupport definition == Stable] of+  case [(.version) definition | definition <- NE.toList languageRegistry, (.support) definition == Stable] of     [version] -> version     _ -> error "keiro-dsl internal invariant: language registry must contain exactly one stable version" @@ -339,17 +339,17 @@ -- published; otherwise authoring falls back to the published stable contract. currentAuthoringLanguageVersion :: LanguageVersion currentAuthoringLanguageVersion =-  case [definitionVersion definition | definition <- NE.toList languageRegistry, definitionMaturity definition == CandidateLanguage] of+  case [(.version) definition | definition <- NE.toList languageRegistry, (.maturity) 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+languageSupportForVersion version = (.support) <$> lookupLanguageDefinition version  lookupLanguageDefinition :: LanguageVersion -> Maybe LanguageDefinition lookupLanguageDefinition version =-  find ((== version) . definitionVersion) (NE.toList languageRegistry)+  find ((== version) . (.version)) (NE.toList languageRegistry)  -- | Grammar-owned syntax introduced after the frozen version-1 contract. -- Keeping these gates beside the released-language registry prevents the@@ -371,20 +371,20 @@ -- | The first released contract that owns each grammar feature. languageFeatureMinimumVersion :: LanguageFeature -> LanguageVersion languageFeatureMinimumVersion feature =-  case find (\definition -> syntaxProfileSupportsFeature (definitionSyntaxProfile definition) feature) (NE.toList languageRegistry) of-    Just definition -> definitionVersion definition+  case find (\definition -> syntaxProfileSupportsFeature ((.syntaxProfile) definition) feature) (NE.toList languageRegistry) of+    Just definition -> (.version) definition     Nothing -> error "keiro-dsl internal invariant: a released language feature has no owning profile"  languageVersionsSupportingFeature :: LanguageFeature -> [LanguageVersion] languageVersionsSupportingFeature feature =-  [ definitionVersion definition+  [ (.version) definition   | definition <- NE.toList languageRegistry,-    syntaxProfileSupportsFeature (definitionSyntaxProfile definition) feature+    syntaxProfileSupportsFeature ((.syntaxProfile) definition) feature   ]  languageSupportsFeature :: LanguageVersion -> LanguageFeature -> Bool languageSupportsFeature version feature =-  maybe False (\definition -> syntaxProfileSupportsFeature (definitionSyntaxProfile definition) feature) (lookupLanguageDefinition version)+  maybe False (\definition -> syntaxProfileSupportsFeature ((.syntaxProfile) definition) feature) (lookupLanguageDefinition version)  effectiveLanguageVersion :: SourceLanguage -> LanguageVersion effectiveLanguageVersion LegacyUnversioned = version1@@ -428,18 +428,18 @@  -- | A source-selection failure with the original member-local source line. data SourceLanguageDiagnostic = SourceLanguageDiagnostic-  { sourceLanguageErrorCode :: !SourceLanguageErrorCode,-    sourceLanguageSource :: !FilePath,-    sourceLanguageLoc :: !Loc,-    sourceLanguageToken :: !(Maybe Text),-    sourceLanguageDeclaredVersion :: !(Maybe LanguageVersion),-    sourceLanguageSupportedVersions :: !(NonEmpty LanguageVersion)+  { errorCode :: !SourceLanguageErrorCode,+    source :: !FilePath,+    loc :: !Loc,+    token :: !(Maybe Text),+    declaredVersion :: !(Maybe LanguageVersion),+    supportedVersions :: !(NonEmpty LanguageVersion)   }   deriving stock (Eq, Show)  renderSourceLanguageDiagnostic :: SourceLanguageDiagnostic -> Text renderSourceLanguageDiagnostic diagnostic =-  T.pack (sourceLanguageSource diagnostic)+  T.pack ((.source) diagnostic)     <> ":"     <> T.pack (show line)     <> ":1: error ["@@ -447,15 +447,15 @@     <> "]: "     <> sourceLanguageDiagnosticMessage diagnostic   where-    Loc line = sourceLanguageLoc diagnostic-    code = sourceLanguageErrorCode diagnostic+    Loc line = (.loc) diagnostic+    code = (.errorCode) diagnostic  sourceLanguageDiagnosticMessage :: SourceLanguageDiagnostic -> Text sourceLanguageDiagnosticMessage diagnostic = detail   where-    code = sourceLanguageErrorCode diagnostic-    supported = T.intercalate ", " (map languageVersionText (NE.toList (sourceLanguageSupportedVersions diagnostic)))-    token = maybe "<missing>" id (sourceLanguageToken diagnostic)+    code = (.errorCode) diagnostic+    supported = T.intercalate ", " (map languageVersionText (NE.toList ((.supportedVersions) diagnostic)))+    token = maybe "<missing>" id ((.token) diagnostic)     detail = case code of       InvalidLanguageVersion ->         "invalid language preamble; expected `language keiro-dsl <positive-decimal>`, found `"@@ -463,7 +463,7 @@           <> "`"       UnsupportedLanguageVersion ->         "declared keiro-dsl language version "-          <> maybe token languageVersionText (sourceLanguageDeclaredVersion diagnostic)+          <> maybe token languageVersionText ((.declaredVersion) diagnostic)           <> " is unsupported; supported versions: "           <> supported       DuplicateLanguagePreamble ->@@ -474,34 +474,34 @@         "selected syntax requires keiro-dsl language version "           <> languageVersionText requiredVersion           <> "; selected version "-          <> maybe token languageVersionText (sourceLanguageDeclaredVersion diagnostic)+          <> maybe token languageVersionText ((.declaredVersion) diagnostic)         where           requiredVersion =             case reverse publishedCompatibilityVersions of               latestCompatibility : _ -> latestCompatibility               [] -> case reverse publishedVersions of                 latestPublished : _ -> latestPublished-                [] -> NE.last (sourceLanguageSupportedVersions diagnostic)+                [] -> NE.last ((.supportedVersions) diagnostic)           supportedDefinitions =             [ (version, definition)-            | version <- NE.toList (sourceLanguageSupportedVersions diagnostic),+            | version <- NE.toList ((.supportedVersions) diagnostic),               Just definition <- [lookupLanguageDefinition version]             ]           publishedVersions =-            [version | (version, definition) <- supportedDefinitions, definitionMaturity definition == PublishedLanguage]+            [version | (version, definition) <- supportedDefinitions, (.maturity) 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+              (.maturity) definition == PublishedLanguage,+              (.support) definition == CompatibilityOnly             ]  -- | A parsed document with its source declaration preserved beside its graph. data ParsedSource = ParsedSource-  { parsedSourceLanguage :: !SourceLanguage,-    parsedSpec :: !Spec+  { sourceLanguage :: !SourceLanguage,+    spec :: !Spec   }   deriving stock (Eq, Show)

src/Keiro/Dsl/Manifest.hs view

@@ -89,7 +89,7 @@       ++ consumerBlocks   where     plan = consumerPlanForService service-    moduleNames = sort (map (moduleNameOf . modulePath) mods)+    moduleNames = sort (map (moduleNameOf . (.path)) mods)     otherModules = case facadeModule of       Nothing -> moduleNames       Just facade -> filter (/= facade) moduleNames@@ -97,16 +97,16 @@       Nothing -> []       Just facade -> ["", "exposed-modules:", "    " <> facade]     consumerBlocks-      | null (consumerMappings plan) = []+      | null ((.mappings) plan) = []       | otherwise =           [ "",             "consumer-packages:"           ]-            ++ map ("    " <>) (consumerPackages plan)+            ++ map ("    " <>) ((.packages) plan)             ++ [ "",                  "consumer-modules:"                ]-            ++ map ("    " <>) (consumerModules plan)+            ++ map ("    " <>) ((.modules) plan)  -- | The dotted module name recovered from a 'ScaffoldModule' path: drop the -- trailing @.hs@ and replace @/@ with @.@.@@ -120,7 +120,7 @@  manifestDependenciesForService :: CheckedService -> [Text] manifestDependenciesForService service =-  sort (nub ("base" : consumerPackages (consumerPlanForService service) <> concatMap (depsForNode service) (specNodes spec)))+  sort (nub ("base" : (.packages) (consumerPlanForService service) <> concatMap (depsForNode service) ((.nodes) spec)))   where     spec = checkedSpec service @@ -149,9 +149,9 @@     hasTypedContractId contract =       or         [ contractIdDomainContractFor (checkedLanguageContract service) prefix /= Nothing-        | event <- ctrEvents contract,-          field <- ceFields event,-          CTypeId prefix <- [cfType field]+        | event <- (.events) contract,+          field <- (.fields) event,+          CTypeId prefix <- [(.valueType) field]         ]  workqueueDependencies :: WorkqueueNode -> [Text]@@ -159,7 +159,7 @@   ["containers" | any (typeExprUses isMap) expressions]     <> ["time" | any (typeExprUses isTime) expressions]   where-    expressions = [expression | field <- wqPayload workqueue, TypedQueueExpression expression <- [wqfType field]]+    expressions = [expression | field <- (.payload) workqueue, TypedQueueExpression expression <- [(.valueType) field]]     isMap (TMap _) = True     isMap _ = False     isTime TTime = True@@ -178,9 +178,9 @@     <> ["containers" | any (typeExprUses isMap) expressions]     <> ["time" | any (typeExprUses isTime) expressions]   where-    expressions = case queryTypes readModel of+    expressions = case (.queryTypes) readModel of       Nothing -> []-      Just queryPair -> [input queryPair, result queryPair]+      Just queryPair -> [(.input) queryPair, (.result) queryPair]     isJson TJson = True     isJson _ = False     isMap TMap {} = True@@ -205,8 +205,8 @@         <> Set.fromList           [ "mmzk-typeid"           | AggregateNominal nominal <- resolvedTypes,-            IdRepresentation {} <- [resolvedNominalRepresentation nominal],-            ConsumerNominal {} <- [resolvedNominalOwnership nominal]+            IdRepresentation {} <- [(.representation) nominal],+            ConsumerNominal {} <- [(.ownership) nominal]           ]     )   where@@ -214,17 +214,17 @@     symbols = aggregateSymbolsFromGraphResult (checkedTypeGraph service) spec     resolvedTypes =       [ resolvedType-      | register <- aggRegs aggregate,-        Right resolvedType <- [resolveAggregateType symbols (regLoc register) RegisterUse (regType register)]+      | register <- (.regs) aggregate,+        Right resolvedType <- [resolveAggregateType symbols ((.loc) register) RegisterUse ((.valueType) register)]       ]         <> [ resolvedType-           | command <- aggCommands aggregate,-             field <- cmdFields command,+           | command <- (.commands) aggregate,+             field <- (.fields) command,              Right resolvedType <- [inferAggregateFieldType symbols aggregate CommandFieldUse field]            ]         <> [ resolvedType-           | event <- aggEvents aggregate,-             EventFields fields <- [evBody event],+           | event <- (.events) aggregate,+             EventFields fields <- [(.body) event],              field <- fields,              Right resolvedType <- [inferAggregateFieldType symbols aggregate EventFieldUse field]            ]

src/Keiro/Dsl/MappedCodecPlan.hs view

@@ -69,7 +69,7 @@           onOptional = id,           onList = id,           onMap = id,-          onRef = \key -> case Map.lookup key (tgDeclarations graph) of+          onRef = \key -> case Map.lookup key ((.declarations) graph) of             Just ResolvedStructural {} -> Set.singleton (StructuralAuthority key)             Just ResolvedOpaque {} -> Set.singleton (OpaqueAuthority key)             Nothing -> Set.empty@@ -91,13 +91,13 @@         onMap = \encode candidate -> "toJSON (Map.map (\\item -> " <> encode "item" <> ") (" <> candidate <> "))",         onRef = encodeReference       }-    (resolvedExpression plan)+    ((.resolvedExpression) plan)     value   where     primitive candidate = "toJSON (" <> candidate <> ")"-    encodeReference key candidate = case Map.lookup key (tgDeclarations graph) of+    encodeReference key candidate = case Map.lookup key ((.declarations) graph) of       Just (ResolvedStructural declaration _) ->-        "encode" <> sdName declaration <> suffix <> argument candidate+        "encode" <> (.name) declaration <> suffix <> argument candidate       Just ResolvedOpaque {} -> case boundary of         ConsumerValueBoundary -> "toJSON " <> candidate         StructuralShapeBoundary -> primitive candidate@@ -125,10 +125,10 @@         onMap = \decode -> "\\value -> (parseJSON value :: Parser (Map Text Value)) >>= traverse (" <> decode <> ")",         onRef = parseReference       }-    (resolvedExpression plan)+    ((.resolvedExpression) plan)   where-    parseReference key = case Map.lookup key (tgDeclarations graph) of-      Just (ResolvedStructural declaration _) -> "parse" <> sdName declaration <> suffix+    parseReference key = case Map.lookup key ((.declarations) graph) of+      Just (ResolvedStructural declaration _) -> "parse" <> (.name) declaration <> suffix       Just ResolvedOpaque {} -> "parseJSON"       Nothing -> "parseJSON"     suffix = case boundary of

src/Keiro/Dsl/MappedConsumer.hs view

@@ -22,84 +22,84 @@ import Keiro.Dsl.TypeGraph  data ConsumerPlan = ConsumerPlan-  { consumerPackages :: ![Text],-    consumerModules :: ![Text],-    consumerMappings :: ![MappingIdentity]+  { packages :: ![Text],+    modules :: ![Text],+    mappings :: ![MappingIdentity]   }   deriving stock (Eq, Show)  data MappingIdentity   = StructuralMapping-      { mappingSpecName :: !Text,-        mappingCanonicalType :: !Text,-        mappingPackage :: !Text,-        mappingModule :: !Text,-        mappingType :: !Text,-        mappingBindingSymbol :: !Text,-        mappingBindingVersion :: !Text+      { specName :: !Text,+        canonicalType :: !Text,+        package :: !Text,+        moduleName :: !Text,+        valueType :: !Text,+        bindingSymbol :: !Text,+        bindingVersion :: !Text       }   | OpaqueMapping-      { mappingSpecName :: !Text,-        mappingPackage :: !Text,-        mappingModule :: !Text,-        mappingType :: !Text,-        mappingCodecIdentity :: !Text,-        mappingCodecVersion :: !Text+      { specName :: !Text,+        package :: !Text,+        moduleName :: !Text,+        valueType :: !Text,+        codecIdentity :: !Text,+        codecVersion :: !Text       }   | NominalMapping-      { mappingSpecName :: !Text,-        mappingNominalCategory :: !Text,-        mappingNominalRepresentation :: !Text,-        mappingCanonicalType :: !Text,-        mappingPackage :: !Text,-        mappingModule :: !Text,-        mappingType :: !Text,-        mappingBindingSymbol :: !Text,-        mappingBindingVersion :: !Text,-        mappingFixtureSymbol :: !Text,-        mappingInitialSymbol :: !(Maybe Text)+      { specName :: !Text,+        nominalCategory :: !Text,+        nominalRepresentation :: !Text,+        canonicalType :: !Text,+        package :: !Text,+        moduleName :: !Text,+        valueType :: !Text,+        bindingSymbol :: !Text,+        bindingVersion :: !Text,+        fixtureSymbol :: !Text,+        initialSymbol :: !(Maybe Text)       }   deriving stock (Eq, Show)  instance ToJSON MappingIdentity where-  toJSON StructuralMapping {mappingSpecName, mappingCanonicalType, mappingPackage, mappingModule, mappingType, mappingBindingSymbol, mappingBindingVersion} =+  toJSON StructuralMapping {specName, canonicalType, package, moduleName, valueType, bindingSymbol, bindingVersion} =     object       [ "schema" .= (1 :: Int),         "mode" .= ("structural" :: Text),-        "specName" .= mappingSpecName,-        "canonicalType" .= mappingCanonicalType,-        "package" .= mappingPackage,-        "module" .= mappingModule,-        "type" .= mappingType,-        "bindingSymbol" .= mappingBindingSymbol,-        "bindingVersion" .= mappingBindingVersion+        "specName" .= specName,+        "canonicalType" .= canonicalType,+        "package" .= package,+        "module" .= moduleName,+        "type" .= valueType,+        "bindingSymbol" .= bindingSymbol,+        "bindingVersion" .= bindingVersion       ]-  toJSON OpaqueMapping {mappingSpecName, mappingPackage, mappingModule, mappingType, mappingCodecIdentity, mappingCodecVersion} =+  toJSON OpaqueMapping {specName, package, moduleName, valueType, codecIdentity, codecVersion} =     object       [ "schema" .= (1 :: Int),         "mode" .= ("opaque" :: Text),-        "specName" .= mappingSpecName,-        "package" .= mappingPackage,-        "module" .= mappingModule,-        "type" .= mappingType,-        "codecIdentity" .= mappingCodecIdentity,-        "codecVersion" .= mappingCodecVersion+        "specName" .= specName,+        "package" .= package,+        "module" .= moduleName,+        "type" .= valueType,+        "codecIdentity" .= codecIdentity,+        "codecVersion" .= codecVersion       ]-  toJSON NominalMapping {mappingSpecName, mappingNominalCategory, mappingNominalRepresentation, mappingCanonicalType, mappingPackage, mappingModule, mappingType, mappingBindingSymbol, mappingBindingVersion, mappingFixtureSymbol, mappingInitialSymbol} =+  toJSON NominalMapping {specName, nominalCategory = resolvedNominalCategory, nominalRepresentation, canonicalType, package, moduleName, valueType, bindingSymbol, bindingVersion, fixtureSymbol, initialSymbol} =     object       [ "schema" .= (1 :: Int),         "mode" .= ("nominal" :: Text),-        "specName" .= mappingSpecName,-        "category" .= mappingNominalCategory,-        "representation" .= mappingNominalRepresentation,-        "canonicalType" .= mappingCanonicalType,-        "package" .= mappingPackage,-        "module" .= mappingModule,-        "type" .= mappingType,-        "bindingSymbol" .= mappingBindingSymbol,-        "bindingVersion" .= mappingBindingVersion,-        "fixtureSymbol" .= mappingFixtureSymbol,-        "initialSymbol" .= mappingInitialSymbol+        "specName" .= specName,+        "category" .= resolvedNominalCategory,+        "representation" .= nominalRepresentation,+        "canonicalType" .= canonicalType,+        "package" .= package,+        "module" .= moduleName,+        "type" .= valueType,+        "bindingSymbol" .= bindingSymbol,+        "bindingVersion" .= bindingVersion,+        "fixtureSymbol" .= fixtureSymbol,+        "initialSymbol" .= initialSymbol       ]  instance FromJSON MappingIdentity where@@ -149,93 +149,93 @@ consumerPlanForService service = case (checkedTypeGraph service, resolveNominalTypes spec) of   (Right graph, Right nominalRegistry) ->     ConsumerPlan-      { consumerPackages = uniqueSorted ([hsPackage (mappedSource declaration) | declaration <- declarations] <> map nominalPackage nominalBindings),-        consumerModules = uniqueSorted (concatMap mappedModules declarations <> concatMap nominalModules nominalBindings),-        consumerMappings = sortMappings (map mappingIdentity declarations <> map nominalMappingIdentity nominalBindings)+      { packages = uniqueSorted ([(.package) (mappedSource declaration) | declaration <- declarations] <> map nominalPackage nominalBindings),+        modules = uniqueSorted (concatMap mappedModules declarations <> concatMap nominalModules nominalBindings),+        mappings = sortMappings (map mappingIdentity declarations <> map nominalMappingIdentity nominalBindings)       }     where-      declarations = Map.elems (tgDeclarations graph)+      declarations = Map.elems ((.declarations) graph)       nominalBindings =         [ (nominal, binding)         | nominal <- Map.elems (nominalTypes nominalRegistry),-          ConsumerNominal binding <- [resolvedNominalOwnership nominal]+          ConsumerNominal binding <- [(.ownership) nominal]         ]   _ -> ConsumerPlan [] [] []   where     spec = checkedSpec service  mappedSource :: ResolvedMappedDecl -> HaskellSource-mappedSource (ResolvedStructural declaration _) = sdHaskell declaration-mappedSource (ResolvedOpaque declaration) = odHaskell declaration+mappedSource (ResolvedStructural declaration _) = (.haskell) declaration+mappedSource (ResolvedOpaque declaration) = (.haskell) declaration  mappedModules :: ResolvedMappedDecl -> [Text] mappedModules (ResolvedStructural declaration _) =-  hsModule (sdHaskell declaration)-    : qualifiedModule (sdBinding declaration)-    : qualifiedModule (sdFixtures declaration)-    : maybe [] (pure . qualifiedModule) (sdInitial declaration)+  (.moduleName) ((.haskell) declaration)+    : qualifiedModule ((.binding) declaration)+    : qualifiedModule ((.fixtures) declaration)+    : maybe [] (pure . qualifiedModule) ((.initial) declaration) mappedModules (ResolvedOpaque declaration) =-  hsModule (odHaskell declaration)-    : qualifiedModule (odFixtures declaration)-    : maybe [] (pure . qualifiedModule) (odInitial declaration)+  (.moduleName) ((.haskell) declaration)+    : qualifiedModule ((.fixtures) declaration)+    : maybe [] (pure . qualifiedModule) ((.initial) declaration)  mappingIdentity :: ResolvedMappedDecl -> MappingIdentity mappingIdentity (ResolvedStructural declaration _) =   StructuralMapping-    { mappingSpecName = sdName declaration,-      mappingCanonicalType = unCanonicalTypeId (sdCanonical declaration),-      mappingPackage = hsPackage (sdHaskell declaration),-      mappingModule = hsModule (sdHaskell declaration),-      mappingType = hsType (sdHaskell declaration),-      mappingBindingSymbol = unQualifiedValueName (sdBinding declaration),-      mappingBindingVersion = unBindingVersion (sdBindingVersion declaration)+    { specName = (.name) declaration,+      canonicalType = unCanonicalTypeId ((.canonical) declaration),+      package = (.package) ((.haskell) declaration),+      moduleName = (.moduleName) ((.haskell) declaration),+      valueType = (.valueType) ((.haskell) declaration),+      bindingSymbol = unQualifiedValueName ((.binding) declaration),+      bindingVersion = unBindingVersion ((.bindingVersion) declaration)     } mappingIdentity (ResolvedOpaque declaration) =   OpaqueMapping-    { mappingSpecName = odName declaration,-      mappingPackage = hsPackage (odHaskell declaration),-      mappingModule = hsModule (odHaskell declaration),-      mappingType = hsType (odHaskell declaration),-      mappingCodecIdentity = unCodecIdentity (odCodecIdentity declaration),-      mappingCodecVersion = unCodecVersion (odCodecVersion declaration)+    { specName = (.name) declaration,+      package = (.package) ((.haskell) declaration),+      moduleName = (.moduleName) ((.haskell) declaration),+      valueType = (.valueType) ((.haskell) declaration),+      codecIdentity = unCodecIdentity ((.codecIdentity) declaration),+      codecVersion = unCodecVersion ((.codecVersion) declaration)     }  nominalMappingIdentity :: (ResolvedNominalType, ConsumerNominalBinding) -> MappingIdentity nominalMappingIdentity (nominal, binding) =   NominalMapping-    { mappingSpecName = resolvedNominalName nominal,-      mappingNominalCategory = nominalCategory nominal,-      mappingNominalRepresentation = nominalRepresentationIdentity nominal,-      mappingCanonicalType = unCanonicalTypeId (consumerNominalCanonical binding),-      mappingPackage = hsPackage source,-      mappingModule = hsModule source,-      mappingType = hsType source,-      mappingBindingSymbol = unQualifiedValueName (consumerNominalBinding binding),-      mappingBindingVersion = unBindingVersion (consumerNominalBindingVersion binding),-      mappingFixtureSymbol = unQualifiedValueName (consumerNominalFixtures binding),-      mappingInitialSymbol = unQualifiedValueName <$> consumerNominalInitial binding+    { specName = (.name) nominal,+      nominalCategory = nominalCategory nominal,+      nominalRepresentation = nominalRepresentationIdentity nominal,+      canonicalType = unCanonicalTypeId ((.canonical) binding),+      package = (.package) source,+      moduleName = (.moduleName) source,+      valueType = (.valueType) source,+      bindingSymbol = unQualifiedValueName ((.binding) binding),+      bindingVersion = unBindingVersion ((.bindingVersion) binding),+      fixtureSymbol = unQualifiedValueName ((.fixtures) binding),+      initialSymbol = unQualifiedValueName <$> (.initial) binding     }   where-    source = consumerNominalHaskell binding+    source = (.haskell) binding  nominalPackage :: (ResolvedNominalType, ConsumerNominalBinding) -> Text-nominalPackage (_, binding) = hsPackage (consumerNominalHaskell binding)+nominalPackage (_, binding) = (.package) ((.haskell) binding)  nominalModules :: (ResolvedNominalType, ConsumerNominalBinding) -> [Text] nominalModules (_, binding) =-  hsModule (consumerNominalHaskell binding)-    : qualifiedModule (consumerNominalBinding binding)-    : qualifiedModule (consumerNominalFixtures binding)-    : maybe [] (pure . qualifiedModule) (consumerNominalInitial binding)+  (.moduleName) ((.haskell) binding)+    : qualifiedModule ((.binding) binding)+    : qualifiedModule ((.fixtures) binding)+    : maybe [] (pure . qualifiedModule) ((.initial) binding)  nominalCategory :: ResolvedNominalType -> Text-nominalCategory nominal = case resolvedNominalRepresentation nominal of+nominalCategory nominal = case (.representation) nominal of   IdRepresentation {} -> "id"   EnumRepresentation {} -> "enum"   ScalarRepresentation {} -> "scalar"  nominalRepresentationIdentity :: ResolvedNominalType -> Text-nominalRepresentationIdentity nominal = case resolvedNominalRepresentation nominal of+nominalRepresentationIdentity nominal = case (.representation) nominal of   IdRepresentation prefix -> "KindID:" <> prefix   EnumRepresentation constructors ->     "enum:" <> T.intercalate "," [constructor <> "=" <> wire | (constructor, wire) <- NE.toList constructors]@@ -255,9 +255,9 @@     sortOnName [] = []     sortOnName mappings =       [ mapping-      | name <- sort (map mappingSpecName mappings),+      | name <- sort (map (.specName) mappings),         mapping <- mappings,-        mappingSpecName mapping == name+        (.specName) mapping == name       ]  uniqueSorted :: [Text] -> [Text]

src/Keiro/Dsl/MappedDiff.hs view

@@ -25,12 +25,12 @@ import Keiro.Dsl.Validate (DiagnosticCode (..))  data MappedFinding = MappedFinding-  { mfDeclaration :: !Name,-    mfLeaf :: !Text,-    mfCode :: !DiagnosticCode,-    mfDetail :: !Text,-    mfUsePaths :: ![UsePath],-    mfOldUnknownFields :: !(Maybe UnknownFields)+  { declaration :: !Name,+    leaf :: !Text,+    code :: !DiagnosticCode,+    detail :: !Text,+    usePaths :: ![UsePath],+    oldUnknownFields :: !(Maybe UnknownFields)   }   deriving stock (Eq, Show) @@ -44,8 +44,8 @@       ++ map (addedDeclaration newGraph) added       ++ map (removedDeclaration oldGraph) removed     where-      oldDeclarations = tgDeclarations oldGraph-      newDeclarations = tgDeclarations newGraph+      oldDeclarations = (.declarations) oldGraph+      newDeclarations = (.declarations) newGraph       matched =         [ (oldDeclaration, newDeclaration)         | (key, newDeclaration) <- Map.toList newDeclarations,@@ -152,7 +152,7 @@       "haskell"       MappedHaskellSourceChanged       "consumer package, module, or type changed without changing declared wire identity; recompile every affected consumer"-  | sdHaskell oldDeclaration /= sdHaskell newDeclaration+  | (.haskell) oldDeclaration /= (.haskell) newDeclaration   ]     ++ [ finding            paths@@ -160,8 +160,8 @@            "binding"            MappedBindingChanged            "binding symbol or binding-version changed; diff cannot inspect binding behavior, so run the two-law, codec, and historical-fixture conformance suite"-       | (sdBinding oldDeclaration, sdBindingVersion oldDeclaration)-           /= (sdBinding newDeclaration, sdBindingVersion newDeclaration)+       | ((.binding) oldDeclaration, (.bindingVersion) oldDeclaration)+           /= ((.binding) newDeclaration, (.bindingVersion) newDeclaration)        ]     ++ [ finding            paths@@ -169,7 +169,7 @@            "fixtures"            MappedFixturesChanged            "fixture evidence symbol changed; runtime wire policy is unchanged, but the complete conformance suite must run"-       | sdFixtures oldDeclaration /= sdFixtures newDeclaration+       | (.fixtures) oldDeclaration /= (.fixtures) newDeclaration        ]     ++ [ finding            paths@@ -177,7 +177,7 @@            "initial"            MappedInitialChanged            "mapped initial symbol changed; new streams and snapshot fingerprints may change while historical event decoding does not"-       | sdInitial oldDeclaration /= sdInitial newDeclaration+       | (.initial) oldDeclaration /= (.initial) newDeclaration        ]     ++ [ finding            paths@@ -185,10 +185,10 @@            "canonical-type"            MappedCanonicalTypeChanged            "canonical type identity changed; rebuild generated projections and invalidate mapped snapshots while declared event bytes remain unchanged"-       | sdCanonical oldDeclaration /= sdCanonical newDeclaration+       | (.canonical) oldDeclaration /= (.canonical) newDeclaration        ]   where-    name = sdName newDeclaration+    name = (.name) newDeclaration  opaqueMetadataDiff :: [UsePath] -> OpaqueDecl -> OpaqueDecl -> [MappedFinding] opaqueMetadataDiff paths oldDeclaration newDeclaration =@@ -198,7 +198,7 @@       "haskell"       MappedHaskellSourceChanged       "consumer package, module, or type changed without changing the opaque codec claim; recompile every affected consumer"-  | odHaskell oldDeclaration /= odHaskell newDeclaration+  | (.haskell) oldDeclaration /= (.haskell) newDeclaration   ]     ++ [ finding            paths@@ -206,8 +206,8 @@            "codec"            MappedOpaqueCodecChanged            "opaque codec identity or version changed; Keiro cannot inspect the codec and historical payload compatibility is unproven"-       | (odCodecIdentity oldDeclaration, odCodecVersion oldDeclaration)-           /= (odCodecIdentity newDeclaration, odCodecVersion newDeclaration)+       | ((.codecIdentity) oldDeclaration, (.codecVersion) oldDeclaration)+           /= ((.codecIdentity) newDeclaration, (.codecVersion) newDeclaration)        ]     ++ [ finding            paths@@ -215,7 +215,7 @@            "fixtures"            MappedFixturesChanged            "fixture evidence symbol changed; runtime codec identity is unchanged, but the complete conformance suite must run"-       | odFixtures oldDeclaration /= odFixtures newDeclaration+       | (.fixtures) oldDeclaration /= (.fixtures) newDeclaration        ]     ++ [ finding            paths@@ -223,10 +223,10 @@            "initial"            MappedInitialChanged            "mapped initial symbol changed; new streams and snapshot fingerprints may change while historical event decoding does not"-       | odInitial oldDeclaration /= odInitial newDeclaration+       | (.initial) oldDeclaration /= (.initial) newDeclaration        ]   where-    name = odName newDeclaration+    name = (.name) newDeclaration  diffShape :: [UsePath] -> Name -> ShapeView -> ShapeView -> [MappedFinding] diffShape paths declaration oldShape newShape = case (oldShape, newShape) of@@ -278,7 +278,7 @@     addedFinding field =       (findingWithUnknown paths declaration (fieldLeaf field) code detail (Just oldUnknown))       where-        hasDefault = isJustValue (rwfOnMissing field)+        hasDefault = isJustValue ((.onMissing) field)         code           | hasDefault = MappedFieldAddedWithDefault           | otherwise = MappedFieldAddedNoDefault@@ -303,21 +303,21 @@     exact =       [ (oldField, newField)       | newField <- newFields,-        oldField <- maybeToList (find ((== rwfHaskell newField) . rwfHaskell) oldFields)+        oldField <- maybeToList (find ((== (.haskell) newField) . (.haskell)) oldFields)       ]-    matchedOld = map (rwfHaskell . fst) exact-    matchedNew = map (rwfHaskell . snd) exact-    unmatchedOld = [field | field <- oldFields, rwfHaskell field `notElem` matchedOld]-    unmatchedNew = [field | field <- newFields, rwfHaskell field `notElem` matchedNew]+    matchedOld = map ((.haskell) . fst) exact+    matchedNew = map ((.haskell) . snd) exact+    unmatchedOld = [field | field <- oldFields, (.haskell) field `notElem` matchedOld]+    unmatchedNew = [field | field <- newFields, (.haskell) field `notElem` matchedNew]     fallback =       [ (oldField, newField)       | newField <- unmatchedNew,-        oldField <- maybeToList (find ((== rwfKey newField) . rwfKey) unmatchedOld)+        oldField <- maybeToList (find ((== (.key) newField) . (.key)) unmatchedOld)       ]-    fallbackOld = map (rwfHaskell . fst) fallback-    fallbackNew = map (rwfHaskell . snd) fallback-    removed = [field | field <- unmatchedOld, rwfHaskell field `notElem` fallbackOld]-    added = [field | field <- unmatchedNew, rwfHaskell field `notElem` fallbackNew]+    fallbackOld = map ((.haskell) . fst) fallback+    fallbackNew = map ((.haskell) . snd) fallback+    removed = [field | field <- unmatchedOld, (.haskell) field `notElem` fallbackOld]+    added = [field | field <- unmatchedNew, (.haskell) field `notElem` fallbackNew]  diffField :: [UsePath] -> Name -> ResolvedWireField -> ResolvedWireField -> [MappedFinding] diffField paths declaration oldField newField =@@ -327,23 +327,23 @@       leaf       GeneratedHaskellNameChanged       ( "generated record selector changed '"-          <> normalizedGeneratedLower (rwfHaskell oldField)+          <> normalizedGeneratedLower ((.haskell) oldField)           <> "' -> '"-          <> normalizedGeneratedLower (rwfHaskell newField)+          <> normalizedGeneratedLower ((.haskell) newField)           <> "' while wire key '"-          <> rwfKey newField+          <> (.key) newField           <> "' remains unchanged; re-scaffold and recompile consumers"       )-  | rwfKey oldField == rwfKey newField,-    normalizedGeneratedLower (rwfHaskell oldField) /= normalizedGeneratedLower (rwfHaskell newField)+  | (.key) oldField == (.key) newField,+    normalizedGeneratedLower ((.haskell) oldField) /= normalizedGeneratedLower ((.haskell) newField)   ]     ++ [ finding            paths            declaration            leaf            MappedWireKeyChanged-           ("wire key changed '" <> rwfKey oldField <> "' -> '" <> rwfKey newField <> "'; version and upcast every affected private event root")-       | rwfKey oldField /= rwfKey newField+           ("wire key changed '" <> (.key) oldField <> "' -> '" <> (.key) newField <> "'; version and upcast every affected private event root")+       | (.key) oldField /= (.key) newField        ]     ++ [ finding            paths@@ -351,13 +351,13 @@            leaf            MappedPresenceChanged            "field presence changed between required and optional; historical decode policy changed"-       | rwfPresence oldField /= rwfPresence newField+       | (.presence) oldField /= (.presence) newField        ]     ++ defaultChanges-    ++ diffExpr paths declaration (leaf <> ".type") (rwfType oldField) (rwfType newField)+    ++ diffExpr paths declaration (leaf <> ".type") ((.valueType) oldField) ((.valueType) newField)   where     leaf = fieldLeaf newField-    defaultChanges = case (rwfOnMissing oldField, rwfOnMissing newField) of+    defaultChanges = case ((.onMissing) oldField, (.onMissing) newField) of       (Just _, Nothing) ->         [ finding             paths@@ -380,15 +380,15 @@ normalizedGeneratedLower :: Text -> Text normalizedGeneratedLower logicalName =   case HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site of-    Right derived -> HaskellName.renderLowerCamelName (HaskellName.lowerCamel derived)+    Right derived -> HaskellName.renderLowerCamelName ((.lowerCamel) derived)     Left _ -> logicalName   where     site =       HaskellName.NameSite-        { HaskellName.siteKind = HaskellName.GeneratedFieldSite,-          HaskellName.siteLogicalName = logicalName,-          HaskellName.siteOwner = "mapped-diff",-          HaskellName.siteLine = 0+        { HaskellName.kind = HaskellName.GeneratedFieldSite,+          HaskellName.logicalName = logicalName,+          HaskellName.owner = "mapped-diff",+          HaskellName.line = 0         }  diffExpr :: [UsePath] -> Name -> Text -> ResolvedTypeExpr -> ResolvedTypeExpr -> [MappedFinding]@@ -439,10 +439,10 @@       declaration       (enumLeaf newEntry)       MappedEnumSpellingChanged-      ("enum wire spelling changed '" <> weTag oldEntry <> "' -> '" <> weTag newEntry <> "'")+      ("enum wire spelling changed '" <> (.tag) oldEntry <> "' -> '" <> (.tag) newEntry <> "'")   | newEntry <- newEntries,-    oldEntry <- maybeToList (find ((== weCtor newEntry) . weCtor) oldEntries),-    weTag oldEntry /= weTag newEntry+    oldEntry <- maybeToList (find ((== (.ctor) newEntry) . (.ctor)) oldEntries),+    (.tag) oldEntry /= (.tag) newEntry   ]     ++ [ finding            paths@@ -451,7 +451,7 @@            MappedEnumValueAdded            "enum value added; existing history remains readable, but deploy readers before writers emit the new spelling; a future public surface exposing this closed enum would classify the addition as consumer-breaking"        | entry <- newEntries,-         isNothing (find ((== weCtor entry) . weCtor) oldEntries)+         isNothing (find ((== (.ctor) entry) . (.ctor)) oldEntries)        ]     ++ [ finding            paths@@ -460,7 +460,7 @@            MappedEnumValueRemoved            "enum value removed; historical payloads carrying its wire spelling no longer decode"        | entry <- oldEntries,-         isNothing (find ((== weCtor entry) . weCtor) newEntries)+         isNothing (find ((== (.ctor) entry) . (.ctor)) newEntries)        ]  diffUnion :: [UsePath] -> Name -> [ResolvedWireArm] -> [ResolvedWireArm] -> [MappedFinding]@@ -476,10 +476,10 @@           declaration           (armLeaf newArm)           MappedArmTagChanged-          ("union arm tag changed '" <> rwaTag oldArm <> "' -> '" <> rwaTag newArm <> "'")-      | rwaTag oldArm /= rwaTag newArm+          ("union arm tag changed '" <> (.tag) oldArm <> "' -> '" <> (.tag) newArm <> "'")+      | (.tag) oldArm /= (.tag) newArm       ]-        ++ case (rwaPayload oldArm, rwaPayload newArm) of+        ++ case ((.payload) oldArm, (.payload) newArm) of           (Nothing, Nothing) -> []           (Just oldPayload, Just newPayload) -> diffExpr paths declaration (armLeaf newArm <> ".payload") oldPayload newPayload           _ -> [finding paths declaration (armLeaf newArm) MappedFieldTypeChanged "union arm payload presence changed; historical tagged objects no longer share one wire shape"]@@ -492,21 +492,21 @@     exact =       [ (oldArm, newArm)       | newArm <- newArms,-        oldArm <- maybeToList (find ((== rwaCtor newArm) . rwaCtor) oldArms)+        oldArm <- maybeToList (find ((== (.ctor) newArm) . (.ctor)) oldArms)       ]-    matchedOld = map (rwaCtor . fst) exact-    matchedNew = map (rwaCtor . snd) exact-    unmatchedOld = [arm | arm <- oldArms, rwaCtor arm `notElem` matchedOld]-    unmatchedNew = [arm | arm <- newArms, rwaCtor arm `notElem` matchedNew]+    matchedOld = map ((.ctor) . fst) exact+    matchedNew = map ((.ctor) . snd) exact+    unmatchedOld = [arm | arm <- oldArms, (.ctor) arm `notElem` matchedOld]+    unmatchedNew = [arm | arm <- newArms, (.ctor) arm `notElem` matchedNew]     fallback =       [ (oldArm, newArm)       | newArm <- unmatchedNew,-        oldArm <- maybeToList (find ((== rwaTag newArm) . rwaTag) unmatchedOld)+        oldArm <- maybeToList (find ((== (.tag) newArm) . (.tag)) unmatchedOld)       ]-    fallbackOld = map (rwaCtor . fst) fallback-    fallbackNew = map (rwaCtor . snd) fallback-    removed = [arm | arm <- unmatchedOld, rwaCtor arm `notElem` fallbackOld]-    added = [arm | arm <- unmatchedNew, rwaCtor arm `notElem` fallbackNew]+    fallbackOld = map ((.ctor) . fst) fallback+    fallbackNew = map ((.ctor) . snd) fallback+    removed = [arm | arm <- unmatchedOld, (.ctor) arm `notElem` fallbackOld]+    added = [arm | arm <- unmatchedNew, (.ctor) arm `notElem` fallbackNew]  addedDeclaration :: TypeGraph -> (MappedKey, ResolvedMappedDecl) -> MappedFinding addedDeclaration _ (key, _) =@@ -536,18 +536,18 @@ resolvedName =   foldMappedDecl     MappedDeclAlgebra-      { onStructuralDecl = \declaration _ -> sdName declaration,-        onOpaqueDecl = odName+      { onStructuralDecl = \declaration _ -> (.name) declaration,+        onOpaqueDecl = (.name)       }  fieldLeaf :: ResolvedWireField -> Text-fieldLeaf field = ".field " <> rwfHaskell field <> "[\"" <> rwfKey field <> "\"]"+fieldLeaf field = ".field " <> (.haskell) field <> "[\"" <> (.key) field <> "\"]"  armLeaf :: ResolvedWireArm -> Text-armLeaf arm = ".arm " <> rwaCtor arm <> "[\"" <> rwaTag arm <> "\"]"+armLeaf arm = ".arm " <> (.ctor) arm <> "[\"" <> (.tag) arm <> "\"]"  enumLeaf :: WireEnum -> Text-enumLeaf entry = ".enum " <> weCtor entry <> "[\"" <> weTag entry <> "\"]"+enumLeaf entry = ".enum " <> (.ctor) entry <> "[\"" <> (.tag) entry <> "\"]"  finding :: [UsePath] -> Name -> Text -> DiagnosticCode -> Text -> MappedFinding finding paths declaration leaf code detail =@@ -556,12 +556,12 @@ findingWithUnknown :: [UsePath] -> Name -> Text -> DiagnosticCode -> Text -> Maybe UnknownFields -> MappedFinding findingWithUnknown paths declaration leaf code detail unknownFields =   MappedFinding-    { mfDeclaration = declaration,-      mfLeaf = leaf,-      mfCode = code,-      mfDetail = detail,-      mfUsePaths = paths,-      mfOldUnknownFields = unknownFields+    { declaration = declaration,+      leaf = leaf,+      code = code,+      detail = detail,+      usePaths = paths,+      oldUnknownFields = unknownFields     }  isJustValue :: Maybe a -> Bool

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, checkedLanguageContract, checkedSpec, effectiveRuntimeProfile)+import Keiro.Dsl.SemanticContract (CheckedService, EffectiveLanguageContract (..), checkedLanguageContract, checkedSpec) import Keiro.Dsl.TypeGraph  data NominalScalarRepresentation@@ -78,19 +78,19 @@   deriving stock (Eq, Ord, Show, Generic)  data CheckedNominalEquality = CheckedNominalEquality-  { equalityKeyRepresentation :: !NominalEqualityKey,-    equalityDomain :: !NominalEqualityDomain,-    equalityContractVersion :: !Text+  { keyRepresentation :: !NominalEqualityKey,+    domain :: !NominalEqualityDomain,+    contractVersion :: !Text   }   deriving stock (Eq, Ord, Show, Generic)  data ConsumerNominalBinding = ConsumerNominalBinding-  { consumerNominalHaskell :: !HaskellSource,-    consumerNominalBinding :: !QualifiedValueName,-    consumerNominalBindingVersion :: !BindingVersion,-    consumerNominalCanonical :: !CanonicalTypeId,-    consumerNominalFixtures :: !QualifiedValueName,-    consumerNominalInitial :: !(Maybe QualifiedValueName)+  { haskell :: !HaskellSource,+    binding :: !QualifiedValueName,+    bindingVersion :: !BindingVersion,+    canonical :: !CanonicalTypeId,+    fixtures :: !QualifiedValueName,+    initial :: !(Maybe QualifiedValueName)   }   deriving stock (Eq, Ord, Show, Generic) @@ -100,40 +100,41 @@   deriving stock (Eq, Ord, Show, Generic)  data ResolvedNominalType = ResolvedNominalType-  { resolvedNominalName :: !Name,-    resolvedNominalRepresentation :: !NominalRepresentation,-    resolvedNominalOwnership :: !NominalOwnership,-    resolvedNominalLoc :: !Loc+  { name :: !Name,+    representation :: !NominalRepresentation,+    ownership :: !NominalOwnership,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  instance Ord ResolvedNominalType where   compare left right =     compare-      (resolvedNominalName left, resolvedNominalRepresentation left, resolvedNominalOwnership left)-      (resolvedNominalName right, resolvedNominalRepresentation right, resolvedNominalOwnership right)+      ((.name) left, (.representation) left, (.ownership) left)+      ((.name) right, (.representation) right, (.ownership) right) -newtype NominalTypeRegistry = NominalTypeRegistry-  { nominalTypes :: Map Name ResolvedNominalType-  }+newtype NominalTypeRegistry = NominalTypeRegistry (Map Name ResolvedNominalType)   deriving stock (Eq, Show, Generic) +nominalTypes :: NominalTypeRegistry -> Map Name ResolvedNominalType+nominalTypes (NominalTypeRegistry values) = values+ lookupNominalType :: Name -> NominalTypeRegistry -> Maybe ResolvedNominalType lookupNominalType name = Map.lookup name . nominalTypes  nominalEqualityContractForService :: EffectiveLanguageContract -> ResolvedNominalType -> Maybe CheckedNominalEquality-nominalEqualityContractForService languageContract nominal = case resolvedNominalRepresentation nominal of+nominalEqualityContractForService languageContract nominal = case (.representation) nominal of   IdRepresentation prefix ->     Just       CheckedNominalEquality-        { equalityKeyRepresentation = NominalTextEqualityKey,-          equalityDomain =+        { keyRepresentation = NominalTextEqualityKey,+          domain =             if enforcesNominalEqualityV2               then EnforcedTypeIdV7TextDomain prefix enforcedIdDomainVersion-              else case resolvedNominalOwnership nominal of+              else case (.ownership) nominal of                 GeneratedNominal -> LegacyUnrestrictedTextDomain                 ConsumerNominal {} -> TypeIdTextDomain prefix,-          equalityContractVersion =+          contractVersion =             if enforcesNominalEqualityV2               then "keiro-dsl/nominal-equality/2"               else nominalEqualityContractVersion@@ -141,14 +142,14 @@   EnumRepresentation constructors ->     Just       CheckedNominalEquality-        { equalityKeyRepresentation = NominalTextEqualityKey,-          equalityDomain = FiniteTextDomain (snd <$> constructors),-          equalityContractVersion = nominalEqualityContractVersion+        { keyRepresentation = NominalTextEqualityKey,+          domain = FiniteTextDomain (snd <$> constructors),+          contractVersion = nominalEqualityContractVersion         }   ScalarRepresentation {} -> Nothing   where     enforcesNominalEqualityV2 =-      runtimeProfileHasCapability (effectiveRuntimeProfile languageContract) NominalEqualityV2+      runtimeProfileHasCapability ((.runtimeProfile) languageContract) NominalEqualityV2  -- | Stable, checked identity used by generated projection tags, fingerprints, -- scaffold history, and explain output. It includes the existing binding@@ -158,11 +159,11 @@   equality <- nominalEqualityContractForService languageContract nominal   pure . T.intercalate "|" $     [ "nominal-equality",-      "name=" <> resolvedNominalName nominal,-      "contract=" <> equalityContractVersion equality,-      "key=" <> renderEqualityKey (equalityKeyRepresentation equality),-      "domain=" <> renderEqualityDomain (equalityDomain equality),-      renderOwnership (resolvedNominalOwnership nominal)+      "name=" <> (.name) nominal,+      "contract=" <> (.contractVersion) equality,+      "key=" <> renderEqualityKey ((.keyRepresentation) equality),+      "domain=" <> renderEqualityDomain ((.domain) equality),+      renderOwnership ((.ownership) nominal)     ]   where     renderEqualityKey NominalTextEqualityKey = "Text"@@ -176,9 +177,9 @@       T.intercalate         ";"         [ "owner=consumer",-          "canonical=" <> unCanonicalTypeId (consumerNominalCanonical binding),-          "binding=" <> unQualifiedValueName (consumerNominalBinding binding),-          "binding-version=" <> unBindingVersion (consumerNominalBindingVersion binding)+          "canonical=" <> unCanonicalTypeId ((.canonical) binding),+          "binding=" <> unQualifiedValueName ((.binding) binding),+          "binding-version=" <> unBindingVersion ((.bindingVersion) binding)         ]  nominalEqualityIdentitiesForService :: CheckedService -> [Text]@@ -211,45 +212,45 @@ resolveNominalTypes spec = do   resolved <- rejectErrors declarationErrors resolvedDeclarations   rejectMany collisionErrors-  let registry = NominalTypeRegistry (Map.fromList [(resolvedNominalName value, value) | value <- resolved])+  let registry = NominalTypeRegistry (Map.fromList [((.name) value, value) | value <- resolved])   rejectMany (registerInitialErrors registry)   pure registry   where     declarationResults =-      map resolveId (specIds spec)-        <> map resolveEnum (specEnums spec)-        <> map resolveScalar (specNominalScalars spec)+      map resolveId ((.ids) spec)+        <> map resolveEnum ((.enums) spec)+        <> map resolveScalar ((.nominalScalars) spec)     declarationErrors = concatMap fst declarationResults     resolvedDeclarations = [value | (_, Just value) <- declarationResults]      resolveId declaration =-      let name = idName declaration-          loc = idLoc declaration+      let name = (.name) declaration+          loc = (.loc) declaration           prefixErrors =-            case idBinding declaration >>= const (TypeID.checkPrefix (idPrefix declaration)) of+            case (.binding) declaration >>= const (TypeID.checkPrefix ((.prefix) declaration)) of               Nothing -> []-              Just err -> [NominalInvalidIdPrefix name loc (idPrefix declaration) (T.pack (show err))]-          (bindingErrors, ownership) = resolveOwnership name loc (idBinding declaration)+              Just err -> [NominalInvalidIdPrefix name loc ((.prefix) declaration) (T.pack (show err))]+          (bindingErrors, ownership) = resolveOwnership name loc ((.binding) declaration)           errors = prefixErrors <> bindingErrors-          value = ResolvedNominalType name (IdRepresentation (idPrefix declaration)) <$> ownership <*> pure loc+          value = ResolvedNominalType name (IdRepresentation ((.prefix) declaration)) <$> ownership <*> pure loc        in (errors, value <* guardNoErrors errors)      resolveEnum declaration =-      let name = enumName declaration-          loc = enumLoc declaration-          representation = NE.nonEmpty (enumCtors declaration)+      let name = (.name) declaration+          loc = (.loc) declaration+          representation = NE.nonEmpty ((.ctors) declaration)           representationErrors = [NominalEmptyEnum name loc | representation == Nothing]-          (bindingErrors, ownership) = resolveOwnership name loc (enumBinding declaration)+          (bindingErrors, ownership) = resolveOwnership name loc ((.binding) declaration)           errors = representationErrors <> bindingErrors           value = ResolvedNominalType name <$> (EnumRepresentation <$> representation) <*> ownership <*> pure loc        in (errors, value <* guardNoErrors errors)      resolveScalar declaration =-      let name = nominalScalarName declaration-          loc = nominalScalarLoc declaration-          representation = scalarRepresentation (nominalScalarRepresentation declaration)-          representationErrors = [NominalUnsupportedScalar name loc (nominalScalarRepresentation declaration) | representation == Nothing]-          (bindingErrors, ownership) = resolveRequiredOwnership name loc (nominalScalarBinding declaration)+      let name = (.name) declaration+          loc = (.loc) declaration+          representation = scalarRepresentation ((.representation) declaration)+          representationErrors = [NominalUnsupportedScalar name loc ((.representation) declaration) | representation == Nothing]+          (bindingErrors, ownership) = resolveRequiredOwnership name loc ((.binding) declaration)           errors = representationErrors <> bindingErrors           value = ResolvedNominalType name <$> (ScalarRepresentation <$> representation) <*> ownership <*> pure loc        in (errors, value <* guardNoErrors errors)@@ -263,21 +264,21 @@       ]     originsByName = Map.fromListWith (<>) [(name, [(category, loc)]) | (name, category, loc) <- origins]     origins =-      [(idName value, "id", idLoc value) | value <- specIds spec]-        <> [(enumName value, "enum", enumLoc value) | value <- specEnums spec]-        <> [(nominalScalarName value, "nominal scalar", nominalScalarLoc value) | value <- specNominalScalars spec]-        <> [(mappedName value, "mapped", mappedLoc value) | value <- specMapped spec]-        <> [(ruleName value, "rule", ruleLoc value) | value <- specRules spec]-        <> [(name, kind <> " node", loc) | node <- specNodes spec, let (kind, name, loc) = nodeIdentityLocal node]+      [((.name) value, "id", (.loc) value) | value <- (.ids) spec]+        <> [((.name) value, "enum", (.loc) value) | value <- (.enums) spec]+        <> [((.name) value, "nominal scalar", (.loc) value) | value <- (.nominalScalars) spec]+        <> [(mappedName value, "mapped", mappedLoc value) | value <- (.mapped) spec]+        <> [((.name) value, "rule", (.loc) value) | value <- (.rules) spec]+        <> [(name, kind <> " node", loc) | node <- (.nodes) spec, let (kind, name, loc) = nodeIdentityLocal node]      registerInitialErrors registry =-      [ NominalMissingRegisterInitial typeName (regLoc register) (regName register)-      | aggregate <- [value | NAggregate value <- specNodes spec],-        register <- aggRegs aggregate,-        TRef typeName <- [regType register],+      [ NominalMissingRegisterInitial typeName ((.loc) register) ((.name) register)+      | aggregate <- [value | NAggregate value <- (.nodes) spec],+        register <- (.regs) aggregate,+        TRef typeName <- [(.valueType) register],         Just resolved <- [lookupNominalType typeName registry],-        ConsumerNominal binding <- [resolvedNominalOwnership resolved],-        consumerNominalInitial binding == Nothing+        ConsumerNominal binding <- [(.ownership) resolved],+        (.initial) binding == Nothing       ]  resolveOwnership :: Name -> Loc -> Maybe NominalBindingDecl -> ([NominalTypeError], Maybe NominalOwnership)@@ -291,22 +292,22 @@     requiredErrors =       [NominalMissingIngredient name loc label | (label, missing) <- missingFacts, missing]     missingFacts =-      [ ("haskell", nominalHaskell binding == Nothing),-        ("binding", nominalBinding binding == Nothing),-        ("binding-version", nominalBindingVersion binding == Nothing),-        ("canonical-type", nominalCanonicalType binding == Nothing),-        ("fixtures", nominalFixtures binding == Nothing)+      [ ("haskell", (.haskell) binding == Nothing),+        ("binding", (.binding) binding == Nothing),+        ("binding-version", (.bindingVersion) binding == Nothing),+        ("canonical-type", (.canonicalType) binding == Nothing),+        ("fixtures", (.fixtures) binding == Nothing)       ]-    haskellErrors = maybe [] (validateHaskellSource name loc) (nominalHaskell binding)-    (bindingErrors, checkedBindingName) = validateQualified name loc "binding" (nominalBinding binding)-    (fixtureErrors, checkedFixtures) = validateQualified name loc "fixtures" (nominalFixtures binding)-    (initialErrors, checkedInitial) = validateOptionalQualified name loc "initial" (nominalInitial binding)-    (bindingVersionErrors, checkedBindingVersion) = validateBindingVersion name loc (nominalBindingVersion binding)-    (canonicalErrors, checkedCanonical) = validateCanonical name loc (nominalCanonicalType binding)+    haskellErrors = maybe [] (validateHaskellSource name loc) ((.haskell) binding)+    (bindingErrors, checkedBindingName) = validateQualified name loc "binding" ((.binding) binding)+    (fixtureErrors, checkedFixtures) = validateQualified name loc "fixtures" ((.fixtures) binding)+    (initialErrors, checkedInitial) = validateOptionalQualified name loc "initial" ((.initial) binding)+    (bindingVersionErrors, checkedBindingVersion) = validateBindingVersion name loc ((.bindingVersion) binding)+    (canonicalErrors, checkedCanonical) = validateCanonical name loc ((.canonicalType) binding)     errors = requiredErrors <> haskellErrors <> bindingErrors <> fixtureErrors <> initialErrors <> bindingVersionErrors <> canonicalErrors     checkedBinding =       ConsumerNominalBinding-        <$> nominalHaskell binding+        <$> (.haskell) binding         <*> checkedBindingName         <*> checkedBindingVersion         <*> checkedCanonical@@ -315,9 +316,9 @@  validateHaskellSource :: Name -> Loc -> HaskellSource -> [NominalTypeError] validateHaskellSource name loc source =-  [NominalInvalidHaskellSource name loc "package" | not (cabalPackageName (hsPackage source))]-    <> [NominalInvalidHaskellSource name loc "module" | not (moduleNameSafe (hsModule source))]-    <> [NominalInvalidHaskellSource name loc "type" | not (constructorSafe (hsType source))]+  [NominalInvalidHaskellSource name loc "package" | not (cabalPackageName ((.package) source))]+    <> [NominalInvalidHaskellSource name loc "module" | not (moduleNameSafe ((.moduleName) source))]+    <> [NominalInvalidHaskellSource name loc "type" | not (constructorSafe ((.valueType) source))]  validateQualified :: Name -> Loc -> Text -> Maybe Text -> ([NominalTypeError], Maybe QualifiedValueName) validateQualified _ _ _ Nothing = ([], Nothing)@@ -373,23 +374,23 @@  nodeIdentityLocal :: Node -> (Text, Name, Loc) nodeIdentityLocal = \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)+  NAggregate value -> ("aggregate", (.name) value, (.loc) value)+  NProcess value -> ("process", (.id) value, (.loc) value)+  NRouter value -> ("router", (.id) value, (.loc) value)+  NContract value -> ("contract", (.name) value, (.loc) value)+  NIntake value -> ("intake", (.name) value, (.loc) value)+  NEmit value -> ("emit", (.name) value, (.loc) value)+  NPublisher value -> ("publisher", (.name) value, (.loc) value)+  NWorkqueue value -> ("workqueue", (.name) value, (.loc) value)+  NPgmqDispatch value -> ("dispatch", (.name) value, (.loc) value)+  NReadModel value -> ("readmodel", (.name) value, (.loc) value)+  NProjectionTarget value -> ("target", (.name) value, (.loc) value)+  NRebuildGroup value -> ("rebuild-group", (.name) value, (.loc) value)+  NProjectionRevision value -> ("projection-revision", (.name) value, (.loc) value)+  NExternalRead value -> ("external-read", externalReadNodeIdentity value, (.loc) value)+  NProjectionOwner value -> ("projection-owner", (.name) value, (.loc) value)+  NWorkflow value -> ("workflow", (.id) value, workflowNodeLoc value)+  NOperation value -> ("operation", (.name) value, (.loc) value)  cabalPackageName :: Text -> Bool cabalPackageName packageName = not (null components) && all validComponent components

src/Keiro/Dsl/Parser.hs view

@@ -29,7 +29,7 @@ -- | Parse a @.keiro@ source. The 'FilePath' is used only as the source name in -- diagnostics; it need not exist on disk. parseSpec :: FilePath -> Text -> Either ParseError Spec-parseSpec sourceName input = parsedSpec <$> first renderParseFailure (parseSource sourceName input)+parseSpec sourceName input = (.spec) <$> first renderParseFailure (parseSource sourceName input)  -- | Convenience wrapper for callers without a source name (tests, stdin). parseSpecText :: Text -> Either ParseError Spec

src/Keiro/Dsl/Parser/Aggregate.hs view

@@ -38,7 +38,7 @@   let items = map snd positionedItems       transitions = [transition | BITransition transition _ <- items]       stateElements =-        [ mapLocated (SurfaceAggregateState name . stName) locatedState+        [ mapLocated (SurfaceAggregateState name . (.name)) locatedState         | locatedState <- locatedStates         ]       transitionElements =@@ -62,20 +62,20 @@     _ -> pure ()   pure     ( Aggregate-        { aggName = name,-          aggRegs = regs,-          aggStates = map locatedValue locatedStates,-          aggCommands = [c | BICommand c _ <- items],-          aggEvents = [e | BIEvent e _ <- items],-          aggTransitions = map locatedValue transitions,-          aggDomainOutcomeTypes = case outcomeDeclarations of+        { name = name,+          regs = regs,+          states = map locatedValue locatedStates,+          commands = [c | BICommand c _ <- items],+          events = [e | BIEvent e _ <- items],+          transitions = map locatedValue transitions,+          domainOutcomeTypes = 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+          domainOutcomeDuplicateLocs = map (.outcomeTypesLoc) (drop 1 outcomeDeclarations),+          wire = listToMaybe [w | BIWire w <- items],+          projection = listToMaybe [p | BIProjection p <- items],+          snapshot = listToMaybe [s | BISnapshot s <- items],+          loc = loc         },       stateElements <> transitionElements <> concatMap bodyElements items     )@@ -117,7 +117,7 @@   ty <- pMappedTypeExpr context   _ <- symbol "="   initial <- (RegInitText <$> stringLit) <|> (RegInitBare <$> (ident <|> signedDecimalText))-  pure RegDecl {regName = name, regType = ty, regInitial = initial, regLoc = loc}+  pure RegDecl {name = name, valueType = ty, initial = initial, loc = loc}  pStatesLine :: P [Located StateDecl] pStatesLine = do@@ -139,7 +139,7 @@       n <- ident       term <- option False (True <$ symbol "!")       notFollowedBy (symbol "--")-      pure StateDecl {stName = n, stTerminal = term, stLoc = loc}+      pure StateDecl {name = n, terminal = term, loc = loc}  pBodyItem :: FrontendContext -> P BodyItem pBodyItem context =@@ -169,7 +169,7 @@   version <- boundedDecimal   _ <- symbol "shape-hash" *> symbol "="   hash <- stringLit-  pure SnapshotSpec {snapPolicy = policy, snapCodecVersion = version, snapShapeHash = hash, snapLoc = loc}+  pure SnapshotSpec {policy = policy, codecVersion = version, shapeHash = hash, loc = loc}  pCommand :: FrontendContext -> P (Command, [Located SurfaceElement]) pCommand context = do@@ -178,8 +178,8 @@   name <- ident   fields <- braces (many (withOwnedSpan (pAggregateField context)))   pure-    ( Command {cmdName = name, cmdFields = map locatedValue fields, cmdLoc = loc},-      map (mapLocated (SurfaceField . aggregateFieldName)) fields+    ( Command {name = name, fields = map locatedValue fields, loc = loc},+      map (mapLocated (SurfaceField . (.name))) fields     )  pAggregateField :: FrontendContext -> P AggregateField@@ -191,11 +191,11 @@   mty <- optional (symbol ":" *> pMappedTypeExpr context)   pure     AggregateField-      { aggregateFieldName = n,-        aggregateFieldSelector = selector,-        aggregateFieldWireKey = wireKey,-        aggregateFieldType = mty,-        aggregateFieldLoc = loc+      { name = n,+        selector = selector,+        wireKey = wireKey,+        valueType = mty,+        loc = loc       }  pEvent :: FrontendContext -> P (Event, [Located SurfaceElement])@@ -219,19 +219,19 @@           fields <- braces (many (withOwnedSpan (pAggregateField context)))           pure             ( EventFields (map locatedValue fields),-              map (mapLocated (SurfaceField . aggregateFieldName)) fields+              map (mapLocated (SurfaceField . (.name))) fields             )       ]   up <- optional pUpcast   pure     ( Event-        { evName = name,-          evBody = body,-          evVersion = ver,-          evUpcastFrom = up,-          evRetiring = retiring,-          evDeprecated = deprecated,-          evLoc = loc+        { name = name,+          body = body,+          version = ver,+          upcastFrom = up,+          retiring = retiring,+          deprecated = deprecated,+          loc = loc         },       elements     )@@ -256,7 +256,7 @@   _ <- symbol "schemaVersion"   _ <- symbol "="   v <- boundedDecimal-  pure WireSpec {wireKind = k, wireFields = f, wireSchemaVersion = v}+  pure WireSpec {kind = k, fields = f, schemaVersion = v}  pProjection :: FrontendContext -> P ProjectionSpec pProjection context = do@@ -278,11 +278,11 @@   sm <- optional pStatusMap   pure     ProjectionSpec-      { projTable = table,-        projConsistency = cons,-        projKey = k,-        projStatusMap = sm,-        projLoc = loc+      { table = table,+        consistency = cons,+        key = k,+        statusMap = sm,+        loc = loc       }   where     pConsistency =@@ -293,7 +293,7 @@   keyword "status-map"   partial <- option False (True <$ keyword "partial")   pairs <- braces (many pPair)-  pure Mapping {mapPairs = pairs, mapPartial = partial}+  pure Mapping {pairs = pairs, partial = partial}   where     pPair = do       l <- ident@@ -344,22 +344,22 @@   let guards = [e | CGuard e <- clauses]   pure     ( Transition-        { tSource = src,-          tCommand = cmd,-          tImplementation = case holeOffsets of+        { source = src,+          command = cmd,+          implementation = case holeOffsets of             _ : _ -> HoleImplementation             [] | frontendSupportsFeature context TypedAggregateExpressionSyntax -> GeneratedImplementation             [] -> LegacyHoleImplementation,-          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+          guard = case guards of [] -> Nothing; es -> Just (foldr1 EAnd es),+          writes = [(r, e) | CWrite r e <- clauses],+          emits = [n | CEmit n <- clauses],+          outcome = case outcomes of             (_, outcome) : _ -> Just outcome             [] -> Nothing,-          tOutcomeDuplicateLocs = map (transitionOutcomeLoc . snd) (drop 1 outcomes),-          tGoto = gt,-          tMode = mode,-          tLoc = loc+          outcomeDuplicateLocs = map (transitionOutcomeLoc . snd) (drop 1 outcomes),+          goto = gt,+          mode = mode,+          loc = loc         },       elements     )

src/Keiro/Dsl/Parser/Coordination.hs view

@@ -41,18 +41,18 @@   timer <- pTimerNode   pure     ProcessNode-      { procId = pid,-        procName = nm,-        procInput = inp,-        procCorrelate = corr,-        procSaga = saga,-        procTarget = tgt,-        procProjections = projs,-        procHandle = handle,-        procRejected = rejected,-        procPoison = poison,-        procTimer = timer,-        procLoc = loc+      { id = pid,+        name = nm,+        input = inp,+        correlate = corr,+        saga = saga,+        target = tgt,+        projections = projs,+        handle = handle,+        rejected = rejected,+        poison = poison,+        timer = timer,+        loc = loc       }  pRouter :: FrontendContext -> P RouterNode@@ -65,7 +65,7 @@   (inp, typedInputSpan) <- pRouterInputDecl context   key <- pRouterKey (maybe False (const True) typedInputSpan)   resolved <- pResolveDecl context-  case (typedInputSpan, rvSource resolved) of+  case (typedInputSpan, (.source) resolved) of     (Just _, ResolveDeclarative {}) -> pure ()     (Nothing, ResolveReadModel {}) -> pure ()     (Nothing, ResolveHole) -> pure ()@@ -80,17 +80,17 @@   poison <- pPolicyLine "poison"   pure     RouterNode-      { rtId = rid,-        rtName = nm,-        rtInput = inp,-        rtKey = key,-        rtResolve = resolved,-        rtTarget = target,-        rtProjections = projections,-        rtDispatch = dispatch,-        rtRejected = rejected,-        rtPoison = poison,-        rtLoc = loc+      { id = rid,+        name = nm,+        input = inp,+        key = key,+        resolve = resolved,+        target = target,+        projections = projections,+        dispatch = dispatch,+        rejected = rejected,+        poison = poison,+        loc = loc       }  pRouterKey :: Bool -> P CorrelateDecl@@ -99,7 +99,7 @@   _ <- keyword "input" *> symbol "."   field <- ident   via <- if declarative then pure "idText" else keyword "via" *> ident-  pure CorrelateDecl {corrField = field, corrVia = via}+  pure CorrelateDecl {field = field, via = via}  pResolveDecl :: FrontendContext -> P ResolveDecl pResolveDecl context = do@@ -114,14 +114,14 @@   source <- choice [ResolveReadModel <$> (keyword "read-model" *> ident), ResolveHole <$ keyword "hole"]   keyword "row"   row <- braces (many ident)-  pure ResolveDecl {rvSource = source, rvRow = row, rvLoc = loc}+  pure ResolveDecl {source = source, row = row, loc = 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}+  pure ResolveDecl {source = ResolveDeclarative selection, row = [], loc = loc}  pRouterSelection :: FrontendContext -> Loc -> P RouterSelectionDecl pRouterSelection context loc = do@@ -157,30 +157,30 @@   (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+      { identity = identity,+        identityLoc = identityLoc,+        version = version,+        versionLoc = versionLoc,+        query = query,+        queryLoc = queryLoc,+        queryInput = queryInput,+        queryInputLoc = queryInputLoc,+        predicate = predicate,+        recipient = recipient,+        limit = recipientLimit,+        order = order,+        orderLoc = orderLoc,+        dedupe = dedupe,+        dedupeLoc = dedupeLoc,+        emptyPolicy = emptyPolicy,+        emptyPolicyLoc = emptyPolicyLoc,+        failurePolicy = failurePolicy,+        failurePolicyLoc = failurePolicyLoc,+        redelivery = redelivery,+        redeliveryLoc = redeliveryLoc,+        partial = partial,+        partialLoc = partialLoc,+        loc = loc       }  locatedClause :: Text -> P a -> P (a, Loc)@@ -214,7 +214,7 @@       <$> (keyword "on-appended" *> pDisp)       <*> (symbol ";" *> keyword "on-duplicate" *> pDisp)       <*> (symbol ";" *> keyword "on-failed" *> pDisp)-  pure RouterDispatchNode {rdCommand = command, rdFields = fields, rdDisposition = disposition, rdLoc = loc}+  pure RouterDispatchNode {command = command, fields = fields, disposition = disposition, loc = loc}  -- | @dispatch-id strategy=uuidv5 from=(…)@ where the tuple is fixed by the -- runtime that derives the id. The line documents a derivation the spec cannot@@ -250,7 +250,7 @@   keyword "input"   nm <- ident   fs <- braces (many pField)-  pure InputDecl {inName = nm, inFields = fs, inType = Nothing, inLoc = loc}+  pure InputDecl {name = nm, fields = fs, valueType = Nothing, loc = loc}  pRouterInputDecl :: FrontendContext -> P (InputDecl, Maybe SourceSpan) pRouterInputDecl context = do@@ -261,10 +261,10 @@     [ do         marker <- withOwnedSpan (symbol ":")         inputType <- pMappedTypeExpr context-        pure (InputDecl {inName = name, inFields = [], inType = Just inputType, inLoc = loc}, Just (spanOf marker)),+        pure (InputDecl {name = name, fields = [], valueType = Just inputType, loc = loc}, Just (spanOf marker)),       do         fields <- braces (many pField)-        pure (InputDecl {inName = name, inFields = fields, inType = Nothing, inLoc = loc}, Nothing)+        pure (InputDecl {name = name, fields = fields, valueType = Nothing, loc = loc}, Nothing)     ]  pCorrelate :: P CorrelateDecl@@ -274,7 +274,7 @@   f <- ident   keyword "via"   v <- ident-  pure CorrelateDecl {corrField = f, corrVia = v}+  pure CorrelateDecl {field = f, via = v}  pSaga :: P SagaRef pSaga = do@@ -282,7 +282,7 @@   agg <- ident   keyword "category"   categoryName <- stringLit-  pure SagaRef {sagaAgg = agg, sagaCategory = categoryName}+  pure SagaRef {agg = agg, category = categoryName}  pHandle :: P HandleNode pHandle = do@@ -292,7 +292,7 @@   disps <- many pDispatch   keyword "schedule"   sched <- ident-  pure HandleNode {hOn = onName, hAdvance = adv, hDispatch = disps, hSchedule = sched}+  pure HandleNode {on = onName, advance = adv, dispatch = disps, schedule = sched}  pAdvance :: P AdvanceNode pAdvance = do@@ -315,7 +315,7 @@       <$> (keyword "on-appended" *> pDisp)       <*> (symbol ";" *> keyword "on-duplicate" *> pDisp)       <*> (symbol ";" *> keyword "on-failed" *> pDisp)-  pure DispatchNode {dispTarget = tgt, dispKey = key, dispCommand = cmd, dispFields = fs, dispDisposition = disp, dispLoc = loc}+  pure DispatchNode {target = tgt, key = key, command = cmd, fields = fs, disposition = disp, loc = loc}  pDisp :: P Disp pDisp =@@ -353,15 +353,15 @@   dl <- stringLit   pure     TimerNode-      { tmName = nm,-        tmId = tid,-        tmFireAt = fat,-        tmPayload = pay,-        tmFire = fire,-        tmDecodeUnknown = unk,-        tmMaxAttempts = ma,-        tmDeadLetter = dl,-        tmLoc = loc+      { name = nm,+        id = tid,+        fireAt = fat,+        payload = pay,+        fire = fire,+        decodeUnknown = unk,+        maxAttempts = ma,+        deadLetter = dl,+        loc = loc       }  pIdExpr :: P IdExpr@@ -370,7 +370,7 @@   pfx <- stringLit   _ <- symbol "<>"   field <- ident-  pure IdExpr {ideStrategy = UuidV5Id, idePrefix = pfx, ideField = field}+  pure IdExpr {strategy = UuidV5Id, prefix = pfx, field = field}  pFireAt :: P FireAtExpr pFireAt = do@@ -378,7 +378,7 @@   f <- ident   _ <- symbol "+"   w <- pWindow-  pure FireAtExpr {faField = f, faWindow = w}+  pure FireAtExpr {field = f, window = w}  pFire :: P FireNode pFire = do@@ -397,7 +397,7 @@       <*> (symbol ";" *> keyword "on-ambiguous" *> pFireOutcome)       <*> (symbol ";" *> keyword "on-error" *> pFireOutcome)       <*> (symbol ";" *> keyword "not-mine" *> pFireOutcome)-  pure FireNode {fireTarget = tgt, fireKey = key, fireCommand = cmd, fireFields = fs, fireFiredEventId = fid, fireDisposition = disp}+  pure FireNode {target = tgt, key = key, command = cmd, fields = fs, firedEventId = fid, disposition = disp}  pFireOutcome :: P FireOutcome pFireOutcome = choice [OFired <$ keyword "Fired", ORetry <$ keyword "Retry"]@@ -406,7 +406,7 @@ pFieldBinding = do   n <- ident   v <- optional (symbol "=" *> pBindingValue)-  pure FieldBinding {fbName = n, fbValue = v}+  pure FieldBinding {name = n, value = v}  -- | A binding value: a quoted string (kept quoted) or a dotted reference. pBindingValue :: P Text

src/Keiro/Dsl/Parser/Core.hs view

@@ -72,14 +72,14 @@ import Prelude hiding (span)  data ContextualParseFailure = ContextualParseFailure-  { contextualFailureCode :: !SourceLanguageErrorCode,-    contextualFailureFeature :: !(Maybe LanguageFeature),-    contextualFailureSpan :: !SourceSpan+  { code :: !SourceLanguageErrorCode,+    feature :: !(Maybe LanguageFeature),+    span :: !SourceSpan   }   deriving stock (Eq, Ord, Show)  instance ShowErrorComponent ContextualParseFailure where-  showErrorComponent contextual = T.unpack (sourceLanguageErrorCodeText (contextualFailureCode contextual))+  showErrorComponent contextual = T.unpack (sourceLanguageErrorCodeText ((.code) contextual))  type P = Parsec ContextualParseFailure Text @@ -116,7 +116,7 @@  contextualFailureAt :: SourceSpan -> SourceLanguageErrorCode -> P a contextualFailureAt span code =-  customFailure ContextualParseFailure {contextualFailureCode = code, contextualFailureFeature = Nothing, contextualFailureSpan = span}+  customFailure ContextualParseFailure {code = code, feature = Nothing, span = span}  requireLanguageFeatureAt :: FrontendContext -> LanguageFeature -> SourceSpan -> P () requireLanguageFeatureAt context feature span@@ -124,9 +124,9 @@   | otherwise =       customFailure         ContextualParseFailure-          { contextualFailureCode = LanguageFeatureRequiresVersion,-            contextualFailureFeature = Just feature,-            contextualFailureSpan = span+          { code = LanguageFeatureRequiresVersion,+            feature = Just feature,+            span = span           }  -- | Space consumer: spaces, newlines, and @#@ line comments are all whitespace.@@ -369,7 +369,7 @@ pField = do   n <- ident   mty <- optional (symbol ":" *> ident)-  pure Field {fieldName = n, fieldType = mty}+  pure Field {name = n, valueType = mty}  pVersion :: P Int pVersion = do

src/Keiro/Dsl/Parser/Declaration.hs view

@@ -25,7 +25,7 @@   _ <- symbol "="   pfx <- wireWord   binding <- optionalLanguageFeature context NominalBindingSyntax "using" pUsingNominalBinding-  pure IdDecl {idName = name, idPrefix = pfx, idBinding = binding, idLoc = loc}+  pure IdDecl {name = name, prefix = pfx, binding = binding, loc = loc}  pEnumDecl :: FrontendContext -> P EnumDecl pEnumDecl context = do@@ -34,7 +34,7 @@   name <- ident   ctors <- braces (many pEnumCtor)   binding <- optionalLanguageFeature context NominalBindingSyntax "using" pUsingNominalBinding-  pure EnumDecl {enumName = name, enumCtors = ctors, enumBinding = binding, enumLoc = loc}+  pure EnumDecl {name = name, ctors = ctors, binding = binding, loc = loc}   where     pEnumCtor = do       c <- ident@@ -57,11 +57,11 @@       elements = map snd parsedCases   pure     ( RuleDecl-        { ruleName = name,-          ruleDomain = dom,-          ruleCodomain = cod,-          ruleCases = cases,-          ruleLoc = loc+        { name = name,+          domain = dom,+          codomain = cod,+          cases = cases,+          loc = loc         },       elements     )

src/Keiro/Dsl/Parser/Document.hs view

@@ -48,8 +48,8 @@             Left bundle -> case firstContextualFailure bundle of               Just contextual ->                 let diagnostic = contextualDiagnostic src sourceLanguage contextual-                    supported = languageVersionsSupportingFeature <$> contextualFailureFeature contextual-                 in Left (frontendFailureFromSourceDiagnostic BodyParsingPhase (contextualFailureSpan contextual) supported diagnostic)+                    supported = languageVersionsSupportingFeature <$> (.feature) contextual+                 in Left (frontendFailureFromSourceDiagnostic BodyParsingPhase ((.span) contextual) supported diagnostic)               Nothing ->                 Left                   ( frontendFailureFromBody

src/Keiro/Dsl/Parser/Integration.hs view

@@ -31,12 +31,12 @@   _ <- symbol "}"   pure     ContractNode-      { ctrName = nm,-        ctrSchemaVersion = sv,-        ctrDiscriminator = disc,-        ctrTopics = topics,-        ctrEvents = events,-        ctrLoc = loc+      { name = nm,+        schemaVersion = sv,+        discriminator = disc,+        topics = topics,+        events = events,+        loc = loc       }   where     pTopic = do@@ -50,7 +50,7 @@       keyword "on"       topicAlias <- ident       fs <- braces (many pContractField)-      pure ContractEvent {ceName = nm, ceTopic = topicAlias, ceFields = fs}+      pure ContractEvent {name = nm, topic = topicAlias, fields = fs}     pContractField = do       loc <- getLoc       n <- ident@@ -59,7 +59,7 @@       _ <- symbol ":"       ty <- pContractType       _ <- optional (symbol ";")-      pure ContractField {cfName = n, cfSelector = selector, cfWireKey = wireKey, cfType = ty, cfLoc = loc}+      pure ContractField {name = n, selector = selector, wireKey = wireKey, valueType = ty, loc = loc}     pContractType =       choice         [ CTypeId <$> (keyword "typeid" *> stringLit),@@ -98,17 +98,17 @@   _ <- symbol "}"   pure     IntakeNode-      { inkName = nm,-        inkContract = ctr,-        inkTopic = tp,-        inkAccept = acc,-        inkBinds = binds,-        inkDedupeKey = dk,-        inkDedupePolicy = dp,-        inkPersist = persistence,-        inkDecode = dec,-        inkDisposition = disp,-        inkLoc = loc+      { name = nm,+        contract = ctr,+        topic = tp,+        accept = acc,+        binds = binds,+        dedupeKey = dk,+        dedupePolicy = dp,+        persist = persistence,+        decode = dec,+        disposition = disp,+        loc = loc       }   where     pBindRow = do@@ -118,7 +118,7 @@       src <- pWireSource       req <- option False (True <$ keyword "required")       xc <- option False (True <$ (keyword "cross-check" *> keyword "body"))-      pure BindRow {brField = f, brSource = src, brRequired = req, brCrossCheck = xc}+      pure BindRow {field = f, source = src, required = req, crossCheck = xc}     pWireSource =       choice         [ SrcHeader <$> (keyword "header" *> stringLit),@@ -137,7 +137,7 @@       _ <- symbol "=="       v <- boundedDecimal       _ <- symbol "}"-      pure DecodeSpec {decEnvelope = env, decBodyStrict = strict, decBodySchemaVersion = v}+      pure DecodeSpec {envelope = env, bodyStrict = strict, bodySchemaVersion = v}     pEnvelopePolicy = do       a <- wireWord       b <- wireWord@@ -151,7 +151,7 @@       o <- ident       _ <- symbol "=>"       act <- pInboxAction-      pure DispositionRow {drOutcome = o, drAction = act, drLoc = loc}+      pure DispositionRow {outcome = o, action = act, loc = loc}     pInboxAction =       choice         [ IAckOk <$ keyword "ackOk",@@ -183,17 +183,17 @@   _ <- symbol "}"   pure     EmitNode-      { emName = nm,-        emContract = ctr,-        emTopic = tp,-        emSource = src,-        emKey = k,-        emDiscriminant = disc,-        emMap = rows,-        emSkip = skip,-        emMessageId = mid,-        emIdempotencyKey = idk,-        emLoc = loc+      { name = nm,+        contract = ctr,+        topic = tp,+        source = src,+        key = k,+        discriminant = disc,+        map = rows,+        skip = skip,+        messageId = mid,+        idempotencyKey = idk,+        loc = loc       }   where     pMapRows = do@@ -205,7 +205,7 @@       v <- stringLit       _ <- symbol "=>"       ev <- ident-      pure EmitMapRow {emrValue = v, emrEvent = ev, emrLoc = loc}+      pure EmitMapRow {value = v, event = ev, loc = loc}     pDerive = do       keyword "derive"       pfx <- optional stringLit@@ -236,11 +236,11 @@   _ <- symbol "}"   pure     PublisherNode-      { pubName = nm,-        pubEmit = em,-        pubOrdering = ord,-        pubMaxAttempts = ma,-        pubBackoff = BackoffSpec {boKind = bk, boWindow = bw, boMax = bm, boMultiplier = multiplier},-        pubOutboxField = obf,-        pubLoc = loc+      { name = nm,+        emit = em,+        ordering = ord,+        maxAttempts = ma,+        backoff = BackoffSpec {kind = bk, window = bw, max = bm, multiplier = multiplier},+        outboxField = obf,+        loc = loc       }

src/Keiro/Dsl/Parser/Mapped.hs view

@@ -107,10 +107,10 @@   binding <- pNominalBindingBlock loc   pure     NominalScalarDecl-      { nominalScalarName = name,-        nominalScalarRepresentation = representation,-        nominalScalarBinding = binding,-        nominalScalarLoc = loc+      { name = name,+        representation = representation,+        binding = binding,+        loc = loc       }  pUsingNominalBinding :: P NominalBindingDecl@@ -130,13 +130,13 @@   initial <- oneClause "initial" (\case MCInitial value -> Just value; _ -> Nothing) clauses   pure     NominalBindingDecl-      { nominalHaskell = hs,-        nominalBinding = binding,-        nominalBindingVersion = bindingVersion,-        nominalCanonicalType = canonical,-        nominalFixtures = fixtures,-        nominalInitial = initial,-        nominalLoc = loc+      { haskell = hs,+        binding = binding,+        bindingVersion = bindingVersion,+        canonicalType = canonical,+        fixtures = fixtures,+        initial = initial,+        loc = loc       }  pNominalClause :: P MappedClause@@ -184,7 +184,7 @@   keyword "type"   _ <- symbol "="   typeName <- ident-  pure HaskellSource {hsPackage = packageName, hsModule = moduleName, hsType = typeName}+  pure HaskellSource {package = packageName, moduleName = moduleName, valueType = typeName}  pQuotedFact :: Text -> P Text pQuotedFact factName = keyword factName *> symbol "=" *> stringLit@@ -229,17 +229,17 @@   keyword "as"   wireKey <- stringLit   _ <- symbol ":"-  fieldType <- pMappedTypeExpr context+  valueType <- pMappedTypeExpr context   presence <- choice [PRequired <$ keyword "required", POptional <$ keyword "optional"]   onMissing <- optional (keyword "on-missing" *> symbol "=" *> pOnMissing)   pure     WireField-      { wfHaskell = haskellName,-        wfKey = wireKey,-        wfType = fieldType,-        wfPresence = presence,-        wfOnMissing = onMissing,-        wfLoc = loc+      { haskell = haskellName,+        key = wireKey,+        valueType = valueType,+        presence = presence,+        onMissing = onMissing,+        loc = loc       }  pWireEnum :: P WireEnum@@ -248,7 +248,7 @@   constructor <- ident   keyword "as"   wireTag <- stringLit-  pure WireEnum {weCtor = constructor, weTag = wireTag, weLoc = loc}+  pure WireEnum {ctor = constructor, tag = wireTag, loc = loc}  pWireArm :: FrontendContext -> P WireArm pWireArm context = do@@ -257,7 +257,7 @@   keyword "as"   wireTag <- stringLit   payload <- optional (symbol ":" *> pMappedTypeExpr context)-  pure WireArm {waCtor = constructor, waTag = wireTag, waPayload = payload, waLoc = loc}+  pure WireArm {ctor = constructor, tag = wireTag, payload = payload, loc = loc}  pMappedTypeExpr :: FrontendContext -> P TypeExpr pMappedTypeExpr context =

src/Keiro/Dsl/Parser/Preamble.hs view

@@ -23,24 +23,24 @@ contextualDiagnostic :: FilePath -> SourceLanguage -> ContextualParseFailure -> SourceLanguageDiagnostic contextualDiagnostic src sourceLanguage contextual =   SourceLanguageDiagnostic-    { sourceLanguageErrorCode = code,-      sourceLanguageSource = src,-      sourceLanguageLoc = Loc line,-      sourceLanguageToken = case code of+    { errorCode = code,+      source = src,+      loc = Loc line,+      token = case code of         LanguageFeatureRequiresVersion -> Just (languageVersionText effectiveVersion)         _ -> Nothing,-      sourceLanguageDeclaredVersion = case code of+      declaredVersion = case code of         LanguageFeatureRequiresVersion -> Just effectiveVersion         _ -> Nothing,-      sourceLanguageSupportedVersions = case contextualFailureFeature contextual of+      supportedVersions = case (.feature) contextual of         Nothing -> supportedLanguageVersions         Just feature -> case NE.nonEmpty (languageVersionsSupportingFeature feature) of           Just versions -> versions           Nothing -> supportedLanguageVersions     }   where-    code = contextualFailureCode contextual-    SourceSpan {start = SourcePoint {line}} = contextualFailureSpan contextual+    code = (.code) contextual+    SourceSpan {start = SourcePoint {line}} = (.span) contextual     effectiveVersion = effectiveLanguageVersion sourceLanguage  -- | Consume a preamble already validated by 'selectSourceLanguage'. This@@ -57,8 +57,8 @@ -- leading whitespace and comments. Body lines are left entirely to -- 'pSurfaceSpec'. data InitialLanguageClause = InitialLanguageClause-  { initialLanguageSpan :: !SourceSpan,-    initialLanguageText :: !Text+  { span :: !SourceSpan,+    text :: !Text   }  selectSourceLanguage :: FilePath -> Text -> Either FrontendFailure SourceLanguage@@ -80,23 +80,23 @@       version <- parsePreamble languageClause       case lookupLanguageDefinition version of         Nothing -> Left (sourceFailure UnsupportedLanguageVersion languageClause (Just (languageVersionText version)) (Just version))-        Just _ -> Right (DeclaredLanguage version (Loc (startLine (initialLanguageSpan languageClause))))+        Just _ -> Right (DeclaredLanguage version (Loc (startLine ((.span) languageClause))))   where     sourceFailure code line tokenText declared =       frontendFailureFromSourceDiagnostic         SourceSelectionPhase-        (initialLanguageSpan line)+        ((.span) line)         Nothing         SourceLanguageDiagnostic-          { sourceLanguageErrorCode = code,-            sourceLanguageSource = src,-            sourceLanguageLoc = Loc (startLine (initialLanguageSpan line)),-            sourceLanguageToken = tokenText,-            sourceLanguageDeclaredVersion = declared,-            sourceLanguageSupportedVersions = supportedLanguageVersions+          { errorCode = code,+            source = src,+            loc = Loc (startLine ((.span) line)),+            token = tokenText,+            declaredVersion = declared,+            supportedVersions = supportedLanguageVersions           } -    parsePreamble line = case T.words (initialLanguageText line) of+    parsePreamble line = case T.words ((.text) line) of       ["language", "keiro-dsl", tokenText]         | T.all (\c -> isAscii c && isDigit c) tokenText && not (T.null tokenText) ->             case TR.decimal tokenText :: Either String (Natural, Text) of@@ -117,4 +117,4 @@       locatedLine <- withOwnedSpan (takeWhileP (Just "language preamble") (\c -> c /= '\n' && c /= '\r'))       let rawLine = locatedValue locatedLine       let content = T.strip (T.takeWhile (/= '#') rawLine)-      pure InitialLanguageClause {initialLanguageSpan = spanOf locatedLine, initialLanguageText = content}+      pure InitialLanguageClause {span = spanOf locatedLine, text = content}

src/Keiro/Dsl/Parser/ProjectionCatalog.hs view

@@ -26,7 +26,7 @@   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}+  pure ProjectionTargetNode {name = name, schema = schema, table = table, reset = reset, dependsOn = dependsOn, loc = loc}   where     pReset = choice [TargetClear <$ keyword "clear", TargetPreserve <$ keyword "preserve"] @@ -40,7 +40,7 @@   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}+  pure RebuildGroupNode {name = name, targets = targets, order = order, loc = loc}  pProjectionRevision :: FrontendContext -> P ProjectionRevisionNode pProjectionRevision context = do@@ -52,7 +52,7 @@   group <- symbol "group" *> symbol "=" *> ident   revisionTargets <- many pRevisionTarget   _ <- symbol "}"-  pure ProjectionRevisionNode {prvName = name, prvGroup = group, prvTargets = revisionTargets, prvLoc = loc}+  pure ProjectionRevisionNode {name = name, group = group, targets = revisionTargets, loc = loc}   where     pRevisionTarget = do       _ <- keyword "target"@@ -68,14 +68,14 @@       _ <- symbol "}"       pure         RevisionTargetNode-          { prtTarget = targetName,-            prtSchemaVersion = schemaVersion,-            prtProvisioner = provisioner,-            prtProvisionerVersion = provisionerVersion,-            prtExpectedShape = expectedShape,-            prtValidator = validator,-            prtValidatorVersion = validatorVersion,-            prtPromotionObjects = promotionObjects+          { target = targetName,+            schemaVersion = schemaVersion,+            provisioner = provisioner,+            provisionerVersion = provisionerVersion,+            expectedShape = expectedShape,+            validator = validator,+            validatorVersion = validatorVersion,+            promotionObjects = promotionObjects           }     pPromotionObject = do       _ <- keyword "promotion"@@ -106,14 +106,14 @@   _ <- symbol "}"   pure     ExternalReadNode-      { erName = name,-        erVersion = version,-        erQueryModel = queryModel,-        erResultSchema = resultSchema,-        erResultType = resultType,-        erCompatibleRevisions = compatibleRevisions,-        erSurfaceGeneration = surfaceGeneration,-        erLoc = loc+      { name = name,+        version = version,+        queryModel = queryModel,+        resultSchema = resultSchema,+        resultType = resultType,+        compatibleRevisions = compatibleRevisions,+        surfaceGeneration = surfaceGeneration,+        loc = loc       }  pProjectionOwner :: FrontendContext -> P ProjectionOwnerNode@@ -135,17 +135,17 @@   _ <- 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+      { name = name,+        sources = sources,+        delivery = delivery,+        group = group,+        targets = targets,+        order = ownerOrder,+        subscription = subscription,+        dedup = dedup,+        checkpointOnMissing = checkpointOnMissing,+        replay = replay,+        loc = loc       }   where     pSource = symbol "source" *> symbol "=" *> choice [CatalogAggregate <$> (keyword "aggregate" *> ident), CatalogCategory <$> (keyword "category" *> stringLit), CatalogAll <$ keyword "all"]

src/Keiro/Dsl/Parser/Queue.hs view

@@ -46,21 +46,21 @@   _ <- symbol "}"   pure     WorkqueueNode-      { wqName = nm,-        wqLogical = logical,-        wqPhysical = phys,-        wqDlq = dlqName,-        wqTable = tbl,-        wqOrdering = ordering,-        wqGroupKey = groupKey,-        wqProvision = provision,-        wqPayloadName = pn,-        wqPayload = fields,-        wqMaxRetries = mr,-        wqDelay = dl,-        wqDlqOn = dlqOn,-        wqDisposition = disp,-        wqLoc = loc+      { name = nm,+        logical = logical,+        physical = phys,+        dlq = dlqName,+        table = tbl,+        ordering = ordering,+        groupKey = groupKey,+        provision = provision,+        payloadName = pn,+        payload = fields,+        maxRetries = mr,+        delay = dl,+        dlqOn = dlqOn,+        disposition = disp,+        loc = loc       }   where     pOrdering = do@@ -76,7 +76,7 @@       _ <- symbol "via"       via <- ident       fixture <- optional (symbol "fixture" *> stringLit)-      pure WqGroupKey {gkField = field, gkVia = via, gkFixture = fixture}+      pure WqGroupKey {field = field, via = via, fixture = fixture}     pProvision = do       _ <- symbol "provision"       choice@@ -101,7 +101,7 @@       -- 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, wqfLoc = loc}+      pure WqField {name = n, wire = w, valueType = ty, loc = loc}     pTypedPayload = do       marker <- withOwnedSpan (symbol ":")       requireLanguageFeatureAt context MappedConsumerSurfaceSyntax (spanOf marker)@@ -119,7 +119,7 @@       o <- ident       _ <- symbol "->"       act <- choice [IAckOk <$ keyword "ackOk", IRetry <$> (keyword "retry" *> pWindow), IDeadLetter <$> (keyword "deadLetter" *> optional stringLit)]-      pure WqDispRow {wqdOutcome = o, wqdAction = act, wqdLoc = loc}+      pure WqDispRow {outcome = o, action = act, loc = loc}  pPgmqDispatch :: P PgmqDispatchNode pPgmqDispatch = do@@ -152,15 +152,15 @@   _ <- symbol "}"   pure     PgmqDispatchNode-      { pdName = nm,-        pdSourceReadModel = srm,-        pdSourceKey = sk,-        pdFanoutBody = fb,-        pdDedupKey = dk,-        pdDedupReadModel = drm,-        pdDedupReadModelField = drmf,-        pdDedupQueue = dq,-        pdDedupQueueField = dqf,-        pdEnqueueTo = enq,-        pdLoc = loc+      { name = nm,+        sourceReadModel = srm,+        sourceKey = sk,+        fanoutBody = fb,+        dedupKey = dk,+        dedupReadModel = drm,+        dedupReadModelField = drmf,+        dedupQueue = dq,+        dedupQueueField = dqf,+        enqueueTo = enq,+        loc = loc       }

src/Keiro/Dsl/Parser/ReadModel.hs view

@@ -52,19 +52,19 @@   _ <- symbol "}"   pure     ReadModelNode-      { rmName = name,-        rmTable = table,-        rmSchema = schema,-        rmColumns = columns,-        rmVersion = version,-        rmShape = shape,-        rmFreshness = freshness,-        rmSupply = supply,-        rmGroup = group,-        rmObservedTargets = observedTargets,-        rmBackingTarget = backingTarget,+      { name = name,+        table = table,+        schema = schema,+        columns = columns,+        version = version,+        shape = shape,+        freshness = freshness,+        supply = supply,+        group = group,+        observedTargets = observedTargets,+        backingTarget = backingTarget,         queryTypes,-        rmLoc = loc+        loc = loc       }   where     pColumn =

src/Keiro/Dsl/Parser/Workflow.hs view

@@ -19,7 +19,7 @@   nm <- stringLit   keyword "in"   inTy <- ident-  inFields <- option [] (braces (many pField))+  fields <- option [] (braces (many pField))   keyword "out"   outTy <- ident   keyword "id"@@ -32,15 +32,15 @@   body <- many pWfBodyItem   pure     WorkflowNode-      { wfId = wid,-        wfStable = nm,-        wfInput = inTy,-        wfInputFields = inFields,-        wfOutput = outTy,-        wfIdField = idField,-        wfIdVia = idVia,-        wfBody = body,-        wfLoc = loc+      { id = wid,+        stable = nm,+        input = inTy,+        inputFields = fields,+        output = outTy,+        idField = idField,+        idVia = idVia,+        body = body,+        loc = loc       }   where     pWfBodyItem =@@ -84,7 +84,7 @@         pSignalOp,         pRunOp       ]-  pure OperationNode {opName = nm, opShape = shape, opLoc = loc}+  pure OperationNode {name = nm, shape = shape, loc = loc}   where     pCommandOp = do       keyword "command"

src/Keiro/Dsl/PrettyPrint.hs view

@@ -31,7 +31,7 @@  -- | Render a source while preserving whether it explicitly declared a version. renderSource :: ParsedSource -> Text-renderSource ParsedSource {parsedSourceLanguage = sourceLanguage, parsedSpec = spec} =+renderSource ParsedSource {sourceLanguage = sourceLanguage, spec = spec} =   case sourceLanguage of     LegacyUnversioned -> renderSpec spec     DeclaredLanguage {declaredLanguageVersion = version} ->@@ -48,7 +48,7 @@  renderTimerPayloadSurface :: TimerNode -> Text renderTimerPayloadSurface timer =-  renderDoc ("payload" <+> braced (map docFieldBinding (tmPayload timer)))+  renderDoc ("payload" <+> braced (map docFieldBinding ((.payload) timer)))  renderTypeExpr :: TypeExpr -> Text renderTypeExpr = renderDoc . docTypeExpr@@ -59,21 +59,21 @@ docSpec :: Spec -> Doc ann docSpec s =   vsep $-    ["context" <+> pretty (specContext s)]-      ++ maybe [] (\r -> ["module" <+> pretty r]) (specModuleRoot s)-      ++ maybe [] (\l -> ["layout" <+> docLayout l]) (specLayout s)+    ["context" <+> pretty ((.context) s)]+      ++ maybe [] (\r -> ["module" <+> pretty r]) ((.moduleRoot) s)+      ++ maybe [] (\l -> ["layout" <+> docLayout l]) ((.layout) s)       ++ [mempty]-      ++ map docId (specIds s)-      ++ blankAfter (specIds s)-      ++ map docEnum (specEnums s)-      ++ blankAfter (specEnums s)-      ++ map docRule (specRules s)-      ++ blankAfter (specRules s)-      ++ map docNominalScalar (specNominalScalars s)-      ++ blankAfter (specNominalScalars s)-      ++ map docMapped (specMapped s)-      ++ blankAfter (specMapped s)-      ++ map docNode (specNodes s)+      ++ map docId ((.ids) s)+      ++ blankAfter ((.ids) s)+      ++ map docEnum ((.enums) s)+      ++ blankAfter ((.enums) s)+      ++ map docRule ((.rules) s)+      ++ blankAfter ((.rules) s)+      ++ map docNominalScalar ((.nominalScalars) s)+      ++ blankAfter ((.nominalScalars) s)+      ++ map docMapped ((.mapped) s)+      ++ blankAfter ((.mapped) s)+      ++ map docNode ((.nodes) s)   where     blankAfter xs = if null xs then [] else [mempty] @@ -83,17 +83,17 @@  docId :: IdDecl -> Doc ann docId d =-  case idBinding d of-    Nothing -> "id" <+> pretty (idName d) <+> ("prefix=" <> pretty (idPrefix d))+  case (.binding) d of+    Nothing -> "id" <+> pretty ((.name) d) <+> ("prefix=" <> pretty ((.prefix) d))     Just binding ->       vsep $-        ["id" <+> pretty (idName d) <+> ("prefix=" <> pretty (idPrefix d)) <+> "using" <+> "{"]+        ["id" <+> pretty ((.name) d) <+> ("prefix=" <> pretty ((.prefix) d)) <+> "using" <+> "{"]           ++ map (indent 2) (docNominalBindingFacts binding)           ++ ["}"]  docEnum :: EnumDecl -> Doc ann docEnum d =-  case enumBinding d of+  case (.binding) d of     Nothing -> enumHeader     Just binding ->       vsep $@@ -101,14 +101,14 @@           ++ map (indent 2) (docNominalBindingFacts binding)           ++ ["}"]   where-    enumHeader = "enum" <+> pretty (enumName d) <+> braced (map ctor (enumCtors d))+    enumHeader = "enum" <+> pretty ((.name) d) <+> braced (map ctor ((.ctors) d))     ctor (c, w) = pretty c <> "=" <> pretty w  docRule :: RuleDecl -> Doc ann docRule d =   vsep-    [ "rule" <+> pretty (ruleName d) <+> ":" <+> pretty (ruleDomain d) <+> "->" <+> pretty (ruleCodomain d),-      indent 2 ("ex" <+> hsep (punctuate " ;" (map cas (ruleCases d))))+    [ "rule" <+> pretty ((.name) d) <+> ":" <+> pretty ((.domain) d) <+> "->" <+> pretty ((.codomain) d),+      indent 2 ("ex" <+> hsep (punctuate " ;" (map cas ((.cases) d))))     ]   where     cas (c, e) = pretty c <+> "=>" <+> docExpr 0 e@@ -138,22 +138,22 @@ docNominalScalar declaration =   vsep $     [ "mapped nominal"-        <+> pretty (nominalScalarName declaration)+        <+> pretty ((.name) declaration)         <+> ":"-        <+> pretty (nominalScalarRepresentation declaration)+        <+> pretty ((.representation) declaration)         <+> "{"     ]-      ++ map (indent 2) (docNominalBindingFacts (nominalScalarBinding declaration))+      ++ map (indent 2) (docNominalBindingFacts ((.binding) declaration))       ++ ["}"]  docNominalBindingFacts :: NominalBindingDecl -> [Doc ann] docNominalBindingFacts binding =-  maybe [] (pure . docHaskellSource) (nominalHaskell binding)-    ++ maybe [] (pure . docQuotedFact "binding") (nominalBinding binding)-    ++ maybe [] (pure . docQuotedFact "binding-version") (nominalBindingVersion binding)-    ++ maybe [] (pure . docQuotedFact "canonical-type") (nominalCanonicalType binding)-    ++ maybe [] (pure . docQuotedFact "fixtures") (nominalFixtures binding)-    ++ maybe [] (pure . docQuotedFact "initial") (nominalInitial binding)+  maybe [] (pure . docHaskellSource) ((.haskell) binding)+    ++ maybe [] (pure . docQuotedFact "binding") ((.binding) binding)+    ++ maybe [] (pure . docQuotedFact "binding-version") ((.bindingVersion) binding)+    ++ maybe [] (pure . docQuotedFact "canonical-type") ((.canonicalType) binding)+    ++ maybe [] (pure . docQuotedFact "fixtures") ((.fixtures) binding)+    ++ maybe [] (pure . docQuotedFact "initial") ((.initial) binding)  docShapeKind :: MappedShape -> Doc ann docShapeKind (ShapeRecord _ _ _) = "record"@@ -163,9 +163,9 @@ docHaskellSource :: HaskellSource -> Doc ann docHaskellSource source =   "haskell"-    <+> ("package=" <> pretty (hsPackage source))-    <+> ("module=" <> pretty (hsModule source))-    <+> ("type=" <> pretty (hsType source))+    <+> ("package=" <> pretty ((.package) source))+    <+> ("module=" <> pretty ((.moduleName) source))+    <+> ("type=" <> pretty ((.valueType) source))  docQuotedFact :: Doc ann -> Text -> Doc ann docQuotedFact label value = label <+> "=" <+> dquoted value@@ -185,9 +185,9 @@ docMappedShape (ShapeUnion encoding arms) =   vsep $     [ "wire tagged-object"-        <+> ("tag=" <> dquoted (ueTagField encoding))-        <+> ("contents=" <> dquoted (ueContentsField encoding))-        <+> ("unknown-fields=" <> docUnknownFields (ueUnknownFields encoding))+        <+> ("tag=" <> dquoted ((.tagField) encoding))+        <+> ("contents=" <> dquoted ((.contentsField) encoding))+        <+> ("unknown-fields=" <> docUnknownFields ((.unknownFields) encoding))         <+> "{"     ]       ++ map (indent 2 . docWireArm) arms@@ -199,13 +199,13 @@  docWireField :: WireField -> Doc ann docWireField field =-  pretty (wfHaskell field)+  pretty ((.haskell) field)     <+> "as"-    <+> dquoted (wfKey field)+    <+> dquoted ((.key) field)     <+> ":"-    <+> docTypeExpr (wfType field)-    <+> docPresence (wfPresence field)-    <> maybe mempty (\value -> " on-missing=" <> docOnMissing value) (wfOnMissing field)+    <+> docTypeExpr ((.valueType) field)+    <+> docPresence ((.presence) field)+    <> maybe mempty (\value -> " on-missing=" <> docOnMissing value) ((.onMissing) field)  docPresence :: Presence -> Doc ann docPresence PRequired = "required"@@ -222,14 +222,14 @@ docOnMissing (OmCtor constructor) = pretty constructor  docWireEnum :: WireEnum -> Doc ann-docWireEnum entry = pretty (weCtor entry) <+> "as" <+> dquoted (weTag entry)+docWireEnum entry = pretty ((.ctor) entry) <+> "as" <+> dquoted ((.tag) entry)  docWireArm :: WireArm -> Doc ann docWireArm arm =-  pretty (waCtor arm)+  pretty ((.ctor) arm)     <+> "as"-    <+> dquoted (waTag arm)-    <> maybe mempty (\payload -> " : " <> docTypeExpr payload) (waPayload arm)+    <+> dquoted ((.tag) arm)+    <> maybe mempty (\payload -> " : " <> docTypeExpr payload) ((.payload) arm)  docTypeExpr :: TypeExpr -> Doc ann docTypeExpr TText = "Text"@@ -272,16 +272,16 @@ docWorkflow :: WorkflowNode -> Doc ann docWorkflow w =   vsep $-    [ "workflow" <+> pretty (wfId w),-      indent 2 ("name" <+> dquoted (wfStable w)),-      indent 2 ("in" <+> pretty (wfInput w) <> inFieldsDoc),-      indent 2 ("out" <+> pretty (wfOutput w)),-      indent 2 ("id from input" <> maybe mempty (\f -> "." <> pretty f) (wfIdField w) <+> "via" <+> pretty (wfIdVia w)),+    [ "workflow" <+> pretty ((.id) w),+      indent 2 ("name" <+> dquoted ((.stable) w)),+      indent 2 ("in" <+> pretty ((.input) w) <> inFieldsDoc),+      indent 2 ("out" <+> pretty ((.output) w)),+      indent 2 ("id from input" <> maybe mempty (\f -> "." <> pretty f) ((.idField) w) <+> "via" <+> pretty ((.idVia) w)),       indent 2 "body"     ]-      ++ map (indent 4 . bodyItem) (wfBody w)+      ++ map (indent 4 . bodyItem) ((.body) w)   where-    inFieldsDoc = case wfInputFields w of+    inFieldsDoc = case (.inputFields) w of       [] -> mempty       fs -> " " <> braced (map docField fs)     bodyItem (WfStep l r _) = "step" <+> pretty l <+> "->" <+> pretty r@@ -294,7 +294,7 @@  docOperation :: OperationNode -> Doc ann docOperation o =-  vsep $ ["operation" <+> pretty (opName o)] ++ map (indent 2) (shapeLines (opShape o))+  vsep $ ["operation" <+> pretty ((.name) o)] ++ map (indent 2) (shapeLines ((.shape) o))   where     shapeLines (CommandOp agg sf sv proj) =       [ "command on" <+> pretty agg,@@ -321,52 +321,52 @@ docWorkqueue :: WorkqueueNode -> Doc ann docWorkqueue w =   vsep $-    [ "workqueue" <+> pretty (wqName w) <+> "{",-      indent 2 ("queue logical =" <+> dquoted (wqLogical w)),-      indent 2 ("derive physical =" <+> dquoted (wqPhysical w)),-      indent 4 ("dlq =" <+> dquoted (wqDlq w)),-      indent 4 ("table =" <+> dquoted (wqTable w))+    [ "workqueue" <+> pretty ((.name) w) <+> "{",+      indent 2 ("queue logical =" <+> dquoted ((.logical) w)),+      indent 2 ("derive physical =" <+> dquoted ((.physical) w)),+      indent 4 ("dlq =" <+> dquoted ((.dlq) w)),+      indent 4 ("table =" <+> dquoted ((.table) w))     ]       ++ orderingLines       ++ groupKeyLines       ++ provisionLines-      ++ [indent 2 ("payload" <+> pretty (wqPayloadName w) <+> "{")]-      ++ map (indent 4 . field) (wqPayload w)+      ++ [indent 2 ("payload" <+> pretty ((.payloadName) w) <+> "{")]+      ++ map (indent 4 . field) ((.payload) w)       ++ [ indent 2 "}",-           indent 2 ("retry maxRetries =" <+> pretty (wqMaxRetries w) <+> "delay =" <+> pretty (wqDelay w) <+> "dlq =" <+> (if wqDlqOn w then "on" else "off")),+           indent 2 ("retry maxRetries =" <+> pretty ((.maxRetries) w) <+> "delay =" <+> pretty ((.delay) w) <+> "dlq =" <+> (if (.dlqOn) w then "on" else "off")),            indent 2 "disposition {"          ]-      ++ map (indent 4 . dispRow) (wqDisposition w)+      ++ map (indent 4 . dispRow) ((.disposition) w)       ++ [indent 2 "}", "}"]   where-    orderingLines = case wqOrdering w of+    orderingLines = case (.ordering) w of       WqUnordered -> []       WqFifoThroughput -> [indent 2 "ordering fifo-throughput"]       WqFifoRoundRobin -> [indent 2 "ordering fifo-roundrobin"]-    groupKeyLines = case wqGroupKey w of+    groupKeyLines = case (.groupKey) w of       Nothing -> []       Just groupKey ->         [ indent 2 $             "group key from"-              <+> pretty (gkField groupKey)+              <+> pretty ((.field) groupKey)               <+> "via"-              <+> pretty (gkVia groupKey)-              <> maybe mempty (\fixture -> " fixture " <> dquoted fixture) (gkFixture groupKey)+              <+> pretty ((.via) groupKey)+              <> maybe mempty (\fixture -> " fixture " <> dquoted fixture) ((.fixture) groupKey)         ]-    provisionLines = case wqProvision w of+    provisionLines = case (.provision) w of       WqStandard -> []       WqUnlogged -> [indent 2 "provision unlogged"]       WqPartitioned interval retention ->         [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) <+> docQueuePayloadType (wqfType f) <> " required"+    field f = pretty ((.name) f) <+> "->" <+> dquoted ((.wire) f) <+> docQueuePayloadType ((.valueType) 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)+    dispRow r = pretty ((.outcome) r) <+> "->" <+> act ((.action) r)     act IAckOk = "ackOk"     act (IRetry win) = "retry" <+> pretty win     act (IDeadLetter Nothing) = "deadLetter"@@ -375,56 +375,56 @@ docPgmqDispatch :: PgmqDispatchNode -> Doc ann docPgmqDispatch d =   vsep-    [ "dispatch" <+> pretty (pdName d) <+> "{",-      indent 2 ("source readModel =" <+> pretty (pdSourceReadModel d) <+> "key =" <+> pretty (pdSourceKey d)),-      indent 2 ("fanout body =" <+> pretty (pdFanoutBody d)),-      indent 2 ("dedup key =" <+> pretty (pdDedupKey d)),-      indent 4 ("seenIn readModel =" <+> pretty (pdDedupReadModel d) <+> "field =" <+> pretty (pdDedupReadModelField d)),-      indent 4 ("seenIn queue =" <+> pretty (pdDedupQueue d) <+> "field =" <+> pretty (pdDedupQueueField d)),-      indent 2 ("enqueue to =" <+> pretty (pdEnqueueTo d)),+    [ "dispatch" <+> pretty ((.name) d) <+> "{",+      indent 2 ("source readModel =" <+> pretty ((.sourceReadModel) d) <+> "key =" <+> pretty ((.sourceKey) d)),+      indent 2 ("fanout body =" <+> pretty ((.fanoutBody) d)),+      indent 2 ("dedup key =" <+> pretty ((.dedupKey) d)),+      indent 4 ("seenIn readModel =" <+> pretty ((.dedupReadModel) d) <+> "field =" <+> pretty ((.dedupReadModelField) d)),+      indent 4 ("seenIn queue =" <+> pretty ((.dedupQueue) d) <+> "field =" <+> pretty ((.dedupQueueField) d)),+      indent 2 ("enqueue to =" <+> pretty ((.enqueueTo) d)),       "}"     ]  docReadModel :: ReadModelNode -> Doc ann docReadModel readModel =   vsep $-    ["readmodel" <+> pretty (rmName readModel) <+> "{"]-      ++ ( if not (T.null (rmTable readModel)) || not (T.null (rmSchema readModel))+    ["readmodel" <+> pretty ((.name) readModel) <+> "{"]+      ++ ( if not (T.null ((.table) readModel)) || not (T.null ((.schema) readModel))              then-               [ indent 2 ("table =" <+> dquoted (rmTable readModel)),-                 indent 2 ("schema =" <+> dquoted (rmSchema readModel))+               [ indent 2 ("table =" <+> dquoted ((.table) readModel)),+                 indent 2 ("schema =" <+> dquoted ((.schema) readModel))                ]              else []          )       ++ [indent 2 "columns {"]-      ++ map (indent 4 . docColumn) (rmColumns readModel)+      ++ map (indent 4 . docColumn) ((.columns) readModel)       ++ [indent 2 "}"]-      ++ maybe [] docQueryTypes (queryTypes readModel)-      ++ [ indent 2 ("version =" <+> pretty (rmVersion readModel)),-           indent 2 ("shape =" <+> dquoted (rmShape readModel))+      ++ maybe [] docQueryTypes ((.queryTypes) readModel)+      ++ [ indent 2 ("version =" <+> pretty ((.version) readModel)),+           indent 2 ("shape =" <+> dquoted ((.shape) 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)+      ++ maybe [] (pure . indent 2 . ("group =" <+>) . pretty) ((.group) readModel)+      ++ [indent 2 ("targets =" <+> bracketed (map pretty ((.observedTargets) readModel))) | (.group) readModel /= Nothing]+      ++ maybe [] (pure . indent 2 . ("backing =" <+>) . pretty) ((.backingTarget) readModel)       ++ ["}"]   where     docColumn columnDecl =-      pretty (rmcName columnDecl)-        <+> pretty (rmcType columnDecl)-        <> if rmcRequired columnDecl then " required" else mempty+      pretty ((.rmcName) columnDecl)+        <+> pretty ((.rmcType) columnDecl)+        <> if (.rmcRequired) columnDecl then " required" else mempty     docScope RmEntireLog = "entire-log"     docScope (RmCategory categoryName) = "category" <+> dquoted categoryName     docFeed RmInline = "inline"     docFeed RmSubscription = "subscription"-    policyLines = case rmSupply readModel of+    policyLines = case (.supply) 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))]+        [indent 2 ("freshness =" <+> docFreshness ((.freshness) readModel))]     docFreshness FreshnessImmediate = "immediate"     docFreshness (FreshnessWaitForHead scope) = "wait-for-head" <+> docScope scope     docQueryTypes ReadModelQueryTypes {input, result} =@@ -435,82 +435,82 @@ 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")+    [ "target" <+> pretty ((.name) target) <+> "{",+      indent 2 ("schema =" <+> dquoted ((.schema) target)),+      indent 2 ("table =" <+> dquoted ((.table) target)),+      indent 2 ("reset =" <+> case (.reset) target of TargetClear -> "clear"; TargetPreserve -> "preserve")     ]-      ++ [indent 2 ("depends-on =" <+> bracketed (map pretty (ptDependsOn target))) | not (null (ptDependsOn target))]+      ++ [indent 2 ("depends-on =" <+> bracketed (map pretty ((.dependsOn) target))) | not (null ((.dependsOn) 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))),+    [ "rebuild-group" <+> pretty ((.name) groupNode) <+> "{",+      indent 2 ("targets =" <+> bracketed (map pretty ((.targets) groupNode))),+      indent 2 ("order =" <+> bracketed (map pretty ((.order) groupNode))),       "}"     ]  docProjectionRevision :: ProjectionRevisionNode -> Doc ann docProjectionRevision revision =   vsep $-    [ "projection-revision" <+> pretty (prvName revision) <+> "{",-      indent 2 ("group =" <+> pretty (prvGroup revision))+    [ "projection-revision" <+> pretty ((.name) revision) <+> "{",+      indent 2 ("group =" <+> pretty ((.group) revision))     ]-      <> concatMap (pure . indent 2 . docRevisionTarget) (prvTargets revision)+      <> concatMap (pure . indent 2 . docRevisionTarget) ((.targets) 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))+        [ "target" <+> pretty ((.target) target) <+> "{",+          indent 2 ("schema-version =" <+> dquoted ((.schemaVersion) target)),+          indent 2 ("provisioner =" <+> dquoted ((.provisioner) target)),+          indent 2 ("provisioner-version =" <+> pretty ((.provisionerVersion) target)),+          indent 2 ("expected-shape =" <+> dquoted ((.expectedShape) target)),+          indent 2 ("validator =" <+> dquoted ((.validator) target)),+          indent 2 ("validator-version =" <+> pretty ((.validatorVersion) target))         ]-          <> map (indent 2 . docPromotionObject) (prtPromotionObjects target)+          <> map (indent 2 . docPromotionObject) ((.promotionObjects) target)           <> ["}"]     docPromotionObject promotionObject =       "promotion"-        <+> ( case rpoKind promotionObject of+        <+> ( case (.kind) promotionObject of                 PromotionIndexNode -> "index"                 PromotionConstraintNode -> "constraint"                 PromotionOwnedSequenceNode -> "owned-sequence"             )-        <+> dquoted (rpoGenerationName promotionObject)+        <+> dquoted ((.generationName) promotionObject)         <+> "->"-        <+> dquoted (rpoCanonicalName promotionObject)+        <+> dquoted ((.canonicalName) 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)),+    [ "external-read" <+> pretty ((.name) externalRead) <+> "{",+      indent 2 ("version =" <+> pretty ((.version) externalRead)),+      indent 2 ("query =" <+> pretty ((.queryModel) externalRead)),+      indent 2 ("result-schema =" <+> dquoted ((.resultSchema) externalRead)),+      indent 2 ("result-type =" <+> dquoted ((.resultType) externalRead)),+      indent 2 ("compatible-revisions =" <+> bracketed (map pretty ((.compatibleRevisions) externalRead))),+      indent 2 ("surface-generation =" <+> pretty ((.surfaceGeneration) 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))+    ["projection-owner" <+> pretty ((.name) owner) <+> "{"]+      ++ map (indent 2 . ("source =" <+>) . docSource) ((.sources) owner)+      ++ [ indent 2 ("delivery =" <+> case (.delivery) owner of DeliveryInline -> "inline"; DeliverySubscription -> "subscription"),+           indent 2 ("group =" <+> pretty ((.group) owner)),+           indent 2 ("targets =" <+> bracketed (map pretty ((.targets) owner))),+           indent 2 ("order =" <+> pretty ((.order) 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)), "}"]+      ++ maybe [] (pure . indent 2 . ("subscription =" <+>) . dquoted) ((.subscription) owner)+      ++ maybe [] (pure . indent 2 . ("dedup =" <+>) . dquoted) ((.dedup) owner)+      ++ map (indent 2 . ("checkpoint-on-missing =" <+>) . docCheckpointOnMissing) ((.checkpointOnMissing) owner)+      ++ [indent 2 ("replay =" <+> docReplay ((.replay) owner)), "}"]   where     docSource (CatalogAggregate aggregateName) = "aggregate" <+> pretty aggregateName     docSource (CatalogCategory categoryName) = "category" <+> dquoted categoryName@@ -524,61 +524,61 @@ docEmit :: EmitNode -> Doc ann docEmit e =   vsep $-    [ "emit" <+> pretty (emName e) <+> "{",-      indent 2 ("contract" <+> pretty (emContract e)),-      indent 2 ("topic" <+> pretty (emTopic e)),-      indent 2 ("source" <+> dquoted (emSource e)),-      indent 2 ("key" <+> pretty (emKey e)),-      indent 2 ("map" <+> pretty (emDiscriminant e) <+> "{")+    [ "emit" <+> pretty ((.name) e) <+> "{",+      indent 2 ("contract" <+> pretty ((.contract) e)),+      indent 2 ("topic" <+> pretty ((.topic) e)),+      indent 2 ("source" <+> dquoted ((.source) e)),+      indent 2 ("key" <+> pretty ((.key) e)),+      indent 2 ("map" <+> pretty ((.discriminant) e) <+> "{")     ]-      ++ map (indent 4 . row) (emMap e)-      ++ [indent 4 "_ => skip" | emSkip e]+      ++ map (indent 4 . row) ((.map) e)+      ++ [indent 4 "_ => skip" | (.skip) e]       ++ [ indent 2 "}",-           indent 2 ("messageId" <+> docDerive (emMessageId e)),-           indent 2 ("idempotencyKey" <+> docDerive (emIdempotencyKey e)),+           indent 2 ("messageId" <+> docDerive ((.messageId) e)),+           indent 2 ("idempotencyKey" <+> docDerive ((.idempotencyKey) e)),            "}"          ]   where-    row r = dquoted (emrValue r) <+> "=>" <+> pretty (emrEvent r)-    docDerive d = "derive" <> maybe mempty (\p -> " " <> dquoted p) (dsPrefix d) <+> "hole"+    row r = dquoted ((.value) r) <+> "=>" <+> pretty ((.event) r)+    docDerive d = "derive" <> maybe mempty (\p -> " " <> dquoted p) ((.dsPrefix) d) <+> "hole"  docPublisher :: PublisherNode -> Doc ann docPublisher p =   vsep-    [ "publisher" <+> pretty (pubName p) <+> "{",-      indent 2 ("emit" <+> pretty (pubEmit p)),-      indent 2 ("ordering" <+> pretty (pubOrdering p)),-      indent 2 ("maxAttempts" <+> pretty (pubMaxAttempts p)),-      indent 2 (docBackoff (pubBackoff p)),-      indent 2 ("outboxId stable from" <+> pretty (pubOutboxField p)),+    [ "publisher" <+> pretty ((.name) p) <+> "{",+      indent 2 ("emit" <+> pretty ((.emit) p)),+      indent 2 ("ordering" <+> pretty ((.ordering) p)),+      indent 2 ("maxAttempts" <+> pretty ((.maxAttempts) p)),+      indent 2 (docBackoff ((.backoff) p)),+      indent 2 ("outboxId stable from" <+> pretty ((.outboxField) p)),       "}"     ]  docIntake :: IntakeNode -> Doc ann docIntake i =   vsep $-    [ "intake" <+> pretty (inkName i) <+> "{",-      indent 2 ("contract" <+> pretty (inkContract i)),-      indent 2 ("topic" <+> pretty (inkTopic i)),-      indent 2 ("accept" <+> hsep (map pretty (inkAccept i)))+    [ "intake" <+> pretty ((.name) i) <+> "{",+      indent 2 ("contract" <+> pretty ((.contract) i)),+      indent 2 ("topic" <+> pretty ((.topic) i)),+      indent 2 ("accept" <+> hsep (map pretty ((.accept) i)))     ]-      ++ map (indent 2 . docBind) (inkBinds i)-      ++ [ indent 2 ("dedupe key" <+> pretty (inkDedupeKey i) <+> "policy" <+> pretty (inkDedupePolicy i))+      ++ map (indent 2 . docBind) ((.binds) i)+      ++ [ indent 2 ("dedupe key" <+> pretty ((.dedupeKey) i) <+> "policy" <+> pretty ((.dedupePolicy) i))          ]-      ++ [indent 2 "persist = dedupe-only" | inkPersist i == InkPersistDedupeOnly]-      ++ [ indent 2 (docDecode (inkDecode i)),+      ++ [indent 2 "persist = dedupe-only" | (.persist) i == InkPersistDedupeOnly]+      ++ [ indent 2 (docDecode ((.decode) i)),            indent 2 "disposition {"          ]-      ++ map (indent 4 . docDispRow) (inkDisposition i)+      ++ map (indent 4 . docDispRow) ((.disposition) i)       ++ [indent 2 "}", "}"]   where     docBind b =       "bind"-        <+> pretty (brField b)+        <+> pretty ((.field) b)         <+> "from"-        <+> docSource (brSource b)-        <> (if brRequired b then " required" else mempty)-        <> (if brCrossCheck b then " cross-check body" else mempty)+        <+> docSource ((.source) b)+        <> (if (.required) b then " required" else mempty)+        <> (if (.crossCheck) b then " cross-check body" else mempty)     docSource (SrcHeader h) = "header" <+> dquoted h     docSource SrcBody = "body"     docSource SrcKafkaKey = "kafka-key"@@ -586,11 +586,11 @@     docDecode d =       vsep         [ "decode {",-          indent 2 ("envelope" <+> pretty (decEnvelope d)),-          indent 2 ("body" <+> (if decBodyStrict d then "strict" else "lenient") <+> "schemaVersion ==" <+> pretty (decBodySchemaVersion d)),+          indent 2 ("envelope" <+> pretty ((.envelope) d)),+          indent 2 ("body" <+> (if (.bodyStrict) d then "strict" else "lenient") <+> "schemaVersion ==" <+> pretty ((.bodySchemaVersion) d)),           "}"         ]-    docDispRow r = pretty (drOutcome r) <+> "=>" <+> docAction (drAction r)+    docDispRow r = pretty ((.outcome) r) <+> "=>" <+> docAction ((.action) r)     docAction IAckOk = "ackOk"     docAction (IRetry w) = "retry" <+> pretty w     docAction (IDeadLetter Nothing) = "deadLetter"@@ -603,28 +603,28 @@ docContract :: ContractNode -> Doc ann docContract c =   vsep $-    [ "contract" <+> pretty (ctrName c) <+> "{",-      indent 2 ("schemaVersion" <+> pretty (ctrSchemaVersion c)),-      indent 2 ("discriminator" <+> pretty (ctrDiscriminator c))+    [ "contract" <+> pretty ((.name) c) <+> "{",+      indent 2 ("schemaVersion" <+> pretty ((.schemaVersion) c)),+      indent 2 ("discriminator" <+> pretty ((.discriminator) c))     ]-      ++ map (indent 2 . docTopic) (ctrTopics c)-      ++ map (indent 2 . docContractEvent) (ctrEvents c)+      ++ map (indent 2 . docTopic) ((.topics) c)+      ++ map (indent 2 . docContractEvent) ((.events) c)       ++ ["}"]   where     docTopic (alias, t) = "topic" <+> pretty alias <+> dquoted t     docContractEvent e =       vsep $-        ["event" <+> pretty (ceName e) <+> "on" <+> pretty (ceTopic e) <+> "{"]-          ++ map (indent 2 . docContractField) (ceFields e)+        ["event" <+> pretty ((.name) e) <+> "on" <+> pretty ((.topic) e) <+> "{"]+          ++ map (indent 2 . docContractField) ((.fields) e)           ++ ["}"]     docContractField f =       hsep-        ( [pretty (cfName f)]-            ++ maybe [] (\selector -> ["haskell", pretty selector]) (cfSelector f)-            ++ maybe [] (\wireKey -> ["as", dquoted wireKey]) (cfWireKey f)+        ( [pretty ((.name) f)]+            ++ maybe [] (\selector -> ["haskell", pretty selector]) ((.selector) f)+            ++ maybe [] (\wireKey -> ["as", dquoted wireKey]) ((.wireKey) f)         )         <> ":"-        <+> docContractType (cfType f)+        <+> docContractType ((.valueType) f)     docContractType (CTypeId p) = "typeid" <+> dquoted p     docContractType CText = "text"     docContractType CInt = "int"@@ -636,74 +636,74 @@ docProcess :: ProcessNode -> Doc ann docProcess p =   vsep-    [ "process" <+> pretty (procId p),-      indent 2 ("name" <+> dquoted (procName p)),-      indent 2 (docInput (procInput p)),-      indent 2 (docCorrelate (procCorrelate p)),-      indent 2 (docSaga (procSaga p)),-      indent 2 ("target" <+> pretty (procTarget p)),-      indent 2 ("projections" <+> bracketed (map pretty (procProjections p))),+    [ "process" <+> pretty ((.id) p),+      indent 2 ("name" <+> dquoted ((.name) p)),+      indent 2 (docInput ((.input) p)),+      indent 2 (docCorrelate ((.correlate) p)),+      indent 2 (docSaga ((.saga) p)),+      indent 2 ("target" <+> pretty ((.target) p)),+      indent 2 ("projections" <+> bracketed (map pretty ((.projections) p))),       mempty,-      indent 2 (docHandle (procHandle p)),+      indent 2 (docHandle ((.handle) p)),       mempty,       indent 2 "dispatch-id strategy=uuidv5 from=(name, correlationId, sourceEventId, emitIndex)",-      indent 2 ("rejected =>" <+> docPolicyChoice (procRejected p)),-      indent 2 ("poison =>" <+> docPolicyChoice (procPoison p)),+      indent 2 ("rejected =>" <+> docPolicyChoice ((.rejected) p)),+      indent 2 ("poison =>" <+> docPolicyChoice ((.poison) p)),       mempty,-      indent 2 (docTimer (procTimer p))+      indent 2 (docTimer ((.timer) p))     ]  docRouter :: RouterNode -> Doc ann docRouter r =   vsep-    [ "router" <+> pretty (rtId r),-      indent 2 ("name" <+> dquoted (rtName r)),-      indent 2 (docInput (rtInput 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))),-      indent 2 (docRouterDispatch (rtDispatch r)),+    [ "router" <+> pretty ((.id) r),+      indent 2 ("name" <+> dquoted ((.name) r)),+      indent 2 (docInput ((.input) r)),+      indent 2 (docRouterKey (isDeclarativeResolve ((.resolve) r)) ((.key) r)),+      indent 2 (docResolve ((.resolve) r)),+      indent 2 ("target" <+> pretty ((.target) r)),+      indent 2 ("projections" <+> bracketed (map pretty ((.projections) r))),+      indent 2 (docRouterDispatch ((.dispatch) r)),       indent 2 "dispatch-id strategy=uuidv5 from=(name, key, sourceEventId, targetStreamName, occurrence)",-      indent 2 ("rejected =>" <+> docPolicyChoice (rtRejected r)),-      indent 2 ("poison =>" <+> docPolicyChoice (rtPoison r))+      indent 2 ("rejected =>" <+> docPolicyChoice ((.rejected) r)),+      indent 2 ("poison =>" <+> docPolicyChoice ((.poison) r))     ]  docRouterKey :: Bool -> CorrelateDecl -> Doc ann docRouterKey declarative key-  | declarative = "key" <+> ("input." <> pretty (corrField key))-  | otherwise = "key" <+> ("input." <> pretty (corrField key)) <+> "via" <+> pretty (corrVia key)+  | declarative = "key" <+> ("input." <> pretty ((.field) key))+  | otherwise = "key" <+> ("input." <> pretty ((.field) key)) <+> "via" <+> pretty ((.via) key)  isDeclarativeResolve :: ResolveDecl -> Bool-isDeclarativeResolve resolve = case rvSource resolve of+isDeclarativeResolve resolve = case (.source) resolve of   ResolveDeclarative {} -> True   _ -> False  docResolve :: ResolveDecl -> Doc ann-docResolve resolve = case rvSource resolve of+docResolve resolve = case (.source) 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))+          indent 2 ("identity =" <+> dquoted ((.identity) selection)),+          indent 2 ("version =" <+> pretty ((.version) selection)),+          indent 2 ("query = read-model" <+> pretty ((.query) selection) <+> "with" <+> pretty ((.queryInput) selection)),+          indent 2 ("where =" <+> docExpr 0 ((.predicate) selection)),+          indent 2 ("recipient =" <+> docExpr 0 ((.recipient) selection)),+          indent 2 ("order =" <+> pretty ((.order) selection)),+          indent 2 ("dedupe =" <+> pretty ((.dedupe) 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)),+          ++ maybe [] (\(recipientLimit, _) -> [indent 2 ("max-recipients =" <+> pretty recipientLimit)]) ((.limit) selection)+          ++ [ indent 2 ("empty =>" <+> docSelectionDisposition ((.emptyPolicy) selection)),+               indent 2 ("failure =>" <+> docSelectionDisposition ((.failurePolicy) selection)),+               indent 2 ("redelivery =" <+> pretty ((.redelivery) selection)),+               indent 2 ("partial =" <+> pretty ((.partial) selection)),                "}"              ]       )   where-    custom source = "resolve stable via" <+> source <+> "row" <+> braced (map pretty (rvRow resolve))+    custom source = "resolve stable via" <+> source <+> "row" <+> braced (map pretty ((.row) resolve))  docSelectionDisposition :: SelectionDispositionSyntax -> Doc ann docSelectionDisposition SelectionAck = "ack"@@ -714,8 +714,8 @@ docRouterDispatch :: RouterDispatchNode -> Doc ann docRouterDispatch dispatch =   vsep-    [ "dispatch-each" <+> pretty (rdCommand dispatch) <+> braced (map docFieldBinding (rdFields dispatch)),-      indent 2 (docDispDisposition (rdDisposition dispatch))+    [ "dispatch-each" <+> pretty ((.command) dispatch) <+> braced (map docFieldBinding ((.fields) dispatch)),+      indent 2 (docDispDisposition ((.disposition) dispatch))     ]  docPolicyChoice :: PolicyChoice -> Doc ann@@ -724,37 +724,37 @@ docPolicyChoice PolSkip = "skip"  docInput :: InputDecl -> Doc ann-docInput input = case inType input of-  Just inputType -> "input" <+> pretty (inName input) <+> ":" <+> docTypeExpr inputType-  Nothing -> "input" <+> pretty (inName input) <+> braced (map docField (inFields input))+docInput input = case (.valueType) input of+  Just inputType -> "input" <+> pretty ((.name) input) <+> ":" <+> docTypeExpr inputType+  Nothing -> "input" <+> pretty ((.name) input) <+> braced (map docField ((.fields) input))  docCorrelate :: CorrelateDecl -> Doc ann-docCorrelate c = "correlate" <+> ("input." <> pretty (corrField c)) <+> "via" <+> pretty (corrVia c)+docCorrelate c = "correlate" <+> ("input." <> pretty ((.field) c)) <+> "via" <+> pretty ((.via) c)  docSaga :: SagaRef -> Doc ann-docSaga s = "saga" <+> pretty (sagaAgg s) <+> "category" <+> dquoted (sagaCategory s)+docSaga s = "saga" <+> pretty ((.agg) s) <+> "category" <+> dquoted ((.category) s)  docHandle :: HandleNode -> Doc ann docHandle h =   vsep $-    ["on" <+> pretty (hOn h)]-      ++ [indent 2 (docAdvance (hAdvance h))]-      ++ map (indent 2 . docDispatch) (hDispatch h)-      ++ [indent 2 ("schedule" <+> pretty (hSchedule h))]+    ["on" <+> pretty ((.on) h)]+      ++ [indent 2 (docAdvance ((.advance) h))]+      ++ map (indent 2 . docDispatch) ((.dispatch) h)+      ++ [indent 2 ("schedule" <+> pretty ((.schedule) h))]  docAdvance :: AdvanceNode -> Doc ann-docAdvance a = "advance" <+> pretty (advCommand a) <+> braced (map docFieldBinding (advFields a))+docAdvance a = "advance" <+> pretty ((.advCommand) a) <+> braced (map docFieldBinding ((.advFields) a))  docDispatch :: DispatchNode -> Doc ann docDispatch d =   vsep-    [ "dispatch" <+> (pretty (dispTarget d) <> "@" <> pretty (dispKey d)) <+> pretty (dispCommand d) <+> braced (map docFieldBinding (dispFields d)),-      indent 2 (docDispDisposition (dispDisposition d))+    [ "dispatch" <+> (pretty ((.target) d) <> "@" <> pretty ((.key) d)) <+> pretty ((.command) d) <+> braced (map docFieldBinding ((.fields) d)),+      indent 2 (docDispDisposition ((.disposition) d))     ]  docDispDisposition :: DispatchDisposition -> Doc ann docDispDisposition x =-  "on-appended" <+> docDisp (onAppended x) <+> ";" <+> "on-duplicate" <+> docDisp (onDuplicate x) <+> ";" <+> "on-failed" <+> docDisp (onFailed x)+  "on-appended" <+> docDisp ((.onAppended) x) <+> ";" <+> "on-duplicate" <+> docDisp ((.onDuplicate) x) <+> ";" <+> "on-failed" <+> docDisp ((.onFailed) x)  docDisp :: Disp -> Doc ann docDisp DAckOk = "AckOk"@@ -764,54 +764,54 @@ docTimer :: TimerNode -> Doc ann docTimer t =   vsep-    [ "timer" <+> pretty (tmName t),-      indent 2 ("id" <+> docIdExpr (tmId t)),-      indent 2 ("fireAt" <+> docFireAt (tmFireAt t)),-      indent 2 ("payload" <+> braced (map docFieldBinding (tmPayload t))),-      indent 2 (docFire (tmFire t)),-      indent 2 ("decode unknown-status =>" <+> pretty (tmDecodeUnknown t)),-      indent 2 ("max-attempts" <+> pretty (tmMaxAttempts t) <+> "dead-letter" <+> dquoted (tmDeadLetter t))+    [ "timer" <+> pretty ((.name) t),+      indent 2 ("id" <+> docIdExpr ((.id) t)),+      indent 2 ("fireAt" <+> docFireAt ((.fireAt) t)),+      indent 2 ("payload" <+> braced (map docFieldBinding ((.payload) t))),+      indent 2 (docFire ((.fire) t)),+      indent 2 ("decode unknown-status =>" <+> pretty ((.decodeUnknown) t)),+      indent 2 ("max-attempts" <+> pretty ((.maxAttempts) t) <+> "dead-letter" <+> dquoted ((.deadLetter) t))     ]  docIdExpr :: IdExpr -> Doc ann-docIdExpr e = "uuidv5" <+> dquoted (idePrefix e) <+> "<>" <+> pretty (ideField e)+docIdExpr e = "uuidv5" <+> dquoted ((.prefix) e) <+> "<>" <+> pretty ((.field) e)  docFireAt :: FireAtExpr -> Doc ann-docFireAt f = ("input." <> pretty (faField f)) <+> "+" <+> pretty (faWindow f)+docFireAt f = ("input." <> pretty ((.field) f)) <+> "+" <+> pretty ((.window) f)  docFire :: FireNode -> Doc ann docFire f =   vsep-    [ "fire dispatch" <+> (pretty (fireTarget f) <> "@" <> pretty (fireKey f)) <+> pretty (fireCommand f) <+> braced (map docFieldBinding (fireFields f)),-      indent 2 ("fired-event-id" <+> docIdExpr (fireFiredEventId f)),-      indent 2 (docFireDisposition (fireDisposition f))+    [ "fire dispatch" <+> (pretty ((.target) f) <> "@" <> pretty ((.key) f)) <+> pretty ((.command) f) <+> braced (map docFieldBinding ((.fields) f)),+      indent 2 ("fired-event-id" <+> docIdExpr ((.firedEventId) f)),+      indent 2 (docFireDisposition ((.disposition) f))     ]  docFireDisposition :: FireDisposition -> Doc ann docFireDisposition x =   "on-ok"-    <+> docFireOutcome (onOk x)+    <+> docFireOutcome ((.onOk) x)     <+> ";"     <+> "on-reject"-    <+> docFireOutcome (onReject x)+    <+> docFireOutcome ((.onReject) x)     <+> ";"     <+> "on-ambiguous"-    <+> docFireOutcome (onAmbiguous x)+    <+> docFireOutcome ((.onAmbiguous) x)     <+> ";"     <+> "on-error"-    <+> docFireOutcome (onError x)+    <+> docFireOutcome ((.onError) x)     <+> ";"     <+> "not-mine"-    <+> docFireOutcome (notMine x)+    <+> docFireOutcome ((.notMine) x)  docFireOutcome :: FireOutcome -> Doc ann docFireOutcome OFired = "Fired" docFireOutcome ORetry = "Retry"  docFieldBinding :: FieldBinding -> Doc ann-docFieldBinding b = case fbValue b of-  Nothing -> pretty (fbName b)-  Just v -> pretty (fbName b) <> "=" <> docValue v+docFieldBinding b = case (.value) b of+  Nothing -> pretty ((.name) b)+  Just v -> pretty ((.name) b) <> "=" <> docValue v   where     docValue v = case T.stripPrefix "\"" v >>= T.stripSuffix "\"" of       Just rawInner -> dquoted rawInner@@ -834,43 +834,43 @@ docAggregate :: Aggregate -> Doc ann docAggregate a =   vsep $-    [ "aggregate" <+> pretty (aggName a),-      maybe mempty (indent 2 . docDomainOutcomeTypes) (aggDomainOutcomeTypes a),+    [ "aggregate" <+> pretty ((.name) a),+      maybe mempty (indent 2 . docDomainOutcomeTypes) ((.domainOutcomeTypes) a),       indent 2 "regs",-      indent 4 (vsep (map docReg (aggRegs a))),-      indent 2 ("states" <+> hsep (map docState (aggStates a))),+      indent 4 (vsep (map docReg ((.regs) a))),+      indent 2 ("states" <+> hsep (map docState ((.states) a))),       mempty     ]-      ++ map (indent 2 . docCommand) (aggCommands a)-      ++ blank (aggCommands a)-      ++ map (indent 2 . docEvent) (aggEvents a)-      ++ blank (aggEvents a)-      ++ map (indent 2 . docTransition) (aggTransitions a)-      ++ blank (aggTransitions a)-      ++ maybe [] (\w -> [indent 2 (docWire w)]) (aggWire a)-      ++ maybe [] (\p -> [indent 2 (docProjection p)]) (aggProjection a)-      ++ maybe [] (\snapshot -> [indent 2 (docSnapshot snapshot)]) (aggSnapshot a)+      ++ map (indent 2 . docCommand) ((.commands) a)+      ++ blank ((.commands) a)+      ++ map (indent 2 . docEvent) ((.events) a)+      ++ blank ((.events) a)+      ++ map (indent 2 . docTransition) ((.transitions) a)+      ++ blank ((.transitions) a)+      ++ maybe [] (\w -> [indent 2 (docWire w)]) ((.wire) a)+      ++ maybe [] (\p -> [indent 2 (docProjection p)]) ((.projection) a)+      ++ maybe [] (\snapshot -> [indent 2 (docSnapshot snapshot)]) ((.snapshot) a)   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))+    <+> ("rejection=" <> pretty ((.rejectionType) declaration))+    <+> ("no-op=" <> pretty ((.noOpType) declaration))  docSnapshot :: SnapshotSpec -> Doc ann docSnapshot snapshot =   vsep-    [ "snapshot" <+> policyDoc (snapPolicy snapshot),-      indent 2 ("state-codec version=" <> pretty (snapCodecVersion snapshot) <+> "shape-hash=" <> dquoted (snapShapeHash snapshot))+    [ "snapshot" <+> policyDoc ((.policy) snapshot),+      indent 2 ("state-codec version=" <> pretty ((.codecVersion) snapshot) <+> "shape-hash=" <> dquoted ((.shapeHash) snapshot))     ]   where     policyDoc (SnapEvery interval) = "every" <+> pretty interval     policyDoc SnapOnTerminal = "on-terminal"  docReg :: RegDecl -> Doc ann-docReg r = pretty (regName r) <+> docTypeExpr (regType r) <+> "=" <+> docRegInitial (regInitial r)+docReg r = pretty ((.name) r) <+> docTypeExpr ((.valueType) r) <+> "=" <+> docRegInitial ((.initial) r)  docRegInitial :: RegInitial -> Doc ann docRegInitial (RegInitBare value) = pretty value@@ -879,46 +879,46 @@ docBackoff :: BackoffSpec -> Doc ann docBackoff backoff =   "backoff"-    <+> pretty (boKind backoff)-    <+> pretty (boWindow backoff)-    <+> maybe mempty (\window -> "max=" <> pretty window) (boMax backoff)-    <+> maybe mempty (\multiplier -> "multiplier=" <> pretty multiplier) (boMultiplier backoff)+    <+> pretty ((.kind) backoff)+    <+> pretty ((.window) backoff)+    <+> maybe mempty (\window -> "max=" <> pretty window) ((.max) backoff)+    <+> maybe mempty (\multiplier -> "multiplier=" <> pretty multiplier) ((.multiplier) backoff)  docState :: StateDecl -> Doc ann-docState s = pretty (stName s) <> (if stTerminal s then "!" else mempty)+docState s = pretty ((.name) s) <> (if (.terminal) s then "!" else mempty)  docCommand :: Command -> Doc ann-docCommand c = "command" <+> pretty (cmdName c) <+> braced (map docAggregateField (cmdFields c))+docCommand c = "command" <+> pretty ((.name) c) <+> braced (map docAggregateField ((.fields) c))  docAggregateField :: AggregateField -> Doc ann docAggregateField f =   hsep-    ( [pretty (aggregateFieldName f)]-        ++ maybe [] (\selector -> ["haskell", pretty selector]) (aggregateFieldSelector f)-        ++ maybe [] (\wireKey -> ["as", dquoted wireKey]) (aggregateFieldWireKey f)+    ( [pretty ((.name) f)]+        ++ maybe [] (\selector -> ["haskell", pretty selector]) ((.selector) f)+        ++ maybe [] (\wireKey -> ["as", dquoted wireKey]) ((.wireKey) f)     )-    <> maybe mempty (\ty -> ":" <> docTypeExpr ty) (aggregateFieldType f)+    <> maybe mempty (\ty -> ":" <> docTypeExpr ty) ((.valueType) f)  docField :: Field -> Doc ann-docField f = case fieldType f of-  Nothing -> pretty (fieldName f)-  Just ty -> pretty (fieldName f) <> ":" <> pretty ty+docField f = case (.valueType) f of+  Nothing -> pretty ((.name) f)+  Just ty -> pretty ((.name) f) <> ":" <> pretty ty  docEvent :: Event -> Doc ann docEvent e =-  case evUpcastFrom e of+  case (.upcastFrom) e of     Nothing -> line1     Just (m, _) -> vsep [line1, indent 2 ("upcast from v" <> pretty m <+> "=" <+> "HOLE")]   where-    kw = case (evRetiring e, evDeprecated e) of+    kw = case ((.retiring) e, (.deprecated) e) of       (False, False) -> "event"       (True, False) -> "retiring event"       (False, True) -> "deprecated event"       (True, True) -> "retiring deprecated event"     nameVer =-      pretty (evName e)-        <> (if evVersion e > 1 then " v" <> pretty (evVersion e) else mempty)-    bodyDoc = case evBody e of+      pretty ((.name) e)+        <> (if (.version) e > 1 then " v" <> pretty ((.version) e) else mempty)+    bodyDoc = case (.body) e of       EventFromCommand cmd -> "=" <+> ("fields(" <> pretty cmd <> ")")       EventFields fs -> braced (map docAggregateField fs)     line1 = kw <+> nameVer <+> bodyDoc@@ -942,19 +942,19 @@ docTransition :: Transition -> Doc ann docTransition t =   vsep $-    [modePrefix <> pretty (tSource t) <+> "--" <+> pretty (tCommand t) <+> "-->"]+    [modePrefix <> pretty ((.source) t) <+> "--" <+> pretty ((.command) t) <+> "-->"]       ++ map (indent 2) clauses   where-    modePrefix = case tMode t of+    modePrefix = case (.mode) t of       TmLive -> mempty       TmReplayOnly -> "replay-only "     clauses =-      ["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)]+      ["implementation hole" | (.implementation) t == HoleImplementation]+        ++ maybe [] (\g -> ["guard" <+> docExpr 0 g]) ((.guard) t)+        ++ map (\(r, e) -> "write" <+> pretty r <+> ":=" <+> docExpr 0 e) ((.writes) t)+        ++ maybe [] (pure . docTransitionOutcome) ((.outcome) t)+        ++ map (\ev -> "emit" <+> pretty ev) ((.emits) t)+        ++ ["goto" <+> pretty ((.goto) t)]  docTransitionOutcome :: TransitionOutcome -> Doc ann docTransitionOutcome (OutcomeAccepted _) = "outcome accepted"@@ -964,21 +964,21 @@ docWire :: WireSpec -> Doc ann docWire w =   "wire"-    <+> ("kind=" <> pretty (wireKind w))-    <+> ("fields=" <> pretty (wireFields w))-    <+> ("schemaVersion=" <> pretty (wireSchemaVersion w))+    <+> ("kind=" <> pretty ((.kind) w))+    <+> ("fields=" <> pretty ((.fields) w))+    <+> ("schemaVersion=" <> pretty ((.schemaVersion) w))  docProjection :: ProjectionSpec -> Doc ann docProjection p =   vsep $     [ hsep $-        ["projection", pretty (projTable p)]-          ++ maybe [] (pure . ("consistency=" <>) . docConsistency) (projConsistency p)-          ++ ["key=" <> pretty (projKey p)]+        ["projection", pretty ((.table) p)]+          ++ maybe [] (pure . ("consistency=" <>) . docConsistency) ((.consistency) p)+          ++ ["key=" <> pretty ((.key) p)]     ]-      ++ maybe [] (\m -> [indent 2 (statusMapHead m <+> braced (map pair (mapPairs m)))]) (projStatusMap p)+      ++ maybe [] (\m -> [indent 2 (statusMapHead m <+> braced (map pair ((.pairs) m)))]) ((.statusMap) p)   where-    statusMapHead m = if mapPartial m then "status-map partial" else "status-map"+    statusMapHead m = if (.partial) m then "status-map partial" else "status-map"     pair (l, r) = pretty l <> "=>" <> pretty r  docConsistency :: Consistency -> Doc ann

src/Keiro/Dsl/ProjectionMappedImpact.hs view

@@ -96,13 +96,13 @@     derivedConsumers =       Set.fromList         [ derived-        | mappedConsumers <- Map.elems (impactDeclarationConsumers semantic),+        | mappedConsumers <- Map.elems ((.declarationConsumers) semantic),           DerivedProjectionConsumer derived <- Set.toList mappedConsumers         ]     mappedRoots =       sort . nub $         [ ProjectionMappedRoot derived declarationKey usePath-        | (declarationKey, usePathValues) <- Map.toAscList (impactUsePaths semantic),+        | (declarationKey, usePathValues) <- Map.toAscList ((.usePaths) semantic),           usePath <- usePathValues,           aggregate <- maybeToList (eventAuthority usePath),           derived <- Set.toAscList derivedConsumers,@@ -111,7 +111,7 @@     operational =       mapMaybeOperation         (Set.toAscList (Set.fromList [derived | ProjectionMappedRoot derived _ _ <- mappedRoots]))-    unsupportedSources = impactUnsupportedProjectionSources semantic+    unsupportedSources = (.unsupportedProjectionSources) semantic      mapMaybeOperation = foldr (maybe id (:) . operationFor graph spec) []     mapMaybeUnsupported = foldr (maybe id (:) . unsupportedFor spec) []@@ -125,13 +125,13 @@   Right graph -> Just (projectionMappedImpact service (semanticImpact graph))  projectionConsumersFor :: ProjectionMappedImpact -> MappedKey -> Set DerivedMappedConsumer-projectionConsumersFor impact declarationKey = Map.findWithDefault Set.empty declarationKey (consumers impact)+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))+    operation <- maybeToList (Map.lookup derived ((.operations) impact))   ]  -- | Stable source metadata for generated aggregate codecs. Existing aggregate@@ -163,7 +163,7 @@         [ renderUsePath (UsePath site (useSiteSegments graph site))             <> "|wire="             <> wireFingerprint graph (unMappedKey declarationKey)-        | site@(RootEventField authority _ _ declarationKey) <- tgUseSites graph,+        | site@(RootEventField authority _ _ declarationKey) <- (.useSites) graph,           authority == aggregate         ] @@ -173,11 +173,11 @@ -- dependency. Category/all boundaries remain explicit and untyped. renderProjectionMappedImpact :: ProjectionMappedImpact -> [Text] renderProjectionMappedImpact impact-  | Map.null (consumers impact) && null (unsupported impact) = []+  | Map.null ((.consumers) impact) && null ((.unsupported) impact) = []   | otherwise =       ["projection mapped impact:"]-        <> concatMap renderDeclaration (Map.toAscList (consumers impact))-        <> renderUnsupported (unsupported impact)+        <> concatMap renderDeclaration (Map.toAscList ((.consumers) impact))+        <> renderUnsupported ((.unsupported) impact)   where     renderDeclaration (declarationKey, derivedConsumers) =       ["  " <> unMappedKey declarationKey]@@ -186,10 +186,10 @@       [ "    " <> mappedConsumerIdentity (DerivedProjectionConsumer derived),         "      inherited event roots: " <> renderSet (Set.fromList (pathsFor declarationKey derived))       ]-        <> maybe [] (pure . ("      operation: " <>) . renderOperation) (Map.lookup derived (operations impact))+        <> maybe [] (pure . ("      operation: " <>) . renderOperation) (Map.lookup derived ((.operations) impact))     pathsFor declarationKey derived =       [ renderUsePath inheritedPath-      | ProjectionMappedRoot candidate declaration inheritedPath <- roots impact,+      | ProjectionMappedRoot candidate declaration inheritedPath <- (.roots) impact,         candidate == derived,         declaration == declarationKey       ]@@ -236,17 +236,17 @@         { consumer = derived,           group = Nothing,           targets = Set.singleton projection,-          readModels = Set.fromList [rmName readModel | readModel <- readModelNodes spec, rmName readModel == projection],+          readModels = Set.fromList [(.name) readModel | readModel <- readModelNodes spec, (.name) readModel == projection],           replayable = False,           sourceFingerprint = projectionAggregateSourceFingerprintWithGraph graph aggregate         }   CatalogProjectionConsumer ownerName aggregate -> do-    owner <- find ((== ownerName) . poName) (projectionOwners spec)+    owner <- find ((== ownerName) . (.name)) (projectionOwners spec)     pure       ProjectionOperationalImpact         { consumer = derived,-          group = Just (poGroup owner),-          targets = Set.fromList (poTargets owner),+          group = Just ((.group) owner),+          targets = Set.fromList ((.targets) owner),           readModels = observingReadModels spec owner,           replayable = isReplayable owner,           sourceFingerprint = projectionAggregateSourceFingerprintWithGraph graph aggregate@@ -254,12 +254,12 @@  unsupportedFor :: Spec -> UnsupportedProjectionSource -> Maybe UnsupportedProjectionImpact unsupportedFor spec boundary = do-  owner <- find ((== unsupportedOwner boundary) . poName) (projectionOwners spec)+  owner <- find ((== unsupportedOwner boundary) . (.name)) (projectionOwners spec)   pure     UnsupportedProjectionImpact       { source = boundary,-        group = poGroup owner,-        targets = Set.fromList (poTargets owner),+        group = (.group) owner,+        targets = Set.fromList ((.targets) owner),         readModels = observingReadModels spec owner,         replayable = isReplayable owner       }@@ -267,14 +267,14 @@ observingReadModels :: Spec -> ProjectionOwnerNode -> Set Name observingReadModels spec owner =   Set.fromList-    [ rmName readModel+    [ (.name) readModel     | readModel <- readModelNodes spec,-      rmGroup readModel == Just (poGroup owner),-      not (Set.disjoint (Set.fromList (rmObservedTargets readModel)) (Set.fromList (poTargets owner)))+      (.group) readModel == Just ((.group) owner),+      not (Set.disjoint (Set.fromList ((.observedTargets) readModel)) (Set.fromList ((.targets) owner)))     ]  eventAuthority :: UsePath -> Maybe Name-eventAuthority UsePath {upRoot = RootEventField aggregate _ _ _} = Just aggregate+eventAuthority UsePath {root = RootEventField aggregate _ _ _} = Just aggregate eventAuthority _ = Nothing  derivedAuthority :: DerivedMappedConsumer -> Name@@ -286,13 +286,13 @@ unsupportedOwner (UnsupportedCatalogAll owner) = owner  projectionOwners :: Spec -> [ProjectionOwnerNode]-projectionOwners spec = [owner | NProjectionOwner owner <- specNodes spec]+projectionOwners spec = [owner | NProjectionOwner owner <- (.nodes) spec]  readModelNodes :: Spec -> [ReadModelNode]-readModelNodes spec = [readModel | NReadModel readModel <- specNodes spec]+readModelNodes spec = [readModel | NReadModel readModel <- (.nodes) spec]  isReplayable :: ProjectionOwnerNode -> Bool-isReplayable owner = case poReplay owner of+isReplayable owner = case (.replay) owner of   ProjectionReplayExplicit -> True   ProjectionLiveOnly _ -> False

src/Keiro/Dsl/ProjectionSupply.hs view

@@ -18,12 +18,12 @@ -- 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+  { queryModel :: !Name,+    projectionOwner :: !Name,+    rebuildGroup :: !Name,+    observedTargets :: !(NonEmpty Name),+    queryLoc :: !Loc,+    ownerLoc :: !Loc   }   deriving stock (Eq, Show) @@ -57,45 +57,45 @@   where     catalogReadModels =       sortOn-        rmName+        (.name)         [ readModel-        | NReadModel readModel <- specNodes spec,-          rmGroup readModel /= Nothing+        | NReadModel readModel <- (.nodes) spec,+          (.group) readModel /= Nothing         ]     targetsByName =       Map.fromList-        [ (ptName target, target)-        | NProjectionTarget target <- specNodes spec+        [ ((.name) target, target)+        | NProjectionTarget target <- (.nodes) spec         ]     groupsByTarget =       Map.fromListWith         (<>)-        [ (targetName, [rgName groupNode])-        | NRebuildGroup groupNode <- specNodes spec,-          targetName <- rgTargets groupNode+        [ (targetName, [(.name) groupNode])+        | NRebuildGroup groupNode <- (.nodes) spec,+          targetName <- (.targets) groupNode         ]     ownersByTarget =       Map.fromListWith         (<>)         [ (targetName, [owner])-        | NProjectionOwner owner <- specNodes spec,-          targetName <- poTargets owner+        | NProjectionOwner owner <- (.nodes) spec,+          targetName <- (.targets) owner         ]     legacyProjections =       [ (aggregate, projection)-      | NAggregate aggregate <- specNodes spec,-        Just projection <- [aggProjection aggregate]+      | NAggregate aggregate <- (.nodes) spec,+        Just projection <- [(.projection) 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)+        observedTargets = sort (nub ((.observedTargets) readModel))+        queryGroup = maybe (error "catalog read model lost its group") id ((.group) readModel)         legacyIssues =           [ SupplyLegacyProjectionConflict readModel aggregate projection           | (aggregate, projection) <- legacyProjections,-            projTable projection == rmName readModel+            (.table) projection == (.name) readModel           ]         targetIssues = concatMap (issuesForTarget readModel queryGroup) observedTargets         structuralIssues@@ -106,11 +106,11 @@               [owner] ->                 [ SupplyOwnerGroupMismatch readModel targetName owner                 | targetName <- observedTargets,-                  poGroup owner /= queryGroup+                  (.group) owner /= queryGroup                 ]               owners -> [SupplyQueryWithMultipleOwners readModel owners]         supplierOwners =-          sortOn poName+          sortOn (.name)             . nubByOwner             $ [ owner               | targetName <- observedTargets,@@ -120,14 +120,14 @@           [] -> case supplierOwners of             [owner] ->               [ ResolvedProjectionSupply-                  { supplyQueryModel = rmName readModel,-                    supplyProjectionOwner = poName owner,-                    supplyRebuildGroup = queryGroup,-                    supplyObservedTargets = case observedTargets of+                  { queryModel = (.name) readModel,+                    projectionOwner = (.name) owner,+                    rebuildGroup = queryGroup,+                    observedTargets = case observedTargets of                       target : rest -> target :| rest                       [] -> error "resolved projection supply lost observed targets",-                    supplyQueryLoc = rmLoc readModel,-                    supplyOwnerLoc = poLoc owner+                    queryLoc = (.loc) readModel,+                    ownerLoc = (.loc) owner                   }               ]             _ -> []@@ -143,21 +143,21 @@           [ SupplyObservedTargetOutsideGroup readModel targetName           | Map.findWithDefault [] targetName groupsByTarget /= [queryGroup]           ]-        ownerIssues = case sortOn poName (Map.findWithDefault [] targetName ownersByTarget) of+        ownerIssues = case sortOn (.name) (Map.findWithDefault [] targetName ownersByTarget) of           [] -> [SupplyObservedTargetWithoutOwner readModel targetName]           [_] -> []           owners -> [SupplyObservedTargetWithMultipleOwners readModel targetName owners] -    nubByOwner = Map.elems . Map.fromList . map (\owner -> (poName owner, owner))+    nubByOwner = Map.elems . Map.fromList . map (\owner -> ((.name) 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)+  SupplyObservedTargetsEmpty readModel -> ((.name) readModel, 0, "")+  SupplyObservedTargetUnknown readModel targetName -> ((.name) readModel, 1, targetName)+  SupplyObservedTargetOutsideGroup readModel targetName -> ((.name) readModel, 2, targetName)+  SupplyObservedTargetWithoutOwner readModel targetName -> ((.name) readModel, 3, targetName)+  SupplyObservedTargetWithMultipleOwners readModel targetName _ -> ((.name) readModel, 4, targetName)+  SupplyOwnerGroupMismatch readModel targetName _ -> ((.name) readModel, 5, targetName)+  SupplyQueryWithoutOwner readModel -> ((.name) readModel, 6, "")+  SupplyQueryWithMultipleOwners readModel _ -> ((.name) readModel, 7, "")+  SupplyLegacyProjectionConflict readModel aggregate _ -> ((.name) readModel, 8, (.name) aggregate)

src/Keiro/Dsl/ReadModelQueryContract.hs view

@@ -32,17 +32,17 @@   deriving stock (Eq, Ord, Show)  data QueryContractIdentity = QueryContractIdentity-  { qciReadModel :: !Name,-    qciPosition :: !QueryContractPosition,-    qciTypeExpression :: !Text,-    qciMappedDependencies :: ![Name]+  { readModel :: !Name,+    position :: !QueryContractPosition,+    typeExpression :: !Text,+    mappedDependencies :: ![Name]   }   deriving stock (Eq, Ord, Show)  data QueryContractDrift = QueryContractDrift-  { qcdKey :: !(Name, QueryContractPosition),-    qcdPrevious :: !(Maybe QueryContractIdentity),-    qcdCurrent :: !(Maybe QueryContractIdentity)+  { key :: !(Name, QueryContractPosition),+    previous :: !(Maybe QueryContractIdentity),+    current :: !(Maybe QueryContractIdentity)   }   deriving stock (Eq, Show) @@ -61,10 +61,10 @@ instance ToJSON QueryContractIdentity where   toJSON identity =     object-      [ "readModel" .= qciReadModel identity,-        "position" .= qciPosition identity,-        "typeExpression" .= qciTypeExpression identity,-        "mappedDependencies" .= qciMappedDependencies identity+      [ "readModel" .= (.readModel) identity,+        "position" .= (.position) identity,+        "typeExpression" .= (.typeExpression) identity,+        "mappedDependencies" .= (.mappedDependencies) identity       ]  instance FromJSON QueryContractIdentity where@@ -76,7 +76,7 @@       <*> fields .: "mappedDependencies"  queryContractIdentityKey :: QueryContractIdentity -> (Name, QueryContractPosition)-queryContractIdentityKey identity = (qciReadModel identity, qciPosition identity)+queryContractIdentityKey identity = ((.readModel) identity, (.position) identity)  queryContractDrift :: [QueryContractIdentity] -> [QueryContractIdentity] -> [QueryContractDrift] queryContractDrift current previous =@@ -99,16 +99,16 @@   fmap (sortOn queryContractIdentityKey . concat) (traverse (identitiesFor graph) readModels)   where     spec = checkedSpec service-    readModels = [readModel | NReadModel readModel <- specNodes spec]+    readModels = [readModel | NReadModel readModel <- (.nodes) 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)+  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+    [ identity QueryInputConsumer ((.input) queryPair) inputExpression,+      identity QueryResultConsumer ((.result) queryPair) resultExpression     ]   where     resolve position location expression =@@ -116,13 +116,13 @@         Left failure -> Left (failure :| [])         Right resolved -> Right resolved       where-        owner = "readmodel '" <> rmName readModel <> "' query " <> positionLabel position+        owner = "readmodel '" <> (.name) 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))+        { readModel = (.name) readModel,+          position = position,+          typeExpression = renderTypeExpr sourceExpression,+          mappedDependencies = Set.toAscList (Set.map unMappedKey (mappedClosure graph resolved))         }  mappedClosure :: TypeGraph -> ResolvedTypeExpr -> Set MappedKey@@ -139,7 +139,7 @@         onOptional = id,         onList = id,         onMap = id,-        onRef = \key -> Set.insert key (Map.findWithDefault Set.empty key (tgReachability graph))+        onRef = \key -> Set.insert key (Map.findWithDefault Set.empty key ((.reachability) graph))       }  positionLabel :: QueryContractPosition -> Text

src/Keiro/Dsl/ReadModelShape.hs view

@@ -23,17 +23,17 @@ -- do not duplicate physical authority owned by their target declarations. canonicalShape :: ReadModelNode -> Text canonicalShape readModel =-  T.intercalate "|" (shapeRoot : map columnSegment (rmColumns readModel))+  T.intercalate "|" (shapeRoot : map columnSegment ((.columns) readModel))   where-    shapeRoot = case rmGroup readModel of-      Nothing -> rmTable readModel+    shapeRoot = case (.group) readModel of+      Nothing -> (.table) readModel       Just _ -> "query-model"     columnSegment columnDecl =       T.intercalate         ":"-        [ rmcName columnDecl,-          rmcType columnDecl,-          if rmcRequired columnDecl then "req" else "null"+        [ (.rmcName) columnDecl,+          (.rmcType) columnDecl,+          if (.rmcRequired) columnDecl then "req" else "null"         ]  -- | A fixed-width FNV-1a-64 digest over the canonical shape's UTF-8 bytes.@@ -51,13 +51,13 @@  -- | The runtime registry identity derived from context and notation name. registryNameFor :: Name -> ReadModelNode -> Text-registryNameFor contextName readModel =-  contextName <> "-" <> T.replace "_" "-" (rmName readModel)+registryNameFor name readModel =+  name <> "-" <> T.replace "_" "-" ((.name) readModel)  -- | The explicit subscription override or its deterministic default. subscriptionNameFor :: Name -> ReadModelNode -> Text-subscriptionNameFor contextName readModel =-  fromMaybe (registryNameFor contextName readModel <> "-sub") (legacyReadModelSubscription readModel)+subscriptionNameFor name readModel =+  fromMaybe (registryNameFor name readModel <> "-sub") (legacyReadModelSubscription readModel)  offsetBasis :: Word64 offsetBasis = 0xcbf29ce484222325

src/Keiro/Dsl/ReplayImpact.hs view

@@ -70,8 +70,8 @@ instance ToJSON AggregateImpact where   toJSON impact =     object-      [ "eventTypes" .= Set.toAscList (eventTypes impact),-        "includeSnapshotStreams" .= includeSnapshotStreams impact+      [ "eventTypes" .= Set.toAscList ((.eventTypes) impact),+        "includeSnapshotStreams" .= (.includeSnapshotStreams) impact       ]  instance ToJSON ReplayImpact where@@ -87,11 +87,11 @@   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+        "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@@ -108,26 +108,26 @@   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]+    oldTargets = Map.fromList [((.name) target, target) | NProjectionTarget target <- (.nodes) oldSpec]+    newTargets = Map.fromList [((.name) target, target) | NProjectionTarget target <- (.nodes) newSpec]+    oldGroups = Map.fromList [((.name) groupNode, groupNode) | NRebuildGroup groupNode <- (.nodes) oldSpec]+    newGroups = Map.fromList [((.name) groupNode, groupNode) | NRebuildGroup groupNode <- (.nodes) newSpec]+    oldOwners = Map.fromList [((.name) owner, owner) | NProjectionOwner owner <- (.nodes) oldSpec]+    newOwners = Map.fromList [((.name) owner, owner) | NProjectionOwner owner <- (.nodes) 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+    groups = changedGroupNames <> Set.fromList (map (.group) changedOwners) <> groupsContainingChangedTargets <> inheritedGroups+    targets = changedTargetNames <> Set.fromList (concatMap (.targets) changedOwners <> concatMap (.targets) changedGroups) <> inheritedTargets+    sources = Set.fromList (map renderSource (concatMap (.sources) changedOwners)) <> inheritedSources     adapters = changedOwnerNames <> inheritedAdapters     groupsContainingChangedTargets =       Set.fromList-        [ rgName groupNode+        [ (.name) groupNode         | groupNode <- Map.elems oldGroups <> Map.elems newGroups,-          any (`Set.member` changedTargetNames) (rgTargets groupNode)+          any (`Set.member` changedTargetNames) ((.targets) groupNode)         ]     changedKeys oldMap newMap =       Set.fromList@@ -154,8 +154,8 @@         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)+    oldMappedOperations = maybe Map.empty (.operations) (projectionImpactFor oldService)+    newMappedOperations = maybe Map.empty (.operations) (projectionImpactFor newService)     projectionImpactFor service = case checkedTypeGraph service of       Left _ -> Nothing       Right graph -> Just (ProjectionImpact.projectionMappedImpact service (semanticImpact graph))@@ -200,24 +200,24 @@     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)]+    oldAggregates = [((.name) aggregate, aggregate) | NAggregate aggregate <- (.nodes) ((.spec) oldContext)]+    newAggregates = Map.fromList [((.name) aggregate, aggregate) | NAggregate aggregate <- (.nodes) ((.spec) newContext)]  data ReplaySurfaceContext = ReplaySurfaceContext-  { surfaceSpec :: !Spec,-    surfaceGraphResult :: Either (NE.NonEmpty TypeGraphError) TypeGraph,-    surfaceSymbols :: AggregateSymbols+  { spec :: !Spec,+    graphResult :: Either (NE.NonEmpty TypeGraphError) TypeGraph,+    symbols :: AggregateSymbols   }  hasImpact :: AggregateImpact -> Bool hasImpact impact =-  not (Set.null (eventTypes impact))-    || includeSnapshotStreams impact+  not (Set.null ((.eventTypes) impact))+    || (.includeSnapshotStreams) impact  removedAggregateImpact :: Aggregate -> AggregateImpact removedAggregateImpact aggregate =   AggregateImpact-    { eventTypes = Set.fromList (evName <$> aggEvents aggregate),+    { eventTypes = Set.fromList ((.name) <$> (.events) aggregate),       includeSnapshotStreams = True     } @@ -227,7 +227,7 @@   newNonTransitionSurface <-     aggregateFoldSurfaceForService       newService-      newAggregate {aggTransitions = aggTransitions oldAggregate}+      (replaceAggregateTransitions oldAggregate.transitions newAggregate)   let nonTransitionFoldChanged = oldSurface /= newNonTransitionSurface   pure     AggregateImpact@@ -238,34 +238,34 @@         includeSnapshotStreams = transitionFoldChanged || nonTransitionFoldChanged || mappedRegisterChanged       }   where-    oldEventTypes = Set.fromList (evName <$> aggEvents oldAggregate)+    oldEventTypes = Set.fromList ((.name) <$> (.events) oldAggregate)     decodeAffected = decodeSurfaceAffected oldContext newContext oldAggregate newAggregate     mappedRegisterChanged =       mappedRegisterSurface oldContext oldAggregate         /= mappedRegisterSurface newContext newAggregate     (transitionAffected, transitionFoldChanged) =-      changedTransitionEvents (aggTransitions oldAggregate) (aggTransitions newAggregate)+      changedTransitionEvents ((.transitions) oldAggregate) ((.transitions) 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]+    newEvents = Map.fromList [((.name) event, event) | event <- (.events) newAggregate]     removedOrChanged =       Set.fromList-        [ evName oldEvent-        | oldEvent <- aggEvents oldAggregate,-          maybe True ((/= eventSurface oldContext oldAggregate oldEvent) . eventSurface newContext newAggregate) (Map.lookup (evName oldEvent) newEvents)+        [ (.name) oldEvent+        | oldEvent <- (.events) oldAggregate,+          maybe True ((/= eventSurface oldContext oldAggregate oldEvent) . eventSurface newContext newAggregate) (Map.lookup ((.name) oldEvent) newEvents)         ]     wireAffected-      | aggWire oldAggregate == aggWire newAggregate = Set.empty-      | otherwise = Set.fromList (evName <$> aggEvents oldAggregate)+      | (.wire) oldAggregate == (.wire) newAggregate = Set.empty+      | otherwise = Set.fromList ((.name) <$> (.events) oldAggregate)  eventDecodeSurface :: Aggregate -> Event -> (Int, Maybe (Int, Hole), [(Name, Text, Maybe TypeExpr)]) eventDecodeSurface aggregate event =-  ( evVersion event,-    evUpcastFrom event,-    [ (fieldDslName identity, fieldWireKey identity, aggregateFieldType field)+  ( (.version) event,+    (.upcastFrom) event,+    [ ((.dslName) identity, (.wireKey) identity, (.valueType) field)     | field <- eventFields aggregate event,       let identity = resolveAggregateFieldIdentity field     ]@@ -278,17 +278,17 @@ mappedFieldSurface :: ReplaySurfaceContext -> Aggregate -> Event -> [(Name, Text)] mappedFieldSurface context aggregate event = mapped <> nominal   where-    mapped = case surfaceGraphResult context of+    mapped = case (.graphResult) context of       Left _ -> []       Right graph ->-        [ (aggregateFieldName field, wireFingerprint graph typeName)+        [ ((.name) field, wireFingerprint graph typeName)         | field <- eventFields aggregate event,-          TRef typeName <- maybeToList (aggregateFieldType field),-          Map.member (MappedKey typeName) (tgDeclarations graph)+          TRef typeName <- maybeToList ((.valueType) field),+          Map.member (MappedKey typeName) ((.declarations) graph)         ]-    symbols = surfaceSymbols context+    symbols = (.symbols) context     nominal =-      [ (aggregateFieldName field, nominalSurface resolved)+      [ ((.name) field, nominalSurface resolved)       | field <- eventFields aggregate event,         Right (AggregateNominal resolved) <- [inferAggregateFieldType symbols aggregate EventFieldUse field]       ]@@ -296,33 +296,33 @@ mappedRegisterSurface :: ReplaySurfaceContext -> Aggregate -> [(Name, Name, Text)] mappedRegisterSurface context aggregate = mapped <> nominal   where-    mapped = case surfaceGraphResult context of+    mapped = case (.graphResult) context of       Left _ -> []       Right graph ->-        [ (regName register, typeName, wireFingerprint graph typeName)-        | register <- aggRegs aggregate,-          TRef typeName <- [regType register],-          Map.member (MappedKey typeName) (tgDeclarations graph)+        [ ((.name) register, typeName, wireFingerprint graph typeName)+        | register <- (.regs) aggregate,+          TRef typeName <- [(.valueType) register],+          Map.member (MappedKey typeName) ((.declarations) graph)         ]-    symbols = surfaceSymbols context+    symbols = (.symbols) context     nominal =-      [ (regName register, resolvedNominalName resolved, nominalSurface resolved)-      | register <- aggRegs aggregate,-        Right (AggregateNominal resolved) <- [resolveAggregateType symbols (regLoc register) RegisterUse (regType register)]+      [ ((.name) register, (.name) resolved, nominalSurface resolved)+      | register <- (.regs) aggregate,+        Right (AggregateNominal resolved) <- [resolveAggregateType symbols ((.loc) register) RegisterUse ((.valueType) register)]       ]  nominalSurface :: ResolvedNominalType -> Text nominalSurface nominal =-  nominalRepresentationSurface (resolvedNominalRepresentation nominal)-    <> case resolvedNominalOwnership nominal of+  nominalRepresentationSurface ((.representation) nominal)+    <> case (.ownership) nominal of       GeneratedNominal -> "|ownership=generated"       ConsumerNominal binding ->         Text.concat           [ "|ownership=consumer",-            "|canonical=" <> unCanonicalTypeId (consumerNominalCanonical binding),-            "|binding=" <> unQualifiedValueName (consumerNominalBinding binding),-            "|binding-version=" <> unBindingVersion (consumerNominalBindingVersion binding),-            "|initial=" <> maybe "(none)" unQualifiedValueName (consumerNominalInitial binding)+            "|canonical=" <> (.unCanonicalTypeId) ((.canonical) binding),+            "|binding=" <> (.unQualifiedValueName) ((.binding) binding),+            "|binding-version=" <> (.unBindingVersion) ((.bindingVersion) binding),+            "|initial=" <> maybe "(none)" (.unQualifiedValueName) ((.initial) binding)           ]  nominalRepresentationSurface :: NominalRepresentation -> Text@@ -337,10 +337,10 @@     NominalTime -> "scalar:Time"  eventFields :: Aggregate -> Event -> [AggregateField]-eventFields aggregate event = case evBody event of+eventFields aggregate event = case (.body) event of   EventFields fields -> fields   EventFromCommand commandName ->-    concat [cmdFields command | command <- aggCommands aggregate, cmdName command == commandName]+    concat [(.fields) command | command <- (.commands) aggregate, (.name) command == commandName]  maybeToList :: Maybe a -> [a] maybeToList = maybe [] pure@@ -371,15 +371,15 @@       Map.fromListWith (<>)         . map (\transition -> (transitionIdentity transition, [transition]))     transitionIdentity transition =-      ( modeKey (tMode transition),-        tSource transition,-        tCommand transition+      ( modeKey ((.mode) transition),+        (.source) transition,+        (.command) transition       )     modeKey TmLive = "live" :: Text     modeKey TmReplayOnly = "replay-only"     transitionSortKey transition =-      (maybe "" canonicalExpr (tGuard transition), canonicalTransition transition)-    emittedBy = Set.fromList . tEmits+      (maybe "" canonicalExpr ((.guard) transition), canonicalTransition transition)+    emittedBy = Set.fromList . (.emits)  -- | Remove byte-identical transitions as a multiset. Sorting makes duplicate -- cancellation independent of declaration order.@@ -413,9 +413,9 @@         guardOnlyLoosening oldTransition newTransition       ]     looseningPairKey (oldTransition, newTransition) =-      ( maybe "" canonicalExpr (tGuard oldTransition),+      ( maybe "" canonicalExpr ((.guard) oldTransition),         canonicalTransition oldTransition,-        maybe "" canonicalExpr (tGuard newTransition),+        maybe "" canonicalExpr ((.guard) newTransition),         canonicalTransition newTransition       ) @@ -426,9 +426,42 @@ -- conjunction elimination, and disjunction introduction. guardOnlyLoosening :: Transition -> Transition -> Bool guardOnlyLoosening oldTransition newTransition =-  oldTransition {tGuard = tGuard newTransition} == newTransition-    && guardImplies (tGuard oldTransition) (tGuard newTransition)+  replaceTransitionGuard newTransition.guard oldTransition == newTransition+    && guardImplies oldTransition.guard newTransition.guard +replaceAggregateTransitions :: [Transition] -> Aggregate -> Aggregate+replaceAggregateTransitions transitions aggregate =+  Aggregate+    { name = aggregate.name,+      regs = aggregate.regs,+      states = aggregate.states,+      commands = aggregate.commands,+      events = aggregate.events,+      transitions,+      domainOutcomeTypes = aggregate.domainOutcomeTypes,+      domainOutcomeDuplicateLocs = aggregate.domainOutcomeDuplicateLocs,+      wire = aggregate.wire,+      projection = aggregate.projection,+      snapshot = aggregate.snapshot,+      loc = aggregate.loc+    }++replaceTransitionGuard :: Maybe Expr -> Transition -> Transition+replaceTransitionGuard guard transition =+  Transition+    { source = transition.source,+      command = transition.command,+      implementation = transition.implementation,+      guard,+      writes = transition.writes,+      emits = transition.emits,+      outcome = transition.outcome,+      outcomeDuplicateLocs = transition.outcomeDuplicateLocs,+      goto = transition.goto,+      mode = transition.mode,+      loc = transition.loc+    }+ guardImplies :: Maybe Expr -> Maybe Expr -> Bool guardImplies _ Nothing = True guardImplies Nothing (Just _) = False@@ -451,8 +484,8 @@       "; "       [ aggregateName           <> " events=["-          <> Text.intercalate "," (Set.toAscList (eventTypes impact))+          <> Text.intercalate "," (Set.toAscList ((.eventTypes) impact))           <> "] snapshots="-          <> if includeSnapshotStreams impact then "yes" else "no"+          <> if (.includeSnapshotStreams) impact then "yes" else "no"       | (aggregateName, impact) <- Map.toAscList aggregates       ]

src/Keiro/Dsl/RouterSelection.hs view

@@ -43,28 +43,28 @@ import Keiro.Dsl.AggregateType import Keiro.Dsl.Grammar import Keiro.Dsl.LanguageVersion (LanguageFeature (DeclarativeRouterSelectionSyntax), languageSupportsFeature)-import Keiro.Dsl.SemanticContract (EffectiveLanguageContract, effectiveContractLanguageVersion)+import Keiro.Dsl.SemanticContract (EffectiveLanguageContract (..)) import Keiro.Dsl.TypeGraph import Numeric (showHex) import Numeric.Natural (Natural)  data CheckedReadModelQuery = CheckedReadModelQuery-  { checkedQueryName :: !Name,-    checkedQueryInputType :: !ResolvedTypeExpr,-    checkedQueryResultType :: !ResolvedTypeExpr+  { name :: !Name,+    inputType :: !ResolvedTypeExpr,+    resultType :: !ResolvedTypeExpr   }   deriving stock (Eq, Show, Generic)  data CheckedMappedExpr = CheckedMappedExpr-  { checkedMappedExprRoot :: !SelectionRoot,-    checkedMappedExprType :: !ResolvedTypeExpr+  { root :: !SelectionRoot,+    valueType :: !ResolvedTypeExpr   }   deriving stock (Eq, Show, Generic)  data CheckedMappedType = CheckedMappedType-  { checkedMappedTypeKey :: !MappedKey,-    checkedMappedTypeConstructor :: !Name,-    checkedMappedTypeFields :: ![ResolvedWireField]+  { key :: !MappedKey,+    constructor :: !Name,+    fields :: ![ResolvedWireField]   }   deriving stock (Eq, Show, Generic) @@ -81,16 +81,16 @@   deriving stock (Eq, Ord, Show, Generic)  data CheckedSelectionPathSegment = CheckedSelectionPathSegment-  { checkedPathField :: !Name,-    checkedPathWireKey :: !Text,-    checkedPathOwner :: !MappedKey+  { field :: !Name,+    wireKey :: !Text,+    owner :: !MappedKey   }   deriving stock (Eq, Ord, Show, Generic)  data CheckedScalarExpr = CheckedScalarExpr-  { checkedScalarType :: !SelectionScalarType,-    checkedScalarNode :: !CheckedScalarNode,-    checkedScalarLoc :: !Loc+  { valueType :: !SelectionScalarType,+    node :: !CheckedScalarNode,+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -130,26 +130,26 @@   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]+  { identity :: !Text,+    version :: !Natural,+    query :: !CheckedReadModelQuery,+    inputBinding :: !CheckedMappedExpr,+    rowBinding :: !CheckedMappedType,+    key :: !CheckedScalarExpr,+    predicate :: !CheckedScalarExpr,+    recipient :: !CheckedScalarExpr,+    commandFields :: !(Map Name CheckedScalarExpr),+    target :: !Name,+    command :: !Name,+    limit :: !Natural,+    order :: !CheckedSelectionOrder,+    dedupe :: !CheckedSelectionDedupe,+    emptyPolicy :: !CheckedEmptySelectionPolicy,+    failurePolicy :: !CheckedSelectionFailurePolicy,+    redeliveryPolicy :: !CheckedRedeliveryPolicy,+    partialPolicy :: !CheckedPartialDispatchPolicy,+    fingerprint :: !Text,+    useSites :: ![UseSite]   }   deriving stock (Eq, Show, Generic) @@ -186,16 +186,16 @@   deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)  data RouterSelectionDiagnostic = RouterSelectionDiagnostic-  { selectionDiagnosticLoc :: !Loc,-    selectionDiagnosticCode :: !RouterSelectionDiagnosticCode,-    selectionDiagnosticMessage :: !Text+  { loc :: !Loc,+    code :: !RouterSelectionDiagnosticCode,+    message :: !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"+checkRouterSelection languageContract graph spec router = case (.source) ((.resolve) router) of+  ResolveReadModel {} -> selectionFailure ((.loc) ((.resolve) router)) SelectionNotDeclarative "custom-unverified router selection has no checked declarative contract"+  ResolveHole -> selectionFailure ((.loc) ((.resolve) router)) SelectionNotDeclarative "custom-unverified router selection has no checked declarative contract"   ResolveDeclarative declaration -> checkDeclaration declaration   where     symbols = aggregateSymbolsFromGraph graph spec@@ -203,149 +203,173 @@     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"+      version <- requirePositive ((.versionLoc) declaration) SelectionVersionInvalid "selection version" ((.version) declaration)+      recipientLimit <- case (.limit) declaration of+        Nothing -> selectionFailure ((.loc) 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)+      order <- requireExact ((.orderLoc) declaration) SelectionOrderUnsupported "order" "target-stream" CheckedOrderByTargetStream ((.order) declaration)+      dedupe <- requireExact ((.dedupeLoc) declaration) SelectionDedupeUnsupported "dedupe" "target-stream" CheckedDedupeByTargetStream ((.dedupe) 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)+      redelivery <- requireExact ((.redeliveryLoc) declaration) SelectionRedeliveryUnsupported "redelivery" "stable-union" CheckedStableUnion ((.redelivery) declaration)+      partial <- requireExact ((.partialLoc) declaration) SelectionPartialDispatchUnsupported "partial" "retain-successes" CheckedRetainSuccesses ((.partial) 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+      keyExpression <- resolveSelectionExpr graph ((.valueType) inputBinding) rowBinding Nothing (EPath ((.loc) ((.input) router)) UnqualifiedRoot ["input", (.field) ((.key) router)])+      requireScalarType ((.loc) ((.input) router)) SelectionQueryInputBindingInvalid "router key" SelectionText keyExpression+      predicate <- resolveSelectionExpr graph ((.valueType) inputBinding) rowBinding Nothing ((.predicate) declaration)+      requireScalarType (exprLoc ((.predicate) declaration)) SelectionPredicateNotBool "where predicate" SelectionBool predicate+      recipient <- resolveSelectionExpr graph ((.valueType) inputBinding) rowBinding Nothing ((.recipient) declaration)+      requireScalarType (exprLoc ((.recipient) 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)+              { identity = identity,+                version = version,+                query = query,+                inputBinding = inputBinding,+                rowBinding = rowBinding,+                key = keyExpression,+                predicate = predicate,+                recipient = recipient,+                commandFields = commandFields,+                target = (.target) router,+                command = (.command) ((.dispatch) router),+                limit = recipientLimit,+                order = order,+                dedupe = dedupe,+                emptyPolicy = emptyPolicy,+                failurePolicy = failurePolicy,+                redeliveryPolicy = redelivery,+                partialPolicy = partial,+                fingerprint = "",+                useSites = queryUseSites ((.query) declaration)               }-      pure initial {checkedFingerprint = routerSelectionFingerprint initial}+      pure (setRouterSelectionFingerprint (routerSelectionFingerprint initial) initial)      requireFeature declaration-      | languageSupportsFeature (effectiveContractLanguageVersion languageContract) DeclarativeRouterSelectionSyntax = Right ()-      | otherwise = selectionFailure (rsLoc declaration) SelectionCapabilityUnavailable "declarative router selection requires language keiro-dsl 5"+      | languageSupportsFeature ((.contractLanguageVersion) languageContract) DeclarativeRouterSelectionSyntax = Right ()+      | otherwise = selectionFailure ((.loc) declaration) SelectionCapabilityUnavailable "declarative router selection requires language keiro-dsl 5" +    setRouterSelectionFingerprint fingerprint selection =+      CheckedRouterSelection+        { identity = selection.identity,+          version = selection.version,+          query = selection.query,+          inputBinding = selection.inputBinding,+          rowBinding = selection.rowBinding,+          key = selection.key,+          predicate = selection.predicate,+          recipient = selection.recipient,+          commandFields = selection.commandFields,+          target = selection.target,+          command = selection.command,+          limit = selection.limit,+          order = selection.order,+          dedupe = selection.dedupe,+          emptyPolicy = selection.emptyPolicy,+          failurePolicy = selection.failurePolicy,+          redeliveryPolicy = selection.redeliveryPolicy,+          partialPolicy = selection.partialPolicy,+          fingerprint,+          useSites = selection.useSites+        }+     requireIdentity declaration-      | T.null (T.strip (rsIdentity declaration)) = selectionFailure (rsIdentityLoc declaration) SelectionIdentityEmpty "selection identity must not be empty"-      | otherwise = Right (rsIdentity declaration)+      | T.null (T.strip ((.identity) declaration)) = selectionFailure ((.identityLoc) declaration) SelectionIdentityEmpty "selection identity must not be empty"+      | otherwise = Right ((.identity) declaration) -    checkEmptyPolicy declaration = case rsEmptyPolicy declaration of+    checkEmptyPolicy declaration = case (.emptyPolicy) 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"+    checkFailurePolicy declaration = case (.failurePolicy) declaration of+      SelectionAck -> selectionFailure ((.failurePolicyLoc) 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 <> "'")+      readModel <- case find ((== (.query) declaration) . (.name)) readModels of+        Nothing -> selectionFailure ((.queryLoc) declaration) SelectionQueryUnknown ("selection query names undeclared readmodel '" <> (.query) 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"+      queryTypesDeclaration <- maybe (selectionFailure ((.queryLoc) declaration) SelectionQueryContractMissing ("readmodel '" <> (.name) readModel <> "' has no typed query input/result contract")) Right ((.queryTypes) readModel)+      if (.queryInput) 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)+        else selectionFailure ((.queryInputLoc) declaration) SelectionQueryInputBindingInvalid "selection query input must be the router input binding `input`"+      queryInput <- liftTypeGraph ((.queryLoc) declaration) (resolveTypeExpression graph ("readmodel " <> (.name) readModel <> " query input") ((.inputLoc) queryTypesDeclaration) ((.input) queryTypesDeclaration))+      queryResult <- liftTypeGraph ((.queryLoc) declaration) (resolveTypeExpression graph ("readmodel " <> (.name) readModel <> " query result") ((.resultLoc) queryTypesDeclaration) ((.result) queryTypesDeclaration))+      routerInputExpression <- maybe (selectionFailure ((.loc) ((.input) router)) SelectionQueryInputBindingInvalid "declarative router input must name its mapped query-input type with `input Name : Type`") Right ((.valueType) ((.input) router))+      routerInput <- liftTypeGraph ((.loc) ((.input) router)) (resolveTypeExpression graph ("router " <> (.id) router <> " input") ((.loc) ((.input) 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+        else selectionFailure ((.loc) ((.input) router)) SelectionQueryInputTypeMismatch ("router input type does not match readmodel '" <> (.name) readModel <> "' query input")+      _ <- structuralRecord ((.loc) ((.input) 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"+        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,+        ( CheckedReadModelQuery ((.name) readModel) queryInput queryResult,           CheckedMappedExpr SelectionInput queryInput,           rowBinding         )      structuralRecord diagnosticLoc diagnosticCode owner = \case-      RRef key -> case Map.lookup key (tgDeclarations graph) of+      RRef key -> case Map.lookup key ((.declarations) 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+    resolveTargetCommand = case [aggregate | NAggregate aggregate <- (.nodes) spec, (.name) aggregate == (.target) router] of+      [aggregate] -> case [command | command <- (.commands) aggregate, (.name) command == (.command) ((.dispatch) 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")+        _ -> selectionFailure ((.loc) ((.dispatch) router)) SelectionCommandUnknown ("target aggregate '" <> (.target) router <> "' has no unique command '" <> (.command) ((.dispatch) router) <> "'")+      _ -> selectionFailure ((.loc) router) SelectionTargetAmbiguous ("declarative router target '" <> (.target) 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)+      let bindings = (.fields) ((.dispatch) router)+          duplicateNames = duplicates (map (.name) bindings)+          expectedNames = sort (map (.name) ((.fields) command))+          actualNames = sort (map (.name) bindings)       case duplicateNames of-        duplicateName : _ -> selectionFailure (rdLoc (rtDispatch router)) SelectionCommandMappingDuplicate ("dispatch field '" <> duplicateName <> "' is mapped more than once")+        duplicateName : _ -> selectionFailure ((.loc) ((.dispatch) 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)+        else selectionFailure ((.loc) ((.dispatch) router)) SelectionCommandMappingIncomplete ("dispatch mapping must bind every field of command '" <> (.name) command <> "' exactly once")+      Map.fromList <$> traverse (checkBinding selectionGraph inputBinding rowBinding aggregate bindings) ((.fields) command)      checkBinding selectionGraph inputBinding rowBinding aggregate bindings field = do-      binding <- case find ((== aggregateFieldName field) . fbName) bindings of+      binding <- case find ((== (.name) field) . (.name)) 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+        Nothing -> selectionFailure ((.loc) ((.dispatch) router)) SelectionCommandMappingIncomplete ("missing dispatch mapping for field '" <> (.name) field <> "'")+      expression <- resolveBinding selectionGraph inputBinding rowBinding ((.loc) ((.dispatch) 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")+        Left _ -> selectionFailure ((.loc) field) SelectionCommandMappingTypeMismatch ("command field '" <> (.name) 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)+      expected <- maybe (selectionFailure ((.loc) field) SelectionCommandMappingTypeMismatch ("command field '" <> (.name) field <> "' is not a supported scalar selection target")) Right (selectionTypeFromAggregate expectedAggregateType)+      requireScalarType ((.loc) expression) SelectionCommandMappingTypeMismatch ("command field '" <> (.name) field <> "'") expected expression+      pure ((.name) field, expression)      queryUseSites queryName =       [ useSite-      | useSite <- tgUseSites graph,+      | useSite <- (.useSites) graph,         case useSite of           RootReadModelQueryInput name _ -> name == queryName           RootReadModelQueryResult name _ -> name == queryName           _ -> False       ] -    readModels = [readModel | NReadModel readModel <- specNodes spec]+    readModels = [readModel | NReadModel readModel <- (.nodes) spec]  resolveBinding :: TypeGraph -> CheckedMappedExpr -> CheckedMappedType -> Loc -> FieldBinding -> Either (NonEmpty RouterSelectionDiagnostic) CheckedScalarExpr resolveBinding graph inputBinding rowBinding diagnosticLoc binding =-  resolveSelectionExpr graph (checkedMappedExprType inputBinding) rowBinding Nothing expression+  resolveSelectionExpr graph ((.valueType) inputBinding) rowBinding Nothing expression   where-    expression = case fbValue binding of-      Nothing -> EPath diagnosticLoc UnqualifiedRoot ["input", fbName binding]+    expression = case (.value) binding of+      Nothing -> EPath diagnosticLoc UnqualifiedRoot ["input", (.name) binding]       Just value         | Just literal <- quotedValue value -> ELiteral diagnosticLoc (LiteralText literal)         | otherwise -> EPath diagnosticLoc UnqualifiedRoot (T.splitOn "." value)@@ -361,7 +385,7 @@   EPath loc UnqualifiedRoot (rootName : fields) -> do     (root, rootType) <- case rootName of       "input" -> Right (SelectionInput, inputType)-      "row" -> Right (SelectionRow, RRef (checkedMappedTypeKey rowType))+      "row" -> Right (SelectionRow, RRef ((.key) 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"@@ -404,18 +428,18 @@       (checkedLeft, checkedRight) <- case left of         ELiteral _ LiteralIntegral {} -> do           rightValue <- resolveSelectionExpr graph inputType rowType Nothing right-          leftValue <- resolveSelectionExpr graph inputType rowType (Just (checkedScalarType rightValue)) left+          leftValue <- resolveSelectionExpr graph inputType rowType (Just ((.valueType) rightValue)) left           pure (leftValue, rightValue)         _ -> do           leftValue <- resolveSelectionExpr graph inputType rowType Nothing left-          rightValue <- resolveSelectionExpr graph inputType rowType (Just (checkedScalarType leftValue)) right+          rightValue <- resolveSelectionExpr graph inputType rowType (Just ((.valueType) leftValue)) right           pure (leftValue, rightValue)-      if checkedScalarType checkedLeft == checkedScalarType checkedRight+      if (.valueType) checkedLeft == (.valueType) checkedRight         then pure ()         else selectionFailure (exprLoc expression) SelectionExpressionTypeMismatch "comparison operands have different scalar types"-      if comparisonAdmitted operator (checkedScalarType checkedLeft)+      if comparisonAdmitted operator ((.valueType) checkedLeft)         then pure ()-        else selectionFailure (exprLoc expression) SelectionOperatorUnsupported ("comparison operator is not admitted for " <> scalarTypeText (checkedScalarType checkedLeft))+        else selectionFailure (exprLoc expression) SelectionOperatorUnsupported ("comparison operator is not admitted for " <> scalarTypeText ((.valueType) checkedLeft))       requireExpected (exprLoc expression) expected SelectionBool       pure (CheckedScalarExpr SelectionBool (CheckedCompare operator checkedLeft checkedRight) (exprLoc expression)) @@ -428,16 +452,16 @@       [] -> 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 <> "'")+      name : rest -> case currentType of+        RRef owner -> case Map.lookup owner ((.declarations) graph) of+          Just (ResolvedStructural _ (RRecord _ _ fields)) -> case find ((== name) . (.haskell)) fields of+            Nothing -> selectionFailure diagnosticLoc SelectionExpressionFieldUnknown ("mapped record '" <> unMappedKey owner <> "' has no field '" <> name <> "'")             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+              | (.presence) field /= PRequired -> selectionFailure diagnosticLoc SelectionExpressionFieldOptional ("field '" <> name <> "' is optional; selection paths must be total")+              | ROptional {} <- (.valueType) field -> selectionFailure diagnosticLoc SelectionExpressionFieldOptional ("field '" <> name <> "' is nullable; selection paths must be total")+              | otherwise -> go (CheckedSelectionPathSegment name ((.key) field) owner : segments) ((.valueType) 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")+        _ -> selectionFailure diagnosticLoc SelectionExpressionFieldUnknown ("cannot project field '" <> name <> "' through a scalar value")  requirePositive :: Loc -> RouterSelectionDiagnosticCode -> Text -> Natural -> Either (NonEmpty RouterSelectionDiagnostic) Natural requirePositive diagnosticLoc diagnosticCode owner value@@ -457,8 +481,8 @@  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))+  | (.valueType) expression == expected = Right ()+  | otherwise = selectionFailure diagnosticLoc diagnosticCode (owner <> " must have type " <> scalarTypeText expected <> ", found " <> scalarTypeText ((.valueType) 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@@ -525,26 +549,26 @@ 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 ((.name) ((.query) selection)),+      canonicalResolvedType ((.inputType) ((.query) selection)),+      canonicalResolvedType ((.resultType) ((.query) selection)),+      canonicalScalar ((.key) selection),+      canonicalScalar ((.predicate) selection),+      canonicalScalar ((.recipient) selection),+      tuple [tuple [atom name, canonicalScalar expression] | (name, expression) <- Map.toAscList ((.commandFields) selection)],+      atom ((.target) selection),+      atom ((.command) selection),+      atom (T.pack (show ((.limit) selection))),       atom "order:target-stream",       atom "dedupe:target-stream",-      atom ("empty:" <> T.pack (show (checkedEmptyPolicy selection))),-      atom ("failure:" <> T.pack (show (checkedFailurePolicy selection))),+      atom ("empty:" <> T.pack (show ((.emptyPolicy) selection))),+      atom ("failure:" <> T.pack (show ((.failurePolicy) selection))),       atom "redelivery:stable-union",       atom "partial:retain-successes"     ]  canonicalScalar :: CheckedScalarExpr -> Text-canonicalScalar expression = tuple [atom (scalarTypeText (checkedScalarType expression)), node (checkedScalarNode expression)]+canonicalScalar expression = tuple [atom (scalarTypeText ((.valueType) expression)), node ((.node) expression)]   where     node = \case       CheckedPath root segments -> tuple (atom (T.pack (show root)) : map segment segments)@@ -554,7 +578,7 @@       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)]+    segment value = tuple [atom (unMappedKey ((.owner) value)), atom ((.field) value), atom ((.wireKey) value)]  canonicalResolvedType :: ResolvedTypeExpr -> Text canonicalResolvedType = \case

src/Keiro/Dsl/RuntimePackage.hs view

@@ -2,6 +2,7 @@ -- generated Keiro modules. module Keiro.Dsl.RuntimePackage   ( RuntimePackageName (..),+    unRuntimePackageName,     mkRuntimePackageName,     isCabalPackageName,   )@@ -17,6 +18,9 @@   { unRuntimePackageName :: Text   }   deriving stock (Eq, Ord, Show)++unRuntimePackageName :: RuntimePackageName -> Text+unRuntimePackageName (RuntimePackageName value) = value  -- | Validate and construct an explicit runtime package name. mkRuntimePackageName :: Text -> Either Text RuntimePackageName

src/Keiro/Dsl/Scaffold.hs view

@@ -99,8731 +99,8760 @@     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)-      ]-        <> concatMap (registerRefusals aggregate) (aggRegs aggregate)-        <> concatMap (fieldRefusals aggregate CommandFieldUse) (concatMap cmdFields (aggCommands aggregate))-        <> concatMap (fieldRefusals aggregate EventFieldUse) [field | event <- aggEvents aggregate, EventFields fields <- [evBody event], field <- fields]-    fieldRefusals aggregate useSite field = case inferAggregateFieldType symbols aggregate useSite field of-      Right _ -> []-      Left _ ->-        [ "FieldTypeUnrepresentable: aggregate '"-            <> aggName aggregate-            <> "' field '"-            <> aggregateFieldName field-            <> "' has unsupported explicit type '"-            <> maybe "(inferred)" typeExprCanonicalName (aggregateFieldType field)-            <> "'"-        ]-    registerRefusals aggregate register =-      case resolveAggregateType symbols (regLoc register) RegisterUse (regType register) of-        Left _ ->-          [ "RegTypeUnsupported: aggregate '"-              <> aggName aggregate-              <> "' register '"-              <> regName register-              <> "' has unsupported type '"-              <> typeExprCanonicalName (regType register)-              <> "'"-          ]-        Right resolved -> case resolveRegisterInitial symbols (regLoc register) resolved (regInitial register) of-          Right _ -> []-          Left _ -> [initialRefusal aggregate register resolved]-    initialRefusal aggregate register resolved = case resolved of-      AggregateText -> label "RegTextInitialNotQuoted" "must use a quoted Text initial"-      AggregateNominal nominal-        | EnumRepresentation {} <- resolvedNominalRepresentation nominal ->-            label "RegInitialNotEnumCtor" ("must start at the declaration-owned initial for enum '" <> resolvedNominalName nominal <> "'")-      AggregateMapped {} -> label "MappedRegisterInitialMissing" "requires the mapped declaration's initial symbol"-      _ -> label "RegInitialInvalidLiteral" ("has an invalid " <> aggregateCanonicalName resolved <> " initial")-      where-        label codeName detail = codeName <> ": aggregate '" <> aggName aggregate <> "' register '" <> regName register <> "' " <> detail-    contractRefusals contract =-      [ "ContractEmpty: contract '" <> ctrName contract <> "' must declare at least one event"-      | null (ctrEvents contract)-      ]-    publisherRefusals publisher =-      let backoff = pubBackoff publisher-          label message = message <> ": publisher '" <> pubName publisher <> "'"-       in case boKind backoff of-            "constant" -> []-            "exponential" -> case (boMax backoff, boMultiplier backoff) of-              (Just maximumWindow, Just multiplierText) ->-                case (windowSeconds (boWindow backoff), windowSeconds maximumWindow, readMaybe (T.unpack multiplierText) :: Maybe Double) of-                  (Right initialSeconds, Right maximumSeconds, Just multiplier)-                    | initialSeconds > 0 && maximumSeconds >= initialSeconds && multiplier >= 1 -> []-                  _ -> [label "BackoffInvalidExponential"]-              _ -> [label "BackoffExponentialIncomplete"]-            other -> [label ("BackoffUnknownKind '" <> other <> "'")]--windowSeconds :: Text -> Either Text Int-windowSeconds window = case T.unsnoc window of-  Just (digits, unit)-    | not (T.null digits),-      Just amount <- readMaybe (T.unpack digits) -> case unit of-        's' -> Right amount-        'm' -> Right (amount * 60)-        'h' -> Right (amount * 3600)-        _ -> Left invalid-  _ -> Left invalid-  where-    invalid = "invalid window '" <> window <> "' (expected digits followed by s, m, or h)"--windowText :: Text -> Text-windowText = either (const "0") tshow' . windowSeconds---- | Render an Expr back to source-ish text for a hole annotation.-renderGuard :: Expr -> Text-renderGuard = renderExpr------------------------------------------------------------------------------------- Text helpers-----------------------------------------------------------------------------------nl :: [Text] -> Text-nl = T.intercalate "\n"---- | Join groups of declarations, blank-line-separated, dropping empties.-sectionsOf :: [[Text]] -> Text-sectionsOf = T.intercalate "\n\n" . filter (not . T.null) . map (T.intercalate "\n\n")--lowerFirst :: Text -> Text-lowerFirst = generatedCase HaskellName.LogicalIdentifier False---- | Assert the shared category proof at emission time as a belt-and-braces--- guard for callers that bypass the CLI's normal validate-before-scaffold path.-staticCategory :: Text -> Text -> Text-staticCategory owner value = case sagaCategoryError value of-  Nothing -> value-  Just reason -> error (T.unpack ("keiro-dsl scaffold: illegal " <> owner <> " category " <> tshow value <> " " <> reason))--pascal :: Text -> Text-pascal = generatedCase HaskellName.LogicalIdentifier True--pascalFromKebab :: Text -> Text-pascalFromKebab = generatedCase HaskellName.LogicalWireWord True--generatedCase :: HaskellName.NameSourceKind -> Bool -> Text -> Text-generatedCase source upper name =-  case HaskellName.deriveHaskellName source site of-    Right derived-      | upper -> HaskellName.renderUpperCamelName (HaskellName.upperCamel derived)-      | otherwise -> HaskellName.renderLowerCamelName (HaskellName.lowerCamel derived)-    Left _ -> name-  where-    site =-      HaskellName.NameSite-        { HaskellName.siteKind = HaskellName.GeneratedHelperSite,-          HaskellName.siteLogicalName = name,-          HaskellName.siteOwner = "scaffold-renderer",-          HaskellName.siteLine = 0+    modernizeScaffoldModule,+    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, 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+  { path :: !FilePath,+    text :: !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+  { ownerKind :: !Text,+    ownerName :: !Text,+    family :: !Text+  }+  deriving stock (Eq, Ord, Show)++moduleRole :: ScaffoldModule -> ModuleRole+moduleRole scaffoldModule =+  ModuleRole+    { ownerKind = headOr "module" originWords,+      ownerName = (.origin) scaffoldModule,+      family = case reverse (T.splitOn "." moduleName) of+        family : _ -> family+        [] -> moduleName+    }+  where+    originWords = T.words ((.origin) scaffoldModule)+    moduleName = T.replace "/" "." (T.dropEnd 3 (T.pack ((.path) 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+  { name :: !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+  { aggregate :: !Name,+    kind :: !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+  { declaration :: !ResolvedNominalType,+    moduleName :: !Text,+    useSites :: !(Set.Set NominalUseSite),+    equalityUsed :: !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 {name = 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+      { path = T.unpack (T.replace "." "/" moduleName <> ".hs"),+        text =+          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 ((.key) entry))+                       <> " -> Just (BehaviorSourceLocation "+                       <> tshow (T.pack ((.file) entry))+                       <> " "+                       <> tshow' ((.line) entry)+                       <> " "+                       <> tshow' ((.column) entry)+                       <> ")"+                   | entry <- sortOn (.key) entries+                   ]+                <> [ "  _ -> Nothing",+                     "",+                     "renderBehaviorSourceLocation :: Text -> Text",+                     "renderBehaviorSourceLocation key = case behaviorSourceLocation key of",+                     "  Just location -> T.pack location.sourceFile <> \":\" <> tshow location.sourceLine <> \":\" <> tshow location.sourceColumn",+                     "  Nothing -> \"<internal invariant: missing behavior source for \" <> key <> \">\"",+                     "",+                     "tshow :: Show value => value -> Text",+                     "tshow = T.pack . show"+                   ]+            ),+        kind = Generated,+        origin = "context " <> (.name) 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 . (.name)++--------------------------------------------------------------------------------+-- 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 =+  [ ((.path) m, breach, n)+  | m <- mods,+    (.kind) m == Generated,+    not (authoritativeScalarModule m),+    (n, line) <- zip [1 ..] (T.lines ((.text) 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` (.text) scaffoldModule+       )+  where+    path = (.path) 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+  { context :: !Context,+    checkedService :: !CheckedService,+    languageContract :: !EffectiveLanguageContract,+    spec :: !Spec,+    aggregate :: !Aggregate,+    ctxPascal :: !Text,+    name :: !Text,+    loc :: !Loc,+    vertexType :: !Text,+    ids :: ![IdDecl],+    enums :: ![EnumDecl],+    regs :: ![ResolvedRegister],+    states :: ![StateDecl],+    commands :: ![ResolvedCtor],+    events :: ![ResolvedCtor],+    domainOutcomeTypes :: !(Maybe ResolvedDomainOutcomeTypes),+    -- | Generated IDs and enums used by this aggregate, in stable name order.+    generatedNominals :: ![ResolvedNominalType],+    transitions :: ![Transition],+    outputMappings :: !(Map.Map (Int, Int) EventOutputMapping),+    wire :: !WireSpec,+    projection :: !(Maybe ProjectionSpec),+    snapshot :: !(Maybe SnapshotSpec),+    foldFingerprint :: !Text,+    readModels :: ![ReadModelNode],+    typeGraph :: !(Maybe TypeGraph),+    symbols :: !AggregateSymbols,+    -- | e.g. @Generated.HospitalCapacity.Reservation@+    genPrefix :: !Text,+    -- | e.g. @HospitalCapacity.Reservation@+    holePrefix :: !Text+  }++data ResolvedDomainOutcomeTypes = ResolvedDomainOutcomeTypes+  { rejectionType :: !ResolvedAggregateType,+    noOpType :: !ResolvedAggregateType+  }+  deriving stock (Eq, Show)++aggregateCheckedService :: Agg -> CheckedService+aggregateCheckedService = (.checkedService)++data ResolvedRegister = ResolvedRegister+  { name :: !Name,+    valueType :: !ResolvedAggregateType,+    initial :: !ResolvedRegisterInitial,+    loc :: !Loc+  }+  deriving stock (Eq, Show)++-- | A command or event constructor with its fully-resolved field identities and+-- aggregate types.+data ResolvedCtor = ResolvedCtor+  { name :: !Text,+    -- | (DSL/selector/wire identity, canonical aggregate type)+    fields :: ![(ResolvedFieldIdentity, ResolvedAggregateType)],+    -- | EP-2: schema version (1 for commands and unversioned events).+    version :: !Int,+    -- | EP-2: the source version this event migrates from (the upcaster step).+    upcastFrom :: !(Maybe Int)+  }++defaultWire :: WireSpec+defaultWire = WireSpec {kind = "ctorName", fields = "camelCase", schemaVersion = 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+    { context = ctx,+      checkedService = service,+      languageContract = checkedLanguageContract service,+      spec = spec,+      aggregate = agg,+      ctxPascal = ctxPascal,+      name = nm,+      loc = (.loc) agg,+      vertexType = vertexType,+      ids = (.ids) spec,+      enums = (.enums) spec,+      regs = map resolveRegister ((.regs) agg),+      states = (.states) agg,+      commands = map resolveCommand ((.commands) agg),+      events = map resolveEvent ((.events) agg),+      domainOutcomeTypes = resolvedDomainOutcomeTypes,+      generatedNominals = generatedNominalsInTypes aggregateResolvedTypes,+      transitions = (.transitions) agg,+      outputMappings =+        Map.fromList+          [ ( (transitionIndex, emitIndex),+              orDieOutput (eventOutputMappingFromGraphResult typeGraphResult spec agg transition emitIndex eventName)+            )+          | (transitionIndex, transition) <- zip [1 ..] ((.transitions) agg),+            (emitIndex, eventName) <- zip [1 ..] ((.emits) transition)+          ],+      wire = fromMaybe defaultWire ((.wire) agg),+      projection = (.projection) agg,+      snapshot = (.snapshot) agg,+      foldFingerprint = either (error . T.unpack . renderFoldSurfaceError) id (aggregateFoldFingerprintForService service agg),+      readModels = [readModel | NReadModel readModel <- (.nodes) spec],+      typeGraph = either (const Nothing) Just typeGraphResult,+      symbols = symbols,+      genPrefix = genPrefixFor ctx nm,+      holePrefix = holePrefixFor ctx nm+    }+  where+    spec = checkedSpec service+    nm = (.name) agg+    typeGraphResult = checkedTypeGraph service+    symbols = aggregateSymbolsFromGraphResult typeGraphResult spec+    ctxPascal = pascalFromKebab ((.name) ctx)+    vertexType = nm <> "Vertex"+    commandFieldTypes = [((.name) c, (.fields) c) | c <- (.commands) agg]+    resolveCommand c = mkCtor CommandFieldUse ((.name) c) ((.fields) c) 1 Nothing+    resolveEvent e =+      mkCtor EventFieldUse ((.name) e) (eventFields e) ((.version) e) (fst <$> (.upcastFrom) e)+      where+        eventFields ev = case (.body) ev of+          EventFields fs -> fs+          EventFromCommand cn -> fromMaybe [] (lookup cn commandFieldTypes)+    mkCtor useSite cn fs version upcastFrom =+      ResolvedCtor+        { name = cn,+          fields = map (\field -> (resolveAggregateFieldIdentity field, orDie (inferAggregateFieldType symbols agg useSite field))) fs,+          version,+          upcastFrom+        }+    aggregateResolvedTypes =+      map (.valueType) (map resolveRegister ((.regs) agg))+        <> map snd (concatMap (.fields) (map resolveCommand ((.commands) agg)))+        <> map snd (concatMap (.fields) (map resolveEvent ((.events) agg)))+    resolvedDomainOutcomeTypes = case (.domainOutcomeTypes) agg of+      Nothing -> Nothing+      Just declaration ->+        Just+          ResolvedDomainOutcomeTypes+            { rejectionType = resolveOutcomeType declaration ((.rejectionType) declaration),+              noOpType = resolveOutcomeType declaration ((.noOpType) declaration)+            }+    resolveOutcomeType declaration name =+      orDie (resolveAggregateType symbols ((.outcomeTypesLoc) declaration) HaskellLoweringUse (TRef name))+    resolveRegister register =+      let resolvedType = orDie (resolveAggregateType symbols ((.loc) register) RegisterUse ((.valueType) register))+          resolvedInitial = orDie (resolveRegisterInitial symbols ((.loc) register) resolvedType ((.initial) register))+       in ResolvedRegister+            { name = (.name) register,+              valueType = resolvedType,+              initial = resolvedInitial,+              loc = (.loc) 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 $+    [ ((.name) nominal, nominal)+    | AggregateNominal nominal <- resolvedTypes,+      GeneratedNominal <- [(.ownership) 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 <- (.nodes) spec]+      generated =+        [ nominal+        | nominal <- Map.elems (nominalTypes registry),+          GeneratedNominal <- [(.ownership) nominal]+        ]+  pure+    [ NominalGenerationOwner+        { declaration = nominal,+          moduleName = generatedNominalModule ctx,+          useSites = Set.fromList (concatMap (usesFor nominal) aggregates),+          equalityUsed = any (nominalEqualityUsedInGeneratedExpressions nominal) aggregates+        }+    | nominal <- generated+    ]+  where+    spec = checkedSpec service+    usesFor nominal aggregate =+      [ NominalUseSite ((.name) aggregate) useKind+      | useKind <- aggregateUseKinds nominal aggregate+      ]++nominalEqualityUsedInGeneratedExpressions :: ResolvedNominalType -> Agg -> Bool+nominalEqualityUsedInGeneratedExpressions nominal aggregate =+  any+    (anyTypedExpression comparesNominal)+    (resolvedGeneratedExpressions aggregate <> resolvedOutcomeExpressions aggregate)+  where+    comparesNominal expression = case (.node) expression of+      TypedEqual left _ -> (.valueType) left == AggregateNominal nominal+      TypedNotEqual left _ -> (.valueType) 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` ((.generatedNominals) aggregate <> outcomeNominals)]+  where+    registerNominals = generatedNominalsInTypes (map (.valueType) ((.regs) aggregate))+    commandNominals = generatedNominalsInTypes (map snd (concatMap (.fields) ((.commands) aggregate)))+    eventNominals = generatedNominalsInTypes (map snd (concatMap (.fields) ((.events) aggregate)))+    outcomeNominals =+      generatedNominalsInTypes+        [ resolvedType+        | outcomeTypes <- maybeToList ((.domainOutcomeTypes) aggregate),+          resolvedType <- [(.rejectionType) outcomeTypes, (.noOpType) 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, [(.name) (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 ((.declarations) graph)+        ]+      projectionModules =+        [ ( ScaffoldModule+              { path = T.unpack (T.replace "." "/" (structuralProjectionModule ctx) <> ".hs"),+                text = emitStructuralProjections ctx graph,+                kind = Generated,+                origin = "context " <> (.context) 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) ((.declarations) 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 (.name) (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+      { path = T.unpack (T.replace "." "/" moduleName <> ".hs"),+        text = emitCodecComparison ctx moduleName graph declaration shape owner,+        kind = Generated,+        origin = "non-production codec comparison " <> requestedName+      }+  where+    comparisonOwners declaration =+      [ aggregate+      | NAggregate aggregate <- (.nodes) spec,+        let resolved = resolveAgg ctx spec aggregate,+        any ((== (.name) declaration) . mappedName) (codecMappedDeclarations resolved)+      ]+      where+        mappedName (ResolvedStructural structural _) = (.name) structural+        mappedName (ResolvedOpaque opaque) = (.name) 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 (historicalCodec.encode 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",+      "          { historicalCodecIdentity = historicalCodec.identity",+      "          , historicalCodecVersion = historicalCodec.version",+      "          , canonicalType = CanonicalTypeId " <> tshow (unCanonicalTypeId ((.canonical) declaration)),+      "          , bindingSymbol = QualifiedValueName " <> tshow (unQualifiedValueName ((.binding) declaration)),+      "          , bindingVersion = BindingVersion " <> tshow (unBindingVersion ((.bindingVersion) declaration)),+      "          , wireFingerprint = " <> 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 = historicalCodec.decode 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 = (.name) declaration+    domainType = renderReferenceOrDie importPlan (haskellTypeReference ((.haskell) declaration))+    codecModule = genPrefixFor ctx ((.name) owner) <> ".Codec"+    fixtureReference = renderReferenceOrDie importPlan (qualifiedValueReference ((.fixtures) declaration))+    importPlan =+      planImportsOrDie+        moduleName+        Set.empty+        ( Set.fromList+            [ haskellTypeReference ((.haskell) declaration),+              qualifiedValueReference ((.fixtures) declaration)+            ]+        )++branchSchemaFor :: TypeGraph -> ResolvedMappedDecl -> BranchSchema+branchSchemaFor graph =+  foldMappedDecl+    MappedDeclAlgebra+      { onStructuralDecl = \_ shape ->+          foldMappedShape+            MappedShapeAlgebra+              { onRecord = \_ _ fields ->+                  BranchRecord+                    [ BranchField+                        ((.key) field)+                        ((.presence) field == POptional)+                        (branchExpr graph ((.valueType) field))+                    | field <- fields+                    ],+                onEnum = const BranchScalar,+                onUnion = \encoding arms ->+                  BranchUnion+                    ((.tagField) encoding)+                    ((.contentsField) encoding)+                    [BranchArm ((.tag) arm) (branchExpr graph <$> (.payload) 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 ((.declarations) 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 ((.wireKey) field)+            <> " "+            <> (if (.presenceOptional) field then "True" else "False")+            <> " ("+            <> renderBranchSchema ((.schema) field)+            <> ")"+        | field <- fields+        ]+      <> "]"+  BranchUnion tagField contentsField arms ->+    "BranchUnion "+      <> tshow tagField+      <> " "+      <> tshow contentsField+      <> " ["+      <> T.intercalate+        ", "+        [ "BranchArm "+            <> tshow ((.wireTag) arm)+            <> " "+            <> maybe "Nothing" (\nested -> "(Just (" <> renderBranchSchema nested <> "))") ((.payloadSchema) 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 (.mappedName) entries))+    | (owner, entries) <- Map.toAscList (Map.fromListWith (<>) [((.moduleName) obligation, [obligation]) | obligation <- obligations])+    ]++emitBindingSkeleton :: Context -> Spec -> TypeGraph -> Text -> [BindingObligation] -> ScaffoldModule+emitBindingSkeleton ctx spec graph owner obligations =+  ScaffoldModule+    { path = T.unpack (T.replace "." "/" owner <> ".hs"),+      text =+        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 "  , ") <> (.symbol) 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 -> (.category) obligation == "structural" && (.kind) obligation `elem` [BindingValue, FixtureValue]) obligations+        ]+          <> [ "Keiro.Codec.Nominal (NominalBinding (..), NominalFixtureCases)"+             | any ((/= "structural") . (.category)) obligations+             ]+          <> [ "Data.KindID (KindID)"+             | obligation <- obligations,+               Just (nominal, _) <- [nominalFor obligation],+               IdRepresentation {} <- [(.representation) nominal]+             ]+          <> [ "Data.Text (Text)"+             | obligation <- obligations,+               Just (nominal, _) <- [nominalFor obligation],+               ScalarRepresentation NominalText <- [(.representation) nominal]+             ]+          <> [ "Data.Time (UTCTime)"+             | obligation <- obligations,+               Just (nominal, _) <- [nominalFor obligation],+               ScalarRepresentation NominalTime <- [(.representation) nominal]+             ]+          <> [ "Numeric.Natural (Natural)"+             | obligation <- obligations,+               Just (nominal, _) <- [nominalFor obligation],+               ScalarRepresentation NominalNatural <- [(.representation) 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 (.kind) obligation of+        BindingValue -> renderBinding importPlan ctx declaration shape obligation+        FixtureValue ->+          [ "-- HOLE: provide deterministic labelled conformance fixtures for " <> (.name) declaration,+            renderStructuralObligationSignature importPlan declaration obligation,+            (.symbol) obligation <> " = error " <> tshow ("HOLE: fill " <> (.name) declaration <> " fixtures")+          ]+        InitialValue ->+          [ "-- HOLE: provide the initial register value for " <> (.name) declaration,+            renderStructuralObligationSignature importPlan declaration obligation,+            (.symbol) obligation <> " = error " <> tshow ("HOLE: fill " <> (.name) declaration <> " initial value")+          ]+    structuralFor obligation = case Map.lookup (MappedKey ((.mappedName) obligation)) ((.declarations) graph) of+      Just (ResolvedStructural declaration shape) -> Just (declaration, shape)+      _ -> Nothing+    nominalFor obligation = do+      registry <- either (const Nothing) Just (resolveNominalTypes spec)+      nominal <- lookupNominalType ((.mappedName) obligation) registry+      binding <- case (.ownership) nominal of+        ConsumerNominal value -> Just value+        GeneratedNominal -> Nothing+      pure (nominal, binding)+    renderNominalObligation nominal binding obligation = case (.kind) obligation of+      BindingValue ->+        [ "-- HOLE: complete both total directions; the generated codec remains wire authority.",+          renderNominalObligationSignature importPlan ctx nominal binding obligation,+          (.symbol) obligation <> " =",+          "  NominalBinding",+          "    { nominalToRepresentation = \\_domainValue -> error " <> tshow ("HOLE: fill " <> (.name) nominal <> " nominalToRepresentation"),+          "    , nominalFromRepresentation = \\_representationValue -> error " <> tshow ("HOLE: fill " <> (.name) nominal <> " nominalFromRepresentation"),+          "    }"+        ]+      FixtureValue ->+        [ "-- HOLE: provide deterministic labelled expected-wire fixtures for " <> (.name) nominal,+          renderNominalObligationSignature importPlan ctx nominal binding obligation,+          (.symbol) obligation <> " = error " <> tshow ("HOLE: fill " <> (.name) nominal <> " fixtures")+        ]+      InitialValue ->+        [ "-- HOLE: provide the initial register value for " <> (.name) nominal,+          renderNominalObligationSignature importPlan ctx nominal binding obligation,+          (.symbol) obligation <> " = error " <> tshow ("HOLE: fill " <> (.name) 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.",+    (.symbol) obligation <> " :: StructuralBinding " <> domainType <> " " <> shapeType,+    (.symbol) obligation <> " =",+    "  StructuralBinding",+    "    { bindingToShape = \\case"+  ]+    <> indentCases (bindingCases True)+    <> ["    , bindingFromShape = \\case"]+    <> indentCases (bindingCases False)+    <> ["    }"]+  where+    domainType = renderReferenceOrDie importPlan (haskellTypeReference ((.haskell) declaration))+    shapeModuleName = structuralShapeModule ctx ((.name) declaration)+    shapeType = renderReferenceOrDie importPlan (qualifiedTypeReference shapeModuleName ((.name) declaration <> "Shape"))+    domainCtor constructor = renderReferenceOrDie importPlan (constructorReference ((.moduleName) ((.haskell) 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 . (.ctor)) entries,+            onUnion = \_ arms -> map (unionCase toShapeDirection) arms+          }+        shape+    recordCase toShapeDirection constructor fields =+      sourceCtor+        <> arguments variables+        <> " -> "+        <> targetCtor+        <> arguments (map (holeFor toShapeDirection . (.haskell)) fields)+      where+        variables = map (("_" <>) . (<> "Value") . (.haskell)) 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") ((.payload) arm)+        <> " -> "+        <> case (.payload) arm of+          Nothing -> holeFor toShapeDirection ((.ctor) arm)+          Just _ -> targetCtor <> " " <> holeFor toShapeDirection ((.ctor) arm <> ".payload")+      where+        sourceCtor = if toShapeDirection then domainCtor ((.ctor) arm) else shapeCtor ((.ctor) arm)+        targetCtor = if toShapeDirection then shapeCtor ((.ctor) arm) else domainCtor ((.ctor) arm)+    arguments [] = ""+    arguments values = " " <> T.unwords values+    holeFor toShapeDirection name =+      "(error "+        <> tshow+          ( "HOLE: fill "+              <> (.name) declaration+              <> (if toShapeDirection then " bindingToShape." else " bindingFromShape.")+              <> name+          )+        <> ")"++bindingSkeletonImportPlan :: Context -> Spec -> TypeGraph -> Text -> [BindingObligation] -> HaskellImportPlan+bindingSkeletonImportPlan ctx spec graph owner obligations =+  planImportsOrDie owner (Set.fromList (map (.symbol) obligations)) (Set.fromList (concatMap obligationReferences obligations))+  where+    obligationReferences obligation = case Map.lookup (MappedKey ((.mappedName) obligation)) ((.declarations) graph) of+      Just (ResolvedStructural declaration shape) ->+        haskellTypeReference ((.haskell) declaration)+          : [ qualifiedTypeReference shapeModuleName ((.name) declaration <> "Shape")+            | (.kind) obligation == BindingValue+            ]+            <> [ reference+               | (.kind) obligation == BindingValue,+                 constructor <- structuralConstructorNames shape,+                 reference <-+                   [ constructorReference ((.moduleName) ((.haskell) declaration)) constructor,+                     constructorReference shapeModuleName constructor+                   ]+               ]+        where+          shapeModuleName = structuralShapeModule ctx ((.name) declaration)+      _ -> case nominalForName ((.mappedName) obligation) of+        Just (nominal, binding) ->+          haskellTypeReference ((.haskell) binding)+            : [ qualifiedTypeReference+                  (nominalRepresentationModule ctx ((.name) nominal))+                  ((.name) nominal <> "Representation")+              | (.kind) obligation == BindingValue,+                EnumRepresentation {} <- [(.representation) nominal]+              ]+        Nothing -> []+    nominalForName name = do+      registry <- either (const Nothing) Just (resolveNominalTypes spec)+      nominal <- lookupNominalType name registry+      binding <- case (.ownership) nominal of+        ConsumerNominal value -> Just value+        GeneratedNominal -> Nothing+      pure (nominal, binding)++structuralConstructorNames :: ResolvedMappedShape -> [Text]+structuralConstructorNames =+  foldMappedShape+    MappedShapeAlgebra+      { onRecord = \constructor _ _ -> [constructor],+        onEnum = map (.ctor),+        onUnion = \_ -> map (.ctor)+      }++structuralShapeReferences :: Context -> StructuralDecl -> ResolvedMappedShape -> [HaskellReference]+structuralShapeReferences ctx declaration shape =+  qualifiedTypeReference moduleName ((.name) declaration <> "Shape")+    : [constructorReference moduleName constructor | constructor <- structuralConstructorNames shape]+      <> [ HaskellReference moduleName selector ValueNamespace RequireQualified+         | selector <- structuralSelectorNames shape+         ]+  where+    moduleName = structuralShapeModule ctx ((.name) declaration)++structuralSelectorNames :: ResolvedMappedShape -> [Text]+structuralSelectorNames =+  foldMappedShape+    MappedShapeAlgebra+      { onRecord = \_ _ -> map (.haskell),+        onEnum = const [],+        onUnion = \_ _ -> []+      }++nominalRepresentationEncoderReference :: Context -> ResolvedNominalType -> HaskellReference+nominalRepresentationEncoderReference ctx nominal =+  HaskellReference+    (nominalRepresentationModule ctx name)+    (lowerFirst name <> "RepresentationText")+    ValueNamespace+    RequireQualified+  where+    name = (.name) nominal++nominalRepresentationConstructorReference :: Context -> ResolvedNominalType -> Text -> HaskellReference+nominalRepresentationConstructorReference ctx nominal constructor =+  HaskellReference+    (nominalRepresentationModule ctx ((.name) nominal))+    constructor+    ConstructorNamespace+    RequireQualified++renderStructuralObligationSignature :: HaskellImportPlan -> StructuralDecl -> BindingObligation -> Text+renderStructuralObligationSignature importPlan declaration obligation =+  (.symbol) obligation+    <> " :: "+    <> case (.kind) obligation of+      BindingValue -> error "structural binding signatures are rendered with renderBinding"+      FixtureValue -> "FixtureCases " <> domainType+      InitialValue -> domainType+  where+    domainType = renderReferenceOrDie importPlan (haskellTypeReference ((.haskell) declaration))++renderNominalObligationSignature :: HaskellImportPlan -> Context -> ResolvedNominalType -> ConsumerNominalBinding -> BindingObligation -> Text+renderNominalObligationSignature importPlan ctx nominal binding obligation =+  (.symbol) obligation+    <> " :: "+    <> case (.kind) obligation of+      BindingValue -> "NominalBinding " <> domainType <> " " <> representationType+      FixtureValue -> "NominalFixtureCases " <> domainType+      InitialValue -> domainType+  where+    domainType = renderReferenceOrDie importPlan (haskellTypeReference ((.haskell) binding))+    representationType = case (.representation) nominal of+      IdRepresentation prefix -> "(KindID " <> tshow prefix <> ")"+      EnumRepresentation {} ->+        renderReferenceOrDie+          importPlan+          ( qualifiedTypeReference+              (nominalRepresentationModule ctx ((.name) nominal))+              ((.name) 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+    { path = T.unpack (T.replace "." "/" (structuralShapeModule ctx ((.name) declaration)) <> ".hs"),+      text = emitShape ctx graph declaration shape,+      kind = Generated,+      origin = nodeOrigin "mapped structural" ((.name) declaration) ((.loc) 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+          { path = T.unpack (T.replace "." "/" (generatedNominalModule ctx) <> ".hs"),+            text = emitGeneratedNominals languageContract ctx owners,+            kind = Generated,+            origin = "context " <> (.context) spec <> " generated nominal declarations"+          },+        []+      )+    ]+      <> [ ( ScaffoldModule+               { path = T.unpack (T.replace "." "/" (generatedNominalInternalModule ctx) <> ".hs"),+                 text = emitGeneratedNominalInternals ctx enforcingIds,+                 kind = Generated,+                 origin = "context " <> (.context) spec <> " generated nominal ID internals"+               },+             []+           )+         | not (null enforcingIds)+         ]+    where+      enforcingIds =+        [ (nominal, contract)+        | owner <- owners,+          let nominal = (.declaration) owner,+          IdRepresentation prefix <- [(.representation) 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 (.equalityUsed) owners+    exactEqualityOwners = [owner | owner <- owners, (.equalityUsed) owner, exactOwner ((.declaration) owner)]+    inexactEqualityOwners = [owner | owner <- owners, (.equalityUsed) owner, not (exactOwner ((.declaration) owner))]+    usesExactEquality = not (null exactEqualityOwners)+    usesInexactEquality = not (null inexactEqualityOwners)+    legacyNominals =+      [ nominal+      | owner <- owners,+        let nominal = (.declaration) owner,+        case (.representation) nominal of+          IdRepresentation prefix -> not (isJust (idDomainContractFor languageContract prefix))+          EnumRepresentation {} -> True+          ScalarRepresentation {} -> False+      ]+    hasExactEnum = any (\owner -> case (.representation) ((.declaration) owner) of EnumRepresentation {} -> True; _ -> False) exactEqualityOwners+    hasExactEnforcedId = any (\owner -> case (.representation) ((.declaration) owner) of IdRepresentation prefix -> isJust (idDomainContractFor languageContract prefix); _ -> False) exactEqualityOwners+    enforcingIds =+      [ nominal+      | owner <- owners,+        let nominal = (.declaration) owner,+        IdRepresentation prefix <- [(.representation) 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 = (.declaration) owner+        name = (.name) nominal+        baseExports = case (.representation) nominal of+          IdRepresentation prefix+            | Just _ <- idDomainContractFor languageContract prefix ->+                [name, "parse" <> name, "mk" <> name, nominalTextName nominal]+          _ -> [name <> " (..)", nominalTextName nominal]+        equalityExports =+          if (.equalityUsed) owner+            then [nominalEqualityTagName nominal, nominalEqualityWitnessName nominal]+            else []+    localExtensions =+      [ExtDeriveAnyClass | any (nominalUsesDeriveAnyClass . (.declaration)) 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 -> [(.name) nominal, "mk" <> (.name) nominal, "parse" <> (.name) nominal, nominalTextName nominal]) enforcingIds)+          <> ")"+      | not (null enforcingIds)+      ]+    declarations = T.dropWhileEnd (== '\n') (sectionsOf [map emitOwner owners])+    emitOwner owner = emitGeneratedNominal languageContract ((.equalityUsed) owner) ((.declaration) owner)+    exactOwner nominal = case (.representation) nominal of+      EnumRepresentation {} -> True+      IdRepresentation prefix -> isJust (idDomainContractFor languageContract prefix)+      ScalarRepresentation {} -> False+    nominalUsesDeriveAnyClass nominal = case (.representation) nominal of+      IdRepresentation prefix -> not (isJust (idDomainContractFor languageContract prefix))+      EnumRepresentation {} -> True+      ScalarRepresentation {} -> False++emitGeneratedNominal :: EffectiveLanguageContract -> Bool -> ResolvedNominalType -> Text+emitGeneratedNominal languageContract equalityUsed nominal = case (.representation) 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 = (.name) 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 = (.name) nominal+    tagName = nominalEqualityTagName nominal+    witnessName = nominalEqualityWitnessName nominal+    equalityIdentity = fromMaybe (error "generated nominal equality contract missing") (nominalEqualityIdentityForService languageContract nominal)+    (exactInstance, witnessConstructor) = case (.representation) 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, _) =+      [ (.name) nominal,+        "parse" <> (.name) nominal,+        "mk" <> (.name) 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 = (.name) nominal+        textName = nominalTextName nominal++nominalEqualityTagName :: ResolvedNominalType -> Text+nominalEqualityTagName nominal = (.name) nominal <> "EqualityProjection"++nominalEqualityWitnessName :: ResolvedNominalType -> Text+nominalEqualityWitnessName nominal = lowerFirst ((.name) 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 . (.name)++-- | 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 ", " [(.name) 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 (.name) (stableNominals parsing)+    importsFor nominal = case (.representation) nominal of+      IdRepresentation prefix+        | Just _ <- idDomainContractFor (checkedLanguageContract service) prefix ->+            [(.name) nominal]+              <> ["parse" <> (.name) nominal | (.name) nominal `elem` parsingNames]+      _ -> [(.name) 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 (.representation) nominal of+      IdRepresentation prefix+        | Just _ <- idDomainContractFor (checkedLanguageContract service) prefix -> [nominalTextName nominal]+      _ -> [(.name) nominal <> " (..)", nominalTextName nominal]+    enforcingIds =+      [ nominal+      | nominal <- stableNominals nominals,+        IdRepresentation prefix <- [(.representation) nominal],+        Just _ <- [idDomainContractFor (checkedLanguageContract service) prefix]+      ]++legacyNominalConstructorName :: ResolvedNominalType -> Text+legacyNominalConstructorName nominal = "unsafe" <> (.name) nominal <> "FromLegacyText"++stableNominals :: [ResolvedNominalType] -> [ResolvedNominalType]+stableNominals = Map.elems . Map.fromList . map (\nominal -> ((.name) nominal, nominal))++nominalRepresentationOwners :: Context -> Spec -> [(ScaffoldModule, [Name])]+nominalRepresentationOwners ctx spec = case resolveNominalTypes spec of+  Left _ -> []+  Right registry ->+    [ (nominalRepresentationModuleValue ctx nominal constructors, [(.name) nominal])+    | nominal <- Map.elems (nominalTypes registry),+      ConsumerNominal {} <- [(.ownership) nominal],+      EnumRepresentation constructors <- [(.representation) nominal]+    ]++nominalRepresentationModuleValue :: Context -> ResolvedNominalType -> NonEmpty (Name, Text) -> ScaffoldModule+nominalRepresentationModuleValue ctx nominal constructors =+  ScaffoldModule+    { path = T.unpack (T.replace "." "/" moduleName <> ".hs"),+      text =+        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" ((.name) nominal) ((.loc) nominal)+    }+  where+    moduleName = nominalRepresentationModule ctx ((.name) nominal)+    representationType = (.name) nominal <> "Representation"+    encoderName = lowerFirst ((.name) 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+          { path = T.unpack (T.replace "." "/" (nominalProjectionModule ctx) <> ".hs"),+            text = emitNominalProjections (checkedLanguageContract service) ctx nominals,+            kind = Generated,+            origin = "context " <> (.context) spec <> " nominal scalar projection facade"+          },+        []+      )+    ]+  where+    spec = checkedSpec service++nominalProjectionTypes :: Either (NE.NonEmpty TypeGraphError) TypeGraph -> Spec -> [ResolvedNominalType]+nominalProjectionTypes typeGraphResult spec =+  Map.elems . Map.fromList $+    [ ((.name) nominal, nominal)+    | aggregate <- [value | NAggregate value <- (.nodes) spec],+      resolved <- registerTypes aggregate <> commandTypes aggregate,+      AggregateNominal nominal <- [resolved],+      ConsumerNominal {} <- [(.ownership) nominal]+    ]+  where+    symbols = aggregateSymbolsFromGraphResult typeGraphResult spec+    registerTypes aggregate =+      [ resolved+      | register <- (.regs) aggregate,+        Right resolved <- [resolveAggregateType symbols ((.loc) register) RegisterUse ((.valueType) register)]+      ]+    commandTypes aggregate =+      [ resolved+      | command <- (.commands) aggregate,+        field <- (.fields) 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 (.representation) 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 = (.representation) nominal == ScalarRepresentation wanted+    hasId nominal = case (.representation) nominal of IdRepresentation {} -> True; _ -> False+    hasEnforcedId nominal = case (.representation) nominal of+      IdRepresentation prefix -> isJust (idDomainContractFor languageContract prefix)+      _ -> False+    hasUnenforcedId nominal = case (.representation) nominal of+      IdRepresentation prefix -> isNothing (idDomainContractFor languageContract prefix)+      _ -> False+    hasExactDomain nominal = case (.representation) nominal of ScalarRepresentation {} -> False; _ -> True+    usesText nominal = case (.representation) nominal of ScalarRepresentation NominalText -> True; IdRepresentation {} -> True; EnumRepresentation {} -> True; _ -> False+    importPlan =+      planImportsOrDie+        moduleName+        ( Set.fromList+            [ tagName+            | nominal <- nominals,+              tagName <- case (.representation) nominal of+                ScalarRepresentation {} -> [(.name) nominal <> "NominalProjection"]+                IdRepresentation {} -> [nominalEqualityTagName nominal]+                EnumRepresentation {} -> [nominalEqualityTagName nominal]+            ]+        )+        ( Set.fromList+            [ reference+            | nominal <- nominals,+              ConsumerNominal binding <- [(.ownership) nominal],+              reference <-+                [ haskellTypeReference ((.haskell) binding),+                  qualifiedValueReference ((.binding) binding)+                ]+                  <> case (.representation) nominal of+                    EnumRepresentation constructors ->+                      HaskellReference representationModule (lowerFirst ((.name) nominal) <> "RepresentationText") ValueNamespace RequireQualified+                        : [ HaskellReference representationModule constructor ConstructorNamespace RequireQualified+                          | (constructor, _) <- NE.toList constructors+                          ]+                      where+                        representationModule = nominalRepresentationModule ctx ((.name) nominal)+                    _ -> []+            ]+        )+    emitNominalProjection nominal = case (.ownership) nominal of+      GeneratedNominal -> ""+      ConsumerNominal binding -> case (.representation) 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 ((.haskell) binding)),+          "  type FieldResult " <> tagName <> " = " <> scalarHaskellType ((.representation) nominal),+          "  fieldShapeId _ = " <> tshow (unCanonicalTypeId ((.canonical) binding)),+          "  projectFieldValue _ = nominalToRepresentation " <> renderReferenceOrDie importPlan (qualifiedValueReference ((.binding) binding)),+          "",+          witnessName <> " :: FieldWitness " <> tagName,+          witnessName <> " = fieldWitness @" <> tagName+        ]+      where+        name = (.name) 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 = (.name) nominal+        tagName = nominalEqualityTagName nominal+        witnessName = nominalEqualityWitnessName nominal+        patternName = lowerFirst name <> "EqualityPattern"+        ownerType = renderReferenceOrDie importPlan (haskellTypeReference ((.haskell) binding))+        bindingName = renderReferenceOrDie importPlan (qualifiedValueReference ((.binding) 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 = (.name) nominal+        tagName = nominalEqualityTagName nominal+        witnessName = nominalEqualityWitnessName nominal+        ownerType = renderReferenceOrDie importPlan (haskellTypeReference ((.haskell) binding))+        bindingName = renderReferenceOrDie importPlan (qualifiedValueReference ((.binding) 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 ((.name) declaration)+    shapeType = (.name) 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+                    [ ((.haskell) field, renderShapeType importPlan ctx graph ((.valueType) field))+                    | field <- fields+                    ]+                  <> ["  deriving stock (Eq, Generic, Show)"],+            onEnum = \entries ->+              "data "+                <> shapeType+                <> " = "+                <> T.intercalate " | " (map (.ctor) 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 = (.ctor) arm <> maybe "" ((" !" <>) . renderShapeType importPlan ctx graph) ((.payload) 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 . (.valueType)) fields,+        onEnum = const [],+        onUnion = \_ arms -> concatMap (maybe [] (exprRequirements ctx graph) . (.payload)) 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 ((.declarations) graph) of+          Just (ResolvedStructural declaration _) ->+            [ ReqReference+                ( HaskellReference+                    (structuralShapeModule ctx ((.name) declaration))+                    ((.name) declaration <> "Shape")+                    TypeNamespace+                    RequireQualified+                )+            ]+          Just (ResolvedOpaque declaration) -> [ReqReference (haskellTypeReference ((.haskell) 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 . ("[" <>) . (<> "]") . (.text),+          onMap = applicationShapeType . ("Map Text " <>) . renderStrictOrApplicationArgument,+          onRef =+            atomicShapeType . \key -> case Map.lookup key ((.declarations) graph) of+              Just (ResolvedStructural nested _) ->+                renderReferenceOrDie+                  importPlan+                  (HaskellReference (structuralShapeModule ctx ((.name) nested)) ((.name) nested <> "Shape") TypeNamespace RequireQualified)+              Just (ResolvedOpaque opaque) ->+                renderReferenceOrDie importPlan (haskellTypeReference ((.haskell) opaque))+              Nothing -> "()"+        }++data ShapeTypePrecedence+  = AtomicShapeType+  | ApplicationShapeType++data RenderedShapeType = RenderedShapeType+  { precedence :: !ShapeTypePrecedence,+    text :: !Text+  }++atomicShapeType :: Text -> RenderedShapeType+atomicShapeType = RenderedShapeType AtomicShapeType++applicationShapeType :: Text -> RenderedShapeType+applicationShapeType = RenderedShapeType ApplicationShapeType++renderStrictOrApplicationArgument :: RenderedShapeType -> Text+renderStrictOrApplicationArgument rendered = case (.precedence) rendered of+  AtomicShapeType -> (.text) rendered+  ApplicationShapeType -> "(" <> (.text) rendered <> ")"++data StructuralProjection = StructuralProjection+  { tag :: !Text,+    witness :: !Text,+    pointer :: !Text,+    owner :: !HaskellSource,+    result :: !Text,+    canonical :: !CanonicalTypeId,+    binding :: !QualifiedValueName,+    selectors :: ![(Text, Text)]+  }+  deriving stock (Eq, Show)++projectionSpecs :: TypeGraph -> [StructuralProjection]+projectionSpecs graph =+  sortOn (.tag) . allocateProjectionNames . concat $+    [ projectionsForRoot graph declaration shape+    | ResolvedStructural declaration shape <- Map.elems ((.declarations) 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+      | (.presence) field /= PRequired = []+      | otherwise = case projectionScalar ((.valueType) field) of+          Just result -> [mkProjection (keys <> [(.key) field]) (selectors <> [(shapeModuleForOwner, (.haskell) field)]) result]+          Nothing -> case (.valueType) field of+            RRef key -> case Map.lookup key ((.declarations) graph) of+              Just (ResolvedStructural nested (RRecord _ _ nestedFields)) ->+                concatMap+                  (walkNested nested (keys <> [(.key) field]) (selectors <> [(shapeModuleForOwner, (.haskell) field)]))+                  nestedFields+              _ -> []+            _ -> []+      where+        shapeModuleForOwner = "__SHAPE__." <> (.name) root++    walkNested owner keys selectors field+      | (.presence) field /= PRequired = []+      | otherwise = case projectionScalar ((.valueType) field) of+          Just result -> [mkProjection (keys <> [(.key) field]) (selectors <> [(shapeModuleFor owner, (.haskell) field)]) result]+          Nothing -> case (.valueType) field of+            RRef key -> case Map.lookup key ((.declarations) graph) of+              Just (ResolvedStructural nested (RRecord _ _ nestedFields)) ->+                concatMap+                  (walkNested nested (keys <> [(.key) field]) (selectors <> [(shapeModuleFor owner, (.haskell) field)]))+                  nestedFields+              _ -> []+            _ -> []++    -- Context is supplied when rendering; this marker is replaced there.+    shapeModuleFor declaration = "__SHAPE__." <> (.name) declaration+    mkProjection keys selectors result =+      StructuralProjection+        { tag = nameStem <> "Projection",+          witness = lowerFirst nameStem <> "Witness",+          pointer = pointer,+          owner = (.haskell) root,+          result = result,+          canonical = (.canonical) root,+          binding = (.binding) root,+          selectors = selectors+        }+      where+        pointer = T.concat ["/" <> escapePointer key | key <- keys]+        nameStem = projectionNameStem ((.name) 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 -> (.tag) left == (.tag) right) (sortOn (.tag) 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 ((.canonical) spec) <> "#" <> (.pointer) spec+    renameWithSuffix suffix spec =+      StructuralProjection+        { tag = nameStem <> suffix <> "Projection",+          witness = lowerFirst nameStem <> suffix <> "Witness",+          pointer = spec.pointer,+          owner = spec.owner,+          result = spec.result,+          canonical = spec.canonical,+          binding = spec.binding,+          selectors = spec.selectors+        }+      where+        nameStem = fromMaybe ((.tag) spec) (T.stripSuffix "Projection" ((.tag) spec))++projectionWitnessName :: TypeGraph -> MappedKey -> Text -> Maybe Text+projectionWitnessName graph owner pointer = do+  ResolvedStructural declaration _ <- Map.lookup owner ((.declarations) graph)+  (.witness)+    <$> find+      (\spec -> (.canonical) spec == (.canonical) declaration && (.pointer) 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 (.witness) specs),+           "  ) where",+           ""+         ]+      <> staticImports+      <> fieldScopeImports+      <> T.lines (renderPlannedImports importPlan)+      <> concatMap renderProjection specs+  where+    moduleName = structuralProjectionModule ctx+    specs = map (resolveProjectionModules ctx) (projectionSpecs graph)+    resultTypes = Set.fromList (map (.result) 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)]+    fieldScopeImports =+      [ "import " <> shapeModuleName <> " (" <> lastSegment shapeModuleName <> "Shape(" <> T.intercalate ", " (Set.toAscList selectors) <> "))"+      | (shapeModuleName, selectors) <- Map.toAscList selectorsByModule+      ]+    selectorsByModule =+      Map.fromListWith+        Set.union+        [ (shapeModuleName, Set.singleton selector)+        | spec <- specs,+          (shapeModuleName, selector) <- (.selectors) spec+        ]+    importPlan =+      planImportsOrDie+        moduleName+        (Set.fromList (map (.tag) specs))+        ( Set.fromList+            ( [haskellTypeReference ((.owner) spec) | spec <- specs]+                <> [qualifiedValueReference ((.binding) spec) | spec <- specs]+            )+        )+    renderProjection spec =+      [ "",+        "data " <> (.tag) spec,+        "",+        "instance FieldProjection " <> (.tag) spec <> " where",+        "  type FieldName " <> (.tag) spec <> " = " <> tshow ((.pointer) spec),+        "  type FieldOwner " <> (.tag) spec <> " = " <> renderReferenceOrDie importPlan (haskellTypeReference ((.owner) spec)),+        "  type FieldResult " <> (.tag) spec <> " = " <> (.result) spec,+        "  fieldShapeId _ = " <> tshow (unCanonicalTypeId ((.canonical) spec)),+        "  projectFieldValue _ owner = " <> renderGetter spec,+        "",+        (.witness) spec <> " :: FieldWitness " <> (.tag) spec,+        (.witness) spec <> " = fieldWitness @" <> (.tag) spec+      ]+    renderGetter spec =+      foldl+        ( \value (_shapeModuleName, selector) ->+            "(" <> value <> ")." <> selector+        )+        ("bindingToShape " <> renderReferenceOrDie importPlan (qualifiedValueReference ((.binding) spec)) <> " owner")+        ((.selectors) spec)++resolveProjectionModules :: Context -> StructuralProjection -> StructuralProjection+resolveProjectionModules ctx spec =+  StructuralProjection+    { tag = spec.tag,+      witness = spec.witness,+      pointer = spec.pointer,+      owner = spec.owner,+      result = spec.result,+      canonical = spec.canonical,+      binding = spec.binding,+      selectors =+        [ (replaceModule marker, selector)+        | (marker, selector) <- spec.selectors+        ]+    }+  where+    replaceModule marker+      | Just name <- T.stripPrefix "__SHAPE__." marker = structuralShapeModule ctx name+      | otherwise = structuralShapeModule ctx (lastSegment marker)++haskellTypeReference :: HaskellSource -> HaskellReference+haskellTypeReference source =+  HaskellReference ((.moduleName) source) ((.valueType) 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 ((.regs) aggregate))]+      <> [ generatedBanner,+           "module " <> (.genPrefix) aggregate <> ".BehaviorContract",+           "  ( BehaviorKey (..)",+           "  , unBehaviorKey",+           "  , ObligationKind (..)",+           "  , EvidenceLevel (..)",+           "  , GuardCoverage (..)",+           "  , BehaviorRequirement (..)",+           "  , RejectionClass (..)",+           "  , LiveExpectation (..)",+           "  , BehaviorWitness (..)",+           "  , BehaviorFailure (..)",+           "  , BehaviorConformanceReport (..)",+           "  , behaviorRequirements",+           "  , behaviorCoverageReport",+           "  , behaviorConformancePassed",+           "  , behaviorConformancePassedWith",+           "  , renderBehaviorConformanceText",+           "  ) where",+           "",+           "import " <> (.genPrefix) aggregate <> ".Codec (encode" <> name <> "Event, parse" <> name <> "Event, " <> valueStem <> "Codec)",+           "import " <> (.genPrefix) aggregate <> ".Domain",+           "import " <> (.genPrefix) aggregate <> ".Transducer (" <> valueStem <> "Transducer)",+           "import " <> contextGeneratedPrefix ((.context) 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)",+           "",+           "unBehaviorKey :: BehaviorKey -> Text",+           "unBehaviorKey (BehaviorKey value) = value",+           "",+           "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 :: !" <> (.vertexType) aggregate,+           "  , requirementCommandName :: !Text",+           "  , requirementExpectedEdge :: !(Maybe (K.EdgeRef " <> (.vertexType) aggregate <> "))",+           "  , requirementTarget :: !(Maybe " <> (.vertexType) 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 behaviorFailure.failureKey",+           "    , \"subject\" .= behaviorFailure.failureSubject",+           "    , \"code\" .= behaviorFailure.failureCode",+           "    , \"detail\" .= behaviorFailure.failureDetail",+           "    ]",+           "",+           "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 report.reportRequired",+           "    , \"filled\" .= keyTexts report.reportFilled",+           "    , \"pending\" .= keyTexts report.reportPending",+           "    , \"missing\" .= keyTexts report.reportMissing",+           "    , \"duplicate\" .= keyTexts report.reportDuplicate",+           "    , \"stale\" .= keyTexts report.reportStale",+           "    , \"failed\" .= report.reportFailed",+           "    , \"verified\" .= keyTexts report.reportVerified",+           "    , \"unverified\" .= keyTexts report.reportUnverified",+           "    ]",+           "",+           "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 [requirement.requirementKey | (requirement, Right ()) <- executions, proofStrength requirement]",+           "    , reportUnverified = sortedKeys [requirement.requirementKey | (requirement, Right ()) <- executions, not (proofStrength requirement)]",+           "    }",+           " where",+           "  requiredByKey = Map.fromList [(requirement.requirementKey, 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 report.reportPending",+           "    && null report.reportMissing",+           "    && null report.reportDuplicate",+           "    && null report.reportStale",+           "    && null report.reportFailed",+           "    && (not failOnUnverified || null report.reportUnverified)",+           "",+           "renderBehaviorConformanceText :: BehaviorConformanceReport -> Text",+           "renderBehaviorConformanceText report = T.unlines",+           "  [ \"behavior conformance: " <> name <> "\"",+           "  , \"schema: keiro/behavior-conformance/1\"",+           "  , countLine \"required\" report.reportRequired",+           "  , countLine \"filled\" report.reportFilled",+           "  , countLine \"pending\" report.reportPending",+           "  , countLine \"missing\" report.reportMissing",+           "  , countLine \"duplicate\" report.reportDuplicate",+           "  , countLine \"stale\" report.reportStale",+           "  , \"failed: \" <> tshow (length report.reportFailed)",+           "  , countLine \"verified\" report.reportVerified",+           "  , countLine \"unverified\" report.reportUnverified",+           "  ] <> T.unlines [\"FAIL \" <> unBehaviorKey behaviorFailure.failureKey <> \" \" <> behaviorFailure.failureSubject <> \" [\" <> behaviorFailure.failureCode <> \"] \" <> behaviorFailure.failureDetail | behaviorFailure <- report.reportFailed]",+           "",+           "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 == requirement.requirementSource) \"history-wrong-source\" \"history does not settle at the required source vertex\"",+           "  ensure requirement (commandKind command == requirement.requirementCommandName) \"command-mismatch\" \"witness command constructor does not match the required state/command cell\"",+           "  case requirement.requirementKind 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 -> (" <> (.vertexType) 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 -> (" <> (.vertexType) 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 == requirement.requirementEventKinds) \"event-envelope-mismatch\" (\"runtime event kinds differ from the declared ordered envelope; actual=\" <> tshow (map eventKind actual) <> \" expected=\" <> tshow requirement.requirementEventKinds)",+           "      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 " <> (.vertexType) 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) == requirement.requirementExpectedEdge) \"edge-attribution\" (\"runtime selected a different guarded sibling; actual=\" <> tshow (Just (K.stepSuccessEdge success)) <> \" expected=\" <> tshow requirement.requirementExpectedEdge)",+           "  ensure requirement (Just (K.stepSuccessState success) == requirement.requirementTarget) \"target-mismatch\" (\"runtime reached a different target vertex; actual=\" <> tshow (Just (K.stepSuccessState success)) <> \" expected=\" <> tshow requirement.requirementTarget)",+           "",+           "runReplay :: BehaviorRequirement -> [" <> name <> "Event] -> [" <> name <> "Event] -> Either BehaviorFailure ()",+           "runReplay requirement prefix chunk = case requirement.requirementKind of",+           "  ReplayTransition -> do",+           "    settled <- settleHistory requirement \"history-prefix\" prefix",+           "    ensure requirement (K.replaySuccessState settled == requirement.requirementSource) \"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) == requirement.requirementTarget) \"target-mismatch\" (\"replay chunk reached a different target vertex; actual=\" <> tshow (Just (K.replaySuccessState replayed)) <> \" expected=\" <> tshow requirement.requirementTarget)",+           "    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 " <> (.vertexType) aggregate <> "] -> Either BehaviorFailure ()",+           "checkSingleAttribution requirement expectedMode eventCount trace = case trace of",+           "  [attribution] -> do",+           "    ensure requirement (Just (K.replayAttributionEdge attribution) == requirement.requirementExpectedEdge) \"replay-edge-attribution\" (\"replay selected a different edge; actual=\" <> tshow (Just (K.replayAttributionEdge attribution)) <> \" expected=\" <> tshow requirement.requirementExpectedEdge)",+           "    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 == requirement.requirementSource) \"replay-source-attribution\" (\"replay attribution starts at the wrong source; actual=\" <> tshow (K.replayAttributionSource attribution) <> \" expected=\" <> tshow requirement.requirementSource)",+           "    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.requirementTarget) \"replay-target-attribution\" (\"replay attribution ends at the wrong target; actual=\" <> tshow (Just (K.replayAttributionTarget attribution)) <> \" expected=\" <> tshow requirement.requirementTarget)",+           "    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 " <> (.vertexType) 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 =",+           "  requirement.requirementEvidence == GeneratedAuthoritative",+           "    && requirement.requirementGuardCoverage `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",+           "        requirement.requirementKey",+           "        (tshow requirement.requirementSource <> \" x \" <> requirement.requirementCommandName <> \": \" <> kindPhrase <> \" (\" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.requirementKey) <> \")\")",+           "        code",+           "        detail",+           "    )",+           " where",+           "  kindPhrase = case requirement.requirementKind 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 = (.name) aggregate+    valueStem = lowerFirst name+    handlerName = valueStem <> "DomainCommandHandler"+    outcomeResultTypes = case (.domainOutcomeTypes) aggregate of+      Nothing -> []+      Just outcomeTypes -> [(.rejectionType) outcomeTypes, (.noOpType) outcomeTypes]+    outcomeImportPlan = eventStreamImportPlan aggregate outcomeResultTypes []+    outcomeGeneratedNominals = generatedNominalsInTypes outcomeResultTypes+    outcomeBehaviorImports = case (.domainOutcomeTypes) aggregate of+      Nothing -> []+      Just _ ->+        ["import " <> (.genPrefix) aggregate <> ".EventStream (" <> handlerName <> ")"]+          <> [ "import "+                 <> generatedNominalModule ((.context) aggregate)+                 <> " ("+                 <> T.intercalate ", " (map (.name) (stableNominals outcomeGeneratedNominals))+                 <> ")"+             | not (null outcomeGeneratedNominals)+             ]+          <> T.lines (renderPlannedImports outcomeImportPlan)+          <> ["import Keiro.Command (DomainCommandHandler (..), SilentCommandContext (..), SilentDomainDecision (..))"]+    outcomeExpectationConstructors = case (.domainOutcomeTypes) aggregate of+      Nothing -> []+      Just outcomeTypes ->+        [ "  | RejectedWith " <> renderDomainType outcomeImportPlan aggregate ((.rejectionType) outcomeTypes),+          "  | NoOpWith " <> renderDomainType outcomeImportPlan aggregate ((.noOpType) outcomeTypes)+        ]+    outcomeGenericRejectionCases = case (.domainOutcomeTypes) 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 (.domainOutcomeTypes) 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 (.domainOutcomeTypes) 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 (.domainOutcomeTypes) aggregate of+      Nothing -> []+      Just outcomeTypes ->+        [ "",+          "runSilentDecision",+          "  :: BehaviorRequirement",+          "  -> (" <> (.vertexType) aggregate <> ", K.RegFile " <> name <> "Regs)",+          "  -> " <> name <> "Command",+          "  -> Either BehaviorFailure (SilentDomainDecision " <> renderDomainType outcomeImportPlan aggregate ((.rejectionType) outcomeTypes) <> " " <> renderDomainType outcomeImportPlan aggregate ((.noOpType) 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 ((.regs) aggregate))]++renderCommandKind :: Agg -> [Text]+renderCommandKind aggregate = case (.commands) aggregate of+  [] -> ["", "commandKind :: " <> (.name) aggregate <> "Command -> Text", "commandKind _ = \"\""]+  commands ->+    [ "",+      "commandKind :: " <> (.name) aggregate <> "Command -> Text",+      "commandKind command = case command of"+    ]+      <> ["  " <> (.name) command <> " _ -> " <> tshow ((.name) 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 ((.key) requirement)),+        "      , requirementKind = " <> T.pack (show ((.kind) requirement)),+        "      , requirementEvidence = " <> T.pack (show ((.evidence) requirement)),+        "      , requirementGuardCoverage = " <> T.pack (show ((.guardCoverage) requirement)),+        "      , requirementSource = " <> vertexCtor aggregate ((.source) requirement),+        "      , requirementCommandName = " <> tshow ((.command) requirement),+        "      , requirementExpectedEdge = " <> edgeExpr aggregate requirement,+        "      , requirementTarget = " <> maybe "Nothing" (\target -> "Just " <> vertexCtor aggregate target) ((.target) requirement),+        "      , requirementEventKinds = " <> renderBehaviorTextList ((.events) requirement),+        "      }"+      ]++behaviorRequirementLabel :: Agg -> Behavior.BehaviorRequirement -> Text+behaviorRequirementLabel aggregate requirement =+  vertexCtor aggregate ((.source) requirement)+    <> " x "+    <> (.command) requirement+    <> ": "+    <> ( case (.kind) requirement of+           Behavior.LiveTransition -> "live transition"+           Behavior.RequiredRejection -> "required rejection"+           Behavior.ReplayTransition -> "replay-only transition"+       )++edgeExpr :: Agg -> Behavior.BehaviorRequirement -> Text+edgeExpr aggregate requirement = case (.kind) requirement of+  Behavior.RequiredRejection -> "Nothing"+  _ -> case behaviorEdgeIndex aggregate requirement of+    Nothing -> error ("required behavior transition missing from resolved aggregate: " <> T.unpack ((.canonical) requirement))+    Just edgeIndex ->+      "(Just (K.EdgeRef "+        <> vertexCtor aggregate ((.source) requirement)+        <> " "+        <> tshow' edgeIndex+        <> "))"++behaviorEdgeIndex :: Agg -> Behavior.BehaviorRequirement -> Maybe Int+behaviorEdgeIndex aggregate requirement = case (.origin) requirement of+  Behavior.RejectionRequirementOrigin {} -> Nothing+  Behavior.TransitionRequirementOrigin originAggregate (SourceIndex.TransitionOrdinal ordinal) -> do+    transition <- case drop ordinal ((.transitions) aggregate) of+      candidate : _ -> Just candidate+      [] -> Nothing+    if originAggregate == (.name) aggregate+      && (.source) transition == (.source) requirement+      && (.command) transition == (.command) requirement+      then+        Just+          ( length+              [ ()+              | candidate <- take ordinal ((.transitions) aggregate),+                (.source) candidate == (.source) transition+              ]+          )+      else Nothing++behaviorRequirementsFor :: Agg -> [Behavior.BehaviorRequirement]+behaviorRequirementsFor aggregate =+  case Behavior.deriveAggregateBehaviorRequirements ((.spec) aggregate) ((.aggregate) aggregate) of+    Left derivationError -> error ("validated aggregate failed behavior derivation: " <> show derivationError)+    Right requirements -> sortOn (.key) requirements++renderBehaviorTextList :: [Text] -> Text+renderBehaviorTextList values = "[" <> T.intercalate ", " (map tshow values) <> "]"++regsEqualityExpression :: Agg -> Text+regsEqualityExpression aggregate = case (.regs) aggregate of+  [] -> "regsEqual _ _ = True"+  registers ->+    "regsEqual left right = "+      <> T.intercalate+        " && "+        [ "(left K.! #" <> (.name) register <> ") == (right K.! #" <> (.name) register <> ")"+        | register <- registers+        ]++behaviorHoleModule :: Agg -> ScaffoldModule+behaviorHoleModule aggregate =+  ScaffoldModule+    { path = T.unpack (T.replace "." "/" ((.holePrefix) aggregate) <> "/BehaviorHoles.hs"),+      text = emitBehaviorHoles aggregate,+      kind = HoleStub,+      origin = nodeOrigin "aggregate behavior witnesses" ((.name) aggregate) ((.loc) aggregate)+    }++emitBehaviorHoles :: Agg -> Text+emitBehaviorHoles aggregate =+  nl $+    [ "-- Consumer-owned behavioral witnesses. Created once; never overwritten.",+      "module " <> (.holePrefix) aggregate <> ".BehaviorHoles (behaviorWitnesses) where",+      "",+      "import " <> (.genPrefix) aggregate <> ".BehaviorContract",+      "",+      "behaviorWitnesses :: [BehaviorWitness]",+      "behaviorWitnesses ="+    ]+      <> case behaviorRequirementsFor aggregate of+        [] -> ["  []"]+        requirements ->+          [ (if index == (0 :: Int) then "  [ " else "  , ")+              <> "Pending (BehaviorKey "+              <> tshow (Behavior.unBehaviorKey ((.key) 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+          { path = T.unpack (T.replace "." "/" moduleName <> ".hs"),+            text = emitReplayAudit,+            kind = Generated,+            origin = "context " <> (.context) spec <> " replay-audit assembly"+          }+      ]+  where+    aggregates = [aggregate | NAggregate aggregate <- (.nodes) 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 ((.name) aggregate) <> ".EventStream qualified as " <> (.name) 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 = (.name) aggregate+            ]+          ++ ["  ]"]++genModule :: Agg -> Text -> Text -> ScaffoldModule+genModule a name body =+  ScaffoldModule+    { path = T.unpack (T.replace "." "/" ((.genPrefix) a) <> "/" <> name <> ".hs"),+      text = body,+      kind = Generated,+      origin = nodeOrigin "aggregate" ((.name) a) ((.loc) a)+    }++holeModule :: Agg -> Text -> ScaffoldModule+holeModule a body =+  ScaffoldModule+    { path = T.unpack (T.replace "." "/" ((.holePrefix) a) <> "/" <> "Holes.hs"),+      text = body,+      kind = HoleStub,+      origin = nodeOrigin "aggregate" ((.name) a) ((.loc) 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+      { path = T.unpack (T.replace "." "/" genPrefix <> "/Contract.hs"),+        text = emitContractGen languageContract genPrefix c,+        kind = Generated,+        origin = nodeOrigin "contract" ((.name) c) ((.loc) c)+      }+  ]+  where+    genPrefix = genPrefixFor ctx (pascal ((.name) 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 ((.discriminator) c) <> ")"+           ]+        ++ [emitPayloadAdt languageContract payloadTy ((.events) c)]+        ++ [ "",+             "messageTypeOf :: " <> payloadTy <> " -> Text",+             "messageTypeOf = \\case"+           ]+        ++ ["  " <> (.name) e <> " {} -> " <> tshow ((.name) e) | e <- (.events) c]+        ++ [ "",+             "encode" <> payloadTy <> " :: " <> payloadTy <> " -> Value",+             "encode" <> payloadTy <> " = \\case"+           ]+        ++ concatMap encodeArm ((.events) c)+        ++ [ "",+             "parse" <> payloadTy <> " :: Value -> Either Text " <> payloadTy,+             "parse" <> payloadTy <> " = mapLeftText . parseEither (withObject " <> tshow payloadTy <> " go)",+             "  where",+             "    go o = do",+             "      kind <- explicitParseField (withText " <> tshow ((.discriminator) c) <> " validateMessageType) o " <> tshow ((.discriminator) c),+             "      case kind of"+           ]+        ++ concatMap decodeArm ((.events) 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 (.name) ((.events) c)) <> " = pure kind",+             "  | otherwise = " <> renderUnknownFailure "message type" "kind" (map (.name) ((.events) c))+           ]+  )+    <> if hasTypedTypeIds then "\n" else ""+  where+    payloadTy = pascal ((.name) c) <> "Payload"+    hasTypedTypeIds = any (any (isTypedTypeId . (.valueType)) . (.fields)) ((.events) c)+    usesPlainFieldDecode = any (any (not . isTypedTypeId . (.valueType)) . (.fields)) ((.events) 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 <> " (..)"+      ]+        ++ ["  , " <> (.name) event <> "Data (..)" | event <- (.events) c]+        ++ ["  , " <> lowerFirst alias <> "Topic" | (alias, _) <- (.topics) 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) <- (.topics) c]+          ]+      | otherwise = [lowerFirst alias <> "Topic :: Text\n" <> lowerFirst alias <> "Topic = " <> tshow topic | (alias, topic) <- (.topics) c]+    isTypedTypeId (CTypeId prefix) = isJust (contractIdDomainContractFor languageContract prefix)+    isTypedTypeId _ = False+    aesonTypesImport = "import Data.Aeson.Types (Parser, explicitParseField, parseEither)"+    encodeArm e =+      [ "  " <> (.name) e <> " payload ->",+        "    object"+      ]+        ++ objectEntriesFor ((tshow ((.discriminator) c) <> " .= (" <> tshow ((.name) e) <> " :: Text)") : map encodeField ((.fields) 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 ((.name) e) <> " ->"]+        ++ case (.fields) e of+          [] -> ["          pure (" <> (.name) e <> " " <> (.name) e <> "Data)"]+          fields ->+            [ "          " <> (.name) e,+              "            <$> ( " <> (.name) e <> "Data"+            ]+              ++ [ (if index == 0 then "                    <$> " else "                    <*> ") <> decodeField field+                 | (index, field) <- zip [(0 :: Int) ..] fields+                 ]+              ++ ["                )"]+    encodeField field =+      tshow ((.wireKey) identity)+        <> " .= "+        <> case (.valueType) field of+          CTypeId prefix+            | isJust (contractIdDomainContractFor languageContract prefix) -> "KindID.toText payload." <> (.selector) identity+          _ -> "payload." <> (.selector) identity+      where+        identity = resolveContractFieldIdentity field+    decodeField field = case (.valueType) field of+      CTypeId prefix+        | isJust (contractIdDomainContractFor languageContract prefix) ->+            "explicitParseField (parseKindIdV7Value @" <> tshow prefix <> ") o " <> tshow wireKey+      _ -> "o .: " <> tshow wireKey+      where+        wireKey = (.wireKey) (resolveContractFieldIdentity field)++contractNeedsDuplicateRecordFields :: ContractNode -> Bool+contractNeedsDuplicateRecordFields = hasDuplicateNames . concatMap (map ((.selector) . resolveContractFieldIdentity) . (.fields)) . (.events)++contractUsesRecordDot :: ContractNode -> Bool+contractUsesRecordDot = any (not . null . (.fields)) . (.events)++emitPayloadAdt :: EffectiveLanguageContract -> Text -> [ContractEvent] -> Text+emitPayloadAdt languageContract tyName events =+  sectionsOf [map dataRecord events, [sumDecl]]+  where+    hasTypedTypeIds = any (any (isTypedTypeId . (.valueType)) . (.fields)) events+    isTypedTypeId (CTypeId prefix) = isJust (contractIdDomainContractFor languageContract prefix)+    isTypedTypeId _ = False+    valueType CText = "Text"+    valueType CInt = "Int"+    valueType (CTypeId prefix)+      | isJust (contractIdDomainContractFor languageContract prefix) = "(KindID " <> tshow prefix <> ")"+      | otherwise = "Text"+    dataRecord e =+      "data "+        <> (.name) e+        <> "Data = "+        <> (.name) e+        <> (if hasTypedTypeIds then "Data {" else "Data { ")+        <> T.intercalate ", " [(.selector) (resolveContractFieldIdentity f) <> " :: !" <> valueType ((.valueType) f) | f <- (.fields) e]+        <> (if hasTypedTypeIds then "}\n  deriving stock (Eq, Show)" else " }\n  deriving stock (Eq, Show)")+    arm e = (.name) e <> " !" <> (.name) 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+      { path = T.unpack (T.replace "." "/" genPrefix <> "/Inbox.hs"),+        text = emitIntakeGen genPrefix i,+        kind = Generated,+        origin = nodeOrigin "intake" ((.name) i) ((.loc) i)+      }+  ]+  where+    genPrefix = genPrefixFor ctx (pascal ((.name) 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 = " <> (.dedupePolicy) 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 ((.persist) 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 ((.outcome) row) <> " -> " <> actionExpression ((.action) row) | row <- (.disposition) 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 ((.name) i)+    outcomeType = stem <> "Outcome"+    dispositionType = stem <> "Disposition"+    outcomeConstructor = (stem <>) . pascal+    outcomeConstructors = map (outcomeConstructor . (.outcome)) ((.disposition) 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+      { path = T.unpack (T.replace "." "/" genPrefix <> "/Publisher.hs"),+        text = emitPublisherGen genPrefix pb,+        kind = Generated,+        origin = nodeOrigin "publisher" ((.name) pb) ((.loc) pb)+      }+  ]+  where+    genPrefix = genPrefixFor ctx (pascal ((.name) 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 (.kind) ((.backoff) pb) == "exponential" then ", ExponentialBackoffOptions (..)" else "")+        <> ")",+      "",+      "publisherOrdering :: OrderingPolicy",+      "publisherOrdering = " <> (.ordering) pb,+      "",+      "publisherBackoff :: BackoffSchedule",+      "publisherBackoff = " <> backoffExpr ((.backoff) pb),+      "",+      "publisherMaxAttempts :: Int",+      "publisherMaxAttempts = " <> tshow' ((.maxAttempts) pb)+    ]+  where+    backoffExpr b = case (.kind) b of+      "constant" -> "ConstantBackoff " <> windowText ((.window) b)+      "exponential" ->+        "ExponentialBackoff ExponentialBackoffOptions { initial = "+          <> windowText ((.window) b)+          <> ", maxDelay = "+          <> maybe "0" windowText ((.max) b)+          <> ", multiplier = "+          <> fromMaybe "0" ((.multiplier) 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 ((.name) 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 ((.name) workqueue))+    queueText+      | any isTypedQueueField ((.payload) 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+      { path = T.unpack (T.replace "." "/" genPrefix <> "/Queue.hs"),+        text = queueText,+        kind = Generated,+        origin = nodeOrigin "workqueue" ((.name) w) ((.loc) w)+      },+    ScaffoldModule+      { path = T.unpack (T.replace "." "/" genPrefix <> "/QueuePolicy.hs"),+        text = emitQueuePolicy genPrefix w,+        kind = Generated,+        origin = nodeOrigin "workqueue" ((.name) w) ((.loc) w)+      },+    ScaffoldModule+      { path = T.unpack (T.replace "." "/" genPrefix <> "/QueueCodec.hs"),+        text = emitQueueCodec genPrefix w,+        kind = Generated,+        origin = nodeOrigin "workqueue" ((.name) w) ((.loc) w)+      }+  ]+  where+    genPrefix = genPrefixFor ctx (pascal ((.name) w))++isTypedQueueField :: WqField -> Bool+isTypedQueueField field = case (.valueType) 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 ((.physical) w),+           "queueDlq = " <> tshow ((.dlq) w),+           "queueTable = " <> tshow ((.table) w),+           ""+         ]+      ++ groupKeyLines+      ++ [ "data " <> payloadTy <> " = " <> payloadTy,+           "  { " <> T.intercalate "\n  , " [(.name) f <> " :: !" <> payloadFieldType f | f <- (.payload) w],+           "  }",+           "  deriving stock (Eq, Show)",+           "",+           "encode" <> payloadTy <> " :: " <> payloadTy <> " -> Value",+           "encode" <> payloadTy <> " p =",+           "  object"+         ]+      ++ [lead i (tshow ((.wire) f) <> " .= p." <> (.name) f) | (i, f) <- zip [(0 :: Int) ..] ((.payload) w)]+      ++ [ "    ]",+           "",+           "parse" <> payloadTy <> " :: Value -> Either Text " <> payloadTy,+           "parse" <> payloadTy <> " = mapLeftText . parseEither (withObject " <> tshow payloadTy <> " go)",+           "  where",+           "    go o = " <> payloadTy <> fieldApps ((.payload) w),+           "",+           "mapLeftText :: Either String b -> Either Text b",+           "mapLeftText = either (Left . T.pack) Right"+         ]+  where+    payloadTy = (.payloadName) w+    payloadFieldType field = case (.valueType) field of+      LegacyQueueScalar scalar -> valueType (queueScalarName scalar)+      TypedQueueExpression _ -> error "keiro-dsl internal invariant: mapped queue lowering is pending"+    groupKeyExport = case (.groupKey) w of+      Nothing -> ""+      Just groupKey+        | (.via) groupKey == "raw" -> "  , groupKeyField, groupKeyFor"+        | otherwise -> "  , groupKeyField"+    groupKeyLines = case (.groupKey) w of+      Nothing -> []+      Just groupKey -> common <> derivationLines groupKey+        where+          common =+            [ "groupKeyField :: Text",+              "groupKeyField = " <> tshow ((.field) groupKey),+              ""+            ]+          derivationLines key+            | (.via) key == "raw" =+                [ "groupKeyFor :: " <> payloadTy <> " -> Text",+                  "groupKeyFor payload = payload." <> (.field) key,+                  ""+                ]+            | otherwise =+                [ "-- Opaque group-key derivation '" <> (.via) key <> "' remains hand-owned.",+                  "-- Captured fixture: " <> fromMaybe "<missing>" ((.fixture) key),+                  ""+                ]+    valueType "bool" = "Bool"+    valueType "int" = "Int"+    valueType _ = "Text"+    lead 0 kv = "    [ " <> kv+    lead _ kv = "    , " <> kv+    fieldApps [] = ""+    fieldApps fs = " <$> " <> T.intercalate " <*> " ["o .: " <> tshow ((.wire) f) | f <- fs]++data ResolvedQueueField = ResolvedQueueField+  { field :: !WqField,+    expression :: !(Maybe ResolvedTypeExpr),+    codecPlan :: !(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 ((.physical) workqueue),+           "queueDlq = " <> tshow ((.dlq) workqueue),+           "queueTable = " <> tshow ((.table) workqueue),+           ""+         ]+      <> groupKeyLines+      <> [ "data " <> payloadType <> " = " <> payloadType,+           "  { " <> T.intercalate "\n  , " [(.name) raw <> " :: " <> strictQueueFieldType (queueFieldType field) | field@ResolvedQueueField {field = 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 ((.wire) raw) <> " .= " <> encodeQueueField field) | (index, field@ResolvedQueueField {field = 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 = (.payloadName) workqueue+    fields = map resolveField ((.payload) workqueue)+    resolveField raw = case (.valueType) raw of+      LegacyQueueScalar {} -> ResolvedQueueField raw Nothing Nothing+      TypedQueueExpression expression ->+        case resolveTypeExpression graph owner ((.loc) 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 '" <> (.name) workqueue <> "' payload field '" <> (.name) raw <> "'"+    plans = [plan | ResolvedQueueField {codecPlan = Just plan} <- fields]+    rootExpressions = [expression | ResolvedQueueField {expression = Just expression} <- fields]+    selectedKeys = Set.unions (map ((.dependencies) . (.consumerType)) plans)+    declarations = mapMaybe (`Map.lookup` (.declarations) graph) (Set.toAscList selectedKeys)+    structuralDeclarations = [(declaration, shape) | ResolvedStructural declaration shape <- declarations]+    mappedCodecExports (declaration, _) =+      [ "  , encode" <> (.name) declaration <> "Mapped",+        "  , decode" <> (.name) 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 ((.haskell) declaration)+                : qualifiedValueReference ((.binding) declaration)+                : structuralShapeReferences ctx declaration shape+          ]+    importPlan =+      planImportsOrDie+        (genPrefix <> ".Queue")+        (Set.singleton payloadType)+        importsPlanReferences+    plannedModules = Set.map (.moduleName) importsPlanReferences+    opaqueInstanceImports =+      sort . nub $+        [ (.moduleName) ((.haskell) declaration) <> " ()"+        | ResolvedOpaque declaration <- declarations,+          Set.notMember ((.moduleName) ((.haskell) 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 {field = raw, expression = Nothing} = legacyQueueType raw+    queueFieldType ResolvedQueueField {expression = 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 (.valueType) raw of+      LegacyQueueScalar scalar -> case queueScalarName scalar of+        "bool" -> "Bool"+        "int" -> "Int"+        _ -> "Text"+      TypedQueueExpression {} -> error "typed queue field reached legacy type rendering"+    encodeQueueField ResolvedQueueField {field = raw, codecPlan = Nothing} = "payload." <> (.name) raw+    encodeQueueField ResolvedQueueField {field = raw, codecPlan = Just plan} =+      renderMappedEncode graph ConsumerValueBoundary plan ("payload." <> (.name) raw)+    decodeQueueField ResolvedQueueField {field = raw, codecPlan = Nothing} =+      "objectValue .: " <> tshow ((.wire) raw)+    decodeQueueField ResolvedQueueField {field = raw, codecPlan = Just plan} =+      "explicitParseField ("+        <> renderMappedParse graph ConsumerValueBoundary plan+        <> ") objectValue "+        <> tshow ((.wire) raw)+    queueFieldApplications [] = ""+    queueFieldApplications values = " <$> " <> T.intercalate " <*> " (map decodeQueueField values)+    groupKeyExport = case (.groupKey) workqueue of+      Nothing -> ""+      Just groupKey+        | (.via) groupKey == "raw" -> "  , groupKeyField, groupKeyFor"+        | otherwise -> "  , groupKeyField"+    groupKeyLines = case (.groupKey) workqueue of+      Nothing -> []+      Just groupKey ->+        [ "groupKeyField :: Text",+          "groupKeyField = " <> tshow ((.field) groupKey),+          ""+        ]+          <> if (.via) groupKey == "raw"+            then+              [ "groupKeyFor :: " <> payloadType <> " -> Text",+                "groupKeyFor payload = payload." <> (.field) groupKey,+                ""+              ]+            else+              [ "-- Opaque group-key derivation '" <> (.via) groupKey <> "' remains hand-owned.",+                "-- Captured fixture: " <> fromMaybe "<missing>" ((.fixture) 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 {codecPlan = Nothing} = True+    isLegacy ResolvedQueueField {codecPlan = Just _} = False+    isEnumShape REnum {} = True+    isEnumShape _ = False+    isTextShape REnum {} = True+    isTextShape RUnion {} = True+    isTextShape _ = False+    rejectsUnknown (RRecord _ RejectUnknown _) = True+    rejectsUnknown (RUnion encoding _) = (.unknownFields) encoding == RejectUnknown+    rejectsUnknown _ = False+    hasOptionalField (RRecord _ _ shapeFields) = any ((== POptional) . (.presence)) shapeFields+    hasOptionalField _ = False++queueLead :: Int -> Text -> Text+queueLead 0 keyValue = "    [ " <> keyValue+queueLead _ keyValue = "    , " <> keyValue++typeUsesNatural :: ResolvedTypeExpr -> Bool+typeUsesNatural = foldTypeExpr (TypeExprAlgebra False False False False True False False id id id (const False))++typeUsesTime :: ResolvedTypeExpr -> Bool+typeUsesTime = foldTypeExpr (TypeExprAlgebra False False False False False True False id id id (const False))++typeUsesText :: ResolvedTypeExpr -> Bool+typeUsesText = foldTypeExpr (TypeExprAlgebra True False False False False False False id id (const True) (const False))++typeUsesJson :: ResolvedTypeExpr -> Bool+typeUsesJson = foldTypeExpr (TypeExprAlgebra False False False False False False True id id id (const False))++typeUsesParserAnnotation :: ResolvedTypeExpr -> Bool+typeUsesParserAnnotation = foldTypeExpr (TypeExprAlgebra False False False False False False False id (const True) (const True) (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 ((.declarations) graph) of+          Just ResolvedOpaque {} -> True+          _ -> False+      }++typeUsesToJson :: TypeGraph -> ResolvedTypeExpr -> Bool+typeUsesToJson = typeUsesParseJson++workqueueUsesRecordDot :: WorkqueueNode -> Bool+workqueueUsesRecordDot workqueue =+  not (null ((.payload) workqueue))+    || maybe False ((== "raw") . (.via)) ((.groupKey) 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 = (.payloadName) w+    stem = lowerFirst (T.concat (map pascal (T.splitOn "_" ((.name) 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' ((.maxRetries) w),+      "    , defaultRetryDelay = RetryDelay " <> windowText ((.delay) w),+      "    , useDeadLetter = " <> (if (.dlqOn) 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 . (.outcome)) ((.disposition) w)),+      "  deriving stock (Eq, Show)",+      "",+      "jobOutcomeFor :: " <> outcomeType <> " -> JobOutcome",+      "jobOutcomeFor o = case o of"+    ]+      ++ ["  " <> pascal ((.outcome) r) <> " -> " <> outcome ((.action) r) | r <- (.disposition) w]+  where+    outcomeType = T.concat (map pascal (T.splitOn "_" ((.name) w))) <> "Outcome"+    queuePolicyImports =+      [ "JobOrdering (..)",+        "JobOutcome (..)",+        "JobTuning",+        "QueueProvision",+        "RetryDelay (..)",+        "RetryPolicy (..)"+      ]+        <> ( case (.provision) w of+               WqStandard -> ["standardProvision"]+               WqUnlogged -> ["unloggedProvision"]+               WqPartitioned {} -> ["PartitionSpec (..)", "partitionedProvision"]+           )+        <> ["withFifoIndexProvision" | (.ordering) w /= WqUnordered]+        <> ["withOrdering"]+    orderingCtor = case (.ordering) w of+      WqUnordered -> "Unordered"+      WqFifoThroughput -> "FifoThroughput"+      WqFifoRoundRobin -> "FifoRoundRobin"+    provisionExpr = fifoWrap baseProvision+    fifoWrap expression = case (.ordering) w of+      WqUnordered -> expression+      _ -> "withFifoIndexProvision (" <> expression <> ")"+    baseProvision = case (.provision) 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+      { path = modulePathFor readModelHolePrefix "ReadModelHoles",+        text = emitReadModelHoles tableModule readModelHolePrefix stem readModel,+        kind = HoleStub,+        origin = readModelOrigin+      }+  ]+  where+    nodeSegment = pascal ((.name) readModel)+    stem = readModelStem readModel+    readModelModule = genPrefixFor ctx nodeSegment+    tableModule = readModelModule <> ".ReadModelTable"+    readModelHolePrefix = holePrefixFor ctx nodeSegment+    readModelOrigin = nodeOrigin "readmodel" ((.name) readModel) ((.loc) readModel)+    generated leaf body =+      ScaffoldModule+        { path = modulePathFor readModelModule leaf,+          text = 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+        { path = modulePathFor readModelHolePrefix "ReadModelHoles",+          text = 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+        { path = modulePathFor readModelHolePrefix "ReadModelHoles",+          text = emitTypedReadModelHoles tableModule queryContractModule readModelHolePrefix stem readModel,+          kind = HoleStub,+          origin = readModelOrigin+        }+    ]+  where+    nodeSegment = pascal ((.name) readModel)+    stem = readModelStem readModel+    readModelModule = genPrefixFor ctx nodeSegment+    tableModule = readModelModule <> ".ReadModelTable"+    queryContractModule = readModelModule <> ".QueryContract"+    readModelHolePrefix = holePrefixFor ctx nodeSegment+    readModelOrigin = nodeOrigin "readmodel" ((.name) readModel) ((.loc) readModel)+    graph = case checkedTypeGraph service of+      Left errors -> error ("checked read-model type graph failed: " <> show errors)+      Right value -> value+    generated leaf body =+      ScaffoldModule+        { path = modulePathFor readModelModule leaf,+          text = body,+          kind = Generated,+          origin = readModelOrigin+        }++ownerDerivedCursor :: CheckedService -> ReadModelNode -> Maybe Text+ownerDerivedCursor service readModel = do+  ownerName <- case [ (.projectionOwner) supply+                    | supply <- (.resolvedProjectionSupplies) (checkedProjectionSupplies service),+                      (.queryModel) supply == (.name) readModel+                    ] of+    [name] -> Just name+    _ -> Nothing+  owner <- case [candidate | NProjectionOwner candidate <- (.nodes) (checkedSpec service), (.name) candidate == ownerName] of+    [candidate] -> Just candidate+    _ -> Nothing+  case (.delivery) owner of+    DeliveryInline -> Nothing+    DeliverySubscription -> (.subscription) 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 (.group) readModel of+  Nothing -> readModel+  Just _ ->+    let backingName = case (.backingTarget) readModel of+          Just name -> Just name+          Nothing -> case (.observedTargets) readModel of+            [single] -> Just single+            _ -> Nothing+     in case [target | NProjectionTarget target <- (.nodes) spec, Just ((.name) target) == backingName] of+          target : _ ->+            ReadModelNode+              { name = readModel.name,+                table = target.table,+                schema = target.schema,+                columns = readModel.columns,+                version = readModel.version,+                shape = readModel.shape,+                freshness = readModel.freshness,+                supply = readModel.supply,+                group = readModel.group,+                observedTargets = readModel.observedTargets,+                backingTarget = readModel.backingTarget,+                queryTypes = readModel.queryTypes,+                loc = readModel.loc+              }+          [] -> 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+          { path = modulePathFor (contextGeneratedPrefix ctx) "ProjectionCatalog",+            text = emitProjectionCatalogWith aggregateFingerprint ctx spec supplyAnalysis,+            kind = Generated,+            origin = "projection-catalog " <> (.name) ctx+          },+        ScaffoldModule+          { path = modulePathFor (holePrefixFor ctx "ProjectionCatalog") "ProjectionCatalogHoles",+            text = emitProjectionCatalogHoles ctx spec owners revisions externalReads,+            kind = HoleStub,+            origin = "projection-catalog " <> (.name) ctx+          }+      ]+  where+    catalogNodes = [() | node <- (.nodes) spec, isCatalogNode node]+    owners = sortOn (.order) [owner | NProjectionOwner owner <- (.nodes) spec]+    revisions = sortOn (.name) [revision | NProjectionRevision revision <- (.nodes) spec]+    externalReads = sortOn (\externalRead -> ((.name) externalRead, (.version) externalRead)) [externalRead | NExternalRead externalRead <- (.nodes) 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 <- (.nodes) spec]+    groups = [groupNode | NRebuildGroup groupNode <- (.nodes) spec]+    revisions = sortOn (.name) [revision | NProjectionRevision revision <- (.nodes) spec]+    externalReads = sortOn (\externalRead -> ((.name) externalRead, (.version) externalRead)) [externalRead | NExternalRead externalRead <- (.nodes) 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 (.order) [owner | NProjectionOwner owner <- (.nodes) spec]+    inlineOwners = [owner | owner <- owners, (.delivery) owner == DeliveryInline]+    sources = nub (concatMap (.sources) owners)+    aggregateSources = nub [aggregateName | CatalogAggregate aggregateName <- sources]+    replayableAggregateSources =+      nub+        [ aggregateName+        | owner <- owners,+          (.replay) owner == ProjectionReplayExplicit,+          CatalogAggregate aggregateName <- (.sources) owner+        ]+    asyncOwners = [owner | owner <- owners, (.delivery) 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 <- (.nodes) spec]+    supplies = (.resolvedProjectionSupplies) supplyAnalysis+    boundReadModels =+      [ readModel+      | supply <- supplies,+        readModel <- readModels,+        (.name) readModel == (.queryModel) supply+      ]+    readModelAlias readModel = "RM" <> pascal ((.name) readModel)+    readModelImport readModel = "import " <> genPrefixFor ctx (pascal ((.name) 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" ((.name) target)+        <> " (Catalog.QualifiedTable "+        <> tshow ((.schema) target)+        <> " "+        <> tshow ((.table) target)+        <> ") "+        <> (case (.reset) target of TargetClear -> "Catalog.ClearBeforeReplay"; TargetPreserve -> "Catalog.PreserveAndReconcile")+        <> " "+        <> renderList (smart "mkTargetId") ((.dependsOn) target)+        <> " "+        <> claim ("target " <> (.name) target)+    groupExpr groupNode =+      "Catalog.RebuildGroupDeclaration "+        <> smart "mkRebuildGroupId" ((.name) groupNode)+        <> " "+        <> renderList (smart "mkTargetId") ((.order) groupNode)+        <> " [] "+        <> claim ("rebuild-group " <> (.name) groupNode)+    revisionExpr revision =+      "Catalog.ProjectionRevision "+        <> smart "mkProjectionRevisionId" ((.name) revision)+        <> " "+        <> smart "mkRebuildGroupId" ((.group) revision)+        <> " (Map.fromList "+        <> renderList (revisionTargetExpr revision) ((.targets) revision)+        <> ") "+        <> renderList (revisionLiveHandlerExpr revision) (revisionOwners revision)+        <> " "+        <> "[Catalog.RevisionReplayAdapter "+        <> tshow ((.name) revision <> "/replay")+        <> " 1 "+        <> revisionRequiredTargets revision+        <> " Holes."+        <> revisionReplayName revision+        <> "] "+        <> "[Catalog.RevisionVerification "+        <> tshow ((.name) revision <> "/verification")+        <> " 1 "+        <> revisionRequiredTargets revision+        <> " Holes."+        <> revisionVerificationName revision+        <> "] [] "+        <> claim ("projection-revision " <> (.name) revision)+    revisionOwners revision = [owner | owner <- owners, (.group) owner == (.group) revision]+    revisionLiveHandlerExpr revision owner =+      "Catalog.RevisionLiveHandler "+        <> tshow ((.name) revision <> "/" <> (.name) owner <> "/live")+        <> " 1 "+        <> revisionLiveDeliveryExpr owner+        <> " "+        <> renderList (smart "mkTargetId") ((.targets) owner)+        <> " Holes."+        <> revisionOwnerLiveName revision owner+    revisionLiveDeliveryExpr owner = case (.delivery) owner of+      DeliveryInline ->+        "(Catalog.RevisionInlineDelivery "+          <> smart "mkProjectionId" ((.name) owner)+          <> " "+          <> tshow ((.name) owner)+          <> ")"+      DeliverySubscription ->+        "(Catalog.RevisionSubscriptionDelivery "+          <> smart "mkProjectionId" ((.name) owner)+          <> " "+          <> smart "mkSubscriptionId" (fromMaybe "" ((.subscription) owner))+          <> " "+          <> smart "mkDedupKeyId" (fromMaybe "" ((.dedup) owner))+          <> ")"+    revisionTargetExpr revision target =+      "("+        <> smart "mkTargetId" ((.target) target)+        <> ", Catalog.TargetProvisioner "+        <> tshow ((.provisioner) target)+        <> " "+        <> T.pack (show ((.provisionerVersion) target))+        <> " (Catalog.TargetSchemaVersion "+        <> tshow ((.schemaVersion) target)+        <> ") "+        <> tshow ((.expectedShape) target)+        <> " Holes."+        <> revisionProvisionName revision target+        <> " "+        <> tshow ((.validator) target)+        <> " "+        <> T.pack (show ((.validatorVersion) target))+        <> " (Just Holes."+        <> revisionValidateName revision target+        <> ") "+        <> renderList promotionObjectExpr ((.promotionObjects) target)+        <> ")"+    externalReadExpr externalRead =+      "Catalog.AllRowsExternalRead "+        <> smart "mkExternalReadContractId" ((.name) externalRead)+        <> " (Catalog.ExternalReadContractVersion "+        <> T.pack (show ((.version) externalRead))+        <> ") "+        <> smart "mkQueryModelId" ((.queryModel) externalRead)+        <> " (Catalog.QualifiedSqlType "+        <> tshow ((.resultSchema) externalRead)+        <> " "+        <> tshow ((.resultType) externalRead)+        <> ") "+        <> tshow (externalReadShape externalRead)+        <> " "+        <> nonEmptyList (smart "mkProjectionRevisionId") ((.compatibleRevisions) externalRead)+        <> " "+        <> T.pack (show ((.surfaceGeneration) externalRead))+        <> " "+        <> claim ("external-read " <> (.name) externalRead <> " v" <> T.pack (show ((.version) externalRead)))+    externalReadShape externalRead = case [(.shape) readModel | readModel <- readModels, (.name) readModel == (.queryModel) externalRead] of+      shape : _ -> shape+      [] -> "keiro-dsl invariant: validated external read query is missing"+    promotionObjectExpr promotionObject =+      "Catalog.PromotionObjectName "+        <> ( case (.kind) promotionObject of+               PromotionIndexNode -> "Catalog.PromotionIndex"+               PromotionConstraintNode -> "Catalog.PromotionConstraint"+               PromotionOwnedSequenceNode -> "Catalog.PromotionOwnedSequence"+           )+        <> " "+        <> tshow ((.generationName) promotionObject)+        <> " "+        <> tshow ((.canonicalName) promotionObject)+    revisionRequiredTargets revision = renderList (smart "mkTargetId") (map (.target) ((.targets) revision))+    subscriptionExpr owner =+      "Catalog.SubscriptionDeclaration "+        <> smart "mkSubscriptionId" (fromMaybe "" ((.subscription) owner))+        <> " "+        <> tshow (fromMaybe "" ((.subscription) owner))+        <> " "+        <> smart "mkSourceId" (catalogSourceId (ownerPrimarySource owner))+        <> " "+        <> checkpointOnMissingExpr owner+        <> " "+        <> claim ("projection-owner " <> (.name) owner <> " subscription")+    dedupExpr owner =+      "Catalog.DedupKeyDeclaration "+        <> smart "mkDedupKeyId" (fromMaybe "" ((.dedup) owner))+        <> " "+        <> tshow (fromMaybe "" ((.dedup) owner))+        <> " "+        <> claim ("projection-owner " <> (.name) owner <> " dedup")+    queryExpr readModel =+      "Catalog.SomeQueryModelBinding (Catalog.QueryModelBinding "+        <> smart "mkQueryModelId" ((.name) readModel)+        <> " "+        <> readModelAlias readModel+        <> "."+        <> readModelStem readModel+        <> "ReadModel "+        <> smart "mkRebuildGroupId" (fromMaybe "" ((.group) readModel))+        <> " "+        <> renderList (smart "mkTargetId") (sort ((.observedTargets) readModel))+        <> " "+        <> claim ("readmodel " <> (.name) readModel)+        <> ")"+    ownerSetName owner = lowerFirst (pascal ((.name) owner)) <> "ProjectionSet"+    ownerInlineViewName owner = lowerFirst (pascal ((.name) 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 ((.name) owner) <> "Event"+    ownerDefinition owner =+      [ "",+        ownerSetName owner <> " :: Catalog.ProjectionSet " <> ownerEventType owner,+        ownerSetName owner <> " =",+        "  Catalog.ProjectionSet",+        "    " <> smart "mkSourceId" (catalogSourceId (ownerPrimarySource owner)),+        "    (Catalog.ProjectionDefinition",+        "      " <> smart "mkProjectionId" ((.name) owner),+        "      " <> smart "mkRebuildGroupId" ((.group) owner),+        "      " <> nonEmptyList (smart "mkTargetId") ((.targets) owner),+        "      " <> replayPolicyExpr owner,+        "      (" <> handlerExpr owner <> " :| [])",+        "      " <> claim ("projection-owner " <> (.name) owner),+        "      :| [])",+        "    " <> claim ("projection-owner " <> (.name) owner <> " source")+      ]+        ++ if (.delivery) 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 (.replay) 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 (.delivery) owner of+      DeliveryInline ->+        "Catalog.InlineHandler (InlineProjection "+          <> tshow ((.name) owner)+          <> " Holes."+          <> ownerLiveApplyName owner+          <> ") "+          <> claim ("projection-owner " <> (.name) owner <> " inline-handler")+      DeliverySubscription ->+        "Catalog.AsyncHandler (AsyncProjection "+          <> tshow (fromMaybe "" ((.dedup) owner))+          <> " "+          <> tshow (ownerQueryRegistry owner)+          <> " "+          <> tshow (fromMaybe "" ((.subscription) owner))+          <> " Holes."+          <> ownerLiveApplyName owner+          <> " Holes."+          <> ownerIdempotencyName owner+          <> ") "+          <> smart "mkSubscriptionId" (fromMaybe "" ((.subscription) owner))+          <> " "+          <> smart "mkDedupKeyId" (fromMaybe "" ((.dedup) owner))+          <> " "+          <> claim ("projection-owner " <> (.name) owner <> " async-handler")+    ownerQueryRegistry owner = case matchingReadModels owner of+      readModel : _ -> registryNameFor ((.name) ctx) readModel+      [] -> ""+    matchingReadModels owner =+      [ readModel+      | supply <- supplies,+        (.projectionOwner) supply == (.name) owner,+        readModel <- boundReadModels,+        (.name) readModel == (.queryModel) supply+      ]+    ownerLiveApplyName owner = "apply" <> pascal ((.name) owner) <> "Live"+    ownerReplayApplyName owner = "apply" <> pascal ((.name) owner) <> "Replay"+    ownerReplayDecodeName owner = "decode" <> pascal ((.name) owner) <> "Replay"+    ownerIdempotencyName owner = lowerFirst (pascal ((.name) owner)) <> "IdempotencyKey"+    revisionProvisionName revision target = "provision" <> pascal ((.name) revision) <> pascal ((.target) target)+    revisionValidateName revision target = "validate" <> pascal ((.name) revision) <> pascal ((.target) target)+    revisionOwnerLiveName revision owner = "apply" <> pascal ((.name) revision) <> pascal ((.name) owner) <> "Live"+    revisionReplayName revision = "apply" <> pascal ((.name) revision) <> "Replay"+    revisionVerificationName revision = "verify" <> pascal ((.name) revision)+    groupIdName groupNode = lowerFirst (pascal ((.name) groupNode)) <> "RebuildGroupId"+    groupStartName groupNode = "start" <> pascal ((.name) groupNode) <> "Rebuild"+    groupExports groupNode = ["  , " <> groupIdName groupNode, "  , " <> groupStartName groupNode]+    groupDefinitions groupNode =+      [ "",+        groupIdName groupNode <> " :: Catalog.RebuildGroupId",+        groupIdName groupNode <> " = " <> smart "mkRebuildGroupId" ((.name) 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 (.sources) owner of+      source : _ -> source+      [] -> CatalogAll+    checkpointOnMissingExpr owner = case (.checkpointOnMissing) 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 <- (.sources) owner]+    exports = concatMap ownerExports owners <> concatMap revisionExports revisions <> map externalReadKeyedName externalReads+    ownerExports owner =+      [pascal ((.name) owner) <> "Event" | not (isAggregateSource owner)]+        <> [ownerLiveApplyName owner]+        <> [ownerIdempotencyName owner | (.delivery) owner == DeliverySubscription]+        <> case (.replay) owner of+          ProjectionLiveOnly _ -> []+          ProjectionReplayExplicit -> [ownerReplayApplyName owner] <> [ownerReplayDecodeName owner | not (isAggregateSource owner)]+    ownerStubs owner =+      ["-- Projection owner " <> (.name) owner <> " (order " <> T.pack (show ((.order) owner)) <> ")."]+        <> ["data " <> ownerEventType owner <> " = " <> ownerEventType owner | not (isAggregateSource owner)]+        <> [ownerLiveSignature owner, ownerLiveApplyName owner <> " = error \"HOLE: fill " <> (.name) owner <> " live apply\""]+        <> ( if (.delivery) owner == DeliverySubscription+               then+                 [ ownerIdempotencyName owner <> " :: RecordedEvent -> EventId",+                   ownerIdempotencyName owner <> " = error \"HOLE: return the durable event id for " <> (.name) owner <> "\""+                 ]+               else []+           )+        <> replayStubs owner+        <> [""]+    revisionExports revision =+      concatMap (\target -> [revisionProvisionName revision target, revisionValidateName revision target]) ((.targets) revision)+        <> map (revisionOwnerLiveName revision) (revisionOwners revision)+        <> [revisionReplayName revision, revisionVerificationName revision]+    revisionStubs revision =+      ["-- Projection revision " <> (.name) revision <> "."]+        <> concatMap targetStubs ((.targets) revision)+        <> concatMap liveStubs (revisionOwners revision)+        <> [ revisionReplayName revision <> " :: Catalog.PhysicalTargets -> RecordedEvent -> Tx.Transaction (Either Catalog.ReplayDecodeError Bool)",+             revisionReplayName revision <> " = error \"HOLE: replay revision " <> (.name) revision <> " through PhysicalTargets\"",+             revisionVerificationName revision <> " :: Catalog.PhysicalTargets -> Tx.Transaction (Either Text ())",+             revisionVerificationName revision <> " = error \"HOLE: verify revision " <> (.name) revision <> " staging targets\"",+             ""+           ]+      where+        liveStubs owner =+          [ revisionOwnerLiveName revision owner <> " :: Catalog.PhysicalTargets -> RecordedEvent -> Tx.Transaction ()",+            revisionOwnerLiveName revision owner <> " = error \"HOLE: apply " <> (.name) owner <> " live events for revision " <> (.name) revision <> " through its owned PhysicalTargets\""+          ]+        targetStubs target =+          [ revisionProvisionName revision target <> " :: Catalog.TargetProvisioningContext -> Tx.Transaction ()",+            revisionProvisionName revision target <> " = error \"HOLE: provision target " <> (.target) target <> " for revision " <> (.name) revision <> "\"",+            revisionValidateName revision target <> " :: Catalog.TargetProvisioningContext -> Tx.Transaction (Either [Catalog.TargetSchemaViolation] Catalog.TargetSchemaEvidence)",+            revisionValidateName revision target <> " = error \"HOLE: validate target " <> (.target) target <> " for revision " <> (.name) revision <> "\""+          ]+    externalReadStubs externalRead =+      [ "-- Keyed alternative for external-read " <> (.name) externalRead <> " v" <> T.pack (show ((.version) 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" ((.name) externalRead),+        "    (Catalog.ExternalReadContractVersion " <> T.pack (show ((.version) externalRead)) <> ")",+        "    " <> smart "mkQueryModelId" ((.queryModel) externalRead),+        "    arguments",+        "    (Catalog.QualifiedSqlType " <> tshow ((.resultSchema) externalRead) <> " " <> tshow ((.resultType) externalRead) <> ")",+        "    privateImplementation",+        "    privateImplementationVersion",+        "    " <> tshow (externalReadShape externalRead),+        "    " <> nonEmptyList (smart "mkProjectionRevisionId") ((.compatibleRevisions) externalRead),+        "    " <> T.pack (show ((.surfaceGeneration) externalRead)),+        "    " <> smart "mkClaimSite" ("external-read " <> (.name) externalRead <> " v" <> T.pack (show ((.version) externalRead)) <> " keyed helper"),+        ""+      ]+    replayStubs owner = case (.replay) owner of+      ProjectionLiveOnly _ -> []+      ProjectionReplayExplicit ->+        ( if not (isAggregateSource owner)+            then+              [ ownerReplayDecodeName owner <> " :: RecordedEvent -> Catalog.ReplayDecodeResult " <> ownerEventType owner,+                ownerReplayDecodeName owner <> " = error \"HOLE: classify and decode every " <> (.name) owner <> " source event\""+              ]+            else []+        )+          <> [ ownerReplayApplyName owner <> " :: " <> ownerEventType owner <> " -> RecordedEvent -> Tx.Transaction ()",+               ownerReplayApplyName owner <> " = error \"HOLE: fill " <> (.name) owner <> " replay apply without live-only side effects\""+             ]+    ownerLiveSignature owner =+      ownerLiveApplyName owner <> " :: " <> case (.delivery) owner of+        DeliveryInline -> ownerEventType owner <> " -> RecordedEvent -> Tx.Transaction ()"+        DeliverySubscription -> "RecordedEvent -> Tx.Transaction ()"+    ownerEventType owner = case ownerPrimarySource owner of+      CatalogAggregate aggregateName -> pascal aggregateName <> "Event"+      _ -> pascal ((.name) owner) <> "Event"+    isAggregateSource owner = case ownerPrimarySource owner of CatalogAggregate {} -> True; _ -> False+    ownerPrimarySource owner = case (.sources) owner of source : _ -> source; [] -> CatalogAll+    ownerLiveApplyName owner = "apply" <> pascal ((.name) owner) <> "Live"+    ownerReplayApplyName owner = "apply" <> pascal ((.name) owner) <> "Replay"+    ownerReplayDecodeName owner = "decode" <> pascal ((.name) owner) <> "Replay"+    ownerIdempotencyName owner = lowerFirst (pascal ((.name) owner)) <> "IdempotencyKey"+    revisionProvisionName revision target = "provision" <> pascal ((.name) revision) <> pascal ((.target) target)+    revisionValidateName revision target = "validate" <> pascal ((.name) revision) <> pascal ((.target) target)+    revisionOwners revision = [owner | owner <- owners, (.group) owner == (.group) revision]+    revisionOwnerLiveName revision owner = "apply" <> pascal ((.name) revision) <> pascal ((.name) owner) <> "Live"+    revisionReplayName revision = "apply" <> pascal ((.name) revision) <> "Replay"+    revisionVerificationName revision = "verify" <> pascal ((.name) revision)+    externalReadKeyedName externalRead = lowerFirst (pascal ((.name) externalRead)) <> "V" <> T.pack (show ((.version) externalRead)) <> "KeyedExternalRead"+    externalReadShape externalRead = case [(.shape) readModel | NReadModel readModel <- (.nodes) spec, (.name) readModel == (.queryModel) 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 "_" . (.name)++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 ((.schema) readModel) <> " " <> tshow ((.table) 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 '" <> (.name) 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 = (.group) readModel /= Nothing+    ownerDerived = (.supply) readModel == OwnerDerivedSupply+    emitsLegacyAsync = not ownerDerived && not catalogManaged && legacyReadModelFeed readModel == Just RmSubscription+    registryName = registryNameFor ((.name) ctx) readModel+    subscriptionName = subscriptionNameFor ((.name) 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 (.freshness) 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 (.freshness) 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 ((.table) readModel),+             "    , schema = " <> tshow ((.schema) readModel),+             "    , version = " <> tshow' ((.version) readModel),+             "    , shapeHash = " <> tshow ((.shape) readModel),+             "    , cursorAuthority = " <> maybe "NoQueryCursor" (("DurableQueryCursor " <>) . tshow) resolvedCursor,+             "    , query = " <> queryName,+             "    }"+           ]+    legacyDefinition =+      [ "  ReadModel",+        "    { name = " <> tshow registryName,+        "    , tableName = " <> tshow ((.table) readModel),+        "    , schema = " <> tshow ((.schema) readModel),+        "    , subscriptionName = " <> tshow subscriptionName,+        "    , version = " <> tshow' ((.version) readModel),+        "    , shapeHash = " <> tshow ((.shape) 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' ((.version) readModel) <> " " <> tshow ((.shape) 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) ((.columns) readModel)+      ++ [ queryName <> " :: " <> queryInputType <> " -> Tx.Transaction " <> queryResultType,+           queryName <> " _input = " <> qualifiedName <> " `seq` error " <> tshow ("HOLE: fill " <> (.name) readModel <> " query")+         ]+      ++ applyStub+  where+    qualifiedName = stem <> "QualifiedTable"+    queryInputType = pascal stem <> "QueryInput"+    queryResultType = pascal stem <> "QueryResult"+    queryName = stem <> "Query"+    applyName = "apply" <> pascal stem+    emitsLegacyAsync = (.group) 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 " <> (.name) 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) ((.columns) readModel)+      ++ [ queryName <> " :: " <> queryInputType <> " -> Tx.Transaction " <> queryResultType,+           queryName <> " _input = " <> qualifiedName <> " `seq` error " <> tshow ("HOLE: fill " <> (.name) readModel <> " query")+         ]+      ++ applyStub+  where+    qualifiedName = stem <> "QualifiedTable"+    queryInputType = pascal stem <> "QueryInput"+    queryResultType = pascal stem <> "QueryResult"+    queryName = stem <> "Query"+    applyName = "apply" <> pascal stem+    emitsLegacyAsync = (.group) 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 " <> (.name) readModel <> " async apply")+          ]+      | otherwise = []++qualifiedTableLiteral :: ReadModelNode -> Text+qualifiedTableLiteral readModel = quoteSqlIdentifier ((.schema) readModel) <> "." <> quoteSqlIdentifier ((.table) 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+      { path = modulePathFor genPrefix "Router",+        text = emitRouterGen genPrefix router,+        kind = Generated,+        origin = routerOrigin+      },+    ScaffoldModule+      { path = modulePathFor holePrefix "RouterHoles",+        text = emitRouterHoles holePrefix router,+        kind = HoleStub,+        origin = routerOrigin+      }+  ]+  where+    genPrefix = genPrefixFor ctx ((.id) router)+    holePrefix = holePrefixFor ctx ((.id) router)+    routerOrigin = nodeOrigin "router" ((.id) router) ((.loc) 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 (.source) ((.resolve) router) of+  ResolveDeclarative {} ->+    [ ScaffoldModule+        { path = modulePathFor genPrefix "Router",+          text = emitDeclarativeRouterGen ctx graph selection readModel targetAggregate targetCommand genPrefix router,+          kind = Generated,+          origin = routerOrigin+        }+    ]+  _ -> scaffoldRouter ctx router+  where+    spec = checkedSpec service+    genPrefix = genPrefixFor ctx ((.id) router)+    routerOrigin = nodeOrigin "router" ((.id) router) ((.loc) 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 <- (.nodes) spec, (.name) value == (.name) ((.query) selection)] of+      [value] -> value+      _ -> error "checked declarative router read model disappeared"+    targetAggregate = case [aggregate | NAggregate aggregate <- (.nodes) spec, (.name) aggregate == (.target) selection] of+      [aggregate] -> aggregate+      _ -> error "checked declarative router target aggregate disappeared"+    targetCommand = case [command | command <- (.commands) targetAggregate, (.name) command == (.command) 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 ((.poison) router)+      ++ [ "",+           "-- The STABLE router name. It participates in every target-keyed",+           "-- deterministicRouterCommandId; renaming it re-keys replayed dispatches.",+           stem <> "Name :: Text",+           stem <> "Name = " <> tshow ((.name) 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") ((.rejected) router) ((.poison) router)+  where+    stem = lowerFirst ((.id) 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 ((.projections) 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)" | (.poison) 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 ((.name) router),+           "",+           "-- SHA-256 of the checked selection semantics (locations and formatting excluded).",+           stem <> "SelectionFingerprint :: Text",+           stem <> "SelectionFingerprint = " <> tshow ((.fingerprint) selection),+           "",+           stem <> "SelectionContract :: RouterSelectionContract",+           stem <> "SelectionContract =",+           "  RouterSelectionContract",+           "    { identity = SelectionIdentity " <> tshow ((.identity) selection),+           "    , version = checkedSelectionVersion",+           "    , fingerprint = SelectionFingerprint " <> stem <> "SelectionFingerprint",+           "    , limit = checkedRecipientLimit",+           "    , order = OrderByTargetStream",+           "    , dedupe = DedupeByTargetStream",+           "    , emptyPolicy = " <> renderCheckedEmptyPolicy ((.emptyPolicy) selection),+           "    , failurePolicy = " <> renderCheckedFailurePolicy ((.failurePolicy) selection),+           "    , redeliveryPolicy = StableUnion",+           "    , partialPolicy = RetainSuccesses",+           "    }",+           "  where",+           "    checkedSelectionVersion = case mkSelectionVersion " <> T.pack (show ((.version) selection)) <> " of",+           "      Right value -> value",+           "      Left _ -> error \"keiro-dsl emitted a non-positive checked selection version\"",+           "    checkedRecipientLimit = case mkRecipientLimit " <> T.pack (show ((.limit) 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 " <> (.name) ((.query) selection) <> " query failed") <> ")",+           "    Right rows ->",+           "      Right",+           "        [ PMCommand",+           "            { target = entityStream TargetStream." <> targetCategory <> " (" <> renderCheckedScalar graph ((.recipient) selection) <> ")",+           "            , command = " <> renderSelectionCommand graph selection targetCommand,+           "            }",+           "        | row <- rows",+           "        , " <> renderCheckedScalar graph ((.predicate) 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 ((.key) selection),+           "    , selectionContract = " <> stem <> "SelectionContract",+           "    , select = " <> stem <> "Select",+           "    , targetEventStream = TargetStream." <> targetEventStream,+           "    , targetProjections = const " <> renderTargetProjections ((.projections) router),+           "    }",+           "",+           "-- Node-level worker policy. Pair it with runDeclarativeRouterWorkerWith.",+           "-- Selection empty/failure policy remains in the generated selection contract."+         ]+      <> workerOptionsLines (stem <> "WorkerOptions") ((.rejected) router) ((.poison) router)+  where+    stem = lowerFirst ((.id) router)+    targetName = (.name) targetAggregate+    targetModule = genPrefixFor ctx targetName+    targetCategory = lowerFirst targetName <> "CommandCategory"+    targetEventStream = lowerFirst targetName <> "EventStream"+    readModelStemValue = readModelStem readModel+    queryInputType = pascal readModelStemValue <> "QueryInput"+    queryNodeSegment = pascal ((.name) 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 (.node) 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 ((.owner) first) pointer)+      where+        pointer = T.concat ["/" <> escapePointer ((.wireKey) segment) | segment <- path]++renderSelectionCommand :: TypeGraph -> CheckedRouterSelection -> Command -> Text+renderSelectionCommand graph selection command =+  "TargetDomain."+    <> (.name) command+    <> " (TargetDomain."+    <> (.name) command+    <> "Data"+    <> T.concat [" (" <> renderCheckedScalar graph (commandExpression field) <> ")" | field <- (.fields) command]+    <> ")"+  where+    commandExpression field =+      fromMaybe+        (error "checked declarative router command field disappeared")+        (Map.lookup ((.name) field) ((.commandFields) 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 :: " <> (.name) ((.input) router) <> " -> Eff es [PMCommand targetCommand]",+      "--   Spec source: " <> resolveSourceText ((.source) ((.resolve) 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 ((.id) router) <> "Name,",+      "--   key, resolve, targetEventStream, and targetProjections; run it with",+      "--   runRouterWorkerWith " <> lowerFirst ((.id) router) <> "WorkerOptions.",+      "-- HOLE targetProjections: spec projections = " <> renderNames ((.projections) 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 " <> (.identity) 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+      { path = T.unpack (T.replace "." "/" genPrefix <> "/Process.hs"),+        text = emitProcessGen sagaGenPrefix genPrefix holePrefix p,+        kind = Generated,+        origin = nodeOrigin "process" ((.id) p) ((.loc) p)+      },+    ScaffoldModule+      { path = T.unpack (T.replace "." "/" holePrefix <> "/ProcessHoles.hs"),+        text = emitProcessHoles genPrefix holePrefix p,+        kind = HoleStub,+        origin = nodeOrigin "process" ((.id) p) ((.loc) p)+      }+  ]+  where+    genPrefix = genPrefixFor ctx ((.id) p)+    holePrefix = holePrefixFor ctx ((.id) p)+    sagaGenPrefix = genPrefixFor ctx (pascal ((.agg) ((.saga) 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 ((.poison) p)+      ++ [ "",+           "-- The define-once ProcessManager name (hole-kind 5: referenced, never retyped).",+           lo <> "ProcessName :: Text",+           lo <> "ProcessName = " <> tshow ((.name) 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") ((.rejected) p) ((.poison) 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 ((.prefix) ((.id) timer)) <> " <> correlationId)",+           lo <> "TimerRequest :: Text -> UTCTime -> TimerRequest",+           lo <> "TimerRequest correlationId fireAtTime =",+           "  TimerRequest",+           "    { timerId = TimerId (namedUuid (" <> tshow ((.prefix) ((.id) timer)) <> " <> correlationId))",+           "    , processManagerName = " <> lo <> "ProcessName",+           "    , correlationId = correlationId",+           "    , fireAt = fireAtTime",+           "    , payload = " <> payloadExpr ((.payload) 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' ((.maxAttempts) timer) <> ", dead-letter = " <> tshow ((.deadLetter) timer),+           "-- (the timer worker must pass Just " <> tshow' ((.maxAttempts) 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 ((.id) p)+    sagaEventStreamType = pascal ((.agg) ((.saga) p)) <> "EventStreamDef"+    categoryName = staticCategory ("process " <> (.id) p) ((.category) ((.saga) p))+    timer = (.timer) p+    fd = (.disposition) ((.fire) 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) ((.value) b >>= stripWrappingQuotes)+    kv b = tshow ((.name) b) <> " .= (" <> maybe "\"\"" tshow ((.value) 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) ((.advance) ((.handle) p)) <> "', the dispatch(es), and the timer) from the input.",+      "-- HOLE streams: build streamFor with entityStream " <> lowerFirst ((.id) p) <> "Category;",+      "--   build target streams with entityStream " <> lowerFirst ((.target) 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 " <> (.command) ((.fire) ((.timer) p)) <> " for the timer fire,",+      "--   keyed by correlationId; the fired-event-id is the deterministic uuidv5 of",+      "--   " <> tshow ((.prefix) ((.firedEventId) ((.fire) ((.timer) 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 " <> (.genPrefix) a <> ".Domain where",+           ""+         ]+      ++ ["import Data.Aeson (FromJSON, ToJSON)" | hasSnapshot a]+      ++ ["import Data.Proxy (Proxy (..))" | not (null ((.regs) 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) ((.commands) a),+               [emitSum ((.name) a <> "Command") ((.commands) a)],+               map (emitRecord importPlan a) ((.events) a),+               [emitSum ((.name) a <> "Event") ((.events) a)],+               [emitRegsType importPlan a, emitInitialRegs importPlan a],+               [ "$(deriveAggregateCtorsAll ''" <> (.name) a <> "Command ''" <> (.name) a <> "Regs)",+                 "",+                 "$(deriveWireCtorsAll ''" <> (.name) a <> "Event)"+               ]+             ]+         ]+  where+    importPlan = domainImportPlan a++domainNeedsDuplicateRecordFields :: Agg -> Bool+domainNeedsDuplicateRecordFields aggregate = hasDuplicateNames selectorNames+  where+    commandSelectors = concatMap (map ((.selector) . fst) . (.fields)) ((.commands) aggregate)+    eventSelectors = concatMap (map ((.selector) . fst) . (.fields)) ((.events) aggregate)+    registerSelectors = map (.name) ((.regs) 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) . (.snapshot)++emitVertex :: Agg -> Text+emitVertex a =+  nl $+    [ "data " <> (.vertexType) a <> " = " <> T.intercalate " | " (map (vertexCtor a . (.name)) ((.states) a)),+      "  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)"+    ]+      ++ ["  deriving anyclass (ToJSON, FromJSON)" | hasSnapshot a]+      ++ [ line+         | hasSnapshot a,+           line <-+             [ "instance CanonicalStateShape " <> (.vertexType) a,+               "instance CanonicalTypeName " <> (.vertexType) a+             ]+         ]++emitRecord :: HaskellImportPlan -> Agg -> ResolvedCtor -> Text+emitRecord importPlan a rc =+  nl $+    [ "data " <> (.name) rc <> "Data = " <> (.name) rc <> "Data"+    ]+      ++ recordFields [((.selector) identity, renderDomainType importPlan a valueType) | (identity, valueType) <- (.fields) 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 = (.name) rc <> " !" <> (.name) 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 " <> (.name) a <> "Regs ="]+      ++ regListLines importPlan a ((.regs) a)++regListLines :: HaskellImportPlan -> Agg -> [ResolvedRegister] -> [Text]+regListLines _ _ [] = ["  '[]"]+regListLines importPlan a rs =+  [ lead i <> "'(" <> tshow ((.name) r) <> ", " <> renderDomainType importPlan a ((.valueType) r) <> ")"+  | (i, r) <- zip [(0 :: Int) ..] rs+  ]+    ++ ["   ]"]+  where+    lead 0 = "  '[ "+    lead _ = "   , "++emitInitialRegs :: HaskellImportPlan -> Agg -> Text+emitInitialRegs importPlan a =+  nl $+    [ "initial" <> (.name) a <> "Regs :: RegFile " <> (.name) a <> "Regs",+      "initial" <> (.name) a <> "Regs ="+    ]+      ++ chain ((.regs) a)+  where+    chain [] = ["  RNil"]+    chain rs =+      [ "  RCons (Proxy @" <> tshow ((.name) r) <> ") " <> regInitialValue importPlan a r <> " $"+      | r <- init rs+      ]+        ++ ["  RCons (Proxy @" <> tshow ((.name) 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 (.initial) register of+  InitialId name -> case find ((== name) . (.name)) ((.generatedNominals) aggregate) >>= generatedIdSampleHaskell aggregate of+    Just value -> value+    Nothing -> renderRegisterInitial ((.initial) register)+  InitialNominal _ value -> renderReferenceOrDie importPlan (qualifiedValueReference value)+  InitialMapped _ value -> renderReferenceOrDie importPlan (qualifiedValueReference value)+  _ -> renderRegisterInitial ((.initial) register)++domainImportPlan :: Agg -> HaskellImportPlan+domainImportPlan aggregate =+  planImportsOrDie+    ((.genPrefix) aggregate <> ".Domain")+    localDeclarations+    (Set.unions (map aggregateSourceReferences (domainAggregateSources aggregate)) <> initialReferences)+  where+    localDeclarations =+      Set.fromList+        ( [ (.vertexType) aggregate,+            (.name) aggregate <> "Command",+            (.name) aggregate <> "Event",+            (.name) aggregate <> "Regs"+          ]+            <> [(.name) constructor <> "Data" | constructor <- (.commands) aggregate <> (.events) aggregate]+            <> map (.name) ((.generatedNominals) aggregate)+        )+    initialReferences =+      Set.fromList+        ( [ qualifiedValueReference initialValue+          | declaration <- mappedUses aggregate,+            initialValue <- maybeToListText (mappedInitial declaration)+          ]+            <> [ qualifiedValueReference initialValue+               | resolvedType <- aggregateTypes aggregate,+                 AggregateNominal nominal <- [resolvedType],+                 ConsumerNominal binding <- [(.ownership) nominal],+                 initialValue <- maybeToListText ((.initial) binding)+               ]+        )++generatedNominalDomainImports :: Agg -> [Text]+generatedNominalDomainImports aggregate+  | null nominals = []+  | otherwise =+      [ "import "+          <> generatedNominalModule ((.context) aggregate)+          <> " ("+          <> T.intercalate ", " (concatMap importsFor nominals)+          <> ")"+      ]+  where+    nominals = stableNominals ((.generatedNominals) aggregate)+    importsFor nominal = case (.representation) nominal of+      IdRepresentation prefix+        | Just _ <- idDomainContractFor ((.languageContract) aggregate) prefix ->+            (.name) nominal+              : ["parse" <> (.name) nominal | needsParser nominal]+      _ -> [(.name) nominal <> " (..)"]+    needsParser nominal =+      any+        (\register -> (.valueType) register == AggregateNominal nominal && case (.initial) register of InitialId {} -> True; _ -> False)+        ((.regs) 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 (.initial) register of InitialTime {} -> True; _ -> False) ((.regs) aggregate)+    timeImports+      | usesTimeLiteral =+          [ "Data.Time.Calendar (fromGregorian)",+            "Data.Time.Clock (UTCTime (..), picosecondsToDiffTime)"+          ]+      | usesTimeType = [timeTypeImport]+      | otherwise = []++domainAggregateSources :: Agg -> [AggregateHaskellSource]+domainAggregateSources aggregate =+  map (aggregateConsumerHaskellSource ((.symbols) aggregate)) (aggregateTypes aggregate)++aggregateTypes :: Agg -> [ResolvedAggregateType]+aggregateTypes aggregate =+  map snd (concatMap (.fields) ((.commands) aggregate <> (.events) aggregate)) <> map (.valueType) ((.regs) aggregate)++mappedUses :: Agg -> [ResolvedMappedDecl]+mappedUses a =+  [ declaration+  | resolvedType <-+      map snd (concatMap (.fields) ((.commands) a <> (.events) a))+        <> map (.valueType) ((.regs) 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 <- (.typeGraph) a+  Map.lookup key ((.declarations) graph)++mappedInitial :: ResolvedMappedDecl -> Maybe QualifiedValueName+mappedInitial (ResolvedStructural declaration _) = (.initial) declaration+mappedInitial (ResolvedOpaque declaration) = (.initial) declaration++renderDomainType :: HaskellImportPlan -> Agg -> ResolvedAggregateType -> Text+renderDomainType importPlan aggregate resolvedType =+  either+    (error . ("validated aggregate Haskell reference failed: " <>) . show)+    id+    (renderAggregateHaskellSource importPlan (aggregateConsumerHaskellSource ((.symbols) aggregate) resolvedType))++maybeToListText :: Maybe value -> [value]+maybeToListText = maybe [] pure++--------------------------------------------------------------------------------+-- Codec module+--------------------------------------------------------------------------------++emitCodec :: Agg -> Text+emitCodec a =+  nl $+    renderGeneratedLanguagePragmas [ExtOverloadedRecordDot | codecUsesRecordDot a]+      ++ [ generatedBanner,+           "module " <> (.genPrefix) a <> ".Codec (",+           "    " <> lowerFirst ((.name) a) <> "Codec,",+           "    parse" <> (.name) a <> "Event,",+           "    encode" <> (.name) a <> "Event,"+         ]+      ++ concatMap mappedExports (codecMappedDeclarations a)+      ++ [ ") where",+           "",+           "import " <> (.genPrefix) a <> ".Domain"+         ]+      ++ generatedNominalCodecImports (aggregateCheckedService a) ((.context) 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" <> (.name) declaration <> "Mapped,",+        "    decode" <> (.name) declaration <> "Mapped,"+      ]+    mappedExports ResolvedOpaque {} = []++codecUsesRecordDot :: Agg -> Bool+codecUsesRecordDot = any (not . null . (.fields)) . (.events)++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 ((.events) 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 (.representation) nominal of+      EnumRepresentation {} -> True+      IdRepresentation {} -> case (.ownership) 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 (.fields) ((.events) aggregate))+  where+    fieldUsesDotColon (_, resolvedType) = case resolvedType of+      AggregateNominal nominal -> case ((.ownership) nominal, (.representation) 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 _ -> (.unknownFields) 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 (.fields) ((.events) 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 (.valueType) fields+  REnum {} -> []+  RUnion _ arms -> mapMaybe (.payload) 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 (.typeGraph) aggregate >>= \graph -> Map.lookup key ((.declarations) graph) of+          Just ResolvedOpaque {} -> True+          _ -> False+      }++codecUsesOptionalFieldHelper :: Agg -> Bool+codecUsesOptionalFieldHelper aggregate =+  any structuralHasOptionalField (codecMappedDeclarations aggregate)+  where+    structuralHasOptionalField (ResolvedStructural _ (RRecord _ _ fields)) =+      any ((== POptional) . (.presence)) fields+    structuralHasOptionalField (ResolvedStructural _ _) = False+    structuralHasOptionalField ResolvedOpaque {} = False++hasConsumerNominalCodec :: Agg -> Bool+hasConsumerNominalCodec = not . null . codecConsumerNominals++hasConsumerNominalIdCodec :: Agg -> Bool+hasConsumerNominalIdCodec aggregate =+  any+    (\nominal -> case (.representation) nominal of IdRepresentation {} -> True; _ -> False)+    (codecConsumerNominals aggregate)++hasEnforcedConsumerNominalIdCodec :: Agg -> Bool+hasEnforcedConsumerNominalIdCodec aggregate =+  any+    ( \nominal -> case (.representation) nominal of+        IdRepresentation prefix -> isJust (idDomainContractFor ((.languageContract) aggregate) prefix)+        _ -> False+    )+    (codecConsumerNominals aggregate)++emitEnumParsers :: Agg -> Text+emitEnumParsers a =+  sectionsOf+    [ [emitEnumParser nominal | nominal <- codecGeneratedNominals a, EnumRepresentation {} <- [(.representation) nominal]]+    ]++emitEnumParser :: ResolvedNominalType -> Text+emitEnumParser nominal = case (.representation) 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 = (.name) nominal++emitConsumerNominalParsers :: HaskellImportPlan -> Agg -> Text+emitConsumerNominalParsers importPlan aggregate = sectionsOf [map emitParser (codecConsumerNominals aggregate)]+  where+    emitParser nominal = case ((.representation) nominal, (.ownership) nominal) of+      (IdRepresentation prefix, ConsumerNominal binding) ->+        nl $+          [ parserName nominal <> " :: Text -> Parser " <> renderReferenceOrDie importPlan (haskellTypeReference ((.haskell) binding))+          ]+            <> parserBody nominal prefix binding+      (EnumRepresentation constructors, ConsumerNominal binding) ->+        nl $+          [ parserName nominal <> " :: Text -> Parser " <> renderReferenceOrDie importPlan (haskellTypeReference ((.haskell) binding)),+            parserName nominal <> " = \\case"+          ]+            <> [ "  "+                   <> tshow wire+                   <> " -> pure (nominalFromRepresentation "+                   <> renderReferenceOrDie importPlan (qualifiedValueReference ((.binding) binding))+                   <> " "+                   <> renderReferenceOrDie importPlan (nominalRepresentationConstructorReference ((.context) aggregate) nominal constructor)+                   <> ")"+               | (constructor, wire) <- NE.toList constructors+               ]+            <> ["  tag -> " <> renderUnknownFailure ((.name) nominal <> " wire value") "tag" (map snd (NE.toList constructors))]+      _ -> ""+    parserName nominal = "parse" <> (.name) nominal <> "Nominal"+    parserBody nominal prefix binding = case idDomainContractFor ((.languageContract) 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 ((.binding) 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 ((.binding) binding)) <> " representation)"+        ]++emitCodecValue :: Agg -> Text+emitCodecValue a =+  nl $+    [ lowerFirst ((.name) a) <> "Codec :: Codec " <> (.name) a <> "Event",+      lowerFirst ((.name) a) <> "Codec =",+      "  Codec",+      "    { eventTypes = " <> eventTypesName a,+      "    , eventType = \\case"+    ]+      ++ ["        " <> (.name) e <> "{} -> EventType " <> tshow ((.name) e) | e <- (.events) a]+      ++ [ "    , schemaVersion = " <> tshow' (maxEventVersion a),+           "    , encode = encode" <> (.name) a <> "Event",+           "    , decode = parse" <> (.name) a <> "Event",+           "    , upcasters = " <> upcastersExpr a,+           "    }"+         ]+      ++ upcasterRungDecls a++emitEventTypes :: Agg -> Text+emitEventTypes aggregate =+  nl+    [ eventTypesName aggregate <> " :: NonEmpty EventType",+      eventTypesName aggregate <> " = " <> eventTypesExpr+    ]+  where+    eventTypesExpr = case map (.name) ((.events) aggregate) of+      [] -> "error \"no events\""+      event : rest -> "EventType " <> tshow event <> " :| [" <> T.intercalate ", " (map (("EventType " <>) . tshow) rest) <> "]"++eventTypesName :: Agg -> Text+eventTypesName aggregate = lowerFirst ((.name) aggregate) <> "EventTypes"++-- | The codec's @schemaVersion@: the maximum declared event version (EP-2).+maxEventVersion :: Agg -> Int+maxEventVersion a = maximum (1 : map (.version) ((.events) 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, (.name) e, "upcast" <> (.name) e <> "V" <> tshow' m)+  | e <- (.events) a,+    Just m <- [(.upcastFrom) 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 " <> (.holePrefix) a <> ".Holes (" <> T.intercalate ", " [fn | (_, _, fn) <- es] <> ")"++emitEncode :: HaskellImportPlan -> Agg -> Text+emitEncode importPlan a =+  nl $+    [ "encode" <> (.name) a <> "Event :: " <> (.name) a <> "Event -> Value",+      "encode" <> (.name) a <> "Event = \\case"+    ]+      ++ concatMap encodeArm ((.events) a)+  where+    encodeArm e =+      [ "  " <> (.name) e <> " payload ->",+        "    object"+      ]+        ++ [ lead i <> kv+           | (i, kv) <- zip [(0 :: Int) ..] (("\"kind\" .= (" <> tshow ((.name) e) <> " :: Text)") : map encodeField ((.fields) e))+           ]+        ++ ["      ]"]+    lead 0 = "      [ "+    lead _ = "      , "+    encodeField (identity, ty) =+      tshow ((.wireKey) identity)+        <> " .= "+        <> encodeFieldValue ((.selector) 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 (.typeGraph) 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 (.ownership) nominal of+      GeneratedNominal -> case (.representation) nominal of+        IdRepresentation {} -> lowerFirst ((.name) nominal) <> "Text " <> value+        EnumRepresentation {} -> lowerFirst ((.name) nominal) <> "Text " <> value+        ScalarRepresentation {} -> value+      ConsumerNominal binding -> case (.representation) nominal of+        IdRepresentation {} -> "KindID.toText (nominalToRepresentation " <> bindingName binding <> " " <> value <> ")"+        EnumRepresentation {} ->+          renderReferenceOrDie importPlan (nominalRepresentationEncoderReference ((.context) a) nominal)+            <> " (nominalToRepresentation "+            <> bindingName binding+            <> " "+            <> value+            <> ")"+        ScalarRepresentation {} -> "nominalToRepresentation " <> bindingName binding <> " " <> value+    bindingName = renderReferenceOrDie importPlan . qualifiedValueReference . (.binding)++emitDecode :: HaskellImportPlan -> Agg -> Text+emitDecode importPlan a =+  nl $+    [ "parse" <> (.name) a <> "Event :: EventType -> Value -> Either Text " <> (.name) a <> "Event",+      "parse" <> (.name) a <> "Event (EventType tag) = mapLeftText . parseEither (withObject " <> tshow ((.name) a <> "Event") <> " go)",+      "  where",+      "    go o = do",+      "      case tag of"+    ]+      ++ concatMap decodeArm ((.events) a)+      ++ ["        _ -> " <> renderUnknownEventTypeFailure a "tag"]+  where+    decodeArm e =+      ["        " <> tshow ((.name) e) <> " ->"]+        ++ case (.fields) e of+          [] -> ["          pure (" <> (.name) e <> " " <> (.name) e <> "Data)"]+          fields ->+            [ "          " <> (.name) e,+              "            <$> ( " <> (.name) e <> "Data"+            ]+              ++ [ (if index == 0 then "                    <$> " else "                    <*> ") <> decodeField field+                 | (index, field) <- zip [(0 :: Int) ..] fields+                 ]+              ++ ["                )"]+    decodeField (identity, ty) = case ty of+      AggregateNominal nominal -> decodeNominalField ((.wireKey) identity) nominal+      _ -> case fieldCat a ty of+        MappedStructuralCat {} -> decodeMapped ty ((.wireKey) identity)+        MappedOpaqueCat {} -> "o .: " <> tshow ((.wireKey) identity)+        _ -> "o .: " <> tshow ((.wireKey) identity)+    decodeMapped (AggregateMapped mappedKey) key = case (.typeGraph) 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 (.ownership) nominal of+      GeneratedNominal -> case (.representation) nominal of+        IdRepresentation prefix -> case idDomainContractFor ((.languageContract) a) prefix of+          Nothing -> "(" <> (.name) nominal <> " <$> o .: " <> tshow name <> ")"+          Just _ -> "(" <> legacyNominalConstructorName nominal <> " <$> o .: " <> tshow name <> ")"+        EnumRepresentation {} ->+          "explicitParseField (withText "+            <> tshow ((.name) nominal)+            <> " parse"+            <> (.name) nominal+            <> ") o "+            <> tshow name+        ScalarRepresentation {} -> "o .: " <> tshow name+      ConsumerNominal binding -> case (.representation) nominal of+        IdRepresentation {} -> consumerNominalFieldParser name nominal+        EnumRepresentation {} -> consumerNominalFieldParser name nominal+        ScalarRepresentation {} -> "(nominalFromRepresentation " <> renderReferenceOrDie importPlan (qualifiedValueReference ((.binding) binding)) <> " <$> o .: " <> tshow name <> ")"+    consumerNominalFieldParser name nominal =+      "explicitParseField (withText "+        <> tshow ((.name) nominal)+        <> " parse"+        <> (.name) nominal+        <> "Nominal) o "+        <> tshow name++codecConsumerNominals :: Agg -> [ResolvedNominalType]+codecConsumerNominals aggregate =+  Map.elems . Map.fromList $+    [ ((.name) nominal, nominal)+    | event <- (.events) aggregate,+      (_, AggregateNominal nominal) <- (.fields) event,+      ConsumerNominal {} <- [(.ownership) nominal]+    ]++codecGeneratedNominals :: Agg -> [ResolvedNominalType]+codecGeneratedNominals aggregate =+  generatedNominalsInTypes+    [ resolvedType+    | event <- (.events) aggregate,+      (_, resolvedType) <- (.fields) event+    ]++codecImportPlan :: Agg -> HaskellImportPlan+codecImportPlan aggregate =+  planImportsOrDie+    ((.genPrefix) aggregate <> ".Codec")+    (Set.fromList [(.name) aggregate <> "Event"])+    (Set.fromList (nominalReferences <> mappedReferences <> nominalRepresentationReferences <> shapeReferences))+  where+    nominalReferences =+      [ reference+      | nominal <- codecConsumerNominals aggregate,+        ConsumerNominal binding <- [(.ownership) nominal],+        reference <- qualifiedValueReference ((.binding) binding) : nominalParserTypeReferences nominal binding+      ]+    nominalParserTypeReferences nominal binding = case (.representation) nominal of+      IdRepresentation {} -> [haskellTypeReference ((.haskell) binding)]+      EnumRepresentation {} -> [haskellTypeReference ((.haskell) binding)]+      ScalarRepresentation {} -> []+    mappedReferences =+      [ reference+      | ResolvedStructural declaration _ <- codecMappedDeclarations aggregate,+        reference <-+          [ haskellTypeReference ((.haskell) declaration),+            qualifiedValueReference ((.binding) declaration)+          ]+      ]+    nominalRepresentationReferences =+      [ reference+      | nominal <- codecConsumerNominals aggregate,+        EnumRepresentation constructors <- [(.representation) nominal],+        reference <-+          nominalRepresentationEncoderReference ((.context) aggregate) nominal+            : [ nominalRepresentationConstructorReference ((.context) aggregate) nominal constructor+              | (constructor, _) <- NE.toList constructors+              ]+      ]+    shapeReferences =+      [ reference+      | ResolvedStructural declaration shape <- codecMappedDeclarations aggregate,+        reference <- structuralShapeReferences ((.context) aggregate) declaration shape+      ]++codecNominalImports :: Agg -> [Text]+codecNominalImports _ = []++codecMappedImports :: Agg -> [Text]+codecMappedImports a = case (.typeGraph) a of+  Nothing -> []+  Just graph ->+    sort . nub $+      [ (.moduleName) ((.haskell) declaration) <> " ()"+      | ResolvedOpaque declaration <- codecMappedDeclarations a+      ]+        <> [ (.moduleName) ((.haskell) declaration) <> " ()"+           | ResolvedStructural _ shape <- codecMappedDeclarations a,+             key <- directShapeRefs shape,+             Just (ResolvedOpaque declaration) <- [Map.lookup key ((.declarations) graph)]+           ]++codecMappedDeclarations :: Agg -> [ResolvedMappedDecl]+codecMappedDeclarations a = case (.typeGraph) a of+  Nothing -> []+  Just graph ->+    mapMaybe (\key -> Map.lookup key ((.declarations) graph)) (sort (Map.keys selected))+    where+      roots =+        [ key+        | event <- (.events) a,+          (_, AggregateMapped key) <- (.fields) event,+          Map.member key ((.declarations) graph)+        ]+      selected =+        Map.fromList+          [ (key, ())+          | root <- roots,+            key <- root : maybe [] (Map.keys . Map.fromSet (const ())) (Map.lookup root ((.reachability) graph))+          ]++directShapeRefs :: ResolvedMappedShape -> [MappedKey]+directShapeRefs =+  foldMappedShape+    MappedShapeAlgebra+      { onRecord = \_ _ fields -> concatMap (exprRefs . (.valueType)) fields,+        onEnum = const [],+        onUnion = \_ arms -> concatMap (maybe [] exprRefs . (.payload)) 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 (.typeGraph) a of+  Nothing -> ""+  Just graph ->+    T.intercalate+      "\n\n"+      [ emitStructuralCodec importPlan ((.context) 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 = (.name) declaration+    consumerType = renderReferenceOrDie importPlan (haskellTypeReference ((.haskell) declaration))+    shapeType = renderReferenceOrDie importPlan (qualifiedTypeReference (structuralShapeModule ctx name) (name <> "Shape"))+    binding = renderReferenceOrDie importPlan (qualifiedValueReference ((.binding) 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 ((.key) field)+                    <> " .= "+                    <> encodeShapeExpr graph ((.valueType) field) ("shape." <> (.haskell) field)+                | field <- fields+                ],+        onEnum = \entries ->+          nl $+            ["encode" <> name <> "Shape = \\case"]+              <> ["  " <> shapeConstructor ((.ctor) entry) <> " -> String " <> tshow ((.tag) entry) | entry <- entries],+        onUnion = \encoding arms ->+          nl $+            ["encode" <> name <> "Shape = \\case"]+              <> concatMap (unionEncodeArm encoding) arms+      }+  where+    name = (.name) declaration+    shapeModuleName = structuralShapeModule ctx name+    shapeConstructor constructor = renderReferenceOrDie importPlan (constructorReference shapeModuleName constructor)+    unionEncodeArm encoding arm =+      [ "  " <> shapeConstructor ((.ctor) arm) <> payloadPattern <> " ->",+        "    object"+      ]+        <> objectEntries+          ( [tshow ((.tagField) encoding) <> " .= (" <> tshow ((.tag) arm) <> " :: Text)"]+              <> [ tshow ((.contentsField) encoding) <> " .= " <> encodeShapeExpr graph payload "payload"+                 | payload <- maybeToListText ((.payload) arm)+                 ]+          )+      where+        payloadPattern = maybe "" (const " payload") ((.payload) 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 (.key) 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 ((.tag) entry) <> " -> pure " <> shapeConstructor ((.ctor) entry) | entry <- entries]+              <> ["  unknownTag -> " <> renderUnknownFailure (name <> " wire value") "unknownTag" (map (.tag) 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 ((.tagField) 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 (.tag) arms) <> " = pure tag",+                   "  | otherwise = " <> renderUnknownFailure (name <> " union tag") "tag" (map (.tag) arms)+                 ]+      }+  where+    name = (.name) 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 ((.tag) arm) <> " -> do"]+        <> rejectLine "      " ((.unknownFields) encoding) allowed "objectValue"+        <> [ case (.payload) arm of+               Nothing -> "      pure " <> shapeConstructor ((.ctor) arm)+               Just payload ->+                 "      "+                   <> shapeConstructor ((.ctor) arm)+                   <> " <$> explicitParseField ("+                   <> decodeShapeExpr graph payload+                   <> ") objectValue "+                   <> tshow ((.contentsField) encoding)+           ]+      where+        allowed = (.tagField) encoding : [(.contentsField) encoding | (.payload) arm /= Nothing]++decodeRecordField :: HaskellImportPlan -> Context -> TypeGraph -> ResolvedWireField -> Text+decodeRecordField importPlan ctx graph field = case (.presence) field of+  PRequired ->+    "explicitParseField (" <> decoder <> ") objectValue " <> key+  POptional ->+    "parseOptionalField ("+      <> missing+      <> ") ("+      <> decoder+      <> ") objectValue "+      <> key+  where+    key = tshow ((.key) field)+    decoder = decodeShapeExpr graph ((.valueType) field)+    missing = case (.onMissing) field of+      Nothing -> "fail " <> tshow ("missing optional field without default: " <> (.key) field)+      Just onMissing -> "pure " <> renderMissingDefault importPlan ctx graph ((.valueType) 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 ((.declarations) graph) of+      Just (ResolvedStructural declaration _) -> renderReferenceOrDie importPlan (constructorReference (structuralShapeModule ctx ((.name) 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) . (.implementation)) . (.transitions)++transitionEntries :: Agg -> [(Int, Transition)]+transitionEntries aggregate =+  [ ((.declarationIndex) entry, (.transition) entry)+  | entry <- transitionLayout ((.transitions) aggregate)+  ]++transitionStem :: Int -> Transition -> Text+transitionStem index transition =+  "transition"+    <> tshow' index+    <> pascal ((.source) transition)+    <> pascal ((.command) 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 =+  [ ( (.name) aggregate,+      outputFunctionName transitionIndex transition emitIndex eventName+    )+  | aggregate <- [value | NAggregate value <- (.nodes) spec],+    entry <- transitionLayout ((.transitions) aggregate),+    let transitionIndex = (.declarationIndex) entry+        transition = (.transition) entry,+    (emitIndex, eventName) <- zip [1 ..] ((.emits) transition),+    Right GeneratedCommandIdentity {} <- [outputMapping aggregate transition emitIndex eventName]+  ]++commandForTransition :: Agg -> Transition -> ResolvedCtor+commandForTransition aggregate transition =+  fromMaybe+    (error ("validated aggregate command disappeared: " <> T.unpack ((.command) transition)))+    (find ((== (.command) transition) . (.name)) ((.commands) aggregate))++eventForName :: Agg -> Name -> ResolvedCtor+eventForName aggregate eventName =+  fromMaybe+    (error ("validated aggregate event disappeared: " <> T.unpack eventName))+    (find ((== eventName) . (.name)) ((.events) aggregate))++commandFieldsType :: Transition -> Text+commandFieldsType transition = "RegFieldsOf " <> (.command) transition <> "Data"++payloadProjectionType :: Agg -> Transition -> Text+payloadProjectionType aggregate transition =+  "B.PayloadProj "+    <> (.name) aggregate+    <> "Regs "+    <> (.name) aggregate+    <> "Command ("+    <> commandFieldsType transition+    <> ")"++data ResolvedGeneratedTransition = ResolvedGeneratedTransition+  { index :: !Int,+    source :: !Transition,+    guard :: !(Maybe TypedScalarExpr),+    writes :: ![(Name, TypedScalarExpr)]+  }+  deriving stock (Eq, Show)++data SilentOutcomeKind = RejectedOutcome | NoOpOutcome+  deriving stock (Eq, Show)++data ResolvedSilentOutcome = ResolvedSilentOutcome+  { layout :: !TransitionLayoutEntry,+    kind :: !SilentOutcomeKind,+    reason :: !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+      { index = index,+        source = transition,+        guard = resolvedGuard index transition <$> (.guard) transition,+        writes =+          [ (registerName, resolvedWrite index transition registerName expression)+          | (registerName, expression) <- (.writes) transition+          ]+      }+  | (index, transition) <- transitionEntries aggregate,+    (.implementation) transition == GeneratedImplementation+  ]+  where+    environment transition = expressionEnvironmentWith ((.symbols) aggregate) ((.typeGraph) aggregate) ((.spec) aggregate) ((.aggregate) 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 ((.guard) resolved)+        <> map snd ((.writes) resolved)++resolvedSilentOutcomes :: Agg -> [ResolvedSilentOutcome]+resolvedSilentOutcomes aggregate =+  [ ResolvedSilentOutcome+      { layout = entry,+        kind = kind,+        reason = resolveReason entry expected expression+      }+  | entry <- transitionLayout ((.transitions) aggregate),+    let transition = (.transition) entry,+    (.mode) transition == TmLive,+    (kind, expected, expression) <- outcomeReason transition+  ]+  where+    outcomeReason transition = case ((.domainOutcomeTypes) aggregate, (.outcome) transition) of+      (Just outcomeTypes, Just (OutcomeRejected expression _)) ->+        [(RejectedOutcome, (.rejectionType) outcomeTypes, expression)]+      (Just outcomeTypes, Just (OutcomeNoOp expression _)) ->+        [(NoOpOutcome, (.noOpType) outcomeTypes, expression)]+      _ -> []+    resolveReason entry expected expression =+      let transition = (.transition) entry+          owner = transitionStem ((.declarationIndex) entry) transition <> "OutcomeReason"+          environment = expressionEnvironmentWith ((.symbols) aggregate) ((.typeGraph) aggregate) ((.spec) aggregate) ((.aggregate) aggregate) transition+       in expressionOrDie owner (resolveScalarExpr environment (ExpectScalarType expected) expression)++resolvedOutcomeExpressions :: Agg -> [TypedScalarExpr]+resolvedOutcomeExpressions = map (.reason) . 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 . (.guard))++-- | Every literal node in an expression tree.+typedExpressionLiterals :: TypedScalarExpr -> [TypedScalarExpr]+typedExpressionLiterals expression = own <> concatMap typedExpressionLiterals (typedExpressionChildren expression)+  where+    own = case (.node) 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 (.node) expression of+      TypedLiteral {} -> [(.valueType) expression]+      _ -> []++anyTypedExpression :: (TypedScalarExpr -> Bool) -> TypedScalarExpr -> Bool+anyTypedExpression predicate expression =+  predicate expression || any (anyTypedExpression predicate) (typedExpressionChildren expression)++typedExpressionChildren :: TypedScalarExpr -> [TypedScalarExpr]+typedExpressionChildren expression = case (.node) 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 ((.valueType) expression, (.node) expression) of+      (AggregateNominal nominal, TypedLiteral ScalarEnumValue {})+        | ConsumerNominal {} <- (.ownership) nominal -> [nominal]+      (AggregateNominal nominal, TypedLiteral ScalarIdValue {})+        | ConsumerNominal {} <- (.ownership) nominal -> [nominal]+      _ -> []++typedGeneratedNominals :: TypedScalarExpr -> [ResolvedNominalType]+typedGeneratedNominals expression = own <> concatMap typedGeneratedNominals (typedExpressionChildren expression)+  where+    own = case (.valueType) expression of+      AggregateNominal nominal+        | GeneratedNominal <- (.ownership) 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+  { target :: !ProjectionAliasTarget,+    name :: !Text+  }+  deriving stock (Eq, Show)++projectionAliasesForTransition :: ResolvedGeneratedTransition -> [ProjectionAlias]+projectionAliasesForTransition resolved = allocateAliases targets+  where+    expressions =+      maybe [] pure ((.guard) resolved)+        <> map snd ((.writes) resolved)+    targets = nub (concatMap projectionAliasTargets expressions)++projectionAliasTargets :: TypedScalarExpr -> [ProjectionAliasTarget]+projectionAliasTargets expression = own <> comparisonTargets <> concatMap projectionAliasTargets children+  where+    children = typedExpressionChildren expression+    own = case (.node) expression of+      TypedProject provenance projection -> [StructuralProjectionAlias provenance projection]+      _ -> []+    comparisonTargets = case (.node) expression of+      TypedEqual left right -> mapMaybe nominalTarget [left, right]+      TypedNotEqual left right -> mapMaybe nominalTarget [left, right]+      _ -> []+    nominalTarget operand = case ((.valueType) operand, (.node) 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 "/" ((.pointer) 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))+    (.name)+    (find ((== target) . (.target)) aliases)++data RenderAssociativity = RenderLeft | RenderRight | RenderNonAssociative+  deriving stock (Eq, Show)++data RenderOperandSide = RenderLeftOperand | RenderRightOperand+  deriving stock (Eq, Show)++data RenderedKeikiExpr = RenderedKeikiExpr+  { text :: !Text,+    precedence :: !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+  | (.precedence) child > parentPrecedence = (.text) child+  | (.precedence) child < parentPrecedence = parenthesized+  | otherwise = case associativity of+      RenderLeft+        | side == RenderLeftOperand -> (.text) child+      RenderRight+        | side == RenderRightOperand -> (.text) child+      _ -> parenthesized+  where+    parenthesized = "(" <> (.text) child <> ")"++renderKeikiPredicate :: HaskellImportPlan -> [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> Text+renderKeikiPredicate importPlan aliases aggregate transition =+  (.text) . renderPredicate+  where+    renderPredicate expression = case (.node) 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 ((.valueType) expression, (.node) 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 (.representation) nominal of+  IdRepresentation {} -> True+  EnumRepresentation {} -> True+  ScalarRepresentation {} -> case (.ownership) nominal of+    ConsumerNominal {} -> True+    GeneratedNominal -> False++enumWireFor :: ResolvedNominalType -> Name -> Text+enumWireFor nominal constructor = case (.representation) 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 "+      <> (.name) aggregate+      <> "Regs "+      <> renderDomainType importPlan aggregate ownerType+      <> ")"+  ScalarCommandRoot name ownerType ->+    "K.inpProj "+      <> projectionQualifier+      <> "."+      <> witness+      <> " inCtor"+      <> (.command) transition+      <> " (#"+      <> commandFieldSelector aggregate ((.command) transition) name+      <> " :: K.Index ("+      <> commandFieldsType transition+      <> ") "+      <> renderDomainType importPlan aggregate ownerType+      <> ")"+  where+    projectionQualifier = case (.ownership) nominal of+      GeneratedNominal -> "GeneratedNominals"+      ConsumerNominal {} -> "NominalProjections"+    witness = case (.representation) nominal of+      ScalarRepresentation {} -> lowerFirst ((.name) nominal) <> "Witness"+      IdRepresentation {} -> nominalEqualityWitnessName nominal+      EnumRepresentation {} -> nominalEqualityWitnessName nominal++renderKeikiTerm :: HaskellImportPlan -> [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> RenderedKeikiExpr+renderKeikiTerm importPlan aliases aggregate transition expression = case (.node) expression of+  TypedLiteral value -> renderedAtom (renderKeikiLiteral importPlan aggregate ((.valueType) expression) value)+  TypedRoot (ScalarRegisterRoot registerName _) -> renderedAtom ("B.reg @" <> tshow registerName)+  TypedRoot (ScalarCommandRoot name _) ->+    renderedAtom ("d." <> commandFieldSelector aggregate ((.command) transition) name)+  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+    <> " ("+    <> (.text) rendered+    <> ") registers command"+  where+    (evaluator, rendered) = case (.node) 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 (.node) 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 ((.valueType) expression, (.node) 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 (.node) expression of+  TypedLiteral value -> renderedAtom (renderKeikiLiteral importPlan aggregate ((.valueType) expression) value)+  TypedRoot (ScalarRegisterRoot registerName _) -> renderedAtom ("B.reg @" <> tshow registerName)+  TypedRoot (ScalarCommandRoot name ownerType) ->+    renderedAtom+      ( "K.inpCtor inCtor"+          <> (.command) transition+          <> " (#"+          <> commandFieldSelector aggregate ((.command) transition) name+          <> " :: 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 "+      <> (.name) aggregate+      <> "Regs "+      <> renderDomainType importPlan aggregate ownerType+      <> ")"+  ScalarCommandRoot name ownerType ->+    "K.inpProj StructuralProjections."+      <> witness+      <> " inCtor"+      <> (.command) transition+      <> " (#"+      <> commandFieldSelector aggregate ((.command) transition) name+      <> " :: K.Index ("+      <> commandFieldsType transition+      <> ") "+      <> renderDomainType importPlan aggregate ownerType+      <> ")"+  where+    witness =+      fromMaybe+        (error ("resolved structural projection witness disappeared: " <> show projection))+        ((.typeGraph) aggregate >>= \graph -> projectionWitnessName graph ((.owner) projection) ((.pointer) 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 (.ownership) nominal of+      GeneratedNominal -> "K.lit " <> constructor+      ConsumerNominal binding ->+        "K.lit (nominalFromRepresentation "+          <> renderReferenceOrDie importPlan (qualifiedValueReference ((.binding) binding))+          <> " "+          <> renderReferenceOrDie importPlan (nominalRepresentationConstructorReference ((.context) aggregate) nominal constructor)+          <> ")"+    _ -> error "validated enum literal lost its nominal type"+  ScalarIdValue typeName value -> case scalarType of+    AggregateNominal nominal -> case (.ownership) nominal of+      GeneratedNominal -> case idDomainContractFor ((.languageContract) 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 (.representation) nominal of+        IdRepresentation prefix ->+          "K.lit (nominalFromRepresentation "+            <> renderReferenceOrDie importPlan (qualifiedValueReference ((.binding) 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 (.representation) nominal of+      IdRepresentation prefix -> Just prefix+      _ -> Nothing++generatedIdSampleHaskell :: Agg -> ResolvedNominalType -> Maybe Text+generatedIdSampleHaskell aggregate nominal = do+  prefix <- case (.representation) nominal of+    IdRepresentation value -> Just value+    _ -> Nothing+  contract <- idDomainContractFor ((.languageContract) aggregate) prefix+  let name = (.name) 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 " <> (.genPrefix) aggregate <> ".Transducer",+           "  ( " <> lowerFirst ((.name) aggregate) <> "Transducer",+           "  , " <> lowerFirst ((.name) aggregate) <> "FoldFingerprint",+           "  , BehaviorOwnership (..)",+           "  , " <> lowerFirst ((.name) aggregate) <> "PredicateVerifications",+           "  ) where",+           "",+           "import " <> (.genPrefix) 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)+        ((.context) 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 " <> (.holePrefix) aggregate <> ".Holes qualified as Holes" | transducerUsesHoles aggregate]+      ++ ["import Data.Text qualified as T" | anyHoleOwned aggregate]+      ++ ["import Keiki.Builder ((=:))" | any (not . null . (.writes) . snd) (transitionEntries aggregate)]+      ++ ["import Keiki.Generics (RegFieldsOf)" | not (null projectionAliases)]+      ++ ["import Keiro.Snapshot.Codec (FoldVersion (..))" | anyHoleOwned aggregate]+      ++ [ "",+           lowerFirst ((.name) aggregate) <> "Transducer",+           "  :: SymTransducer",+           "       (HsPred " <> (.name) aggregate <> "Regs " <> (.name) aggregate <> "Command)",+           "       " <> (.name) aggregate <> "Regs",+           "       " <> (.vertexType) aggregate,+           "       " <> (.name) aggregate <> "Command",+           "       " <> (.name) aggregate <> "Event",+           lowerFirst ((.name) aggregate) <> "Transducer =",+           "  B.buildTransducer " <> initialVertex aggregate <> " initial" <> (.name) aggregate <> "Regs isTerminal do",+           nl (concatMap (generatedFromBlock importPlan aggregate resolvedTransitions) (groupTransitionEntriesBySource aggregate)),+           " where",+           "  isTerminal = \\case",+           nl ["    " <> vertexCtor aggregate ((.name) state) <> " -> True" | state <- (.states) aggregate, (.terminal) state],+           "    _ -> False",+           "",+           lowerFirst ((.name) aggregate) <> "FoldFingerprint :: Text",+           lowerFirst ((.name) 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 ((.name) aggregate) <> "PredicateVerifications :: IO [(Text, BehaviorOwnership, S.PredicateVerification)]",+           lowerFirst ((.name) aggregate) <> "PredicateVerifications = sequence",+           nl (renderVerificationList aggregate),+           " where",+           "  verifyTransition label owner source edgeIndex =",+           "    case drop edgeIndex (K.edgesOut " <> lowerFirst ((.name) 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 (.target) projectionAliases+    structuralProjectionImport =+      [ "import " <> structuralProjectionModule ((.context) aggregate) <> " qualified as StructuralProjections"+      | any isStructuralProjection projectionTargets+      ]+    generatedNominalProjectionImport =+      [ "import " <> generatedNominalModule ((.context) aggregate) <> " qualified as GeneratedNominals"+      | any isGeneratedNominalProjection projectionTargets+      ]+    consumerNominalProjectionImport =+      [ "import " <> nominalProjectionModule ((.context) 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 . (.representation)) consumerLiteralNominals+    usedOperators = nub (concatMap generatedTransitionOperators resolvedTransitions)+    keikiCoreImports = ["HsPred", "SymTransducer"] <> ["(" <> operator <> ")" | operator <- expressionOperatorOrder, operator `elem` usedOperators]+    isTimeLiteral expression = case (.node) expression of+      TypedLiteral ScalarTimeValue {} -> True+      _ -> False+    isNaturalLiteral expression = case (.node) 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,+        (.implementation) transition == GeneratedImplementation,+        emitIndex <- [1 .. length ((.emits) transition)]+      ]+    generatedOutputUsesCommandField (GeneratedCommandIdentity _ fields) = not (null fields)+    generatedOutputUsesCommandField HandOwnedEventOutput {} = False+    expressionUsesCommandRoot = anyTypedExpression isCommandRoot+    isCommandRoot expression = case (.node) expression of+      TypedRoot ScalarCommandRoot {} -> True+      _ -> False++transducerImportPlan :: Agg -> [ResolvedAggregateType] -> [ResolvedNominalType] -> HaskellImportPlan+transducerImportPlan aggregate importedTypes literalNominals =+  planImportsOrDie+    ((.genPrefix) aggregate <> ".Transducer")+    (Set.fromList [(.name) aggregate <> "Regs", (.name) aggregate <> "Command", (.name) aggregate <> "Event"])+    ( Set.unions+        [ aggregateSourceReferences (aggregateConsumerHaskellSource ((.symbols) aggregate) resolvedType)+        | resolvedType <- importedTypes+        ]+        <> Set.fromList+          [ reference+          | nominal <- literalNominals,+            ConsumerNominal binding <- [(.ownership) nominal],+            reference <-+              qualifiedValueReference ((.binding) binding)+                : case (.representation) nominal of+                  EnumRepresentation constructors ->+                    [ nominalRepresentationConstructorReference ((.context) aggregate) nominal constructor+                    | (constructor, _) <- NE.toList constructors+                    ]+                  _ -> []+          ]+    )++typedExpressionImportTypes :: TypedScalarExpr -> [ResolvedAggregateType]+typedExpressionImportTypes expression = own <> concatMap typedExpressionImportTypes (typedExpressionChildren expression)+  where+    own = case (.node) expression of+      TypedLiteral {} -> [(.valueType) 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 _) = (.ownership) nominal == GeneratedNominal+isGeneratedNominalProjection StructuralProjectionAlias {} = False++isConsumerNominalProjection :: ProjectionAliasTarget -> Bool+isConsumerNominalProjection (NominalProjectionAlias nominal _) = case (.ownership) nominal of+  ConsumerNominal {} -> True+  GeneratedNominal -> False+isConsumerNominalProjection StructuralProjectionAlias {} = False++expressionOperatorOrder :: [Text]+expressionOperatorOrder = [".*", ".+", ".-", ".==", "./=", ".<", ".<=", ".>", ".>=", ".&&", ".||"]++generatedTransitionOperators :: ResolvedGeneratedTransition -> [Text]+generatedTransitionOperators resolved =+  maybe [] expressionPredicateOperators ((.guard) resolved)+    <> concatMap (expressionTermOperators . snd) ((.writes) resolved)++outcomeExpressionOperators :: TypedScalarExpr -> [Text]+outcomeExpressionOperators expression = case (.node) 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 (.node) 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 (.node) 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) . (.implementation)) . (.transitions)++transducerUsesHoles :: Agg -> Bool+transducerUsesHoles aggregate =+  anyHoleOwned aggregate+    || any isHandOwned (Map.elems ((.outputMappings) 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 (.implementation) 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 ((.transitions) aggregate)),+        entry <- transitions,+        let edgeIndex = (.outgoingIndex) entry+            transitionIndex = (.declarationIndex) entry+            transition = (.transition) entry+      ]++foldFingerprintExpression :: Agg -> Text+foldFingerprintExpression aggregate = case holeVersions of+  [] -> tshow ((.foldFingerprint) aggregate)+  _ ->+    "T.intercalate \"|\" ("+      <> tshow ((.foldFingerprint) 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,+        (.implementation) transition == HoleImplementation+      ]++groupTransitionEntriesBySource :: Agg -> [(Text, [(Int, Transition)])]+groupTransitionEntriesBySource aggregate =+  [ ( source,+      [((.declarationIndex) entry, (.transition) entry) | entry <- entries]+    )+  | (source, entries) <- groupTransitionLayoutBySource (transitionLayout ((.transitions) 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" <> (.command) transition <> " $ \\" <> payloadBinder <> " -> B.do"]+    ++ projectionBindingLines+    ++ ["        B.replayOnly" | (.mode) transition == TmReplayOnly]+    ++ generatedBehavior+    ++ outputLines+    ++ ["        B.noEmit" | null ((.emits) transition)]+    ++ ["        B.goto " <> vertexCtor aggregate ((.goto) transition)]+  where+    generatedBehavior = case (.implementation) transition of+      GeneratedImplementation ->+        maybe [] (renderGuardLines importPlan aliases aggregate transition) ((.guard) resolved)+          ++ [ "        B.slot @" <> tshow registerName <> " =: " <> renderAssignmentOperand (renderKeikiTerm importPlan aliases aggregate transition expression)+             | (registerName, expression) <- (.writes) 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) . (.index)) resolvedTransitions)+    aliases+      | (.implementation) 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 ..] ((.emits) transition)+        ]+    payloadBinder+      | payloadIsUsed = "d"+      | otherwise = "_d"+    payloadIsUsed = case (.implementation) transition of+      GeneratedImplementation ->+        isJust ((.guard) resolved)+          || not (null ((.writes) resolved))+          || any outputUsesPayload (zip [1 ..] ((.emits) 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 =+  (.name) alias <> " = " <> case (.target) 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+  | (.precedence) expression <= 6 = "(" <> (.text) expression <> ")"+  | otherwise = (.text) 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 [ (.selector) identity+       | command <- (.commands) aggregate,+         (.name) command == commandName,+         (identity, _) <- (.fields) command,+         (.dslName) 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) ((.outputMappings) aggregate))++--------------------------------------------------------------------------------+-- EventStream module+--------------------------------------------------------------------------------++emitEventStream :: Agg -> Text+emitEventStream a =+  nl $+    renderGeneratedLanguagePragmas [ExtOverloadedLabels | outcomeUsesLabels]+      ++ [ generatedBanner,+           "module " <> (.genPrefix) a <> ".EventStream",+           "  ( " <> lowerFirst ((.name) a) <> "Category",+           "  , " <> lowerFirst ((.name) a) <> "CommandCategory",+           "  , " <> lowerFirst ((.name) a) <> "EventStream",+           "  , " <> lowerFirst ((.name) a) <> "EventStreamDef",+           "  , " <> (.name) a <> "EventStream",+           "  , " <> (.name) a <> "EventStreamDef"+         ]+      ++ ["  , " <> lowerFirst ((.name) a) <> "SnapshotFixture" | hasSnapshot a]+      ++ ["  , " <> lowerFirst ((.name) a) <> "DomainCommandHandler" | outcomeEnabled]+      ++ [ "  ) where",+           "",+           "import " <> (.genPrefix) a <> ".Domain",+           "import " <> (.genPrefix) a <> ".Codec (" <> lowerFirst ((.name) 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 ((.name) a) <> "Category :: Stream.StreamCategory " <> (.name) a <> "EventStreamDef",+           lowerFirst ((.name) a) <> "Category = Stream.categoryUnsafe " <> tshow categoryName,+           "",+           "-- The same category text, typed for command envelopes such as PMCommand.",+           lowerFirst ((.name) a) <> "CommandCategory :: Stream.StreamCategory " <> (.name) a <> "Command",+           lowerFirst ((.name) a) <> "CommandCategory = Stream.categoryUnsafe " <> tshow categoryName,+           "",+           "type " <> (.name) a <> "EventStreamDef =",+           "  EventStream (HsPred " <> (.name) a <> "Regs " <> (.name) a <> "Command) " <> (.name) a <> "Regs " <> (.vertexType) a <> " " <> (.name) a <> "Command " <> (.name) a <> "Event",+           "",+           "type " <> (.name) a <> "EventStream =",+           "  ValidatedEventStream (HsPred " <> (.name) a <> "Regs " <> (.name) a <> "Command) " <> (.name) a <> "Regs " <> (.vertexType) a <> " " <> (.name) a <> "Command " <> (.name) a <> "Event",+           "",+           lowerFirst ((.name) a) <> "EventStreamDef :: " <> (.name) a <> "EventStreamDef",+           lowerFirst ((.name) a) <> "EventStreamDef =",+           "  EventStream",+           "    { transducer = " <> lowerFirst ((.name) a) <> "Transducer,",+           "      initialState = " <> initialVertex a <> ",",+           "      initialRegisters = initial" <> (.name) a <> "Regs,",+           "      eventCodec = " <> lowerFirst ((.name) a) <> "Codec,",+           "      resolveStreamName = Stream.streamName,",+           "      snapshotPolicy = " <> snapshotPolicyExpr a <> ","+         ]+      ++ stateCodecFieldLines a+      ++ [ "    }",+           ""+         ]+      ++ snapshotFixtureLines a+      ++ [ lowerFirst ((.name) a) <> "EventStream :: " <> (.name) a <> "EventStream",+           lowerFirst ((.name) a) <> "EventStream =",+           "  mkEventStreamOrThrow " <> tshow ((.name) a) <> " " <> lowerFirst ((.name) a) <> "EventStreamDef"+         ]+      ++ outcomeHandlerLines importPlan a silentOutcomes+  where+    categoryName = staticCategory ("aggregate " <> (.name) a) (lowerFirst ((.name) a))+    outcomeEnabled = isJust ((.domainOutcomeTypes) a)+    silentOutcomes = resolvedSilentOutcomes a+    outcomeExpressions = map (.reason) silentOutcomes+    outcomeResultTypes = case (.domainOutcomeTypes) a of+      Nothing -> []+      Just outcomeTypes -> [(.rejectionType) outcomeTypes, (.noOpType) 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)+        ((.context) a)+        generatedOutcomeNominals+        generatedLiteralNominals+    projectionTargets = nub (concatMap projectionAliasTargets outcomeExpressions)+    structuralProjectionImports =+      [ "import " <> structuralProjectionModule ((.context) a) <> " qualified as StructuralProjections"+      | any isStructuralProjection projectionTargets+      ]+    generatedNominalProjectionImports =+      [ "import " <> generatedNominalModule ((.context) a) <> " qualified as GeneratedNominals"+      | any isGeneratedNominalProjection projectionTargets+      ]+    consumerNominalProjectionImports =+      [ "import " <> nominalProjectionModule ((.context) 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 . (.representation)) 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 (.node) expression of+      TypedRoot ScalarRegisterRoot {} -> True+      TypedProject provenance _ -> case provenance of+        ScalarRegisterRoot {} -> True+        ScalarCommandRoot {} -> False+      _ -> False+    usesCommandRoot expression = case (.node) expression of+      TypedRoot ScalarCommandRoot {} -> True+      TypedProject provenance _ -> case provenance of+        ScalarCommandRoot {} -> True+        ScalarRegisterRoot {} -> False+      _ -> False+    isTextLiteral expression = case (.node) expression of+      TypedLiteral ScalarTextValue {} -> True+      _ -> False+    isTimeLiteral expression = case (.node) 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 (.domainOutcomeTypes) aggregate of+  Nothing -> []+  Just outcomeTypes ->+    [ "",+      handlerName,+      "  :: DomainCommandHandler",+      "       (HsPred " <> (.name) aggregate <> "Regs " <> (.name) aggregate <> "Command)",+      "       " <> (.name) aggregate <> "Regs",+      "       " <> (.vertexType) aggregate,+      "       " <> (.name) aggregate <> "Command",+      "       " <> (.name) aggregate <> "Event",+      "       " <> renderDomainType importPlan aggregate ((.rejectionType) outcomeTypes),+      "       " <> renderDomainType importPlan aggregate ((.noOpType) outcomeTypes),+      handlerName <> " =",+      "  DomainCommandHandler " <> lowerFirst ((.name) aggregate) <> "EventStream " <> classifierName,+      "",+      classifierName,+      "  :: SilentCommandContext " <> (.name) aggregate <> "Regs " <> (.vertexType) aggregate <> " " <> (.name) aggregate <> "Command",+      "  -> SilentDomainDecision",+      "       " <> renderDomainType importPlan aggregate ((.rejectionType) outcomeTypes),+      "       " <> renderDomainType importPlan aggregate ((.noOpType) 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 " <> (.name) aggregate <> " edge ")+             <> " <> show source <> \"#\" <> show index)"+         ]+  where+    handlerName = lowerFirst ((.name) aggregate) <> "DomainCommandHandler"+    classifierName = lowerFirst ((.name) aggregate) <> "SilentDecision"+    sourceGroups =+      [ (source, filter ((== source) . (.source) . (.transition) . (.layout)) silentOutcomes)+      | source <- nub (map ((.source) . (.transition) . (.layout)) silentOutcomes)+      ]+    renderSourceGroup (source, outcomes) =+      [ "    " <> vertexCtor aggregate source <> " ->",+        "      case edgeIndex of"+      ]+        ++ map renderArm outcomes+        ++ ["        _ -> outcomeInvariant edgeSource edgeIndex"]+    renderArm outcome =+      let entry = (.layout) outcome+          transition = (.transition) entry+          constructor = case (.kind) outcome of+            RejectedOutcome -> "SilentRejected"+            NoOpOutcome -> "SilentNoOp"+       in "        "+            <> tshow' ((.outgoingIndex) entry)+            <> " -> "+            <> constructor+            <> " ("+            <> renderOutcomeReasonEvaluation importPlan aggregate transition ((.reason) outcome)+            <> ")"++eventStreamImportPlan :: Agg -> [ResolvedAggregateType] -> [ResolvedNominalType] -> HaskellImportPlan+eventStreamImportPlan aggregate importedTypes literalNominals =+  planImportsOrDie+    ((.genPrefix) aggregate <> ".EventStream")+    localDeclarations+    ( Set.unions+        [ aggregateSourceReferences (aggregateConsumerHaskellSource ((.symbols) aggregate) resolvedType)+        | resolvedType <- importedTypes+        ]+        <> Set.fromList+          [ reference+          | nominal <- literalNominals,+            ConsumerNominal binding <- [(.ownership) nominal],+            reference <-+              qualifiedValueReference ((.binding) binding)+                : case (.representation) nominal of+                  EnumRepresentation constructors ->+                    [ nominalRepresentationConstructorReference ((.context) aggregate) nominal constructor+                    | (constructor, _) <- NE.toList constructors+                    ]+                  _ -> []+          ]+    )+  where+    localDeclarations =+      Set.fromList+        ( [ (.vertexType) aggregate,+            (.name) aggregate <> "Command",+            (.name) aggregate <> "Event",+            (.name) aggregate <> "Regs",+            (.name) aggregate <> "EventStream",+            (.name) aggregate <> "EventStreamDef"+          ]+            <> map (.name) ((.generatedNominals) aggregate)+            <> [ (.name) nominal+               | resolvedType <- importedTypes,+                 AggregateNominal nominal <- [resolvedType],+                 GeneratedNominal <- [(.ownership) nominal]+               ]+        )++snapshotPolicyExpr :: Agg -> Text+snapshotPolicyExpr aggregate = case (.snapshot) aggregate of+  Nothing -> "Never"+  Just snapshot -> case (.policy) snapshot of+    SnapEvery interval -> "Every " <> tshow' interval+    SnapOnTerminal -> "OnTerminal"++stateCodecExpr :: Agg -> Text+stateCodecExpr aggregate = case (.snapshot) aggregate of+  Nothing -> "Nothing"+  Just snapshot ->+    "Just (withFoldFingerprint "+      <> foldFingerprintValue aggregate+      <> " (defaultStateCodec "+      <> tshow' ((.codecVersion) snapshot)+      <> "))"++transducerImport :: Agg -> Text+transducerImport aggregate+  | hasVersion2Ownership aggregate =+      "import "+        <> (.genPrefix) aggregate+        <> ".Transducer ("+        <> (if hasSnapshot aggregate then lowerFirst ((.name) aggregate) <> "FoldFingerprint, " else "")+        <> lowerFirst ((.name) aggregate)+        <> "Transducer)"+  | otherwise =+      "import "+        <> (.holePrefix) aggregate+        <> ".Holes ("+        <> lowerFirst ((.name) aggregate)+        <> "Transducer)"++foldFingerprintValue :: Agg -> Text+foldFingerprintValue aggregate+  | hasVersion2Ownership aggregate = lowerFirst ((.name) aggregate) <> "FoldFingerprint"+  | otherwise = tshow ((.foldFingerprint) aggregate)++stateCodecFieldLines :: Agg -> [Text]+stateCodecFieldLines aggregate = case (.snapshot) 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 (.snapshot) aggregate of+  Nothing -> []+  Just snapshot ->+    [ lowerFirst ((.name) aggregate) <> "SnapshotFixture :: (Int, Text)",+      lowerFirst ((.name) aggregate) <> "SnapshotFixture = (" <> tshow' ((.codecVersion) snapshot) <> ", " <> tshow ((.shapeHash) snapshot) <> ")",+      ""+    ]++--------------------------------------------------------------------------------+-- Projection module+--------------------------------------------------------------------------------++emitProjection :: Agg -> Text+emitProjection a = case (.projection) a of+  Nothing ->+    nl+      ( renderGeneratedLanguagePragmas []+          <> [ generatedBanner,+               "module " <> (.genPrefix) a <> ".Projection () where",+               "",+               "-- No projection declarations are present; this module keeps the generated manifest inventory total."+             ]+      )+  Just p ->+    nl+      [ generatedBanner,+        "module " <> (.genPrefix) a <> ".Projection",+        "  ( " <> lowerFirst ((.table) p) <> "Projection",+        "  , " <> lowerFirst ((.table) p) <> "StatusFor",+        "  ) where",+        "",+        "import " <> (.genPrefix) a <> ".Domain",+        "import " <> (.holePrefix) a <> ".Holes (apply" <> pascal ((.table) 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 ((.table) p) <> "StatusFor :: " <> (.name) a <> "Event -> Maybe Text",+        lowerFirst ((.table) p) <> "StatusFor = \\case",+        nl (statusArms a p),+        "",+        lowerFirst ((.table) p) <> "Projection :: InlineProjection " <> (.name) a <> "Event",+        lowerFirst ((.table) p) <> "Projection =",+        "  InlineProjection",+        "    { name = " <> tshow (contextNameToProjName a p),+        "    , apply = apply" <> pascal ((.table) p),+        "    }"+      ]++statusArms :: Agg -> ProjectionSpec -> [Text]+statusArms a p =+  [ "  " <> (.name) e <> " {} -> " <> statusFor e+  | e <- (.events) a+  ]+    ++ ["  _ -> Nothing" | hasWildcard]+  where+    pairs = maybe [] (.pairs) ((.statusMap) p)+    statusFor e = case lookup ((.name) 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 <> "-" <> (.table) p <> "-inline"++contextKebab :: Agg -> Text+contextKebab = kebabFromPascal . (.ctxPascal)++projectionReadModel :: Agg -> Maybe ReadModelNode+projectionReadModel aggregate = do+  projection <- (.projection) aggregate+  find ((== (.table) projection) . (.name)) ((.readModels) aggregate)++projectionTableComment :: Agg -> ProjectionSpec -> Text+projectionTableComment aggregate projection = case projectionReadModel aggregate of+  Nothing ->+    "-- WARNING: no readmodel node declares '"+      <> (.table) projection+      <> "'; unqualified SQL depends on search_path."+  Just readModel ->+    "-- Qualified table "+      <> qualifiedTableLiteral readModel+      <> "; use "+      <> genPrefixFor ((.context) aggregate) (pascal ((.name) 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 " <> (.holePrefix) a <> ".Holes",+      "  ( " <> lowerFirst ((.name) a) <> "Transducer",+      holeProjectionExport a,+      holeUpcasterExports a,+      "  ) where",+      "",+      "import " <> (.genPrefix) 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 ((.name) a) <> "Transducer",+      "  :: SymTransducer",+      "       (HsPred " <> (.name) a <> "Regs " <> (.name) a <> "Command)",+      "       " <> (.name) a <> "Regs",+      "       " <> (.vertexType) a,+      "       " <> (.name) a <> "Command",+      "       " <> (.name) a <> "Event",+      lowerFirst ((.name) a) <> "Transducer =",+      "  B.buildTransducer " <> initialVertex a <> " initial" <> (.name) a <> "Regs isTerminal do",+      nl (concatMap (fromBlock a) (groupBySource a)),+      " where",+      "  isTerminal = \\case",+      nl ["    " <> vertexCtor a ((.name) s) <> " -> True" | s <- (.states) a, (.terminal) 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 " <> (.genPrefix) 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 ((.fields) (eventForName aggregate eventName))+    | (transitionIndex, transition) <- transitionEntries aggregate,+      (emitIndex, eventName) <- zip [1 ..] ((.emits) transition)+    ]+  where+    isHandOwned HandOwnedEventOutput {} = True+    isHandOwned GeneratedCommandIdentity {} = False++version2HoleModuleDeclaration :: Agg -> [Text]+version2HoleModuleDeclaration aggregate = case version2HoleExports aggregate of+  [] -> ["module " <> (.holePrefix) aggregate <> ".Holes () where"]+  firstExport : rest ->+    [ "module " <> (.holePrefix) 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 ..] ((.emits) transition),+        HandOwnedEventOutput {} <- [outputMappingFor aggregate transitionIndex emitIndex]+      ]+    holeExports =+      concat+        [ [holeFunctionName index transition, holeFoldVersionName index transition]+        | (index, transition) <- transitionEntries aggregate,+          (.implementation) transition == HoleImplementation+        ]+    projectionExports = case (.projection) aggregate of+      Nothing -> []+      Just projection -> ["apply" <> pascal ((.table) projection)]++emitOutputHooks :: Agg -> Int -> Transition -> [Text]+emitOutputHooks aggregate transitionIndex transition =+  concat+    [ emitOutputHook aggregate transitionIndex transition emitIndex (eventForName aggregate eventName)+    | (emitIndex, eventName) <- zip [1 ..] ((.emits) 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 ((.name) event)+    inputFields = "(" <> commandFieldsType transition <> ")"+    outputType+      | null ((.fields) event) =+          "K.OutFields "+            <> (.name) aggregate+            <> "Regs "+            <> (.name) aggregate+            <> "Command "+            <> inputFields+            <> " ()"+      | otherwise =+          (.name) event+            <> "TermFields "+            <> (.name) aggregate+            <> "Regs "+            <> (.name) aggregate+            <> "Command "+            <> inputFields+    outputValue+      | null ((.fields) event) = "B.oNil"+      | otherwise =+          (.name) event+            <> "TermFields\n"+            <> nl+              ( valueRecord+                  [ ((.selector) identity, outputFieldValue identity valueType)+                  | (identity, valueType) <- (.fields) event+                  ]+              )+    command = commandForTransition aggregate transition+    outputFieldValue identity valueType+      | Just (commandIdentity, commandType) <- find ((== (.dslName) identity) . (.dslName) . fst) ((.fields) command),+        commandType == valueType =+          "d." <> (.selector) commandIdentity+      | Just register <- find ((== (.dslName) identity) . (.name)) ((.regs) aggregate),+        (.valueType) register == valueType =+          "B.reg @" <> tshow ((.dslName) identity)+      | otherwise = "error " <> tshow ("HOLE: fill output field " <> (.name) event <> "." <> (.dslName) identity)+    valueRecord fields =+      [ lead fieldIndex <> name <> " = " <> fieldValue+      | (fieldIndex, (name, fieldValue)) <- zip [0 :: Int ..] fields+      ]+        ++ ["  }"]+    lead 0 = "  { "+    lead _ = "  , "++emitHoleImplementation :: Agg -> Int -> Transition -> [Text]+emitHoleImplementation aggregate index transition+  | (.implementation) 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 "+          <> (.name) aggregate+          <> "Regs "+          <> (.name) aggregate+          <> "Command "+          <> (.name) aggregate+          <> "Event "+          <> (.vertexType) 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 (.projection) a of+  Nothing -> "  -- (no projection)"+  Just p -> "  , apply" <> pascal ((.table) p)++holeProjectionImports :: Agg -> Text+holeProjectionImports aggregate = case projectionReadModel aggregate of+  Nothing -> ""+  Just readModel ->+    "import "+      <> genPrefixFor ((.context) aggregate) (pascal ((.name) readModel))+      <> ".ReadModelTable ("+      <> readModelStem readModel+      <> "QualifiedTable)"++holeProjectionStub :: Agg -> Text+holeProjectionStub a = case (.projection) 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 ((.table) p) <> "StatusFor)."+        ]+          ++ projectionGuidance+          ++ [ "apply" <> pascal ((.table) p) <> " :: " <> (.name) a <> "Event -> recorded -> txn ()",+               "apply" <> pascal ((.table) p) <> " _event _recorded = " <> projectionTableUse <> "error \"HOLE: fill " <> (.table) 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) ((.columns) 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 (.transition) 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 = (.transitions)++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" <> (.command) 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" | (.mode) t == TmReplayOnly]+    ++ maybe [] (\g -> ["        -- HOLE guard: " <> renderGuard g]) ((.guard) t)+    ++ ["        -- HOLE write " <> r <> " := " <> renderGuard e | (r, e) <- (.writes) t]+    ++ ["        -- HOLE emit " <> ev <> " (B.emit wire" <> ev <> " ...)" | ev <- (.emits) t]+    ++ ["        B.goto " <> vertexCtor a ((.goto) 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 {} <- (.representation) nominal =+      IdCat+  | AggregateNominal nominal <- ty,+    EnumRepresentation {} <- (.representation) 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 <- (.enums) a, (.name) e == ty, (c, _) <- take 1 ((.ctors) e)] of+    (c : _) -> Just c+    [] -> Nothing++vertexCtor :: Agg -> Text -> Text+vertexCtor a s = (.name) a <> s++initialVertex :: Agg -> Text+initialVertex a = case (.states) a of+  (s : _) -> vertexCtor a ((.name) s)+  [] -> (.name) 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 ((.contractLanguageVersion) 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+      (path, attributedOrigin)+        | ".keiro" `T.isSuffixOf` path,+          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+  | modernized.kind == HoleStub = modernized+  | otherwise = ScaffoldModule modernized.path stampedText modernized.kind modernized.origin+  where+    modernized = modernizeScaffoldModule moduleValue+    banner = generatedBannerFor languageContract modernized.origin+    sourceLines = T.splitOn "\n" modernized.text+    stampedText = case replaceFirstGeneratedBanner banner sourceLines of+      Nothing -> banner <> "\n" <> modernized.text+      Just linesWithStamp -> T.intercalate "\n" linesWithStamp++modernizeScaffoldModule :: ScaffoldModule -> ScaffoldModule+modernizeScaffoldModule (ScaffoldModule path source kind origin) =+  ScaffoldModule path (modernizeGeneratedHaskellSource source) kind origin++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 <- (.nodes) spec]+    contracts = [contract | NContract contract <- (.nodes) spec]+    publishers = [publisher | NPublisher publisher <- (.nodes) spec]+    aggregateRefusals aggregate =+      [ "AggregateEmpty: aggregate '" <> (.name) aggregate <> "' must declare at least one command, event, and transition"+      | null ((.commands) aggregate) || null ((.events) aggregate) || null ((.transitions) aggregate)+      ]+        <> concatMap (registerRefusals aggregate) ((.regs) aggregate)+        <> concatMap (fieldRefusals aggregate CommandFieldUse) (concatMap (.fields) ((.commands) aggregate))+        <> concatMap (fieldRefusals aggregate EventFieldUse) [field | event <- (.events) aggregate, EventFields fields <- [(.body) event], field <- fields]+    fieldRefusals aggregate useSite field = case inferAggregateFieldType symbols aggregate useSite field of+      Right _ -> []+      Left _ ->+        [ "FieldTypeUnrepresentable: aggregate '"+            <> (.name) aggregate+            <> "' field '"+            <> (.name) field+            <> "' has unsupported explicit type '"+            <> maybe "(inferred)" typeExprCanonicalName ((.valueType) field)+            <> "'"+        ]+    registerRefusals aggregate register =+      case resolveAggregateType symbols ((.loc) register) RegisterUse ((.valueType) register) of+        Left _ ->+          [ "RegTypeUnsupported: aggregate '"+              <> (.name) aggregate+              <> "' register '"+              <> (.name) register+              <> "' has unsupported type '"+              <> typeExprCanonicalName ((.valueType) register)+              <> "'"+          ]+        Right resolved -> case resolveRegisterInitial symbols ((.loc) register) resolved ((.initial) register) of+          Right _ -> []+          Left _ -> [initialRefusal aggregate register resolved]+    initialRefusal aggregate register resolved = case resolved of+      AggregateText -> label "RegTextInitialNotQuoted" "must use a quoted Text initial"+      AggregateNominal nominal+        | EnumRepresentation {} <- (.representation) nominal ->+            label "RegInitialNotEnumCtor" ("must start at the declaration-owned initial for enum '" <> (.name) nominal <> "'")+      AggregateMapped {} -> label "MappedRegisterInitialMissing" "requires the mapped declaration's initial symbol"+      _ -> label "RegInitialInvalidLiteral" ("has an invalid " <> aggregateCanonicalName resolved <> " initial")+      where+        label codeName detail = codeName <> ": aggregate '" <> (.name) aggregate <> "' register '" <> (.name) register <> "' " <> detail+    contractRefusals contract =+      [ "ContractEmpty: contract '" <> (.name) contract <> "' must declare at least one event"+      | null ((.events) contract)+      ]+    publisherRefusals publisher =+      let backoff = (.backoff) publisher+          label message = message <> ": publisher '" <> (.name) publisher <> "'"+       in case (.kind) backoff of+            "constant" -> []+            "exponential" -> case ((.max) backoff, (.multiplier) backoff) of+              (Just maximumWindow, Just multiplierText) ->+                case (windowSeconds ((.window) backoff), windowSeconds maximumWindow, readMaybe (T.unpack multiplierText) :: Maybe Double) of+                  (Right initialSeconds, Right maximumSeconds, Just multiplier)+                    | initialSeconds > 0 && maximumSeconds >= initialSeconds && multiplier >= 1 -> []+                  _ -> [label "BackoffInvalidExponential"]+              _ -> [label "BackoffExponentialIncomplete"]+            other -> [label ("BackoffUnknownKind '" <> other <> "'")]++windowSeconds :: Text -> Either Text Int+windowSeconds window = case T.unsnoc window of+  Just (digits, unit)+    | not (T.null digits),+      Just amount <- readMaybe (T.unpack digits) -> case unit of+        's' -> Right amount+        'm' -> Right (amount * 60)+        'h' -> Right (amount * 3600)+        _ -> Left invalid+  _ -> Left invalid+  where+    invalid = "invalid window '" <> window <> "' (expected digits followed by s, m, or h)"++windowText :: Text -> Text+windowText = either (const "0") tshow' . windowSeconds++-- | Render an Expr back to source-ish text for a hole annotation.+renderGuard :: Expr -> Text+renderGuard = renderExpr++--------------------------------------------------------------------------------+-- Text helpers+--------------------------------------------------------------------------------++nl :: [Text] -> Text+nl = T.intercalate "\n"++-- | Join groups of declarations, blank-line-separated, dropping empties.+sectionsOf :: [[Text]] -> Text+sectionsOf = T.intercalate "\n\n" . filter (not . T.null) . map (T.intercalate "\n\n")++lowerFirst :: Text -> Text+lowerFirst = generatedCase HaskellName.LogicalIdentifier False++-- | Assert the shared category proof at emission time as a belt-and-braces+-- guard for callers that bypass the CLI's normal validate-before-scaffold path.+staticCategory :: Text -> Text -> Text+staticCategory owner value = case sagaCategoryError value of+  Nothing -> value+  Just reason -> error (T.unpack ("keiro-dsl scaffold: illegal " <> owner <> " category " <> tshow value <> " " <> reason))++pascal :: Text -> Text+pascal = generatedCase HaskellName.LogicalIdentifier True++pascalFromKebab :: Text -> Text+pascalFromKebab = generatedCase HaskellName.LogicalWireWord True++generatedCase :: HaskellName.NameSourceKind -> Bool -> Text -> Text+generatedCase source upper name =+  case HaskellName.deriveHaskellName source site of+    Right derived+      | upper -> HaskellName.renderUpperCamelName ((.upperCamel) derived)+      | otherwise -> HaskellName.renderLowerCamelName ((.lowerCamel) derived)+    Left _ -> name+  where+    site =+      HaskellName.NameSite+        { HaskellName.kind = HaskellName.GeneratedHelperSite,+          HaskellName.logicalName = name,+          HaskellName.owner = "scaffold-renderer",+          HaskellName.line = 0         }  kebabFromPascal :: Text -> Text

src/Keiro/Dsl/ScaffoldRecord.hs view

@@ -39,45 +39,45 @@ import System.FilePath (isAbsolute, splitDirectories)  data ScaffoldRecord = ScaffoldRecord-  { recSpecPath :: !Text,-    recModuleRoot :: !Text,-    recLayout :: !Text,-    recSourceLanguage :: !SourceLanguage,-    recLanguageContract :: !EffectiveLanguageContract,-    recNamingEdition :: !GeneratedHaskellNamingEdition,-    recModuleRoles :: ![ScaffoldModuleRoleRow],-    recFiles :: ![(ModuleKind, FilePath)],-    recMappings :: ![MappingIdentity],-    recIdDomains :: ![Text],-    recNominalEqualities :: ![Text],-    recBindingObligations :: ![BindingHole],-    recBehaviorRequirements :: ![BehaviorRecordRow],-    recProjectionCatalogFacts :: ![Text],-    recQueryContractBaseline :: !Bool,-    recQueryContracts :: ![QueryContractIdentity],-    recRouterSelections :: ![RouterSelectionSnapshot],-    recSemanticImpact :: !(Maybe SemanticImpactSnapshot)+  { specPath :: !Text,+    moduleRoot :: !Text,+    layout :: !Text,+    sourceLanguage :: !SourceLanguage,+    languageContract :: !EffectiveLanguageContract,+    namingEdition :: !GeneratedHaskellNamingEdition,+    moduleRoles :: ![ScaffoldModuleRoleRow],+    files :: ![(ModuleKind, FilePath)],+    mappings :: ![MappingIdentity],+    idDomains :: ![Text],+    nominalEqualities :: ![Text],+    bindingObligations :: ![BindingHole],+    behaviorRequirements :: ![BehaviorRecordRow],+    projectionCatalogFacts :: ![Text],+    queryContractBaseline :: !Bool,+    queryContracts :: ![QueryContractIdentity],+    routerSelections :: ![RouterSelectionSnapshot],+    semanticImpact :: !(Maybe SemanticImpactSnapshot)   }   deriving stock (Eq, Show)  data ScaffoldModuleRoleRow = ScaffoldModuleRoleRow-  { srrRole :: !ModuleRole,-    srrKind :: !ModuleKind,-    srrPath :: !FilePath+  { role :: !ModuleRole,+    kind :: !ModuleKind,+    path :: !FilePath   }   deriving stock (Eq, Show)  instance Aeson.ToJSON ScaffoldModuleRoleRow where   toJSON row =     Aeson.object-      [ "ownerKind" .= roleOwnerKind role,-        "ownerName" .= roleOwnerName role,-        "family" .= roleFamily role,-        "kind" .= (case srrKind row of Generated -> "generated" :: Text; HoleStub -> "hole"),-        "path" .= T.pack (srrPath row)+      [ "ownerKind" .= (.ownerKind) role,+        "ownerName" .= (.ownerName) role,+        "family" .= (.family) role,+        "kind" .= (case (.kind) row of Generated -> "generated" :: Text; HoleStub -> "hole"),+        "path" .= T.pack ((.path) row)       ]     where-      role = srrRole row+      role = (.role) row  instance Aeson.FromJSON ScaffoldModuleRoleRow where   parseJSON = Aeson.withObject "ScaffoldModuleRoleRow" $ \fields -> do@@ -92,36 +92,36 @@     rowPath <- fields .: "path"     pure       ScaffoldModuleRoleRow-        { srrRole = ModuleRole ownerKind ownerName family,-          srrKind = rowKind,-          srrPath = T.unpack (rowPath :: Text)+        { role = ModuleRole ownerKind ownerName family,+          kind = rowKind,+          path = T.unpack (rowPath :: Text)         }  renderRecord :: ScaffoldRecord -> Text renderRecord record =   T.unlines $     [ "keiro-dsl scaffold record v1",-      "spec: " <> recSpecPath record,+      "spec: " <> (.specPath) record,       "module-root: " <> rootLabel,-      "layout: " <> recLayout record,-      "source-language " <> Text.decodeUtf8 (BL.toStrict (Aeson.encode (recSourceLanguage record))),-      "semantic-contract " <> Text.decodeUtf8 (BL.toStrict (Aeson.encode (recLanguageContract record))),-      "naming-edition " <> renderGeneratedHaskellNamingEdition (recNamingEdition record)+      "layout: " <> (.layout) record,+      "source-language " <> Text.decodeUtf8 (BL.toStrict (Aeson.encode ((.sourceLanguage) record))),+      "semantic-contract " <> Text.decodeUtf8 (BL.toStrict (Aeson.encode ((.languageContract) record))),+      "naming-edition " <> renderGeneratedHaskellNamingEdition ((.namingEdition) record)     ]-      <> map ("module-role " <>) (map (Text.decodeUtf8 . BL.toStrict . Aeson.encode) (recModuleRoles record))-      <> map renderFile (recFiles record)-      <> map renderMapping (recMappings record)-      <> map ("id-domain " <>) (recIdDomains record)-      <> 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]]+      <> map ("module-role " <>) (map (Text.decodeUtf8 . BL.toStrict . Aeson.encode) ((.moduleRoles) record))+      <> map renderFile ((.files) record)+      <> map renderMapping ((.mappings) record)+      <> map ("id-domain " <>) ((.idDomains) record)+      <> map ("nominal-equality " <>) ((.nominalEqualities) record)+      <> map renderBindingObligation ((.bindingObligations) record)+      <> map renderBehaviorRequirement ((.behaviorRequirements) record)+      <> map ("projection-catalog-fact " <>) ((.projectionCatalogFacts) record)+      <> ["query-contract-baseline v1" | (.queryContractBaseline) record]+      <> map ("query-contract " <>) (map (Text.decodeUtf8 . BL.toStrict . Aeson.encode) ((.queryContracts) record))+      <> map ("router-selection " <>) (map (Text.decodeUtf8 . BL.toStrict . Aeson.encode) ((.routerSelections) record))+      <> ["semantic-impact " <> Text.decodeUtf8 (BL.toStrict (Aeson.encode snapshot)) | Just snapshot <- [(.semanticImpact) record]]   where-    rootLabel = if T.null (recModuleRoot record) then "(none)" else recModuleRoot record+    rootLabel = if T.null ((.moduleRoot) record) then "(none)" else (.moduleRoot) record     renderFile (Generated, path) = "generated " <> T.pack path     renderFile (HoleStub, path) = "hole " <> T.pack path     renderMapping mapping =@@ -158,29 +158,29 @@         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)+        if hasDuplicateMappingNames mappings || hasDuplicates idDomains || hasDuplicates nominalEqualities || hasDuplicateBindingObligations bindingEntries || hasDuplicateBehaviorRequirements behaviorEntries || hasDuplicates catalogFacts || hasDuplicates (map queryContractIdentityKey queryContracts) || hasDuplicates (map (.router) routerSelections)           then Nothing           else             pure               ScaffoldRecord-                { recSpecPath = specPath,-                  recModuleRoot = if rootLabel == "(none)" then "" else rootLabel,-                  recLayout = layout,-                  recSourceLanguage = sourceLanguage,-                  recLanguageContract = languageContract,-                  recNamingEdition = namingEdition,-                  recModuleRoles = moduleRoles,-                  recFiles = files,-                  recMappings = mappings,-                  recIdDomains = idDomains,-                  recNominalEqualities = nominalEqualities,-                  recBindingObligations = bindingEntries,-                  recBehaviorRequirements = behaviorEntries,-                  recProjectionCatalogFacts = catalogFacts,-                  recQueryContractBaseline = queryContractBaseline,-                  recQueryContracts = queryContracts,-                  recRouterSelections = routerSelections,-                  recSemanticImpact = semanticImpact+                { specPath = specPath,+                  moduleRoot = if rootLabel == "(none)" then "" else rootLabel,+                  layout = layout,+                  sourceLanguage = sourceLanguage,+                  languageContract = languageContract,+                  namingEdition = namingEdition,+                  moduleRoles = moduleRoles,+                  files = files,+                  mappings = mappings,+                  idDomains = idDomains,+                  nominalEqualities = nominalEqualities,+                  bindingObligations = bindingEntries,+                  behaviorRequirements = behaviorEntries,+                  projectionCatalogFacts = catalogFacts,+                  queryContractBaseline = queryContractBaseline,+                  queryContracts = queryContracts,+                  routerSelections = routerSelections,+                  semanticImpact = semanticImpact                 }   _ -> Nothing   where@@ -222,13 +222,20 @@         payload <- T.stripPrefix "semantic-impact " row         Just <$> Aeson.decodeStrict' (Text.encodeUtf8 payload)       _ -> Nothing+    parseModuleRole :: Text -> Maybe ScaffoldModuleRoleRow     parseModuleRole row = do       payload <- T.stripPrefix "module-role " row       decoded <- Aeson.decodeStrict' (Text.encodeUtf8 payload)       checkedRole decoded+    checkedRole :: ScaffoldModuleRoleRow -> Maybe ScaffoldModuleRoleRow     checkedRole roleRow = do-      path <- checkedPath (T.pack (srrPath roleRow))-      pure roleRow {srrPath = path}+      path <- checkedPath (T.pack ((.path) roleRow))+      pure+        ScaffoldModuleRoleRow+          { role = (.role) roleRow,+            kind = (.kind) roleRow,+            path = path+          }     checkedPath pathText =       let path = T.unpack pathText        in if null path || isAbsolute path || ".." `elem` splitDirectories path@@ -252,21 +259,21 @@       [row] -> T.stripPrefix "naming-edition " row >>= parseGeneratedHaskellNamingEdition       _ -> Nothing     hasDuplicateMappingNames mappings =-      let names = map mappingSpecName mappings+      let names = map (.specName) mappings        in length names /= length (nub names)     hasDuplicates values = length values /= length (nub values)     hasDuplicateBindingObligations obligations =       let keys = map bindingKey obligations        in length keys /= length (nub keys)     bindingKey hole =-      ( holeMappedName hole,-        holeModule hole,-        holeSymbol hole,-        holeKind hole,-        holePath hole+      ( (.mappedName) hole,+        (.moduleName) hole,+        (.symbol) hole,+        (.kind) hole,+        (.path) hole       )     hasDuplicateBehaviorRequirements requirements =-      let keys = map behaviorRecordKey requirements+      let keys = map (.key) requirements        in length keys /= length (nub keys)  recordFileName :: Text -> FilePath@@ -286,109 +293,109 @@   projectionCatalogFactsWith (checkedSpec service) (checkedProjectionSupplies service)  projectionCatalogFactsWith :: Spec -> ProjectionSupplyAnalysis -> [Text]-projectionCatalogFactsWith spec supplyAnalysis = sort (concatMap nodeFacts (specNodes spec) <> map supplyFact supplies)+projectionCatalogFactsWith spec supplyAnalysis = sort (concatMap nodeFacts ((.nodes) spec) <> map supplyFact supplies)   where-    supplies = resolvedProjectionSupplies supplyAnalysis-    owners = [owner | NProjectionOwner owner <- specNodes spec]+    supplies = (.resolvedProjectionSupplies) supplyAnalysis+    owners = [owner | NProjectionOwner owner <- (.nodes) spec]     nodeFacts (NProjectionTarget target) =-      [T.intercalate "|" ["target", ptName target, ptSchema target, ptTable target, resetText (ptReset target), T.intercalate "," (ptDependsOn target), lineText (ptLoc target)]]+      [T.intercalate "|" ["target", (.name) target, (.schema) target, (.table) target, resetText ((.reset) target), T.intercalate "," ((.dependsOn) target), lineText ((.loc) target)]]     nodeFacts (NRebuildGroup groupNode) =-      [T.intercalate "|" ["group", rgName groupNode, T.intercalate "," (sort (rgTargets groupNode)), T.intercalate "," (rgOrder groupNode), lineText (rgLoc groupNode)]]+      [T.intercalate "|" ["group", (.name) groupNode, T.intercalate "," (sort ((.targets) groupNode)), T.intercalate "," ((.order) groupNode), lineText ((.loc) groupNode)]]     nodeFacts (NProjectionRevision revision) =       [ T.intercalate           "|"           [ "revision",-            prvName revision,-            prvGroup revision,-            T.intercalate ";" (map revisionTargetText (prvTargets revision)),-            lineText (prvLoc revision)+            (.name) revision,+            (.group) revision,+            T.intercalate ";" (map revisionTargetText ((.targets) revision)),+            lineText ((.loc) revision)           ]       ]     nodeFacts (NExternalRead externalRead) =       [ T.intercalate           "|"           [ "external-read",-            erName externalRead,-            T.pack (show (erVersion externalRead)),-            erQueryModel externalRead,-            erResultSchema externalRead <> "." <> erResultType externalRead,+            (.name) externalRead,+            T.pack (show ((.version) externalRead)),+            (.queryModel) externalRead,+            (.resultSchema) externalRead <> "." <> (.resultType) externalRead,             externalReadShape externalRead,-            T.intercalate "," (sort (erCompatibleRevisions externalRead)),-            T.pack (show (erSurfaceGeneration externalRead)),-            lineText (erLoc externalRead)+            T.intercalate "," (sort ((.compatibleRevisions) externalRead)),+            T.pack (show ((.surfaceGeneration) externalRead)),+            lineText ((.loc) 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)+            (.name) owner,+            T.intercalate "," (map sourceText ((.sources) owner)),+            (.group) owner,+            T.intercalate "," (sort ((.targets) owner)),+            T.pack (show ((.order) owner)),+            maybe "" id ((.subscription) owner),+            maybe "" id ((.dedup) owner),+            T.intercalate "," (map checkpointOnMissingText ((.checkpointOnMissing) owner)),+            replayText ((.replay) owner),+            lineText ((.loc) owner)           ],         T.intercalate           "|"           [ "delivery",-            poName owner,-            deliveryText (poDelivery owner),-            lineText (poLoc owner)+            (.name) owner,+            deliveryText ((.delivery) owner),+            lineText ((.loc) owner)           ]       ]     nodeFacts (NReadModel readModel)-      | Just groupName <- rmGroup readModel =+      | Just groupName <- (.group) readModel =           [ T.intercalate               "|"               [ "query",-                rmName readModel,+                (.name) readModel,                 groupName,-                T.intercalate "," (sort (rmObservedTargets readModel)),+                T.intercalate "," (sort ((.observedTargets) readModel)),                 fromMaybe "" (effectiveBacking readModel),-                lineText (rmLoc readModel)+                lineText ((.loc) readModel)               ],             T.intercalate               "|"               [ "freshness",-                rmName readModel,-                freshnessText (rmFreshness readModel),-                lineText (rmLoc readModel)+                (.name) readModel,+                freshnessText ((.freshness) readModel),+                lineText ((.loc) readModel)               ],             T.intercalate               "|"               [ "cursor",-                rmName readModel,+                (.name) readModel,                 fromMaybe "none" (resolvedCursor readModel),-                lineText (rmLoc readModel)+                lineText ((.loc) readModel)               ]           ]     nodeFacts _ = []-    externalReadShape externalRead = case [rmShape readModel | NReadModel readModel <- specNodes spec, rmName readModel == erQueryModel externalRead] of+    externalReadShape externalRead = case [(.shape) readModel | NReadModel readModel <- (.nodes) spec, (.name) readModel == (.queryModel) 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))+        [ (.target) target,+          (.schemaVersion) target,+          (.provisioner) target,+          T.pack (show ((.provisionerVersion) target)),+          (.expectedShape) target,+          (.validator) target,+          T.pack (show ((.validatorVersion) target)),+          T.intercalate ":" (map promotionText ((.promotionObjects) target))         ]     promotionText promotionObject =       T.intercalate         ">"-        [ promotionKindText (rpoKind promotionObject),-          rpoGenerationName promotionObject,-          rpoCanonicalName promotionObject+        [ promotionKindText ((.kind) promotionObject),+          (.generationName) promotionObject,+          (.canonicalName) promotionObject         ]     promotionKindText PromotionIndexNode = "index"     promotionKindText PromotionConstraintNode = "constraint"@@ -397,16 +404,16 @@       T.intercalate         "|"         [ "supply",-          supplyQueryModel supply,-          supplyProjectionOwner supply,-          supplyRebuildGroup supply,-          T.intercalate "," (NE.toList (supplyObservedTargets supply)),-          lineText (supplyQueryLoc supply),-          lineText (supplyOwnerLoc supply)+          (.queryModel) supply,+          (.projectionOwner) supply,+          (.rebuildGroup) supply,+          T.intercalate "," (NE.toList ((.observedTargets) supply)),+          lineText ((.queryLoc) supply),+          lineText ((.ownerLoc) supply)         ]-    effectiveBacking readModel = case rmBackingTarget readModel of+    effectiveBacking readModel = case (.backingTarget) readModel of       Just targetName -> Just targetName-      Nothing -> case sort (rmObservedTargets readModel) of+      Nothing -> case sort ((.observedTargets) readModel) of         [targetName] -> Just targetName         _ -> Nothing     resetText TargetClear = "clear"@@ -420,18 +427,18 @@     freshnessText (FreshnessWaitForHead RmEntireLog) = "wait-for-head:entire-log"     freshnessText (FreshnessWaitForHead (RmCategory categoryName)) = "wait-for-head:category:" <> categoryName     resolvedCursor readModel = do-      ownerName <- case [ supplyProjectionOwner supply+      ownerName <- case [ (.projectionOwner) supply                         | supply <- supplies,-                          supplyQueryModel supply == rmName readModel+                          (.queryModel) supply == (.name) readModel                         ] of         [name] -> Just name         _ -> Nothing-      owner <- case [candidate | candidate <- owners, poName candidate == ownerName] of+      owner <- case [candidate | candidate <- owners, (.name) candidate == ownerName] of         [candidate] -> Just candidate         _ -> Nothing-      case poDelivery owner of+      case (.delivery) owner of         DeliveryInline -> Nothing-        DeliverySubscription -> poSubscription owner+        DeliverySubscription -> (.subscription) owner     checkpointOnMissingText CheckpointFromBeginning = "from-beginning"     checkpointOnMissingText CheckpointFromCurrentHead = "from-current-head"     checkpointOnMissingText CheckpointFail = "fail"

src/Keiro/Dsl/ScaffoldRun.hs view

@@ -2,1719 +2,2053 @@ -- execution so every refusal is known before the first output byte is written. module Keiro.Dsl.ScaffoldRun   ( Refusal (..),-    WriteDisposition (..),-    GeneratedArtifactCategory (..),-    GeneratedArtifactImpact (..),-    StaleGeneratedEvidence (..),-    StaleModule (..),-    MappingDrift (..),-    QueryContractMigration (..),-    SourceLanguageDrift (..),-    ScaffoldReport (..),-    scaffoldServiceModules,-    scaffoldServiceModulesWithGoldens,-    scaffoldModules,-    scaffoldModulesWithGoldens,-    planIndexedServiceScaffold,-    planIndexedServiceScaffoldWithGoldens,-    planIndexedServiceScaffoldWithRuntimePackage,-    planIndexedServiceScaffoldWithRuntimePackageAndGoldens,-    executeServiceScaffold,-    executeServiceScaffoldWithRuntimePackage,-    executeServiceScaffoldWithRuntimePackageAndNameMigrations,-    executeScaffold,-    executeScaffoldWithLanguage,-    renderRefusals,-    renderScaffoldReport,-    checkedSemanticImpactSnapshot,-    semanticImpactForMappingDrift,-    generatedArtifactImpact,-    renderSemanticImpactReport,-    renderGeneratedArtifactImpact,-    renderRouterSelectionDrift,--    -- * Shared with whole-workspace scaffolding ("Keiro.Dsl.WorkspaceScaffold")--    ---    -- $shared-    planningGatePipeline,-    planningRefusalDiagnostics,-    checkIndexedServiceDiagnostics,-    inertNodesOf,-    renderInertNodeSection,-    withSidecarMovesApplied,-    originLine,-    pureRefusalsForService,-    auditGeneratedHaskell,-    missingGeneratedBanners,-    staleAgainst,-    PreparedSourceMove,-    preparedSourceMove,-    preflightSourceMoves,-    applyPreparedSourceMoves,-    constraintPlanForService,-    mappingDrift,-    behaviorDrift,-    newBindingObligations,-    queryContractMigrations,-    obligationKindLabel,-    renderMappingIdentity,-  )-where--import Data.List (sortOn)-import Data.List.NonEmpty qualified as NE-import Data.Map.Strict qualified as Map-import Data.Set qualified as Set-import Data.Text (Text)-import Data.Text qualified as T-import Data.Text.IO qualified as TIO-import Keiro.Dsl.BehaviorCoverage (BehaviorDerivationError, BehaviorKey (..), BehaviorRecordRow (..), behaviorRecordRows, 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,-    ConformanceServiceKey (StandaloneConformanceService),-    executePreparedConformancePackage,-    planConformancePackage,-    preflightConformancePackage,-    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, 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 (..), 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, 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.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, (</>))-import Text.Read (readMaybe)---- $shared--- These are the pieces whole-workspace scaffolding reuses verbatim rather than--- reimplementing, so a workspace and a single spec can never disagree about what--- counts as a refusal, what counts as stale, or how an identity renders.--- "Keiro.Dsl.WorkspaceScaffold" cannot live in this module because--- "Keiro.Dsl.Workspace" already imports it (its cross-member collision check asks--- the planner), so the seam is exports rather than shared privates.--data Refusal-  = PathCollision !FilePath ![Text]-  | FirewallBreach ![(FilePath, Text, Int)]-  | LoweringRefusal ![Text]-  | 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.-    --       This is an internal/API misuse refusal and is detected before writes.-    SemanticContractMismatch !Text-  | -- | Golden payload fixtures found beside a workspace member that the one-    --       workspace golden root does not have. Raised only by the workspace path.-    GoldenRootDivergence !FilePath ![FilePath]-  | DuplicateConformanceFactKeys ![DuplicateServiceFactKey]-  | ConformancePackageRefusal !ConformancePackageFailure-  | GeneratedNameInvariantViolation ![Text]-  | NameMigrationRequired ![SourceMove]-  | NameMigrationRefusal ![Text]-  | SidecarMigrationRequired ![SidecarMove]-  | SidecarMigrationRefusal ![Text]-  | -- | Not a refusal on its own: an accompanying note that the run had already-    --       applied its sidecar renames before a later gate refused. Every other-    --       refusal says "nothing was written", which without this note is false.-    --       The renames are idempotent and forward-consistent, so re-running after-    --       fixing the refusal is correct and needs no undo.-    SidecarMovesAlreadyApplied ![SidecarMove]-  deriving stock (Eq, Show)---- | What one module write did. 'Unchanged' 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-  deriving stock (Eq, Show)--data StaleModule = StaleModule-  { staleKind :: !ModuleKind,-    stalePath :: !FilePath,-    staleGeneratedEvidence :: !(Maybe StaleGeneratedEvidence)-  }-  deriving stock (Eq, Show)--data MappingDrift = MappingDrift-  { driftSpecName :: !Text,-    driftPrevious :: !(Maybe MappingIdentity),-    driftCurrent :: !(Maybe MappingIdentity)-  }-  deriving stock (Eq, Show)--data SourceLanguageDrift = SourceLanguageDrift-  { languageDriftPrevious :: !SourceLanguage,-    languageDriftCurrent :: !SourceLanguage-  }-  deriving stock (Eq, Show)--data ScaffoldReport = ScaffoldReport-  { reportSpecPath :: !FilePath,-    reportOutDir :: !FilePath,-    reportContext :: !Context,-    reportDispositions :: ![(ScaffoldModule, WriteDisposition)],-    reportInertNodes :: ![(Text, Text)],-    reportManifestPath :: !FilePath,-    reportRecordPath :: !FilePath,-    reportPreviousSpecPath :: !(Maybe Text),-    reportStale :: ![StaleModule],-    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],-    reportRemovedBehavior :: ![BehaviorRecordRow],-    reportObsoleteOutputHooks :: ![(Text, Text)],-    reportConformancePackage :: !(Maybe ConformancePackageReport),-    reportNameMoves :: ![SourceMove],-    reportSidecarMoves :: ![SidecarMove]-  }-  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.-scaffoldServiceModules :: Context -> CheckedService -> [ScaffoldModule]-scaffoldServiceModules = scaffoldServiceModulesWithGoldens []--scaffoldServiceModulesWithGoldens :: [GoldenPayload] -> Context -> CheckedService -> [ScaffoldModule]-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 -> 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 -> 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 _ -> []-          NOperation _ -> []-      | node <- specNodes spec-      ]-  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 []--scaffoldModulesWithGoldens :: [GoldenPayload] -> Context -> Spec -> [ScaffoldModule]-scaffoldModulesWithGoldens goldens ctx = scaffoldServiceModulesWithGoldens goldens ctx . legacyCheckedService---- | 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--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.-planIndexedServiceScaffoldWithRuntimePackage :: Maybe RuntimePackageName -> SemanticSourceIndex -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]-planIndexedServiceScaffoldWithRuntimePackage = planIndexedServiceScaffoldWithRuntimePackageAndGoldens []--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)-    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)-              (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--- drift by input shape.-planningGatePipeline ::-  Context ->-  CheckedService ->-  Either [Refusal] [ScaffoldModule] ->-  Either [Refusal] () ->-  Either [Refusal] [ScaffoldModule]-planningGatePipeline ctx service modulePlan packagePlan =-  case traverse (aggregateFoldSurfaceForService service) [aggregate | NAggregate aggregate <- specNodes spec] of-    Left surfaceError -> Left [FoldSurfaceRefusal surfaceError]-    Right _ -> case 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 pureRefusalsForService ctx service modules of-            [] -> Right modules-            refusals -> Left refusals-  where-    spec = checkedSpec service---- | The nodes a spec declares that contribute no generated module.------ They are still parsed, validated, and diff-classified; naming them in the--- scaffold report is what stops an author from concluding the toolchain lost--- their declaration. Shared by the single-spec and workspace planners so a--- workspace — the recommended layout — reports exactly what one spec reports.-inertNodesOf :: Spec -> [(Text, Text)]-inertNodesOf spec =-  [ (kindLabel, nodeName)-  | node <- specNodes spec,-    (kindLabel, nodeName) <- case node of-      NEmit emitNode -> [("emit", emName emitNode)]-      NPgmqDispatch dispatchNode -> [("dispatch", pdName dispatchNode)]-      NOperation operationNode -> [("operation", opName operationNode)]-      _ -> []-  ]---- | The report line naming 'inertNodesOf', or nothing when every declaration--- produced a module.-renderInertNodeSection :: [(Text, Text)] -> [Text]-renderInertNodeSection = \case-  [] -> []-  nodes ->-    [ "no-modules: "-        <> T.intercalate ", " [kindLabel <> " " <> nodeName | (kindLabel, nodeName) <- nodes]-        <> " (validated and diff-classified; no generated modules)"-    ]---- | 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 planIndexedServiceScaffoldWithRuntimePackage runtimePackage sourceIndex ctx service of-          Right _ -> []-          Left refusals -> planningRefusalDiagnostics refusals-  where-    validationDiagnostics = validateService service-    blocksPlanning diagnostic =-      severity diagnostic == Error-        && code diagnostic /= GeneratedOccurrenceCollision---- | Present pure planning refusals through check's stable located diagnostic--- vocabulary. Planner-invariant failures retain the detailed scaffold refusal--- text in their message while receiving one machine code.-planningRefusalDiagnostics :: [Refusal] -> [Diagnostic]-planningRefusalDiagnostics = concatMap diagnosticsFor-  where-    diagnosticsFor (PathCollision path origins) = [pathCollisionDiagnostic path origins]-    diagnosticsFor (ImportCycle path) =-      [ planningError 1 GeneratedImportCycle $-          "generated/consumer import cycle "-            <> T.intercalate " -> " path-            <> "; keep bindings in a leaf module that imports only Structural.Shape.* and Keiro.Codec.Structural"-      ]-    diagnosticsFor (BehaviorRefusal errors) =-      [ planningError (behaviorErrorLine behaviorError) BehaviorDerivationInvalid $-          "behavior obligations cannot be derived soundly: " <> T.pack (show behaviorError)-      | behaviorError <- errors-      ]-    diagnosticsFor (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 '"-            <> duplicateServiceFactKey duplicate-            <> "' is produced more than once"-      | duplicate <- duplicates-      ]-    diagnosticsFor refusal =-      [ planningError 1 GeneratedPlanningInvariantViolation $-          "validated service failed an internal scaffold-planning invariant: "-            <> T.intercalate " | " (renderRefusals [refusal])-      ]--    pathCollisionDiagnostic path origins =-      Diagnostic-        { line = primaryLine,-          severity = Error,-          code = GeneratedPathCollision,-          relatedLocations =-            [ (claimLine, "claimed here by " <> claimOrigin)-            | (claimLine, claimOrigin) <- remainingClaims-            ],-          message =-            "generated module path '"-              <> T.pack path-              <> "' is claimed more than once; on a case-insensitive filesystem these are one file; claimants: "-              <> T.intercalate "; " origins-        }-      where-        orderedClaims = reverse (sortOn fst [(claimLine, claimOrigin) | claimOrigin <- origins, Just claimLine <- [originLine claimOrigin]])-        (primaryLine, remainingClaims) = case orderedClaims of-          (claimLine, _) : rest -> (claimLine, rest)-          [] -> (1, [])--    behaviorErrorLine (Behavior.DuplicateBehaviorIdentity _ locations) = maximum (1 : map unLoc locations)-    behaviorErrorLine _ = 1--    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,-          severity = Error,-          code = diagnosticCode,-          relatedLocations = [],-          message = diagnosticMessage-        }---- | Recover the source line embedded in a generated module's origin text,--- which scaffold formats as @<kind> <name> (line N)@.-originLine :: Text -> Maybe Int-originLine originText = do-  withoutClose <- T.stripSuffix ")" originText-  let (before, after) = T.breakOnEnd " (line " withoutClose-  if T.null before then Nothing else readMaybe (T.unpack after)---- | 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.-pureRefusalsForService :: Context -> CheckedService -> [ScaffoldModule] -> [Refusal]-pureRefusalsForService ctx service modules =-  collisionRefusals modules-    <> dependencyRefusalsForService ctx service modules-    <> [FirewallBreach breaches | not (null breaches)]-    <> [GeneratedNameInvariantViolation namingViolations | not (null namingViolations)]-    <> [LoweringRefusal lowering | let lowering = scaffoldRefusalsForService service, not (null lowering)]-    <> [BehaviorRefusal errors | Left errors <- [deriveBehaviorRequirementsForService service]]-  where-    breaches = firewallBreaches modules-    namingViolations = generatedNameInvariantViolations modules--generatedNameInvariantViolations :: [ScaffoldModule] -> [Text]-generatedNameInvariantViolations = concatMap auditGeneratedHaskell---- | Inventory and check declarations in one generated source file.  The--- lexical mask keeps comments and literals out of the declaration inventory;--- this is deliberately a final defense after the typed naming plan, so a--- literal template declaration cannot bypass the checked constructors.-auditGeneratedHaskell :: ScaffoldModule -> [Text]-auditGeneratedHaskell scaffoldModule = lexicalErrors <> declarationErrors <> duplicateDeclarationErrors <> occurrenceErrors-  where-    expectedModule = moduleNameOf (modulePath scaffoldModule)-    (lexicalErrors, codeSource) = case maskNonCode (moduleText scaffoldModule) of-      Left message -> ([prefix 1 <> message], "")-      Right masked -> ([], masked)-    sourceLines = zip [1 :: Int ..] (T.lines codeSource)-    declarationErrors = moduleDeclarationErrors <> moduleSegmentErrors-    moduleDeclarationErrors = case declaredModuleName codeSource of-      Nothing -> [T.pack (modulePath scaffoldModule) <> ": missing Haskell module declaration"]-      Just declared-        | declared == expectedModule -> []-        | otherwise ->-            [ T.pack (modulePath scaffoldModule)-                <> ": declares "-                <> declared-                <> " but its planned module is "-                <> expectedModule-            ]-    moduleSegmentErrors =-      [ prefix 1 <> "module segment '" <> segment <> "' is not UpperCamelCase"-      | segment <- T.splitOn "." expectedModule,-        isLeftName (HaskellName.checkedModuleSegment (auditSite HaskellName.NodeModuleSite segment 1) segment)-      ]-    occurrenceErrors =-      concat-        [ checkCandidates lineNumber (signatureCandidates sourceLine)-            <> checkCandidates lineNumber (typeCandidates sourceLine)-            <> checkCandidates lineNumber (constructorCandidates sourceLine)-            <> checkCandidates lineNumber (topLevelValueCandidates sourceLine)-        | (lineNumber, sourceLine) <- sourceLines-        ]--    duplicateDeclarationErrors = duplicateErrors "top-level type signature" signatureCandidates <> duplicateErrors "top-level type declaration" typeCandidates-    duplicateErrors label candidates =-      [ prefix laterLine-          <> "repeated "-          <> label-          <> " '"-          <> candidate-          <> "' (first declared at line "-          <> tshow firstLine-          <> ")"-      | (candidate, declarationLines) <- Map.toAscList declarations,-        firstLine : laterLines <- [declarationLines],-        laterLine <- laterLines-      ]-      where-        declarations =-          Map.fromListWith-            (flip (++))-            [ (candidate, [lineNumber])-            | (lineNumber, sourceLine) <- sourceLines,-              sourceLine == T.stripStart sourceLine,-              candidate <- candidates sourceLine-            ]--    checkCandidates lineNumber = concatMap (checkCandidate lineNumber)-    checkCandidate lineNumber candidate-      | T.null candidate = []-      | asciiUpperInitial candidate =-          [prefix lineNumber <> "generated declaration '" <> candidate <> "' is not UpperCamelCase" | isLeftName (HaskellName.checkedUpperOccurrence (auditSite HaskellName.GeneratedTypeSite candidate lineNumber) candidate)]-      | otherwise =-          [prefix lineNumber <> "generated declaration '" <> candidate <> "' is not lowerCamelCase" | isLeftName (HaskellName.checkedLowerOccurrence (auditSite HaskellName.GeneratedValueSite candidate lineNumber) candidate)]--    prefix lineNumber = T.pack (modulePath scaffoldModule) <> ":" <> tshow lineNumber <> ": "--    auditSite kind candidate lineNumber =-      HaskellName.NameSite-        { HaskellName.siteKind = kind,-          HaskellName.siteLogicalName = candidate,-          HaskellName.siteOwner = T.pack (modulePath scaffoldModule),-          HaskellName.siteLine = lineNumber-        }--isLeftName :: Either left right -> Bool-isLeftName = \case Left _ -> True; Right _ -> False--declaredModuleName :: Text -> Maybe Text-declaredModuleName source =-  case [T.takeWhile moduleCharacter (T.drop 7 sourceLine) | sourceLine <- T.lines source, "module " `T.isPrefixOf` sourceLine] of-    declaration : _ | not (T.null declaration) -> Just declaration-    _ -> Nothing-  where-    moduleCharacter character = identifierCharacter character || character == '.'--signatureCandidates :: Text -> [Text]-signatureCandidates sourceLine-  | T.null suffix || T.any (`elem` ['=', '(', ')', '[', ']']) prefix = []-  | otherwise = filter isIdentifier (map T.strip (T.splitOn "," prefix))-  where-    (prefix, suffix) = T.breakOn "::" (T.strip sourceLine)--typeCandidates :: Text -> [Text]-typeCandidates sourceLine = case T.words (T.strip sourceLine) of-  keyword : candidate : _-    | keyword `elem` ["data", "newtype", "type"], candidate /= "family", candidate /= "instance" -> [cleanIdentifier candidate]-  _ -> []--constructorCandidates :: Text -> [Text]-constructorCandidates sourceLine-  | "|" `T.isPrefixOf` stripped = takeFollowingIdentifier (T.drop 1 stripped)-  | any (`T.isPrefixOf` stripped) ["data ", "newtype "] = takeFollowingIdentifier (T.drop 1 (snd (T.breakOn "=" stripped)))-  | otherwise = []-  where-    stripped = T.strip sourceLine-    takeFollowingIdentifier value = case T.words value of-      candidate : _ | asciiUpperInitial (cleanIdentifier candidate) -> [cleanIdentifier candidate]-      _ -> []--topLevelValueCandidates :: Text -> [Text]-topLevelValueCandidates sourceLine-  | T.null sourceLine || T.head sourceLine == ' ' || T.head sourceLine == '\t' = []-  | T.null suffix = []-  | otherwise = case T.words prefix of-      candidate : _-        | candidate `notElem` declarationKeywords,-          isIdentifier candidate ->-            [candidate]-      _ -> []-  where-    (prefix, suffix) = T.breakOn "=" sourceLine-    declarationKeywords = ["data", "newtype", "type", "class", "instance", "module", "import", "deriving", "infix", "infixl", "infixr"]--cleanIdentifier :: Text -> Text-cleanIdentifier = T.takeWhile identifierCharacter . T.dropWhile (not . identifierCharacter)--isIdentifier :: Text -> Bool-isIdentifier candidate = not (T.null candidate) && T.all identifierCharacter candidate--identifierCharacter :: Char -> Bool-identifierCharacter character =-  (character >= 'A' && character <= 'Z')-    || (character >= 'a' && character <= 'z')-    || (character >= '0' && character <= '9')-    || character == '_'-    || character == '\''--asciiUpperInitial :: Text -> Bool-asciiUpperInitial candidate = case T.uncons candidate of-  Just (first, _) -> first >= 'A' && first <= 'Z'-  Nothing -> False--data AuditLexState = AuditCode | AuditLineComment | AuditBlockComment !Int | AuditString | AuditCharacter--maskNonCode :: Text -> Either Text Text-maskNonCode = fmap T.pack . go AuditCode . T.unpack-  where-    go state input = case (state, input) of-      (AuditCode, []) -> Right []-      (AuditLineComment, []) -> Right []-      (AuditBlockComment _, []) -> Left "unterminated block comment in generated source"-      (AuditString, []) -> Left "unterminated string literal in generated source"-      (AuditCharacter, []) -> Left "unterminated character literal in generated source"-      (AuditCode, '-' : '-' : rest) -> prependSpaces 2 <$> go AuditLineComment rest-      (AuditCode, '{' : '-' : rest) -> prependSpaces 2 <$> go (AuditBlockComment 1) rest-      (AuditCode, '"' : rest) -> (' ' :) <$> go AuditString rest-      (AuditCode, '\'' : rest)-        | looksLikeCharacterLiteral rest -> (' ' :) <$> go AuditCharacter rest-      (AuditCode, character : rest) -> (character :) <$> go AuditCode rest-      (AuditLineComment, '\n' : rest) -> ('\n' :) <$> go AuditCode rest-      (AuditLineComment, _ : rest) -> (' ' :) <$> go AuditLineComment rest-      (AuditBlockComment depth, '{' : '-' : rest) -> prependSpaces 2 <$> go (AuditBlockComment (depth + 1)) rest-      (AuditBlockComment 1, '-' : '}' : rest) -> prependSpaces 2 <$> go AuditCode rest-      (AuditBlockComment depth, '-' : '}' : rest) -> prependSpaces 2 <$> go (AuditBlockComment (depth - 1)) rest-      (AuditBlockComment depth, '\n' : rest) -> ('\n' :) <$> go (AuditBlockComment depth) rest-      (AuditBlockComment depth, _ : rest) -> (' ' :) <$> go (AuditBlockComment depth) rest-      (AuditString, '\\' : _escaped : rest) -> prependSpaces 2 <$> go AuditString rest-      (AuditString, '"' : rest) -> (' ' :) <$> go AuditCode rest-      (AuditString, '\n' : _) -> Left "newline in generated string literal"-      (AuditString, _ : rest) -> (' ' :) <$> go AuditString rest-      (AuditCharacter, '\\' : _escaped : rest) -> prependSpaces 2 <$> go AuditCharacter rest-      (AuditCharacter, '\'' : rest) -> (' ' :) <$> go AuditCode rest-      (AuditCharacter, '\n' : _) -> Left "newline in generated character literal"-      (AuditCharacter, _ : rest) -> (' ' :) <$> go AuditCharacter rest--    prependSpaces count suffix = replicate count ' ' <> suffix-    looksLikeCharacterLiteral = \case-      '\\' : _escaped : '\'' : _ -> True-      _character : '\'' : _ -> True-      _ -> False--dependencyRefusalsForService :: Context -> CheckedService -> [ScaffoldModule] -> [Refusal]-dependencyRefusalsForService ctx service modules = collisionWithConsumers <> namespaceCycles-  where-    plan = consumerPlanForService service-    generatedByName = Map.fromList [(moduleNameOf (modulePath moduleValue), moduleValue) | moduleValue <- modules, kind moduleValue == Generated]-    collisionWithConsumers =-      [ PathCollision-          (modulePath generated)-          [origin generated, "consumer module " <> consumerModule]-      | consumerModule <- consumerModules plan,-        Just generated <- [Map.lookup consumerModule generatedByName]-      ]-    namespaceCycles =-      [ ImportCycle [importer, consumerModule, importer]-      | consumerModule <- consumerModules plan,-        generatedNamespaceOwned ctx consumerModule,-        importer <- take 1 (importersOf consumerModule modules <> [contextGeneratedRoot ctx])-      ]--generatedNamespaceOwned :: Context -> Text -> Bool-generatedNamespaceOwned ctx consumerModule = case placement ctx of-  GeneratedPrefix -> contextGeneratedRoot ctx `T.isPrefixOf` consumerModule-  CollocatedLeaf ->-    (root <> contextSegment <> ".") `T.isPrefixOf` consumerModule-      && ".Generated" `T.isInfixOf` consumerModule-  where-    root = if T.null (moduleRoot ctx) then "" else moduleRoot ctx <> "."-    contextSegment = pascalFromKebab (contextName ctx)--contextGeneratedRoot :: Context -> Text-contextGeneratedRoot 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)--importersOf :: Text -> [ScaffoldModule] -> [Text]-importersOf imported =-  map (moduleNameOf . modulePath)-    . filter (any (importsModule imported) . T.lines . moduleText)--importsModule :: Text -> Text -> Bool-importsModule expected line = case T.words (T.strip line) of-  "import" : rest -> expected `elem` rest-  _ -> False--collisionRefusals :: [ScaffoldModule] -> [Refusal]-collisionRefusals modules =-  [ PathCollision (modulePath first) (map origin (first : rest))-  | first : rest <- Map.elems grouped,-    not (null rest)-  ]-  where-    grouped =-      Map.fromListWith-        (flip (<>))-        [(T.toCaseFold (T.pack (modulePath m)), [m]) | m <- modules]---- | Check existing generated paths, then perform the deterministic writes and--- manifest rewrite. Banner refusal is evaluated for the complete set before the--- output directory is created or any file is changed.-executeScaffold :: FilePath -> Bool -> FilePath -> Context -> Spec -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport)-executeScaffold out forceGeneratedOverwrite specPath ctx spec modules =-  executeScaffoldWithLanguage out forceGeneratedOverwrite specPath LegacyUnversioned ctx spec modules---- | Source-aware execution used by the CLI; semantic planning still receives only 'Spec'.-executeScaffoldWithLanguage :: FilePath -> Bool -> FilePath -> SourceLanguage -> Context -> Spec -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport)-executeScaffoldWithLanguage out forceGeneratedOverwrite specPath sourceLanguage ctx spec modules =-  executeServiceScaffold out forceGeneratedOverwrite specPath sourceLanguage ctx (checkedService sourceLanguage spec) modules---- | Execute a module plan while retaining both the effective semantic contract--- and the source declaration provenance written to history. A mismatch refuses--- before checking or creating any output path.-executeServiceScaffold :: FilePath -> Bool -> FilePath -> SourceLanguage -> Context -> CheckedService -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport)-executeServiceScaffold = executeServiceScaffoldWithRuntimePackage Nothing--executeServiceScaffoldWithRuntimePackage :: Maybe RuntimePackageName -> FilePath -> Bool -> FilePath -> SourceLanguage -> Context -> CheckedService -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport)-executeServiceScaffoldWithRuntimePackage runtimePackage =-  executeServiceScaffoldWithRuntimePackageAndNameMigrations runtimePackage False--executeServiceScaffoldWithRuntimePackageAndNameMigrations :: Maybe RuntimePackageName -> Bool -> FilePath -> Bool -> FilePath -> SourceLanguage -> Context -> CheckedService -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport)-executeServiceScaffoldWithRuntimePackageAndNameMigrations runtimePackage applyNameMigrations out forceGeneratedOverwrite specPath sourceLanguage ctx service plannedModules-  | effectiveLanguageContract sourceLanguage /= checkedLanguageContract service =-      pure (Left [SemanticContractMismatch "source provenance and checked service selected different effective language contracts"])-  | otherwise = case packagePlan of-      Left failures -> pure (Left (map ConformancePackageRefusal failures))-      Right plannedPackage -> do-        sidecarResult <- planSidecarMigrations out (ContextSidecars (specContext spec)) plannedPackage-        case sidecarResult of-          Left reasons -> pure (Left [SidecarMigrationRefusal reasons])-          Right preparedSidecars-            | not (null preparedSidecars) && not applyNameMigrations ->-                pure (Left [SidecarMigrationRequired (map preparedSidecarMove preparedSidecars)])-            | otherwise -> do-                applyPreparedSidecarMoves out preparedSidecars-                let moves = map preparedSidecarMove preparedSidecars-                    -- Past this point the renames are on disk, so a later-                    -- refusal's "nothing was written" needs qualifying.-                    noteApplied = withSidecarMovesApplied moves-                result <- case plannedPackage of-                  Nothing -> executeCheckedScaffold moves Nothing-                  Just package -> do-                    preparedPackage <- preflightConformancePackage out forceGeneratedOverwrite package-                    case preparedPackage of-                      Left failures -> pure (Left (map ConformancePackageRefusal failures))-                      Right packageReady -> executeCheckedScaffold moves (Just packageReady)-                pure (either (Left . noteApplied) Right result)-  where-    spec = checkedSpec service-    modules = stampGeneratedModules (checkedLanguageContract service) plannedModules-    facadeModule = case runtimePackage of-      Nothing -> Nothing-      Just _ -> Just (serviceConformanceModuleName ctx)-    packagePlan =-      traverse-        (\packageName -> planConformancePackage (StandaloneConformanceService (contextName ctx)) packageName (serviceConformanceModuleName ctx) service)-        runtimePackage-    executeCheckedScaffold sidecarMoves preparedPackage =-      case deriveBehaviorRequirementsForService service of-        Left errors -> pure (Left [BehaviorRefusal errors])-        Right requirements -> do-          bannerless <- if forceGeneratedOverwrite then pure [] else missingGeneratedBanners out modules-          if not (null bannerless)-            then pure (Left [MissingGeneratedBanner bannerless])-            else do-              let recordPath = out </> recordFileName (specContext spec)-              previousRecord <- readRecord recordPath-              case planRecordedSourceMoves previousRecord modules of-                Left moveErrors -> pure (Left [NameMigrationRefusal [T.pack (show moveError) | moveError <- NE.toList moveErrors]])-                Right moves -> do-                  preparedMoves <- preflightSourceMoves out moves-                  case preparedMoves of-                    Left moveErrors -> pure (Left [NameMigrationRefusal moveErrors])-                    Right prepared-                      | not (null prepared) && not applyNameMigrations ->-                          pure (Left [NameMigrationRequired (map preparedSourceMove prepared)])-                      | otherwise -> do-                          applyPreparedSourceMoves out prepared-                          stale <- maybe (pure []) (existingStale out modules) previousRecord-                          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-                                  then Nothing-                                  else Just (SourceLanguageDrift (recSourceLanguage previous) sourceLanguage)-                              currentObligations = either (const []) id (bindingHolesForService service)-                              newHoles = maybe [] (newBindingObligations currentObligations . recBindingObligations) previousRecord-                              currentBehavior = behaviorRecordRows requirements-                              (addedBehavior, removedBehavior) = maybe (currentBehavior, []) (behaviorDrift currentBehavior . recBehaviorRequirements) previousRecord-                          createDirectoryIfMissing True out-                          dispositions <- mapM (writeModule out) modules-                          let manifestPath = out </> contextCabalFragmentFileName (specContext spec)-                          TIO.writeFile manifestPath (renderManifestForServiceWithFacade facadeModule (T.pack specPath) modules service)-                          TIO.writeFile recordPath (renderRecord (currentRecord specPath sourceLanguage ctx service modules queryHistoryBaseline currentBehavior currentSemanticImpact))-                          packageReport <- traverse executePreparedConformancePackage preparedPackage-                          pure $-                            Right-                              ScaffoldReport-                                { reportSpecPath = specPath,-                                  reportOutDir = out,-                                  reportContext = ctx,-                                  reportDispositions = dispositions,-                                  reportInertNodes = inertNodesOf spec,-                                  reportManifestPath = manifestPath,-                                  reportRecordPath = recordPath,-                                  reportPreviousSpecPath = recSpecPath <$> previousRecord,-                                  reportStale = stale,-                                  reportConsumerPlan = currentConsumerPlan,-                                  reportConstraintPlan = 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 = obsoleteGeneratedOutputHooksForService service,-                                  reportConformancePackage = packageReport,-                                  reportNameMoves = map preparedSourceMove prepared,-                                  reportSidecarMoves = sidecarMoves-                                }--planRecordedSourceMoves :: Maybe ScaffoldRecord -> [ScaffoldModule] -> Either (NE.NonEmpty SourceMoveError) [SourceMove]-planRecordedSourceMoves Nothing _ = Right []-planRecordedSourceMoves (Just previous) current =-  planSourceMoves priorArtifacts current-  where-    priorArtifacts = case recModuleRoles previous of-      [] -> [(Nothing, fileKind, path) | (fileKind, path) <- recFiles previous]-      rows -> [(Just (srrRole row), srrKind row, srrPath row) | row <- rows]--data PreparedSourceMove-  = SourceMoveReady !SourceMove !Text-  | SourceMoveAlreadyApplied !SourceMove--preparedSourceMove :: PreparedSourceMove -> SourceMove-preparedSourceMove = \case-  SourceMoveReady move _ -> move-  SourceMoveAlreadyApplied move -> move--preflightSourceMoves :: FilePath -> [SourceMove] -> IO (Either [Text] [PreparedSourceMove])-preflightSourceMoves out moves = do-  prepared <- mapM preflight moves-  let errors = [message | Left message <- prepared]-  pure $ if null errors then Right [value | Right value <- prepared] else Left errors-  where-    replacements = Map.fromList [(moveOldModule move, moveNewModule move) | move <- moves]-    preflight move = do-      let oldPath = out </> moveOldPath move-          newPath = out </> moveNewPath move-          backupPath = out </> moveBackupPath move-          preparedPath = preparedSourcePath out move-          statePath = sourceMoveStatePath out move-      oldExists <- doesFileExist oldPath-      newExists <- doesFileExist newPath-      backupExists <- doesFileExist backupPath-      preparedExists <- doesFileExist preparedPath-      stateExists <- doesFileExist statePath-      case (oldExists, backupExists) of-        (True, True) -> conflict move newExists backupExists preparedExists "both legacy source and backup exist"-        (False, False) ->-          if newExists-            then conflict move newExists backupExists preparedExists "target exists without a recoverable legacy source"-            else pure (Left (T.pack (moveOldPath move) <> ": recorded legacy source is missing"))-        _ -> do-          source <- TIO.readFile (if oldExists then oldPath else backupPath)-          if moveKind move == Generated && not (any isGeneratedBannerLine (T.lines source))-            then pure (Left (T.pack (moveOldPath move) <> ": generated source lacks an exact generated banner"))-            else case rewriteHaskellModuleReferences replacements source of-              Left lexicalError -> pure (Left (T.pack (moveOldPath move) <> ": " <> T.pack (show lexicalError)))-              Right rewritten-                | not (declaresExpectedModule (moveNewModule move) rewritten) ->-                    pure-                      ( Left-                          ( T.pack (moveOldPath move)-                              <> ": transformed source does not declare expected module "-                              <> moveNewModule move-                          )-                      )-                | otherwise -> do-                    let hydrated =-                          move-                            { moveContentDigest = Just (contentDigest source),-                              moveTransformedDigest = Just (contentDigest rewritten)-                            }-                        expectedState = renderSourceMoveState hydrated-                    stateError <- verifyOptionalText stateExists statePath expectedState "migration state"-                    preparedError <- verifyOptionalDigest preparedExists preparedPath (contentDigest rewritten) "prepared source"-                    targetError <- verifyOptionalDigest newExists newPath (contentDigest rewritten) "target source"-                    case [message | Just message <- [stateError, preparedError, targetError]] of-                      message : _ -> pure (Left (T.pack (moveOldPath move) <> ": " <> message))-                      []-                        | newExists && not backupExists && not oldExists -> conflict hydrated newExists backupExists preparedExists "target has no recoverable backup"-                        | newExists && backupExists && not oldExists -> pure (Right (SourceMoveAlreadyApplied hydrated))-                        | otherwise -> pure (Right (SourceMoveReady hydrated rewritten))--    conflict move newExists backupExists preparedExists reason =-      pure-        ( Left-            ( T.pack (moveOldPath move)-                <> ": migration state conflicts ("-                <> reason-                <> "; target="-                <> T.pack (show newExists)-                <> ", backup="-                <> T.pack (show backupExists)-                <> ", prepared="-                <> T.pack (show preparedExists)-                <> ")"-            )-        )--    verifyOptionalText False _ _ _ = pure Nothing-    verifyOptionalText True path expected label = do-      actual <- TIO.readFile path-      pure $ if actual == expected then Nothing else Just (label <> " digest/path evidence does not match")--    verifyOptionalDigest False _ _ _ = pure Nothing-    verifyOptionalDigest True path expected label = do-      actual <- contentDigest <$> TIO.readFile path-      pure $ if actual == expected then Nothing else Just (label <> " digest does not match " <> expected)--    declaresExpectedModule expected source =-      any (T.isPrefixOf ("module " <> expected <> " ")) (T.lines source)-        || any (== ("module " <> expected)) (T.lines source)--applyPreparedSourceMoves :: FilePath -> [PreparedSourceMove] -> IO ()-applyPreparedSourceMoves out prepared = do-  -- Prepare every transformed file and durable digest record before moving a-  -- single active source.  The temporary file lives beside its destination,-  -- so installation is a same-filesystem rename.-  mapM_ prepareMove prepared-  mapM_ backupMove prepared-  mapM_ installMove prepared-  where-    prepareMove preparedMove = do-      let move = preparedSourceMove preparedMove-          statePath = sourceMoveStatePath out move-      createDirectoryIfMissing True (takeDirectory statePath)-      TIO.writeFile statePath (renderSourceMoveState move)-      case preparedMove of-        SourceMoveAlreadyApplied _ -> pure ()-        SourceMoveReady _ rewritten -> do-          let path = preparedSourcePath out move-          createDirectoryIfMissing True (takeDirectory path)-          exists <- doesFileExist path-          if exists then pure () else TIO.writeFile path rewritten--    backupMove (SourceMoveAlreadyApplied _) = pure ()-    backupMove (SourceMoveReady move _) = do-      let oldPath = out </> moveOldPath move-          backupPath = out </> moveBackupPath move-      oldExists <- doesFileExist oldPath-      if oldExists-        then do-          createDirectoryIfMissing True (takeDirectory backupPath)-          renameFile oldPath backupPath-        else pure ()--    installMove preparedMove = do-      let move = preparedSourceMove preparedMove-          preparedPath = preparedSourcePath out move-          newPath = out </> moveNewPath move-      newExists <- doesFileExist newPath-      preparedExists <- doesFileExist preparedPath-      if newExists-        then if preparedExists then removeFile preparedPath else pure ()-        else do-          createDirectoryIfMissing True (takeDirectory newPath)-          renameFile preparedPath newPath--preparedSourcePath :: FilePath -> SourceMove -> FilePath-preparedSourcePath out move = out </> (moveNewPath move <> ".keiro-dsl-name-migration-prepared")--sourceMoveStatePath :: FilePath -> SourceMove -> FilePath-sourceMoveStatePath out move = out </> (moveBackupPath move <> ".keiro-dsl-name-migration-state")--renderSourceMoveState :: SourceMove -> Text-renderSourceMoveState move =-  T.unlines-    [ "keiro-dsl-name-migration-state v1",-      "old-path " <> T.pack (moveOldPath move),-      "new-path " <> T.pack (moveNewPath move),-      "old-module " <> moveOldModule move,-      "new-module " <> moveNewModule move,-      "source-digest " <> maybe "<missing>" id (moveContentDigest move),-      "transformed-digest " <> maybe "<missing>" id (moveTransformedDigest move)-    ]--constraintPlanForService :: CheckedService -> ConsumerPlan -> [Text]-constraintPlanForService service plan = case checkedTypeGraph service of-  Left _ -> []-  Right graph ->-    let registerRoots =-          Set.fromList-            [ key-            | RootRegister _ _ key <- tgUseSites graph-            ]-     in map (constraintFor registerRoots) (consumerMappings plan)-  where-    constraintFor registerRoots mapping =-      mappingSpecName mapping-        <> ": "-        <> T.intercalate ", " (baseConstraints mapping <> registerConstraints registerRoots mapping)-    baseConstraints StructuralMapping {} = ["Eq", "Show", "CanonicalTypeName", "StructuralBinding"]-    baseConstraints OpaqueMapping {} = ["Eq", "Show", "ToJSON", "FromJSON"]-    baseConstraints NominalMapping {} = ["Eq", "Show", "NominalBinding"]-    registerConstraints roots mapping-      | MappedKey (mappingSpecName mapping) `Set.member` roots = ["register initial", "snapshot ToJSON", "snapshot FromJSON"]-      | otherwise = []--mappingDrift :: [MappingIdentity] -> [MappingIdentity] -> [MappingDrift]-mappingDrift current previous =-  [ MappingDrift name old new-  | name <- Set.toAscList (Map.keysSet oldByName <> Map.keysSet newByName),-    let old = Map.lookup name oldByName,-    let new = Map.lookup name newByName,-    old /= new-  ]-  where-    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-  | obligation <- current,-    obligation `Set.notMember` previousSet-  ]-  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],-    [row | row <- sortOn behaviorRecordKey previous, behaviorRecordKey row `Set.notMember` currentKeys]-  )-  where-    currentKeys = Set.fromList (map behaviorRecordKey current)-    previousKeys = Set.fromList (map behaviorRecordKey previous)--readRecord :: FilePath -> IO (Maybe ScaffoldRecord)-readRecord path = do-  exists <- doesFileExist path-  if exists then parseRecord <$> TIO.readFile path else pure Nothing--existingStale :: FilePath -> [ScaffoldModule] -> ScaffoldRecord -> IO [StaleModule]-existingStale out modules record = staleAgainst out (map modulePath modules) (recFiles record)---- | The files a previous run recorded that the current plan no longer produces--- and that are still on disk. keiro-dsl never deletes; this is what the report--- lists for a human to review.-staleAgainst :: FilePath -> [FilePath] -> [(ModuleKind, FilePath)] -> IO [StaleModule]-staleAgainst out currentPathList previous = fmap concat $ mapM stillExists removed-  where-    currentPaths = Set.fromList currentPathList-    removed = [(fileKind, path) | (fileKind, path) <- previous, path `Set.notMember` currentPaths]-    stillExists (fileKind, path) = do-      let fullPath = out </> path-      exists <- doesFileExist fullPath-      if not exists-        then pure []-        else do-          evidence <- case fileKind of-            HoleStub -> pure Nothing-            Generated -> do-              contents <- TIO.readFile fullPath-              pure . Just $-                if any isGeneratedBannerLine (T.lines contents)-                  then ExactGeneratedBannerPresent-                  else ExactGeneratedBannerMissing-          pure [StaleModule fileKind path evidence]--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,-      recLayout = case placement ctx of GeneratedPrefix -> "prefixed"; CollocatedLeaf -> "collocated",-      recSourceLanguage = sourceLanguage,-      recLanguageContract = checkedLanguageContract service,-      recNamingEdition = currentGeneratedHaskellNamingEdition,-      recModuleRoles = [ScaffoldModuleRoleRow (moduleRole m) (kind m) (modulePath m) | m <- modules],-      recFiles = [(kind m, modulePath m) | m <- modules],-      recMappings = consumerMappings (consumerPlanForService service),-      recIdDomains = idDomainIdentitiesForService service,-      recNominalEqualities = nominalEqualityIdentitiesForService service,-      recBindingObligations = either (const []) id (bindingHolesForService service),-      recBehaviorRequirements = currentBehavior,-      recProjectionCatalogFacts = projectionCatalogFactsForService service,-      recQueryContractBaseline = queryHistoryBaseline,-      recQueryContracts = either (const []) id (queryContractIdentitiesForService service),-      recRouterSelections = routerSelectionSnapshots service,-      recSemanticImpact = Just currentSemanticImpact-    }--missingGeneratedBanners :: FilePath -> [ScaffoldModule] -> IO [FilePath]-missingGeneratedBanners out modules = fmap concat $ mapM check generated-  where-    generated = [m | m <- modules, kind m == Generated]-    check m = do-      let path = out </> modulePath m-      exists <- doesFileExist path-      if not exists-        then pure []-        else do-          contents <- TIO.readFile path-          pure [modulePath m | not (any isGeneratedBannerLine (T.lines contents))]--writeModule :: FilePath -> ScaffoldModule -> IO (ScaffoldModule, WriteDisposition)-writeModule out m = do-  let path = out </> modulePath m-  createDirectoryIfMissing True (takeDirectory path)-  case kind m of-    Generated -> do-      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-        then pure (m, Skipped)-        else TIO.writeFile path (moduleText m) >> pure (m, Created)---- | Qualify a refusal set raised after the run's sidecar renames were applied.------ Every refusal message says "nothing was written", which is true of the module--- tree but not of the renames, so the note is appended rather than the claim--- being weakened everywhere. A refusal set that is empty stays empty.-withSidecarMovesApplied :: [SidecarMove] -> [Refusal] -> [Refusal]-withSidecarMovesApplied [] refusals = refusals-withSidecarMovesApplied _ [] = []-withSidecarMovesApplied moves refusals = refusals <> [SidecarMovesAlreadyApplied moves]--renderRefusals :: [Refusal] -> [Text]-renderRefusals = concatMap render-  where-    render (PathCollision path origins) =-      [ "error: module path collision -- refusing to scaffold; nothing was written",-        "  " <> T.pack path-      ]-        <> ["    from " <> source | source <- origins]-    render (FirewallBreach breaches) =-      [ "error: firewall breach -- refusing to scaffold; nothing was written",-        "firewall: BREACH (" <> tshow (length breaches) <> " forbidden token occurrence(s)):"-      ]-        <> ["  " <> T.pack path <> ":" <> tshow line <> " contains " <> token | (path, token, line) <- breaches]-    render (LoweringRefusal refusals) =-      ["error: scaffold cannot lower this spec faithfully -- refusing; nothing was written"]-        <> map ("  " <>) refusals-    render (MissingGeneratedBanner paths) =-      [ "error: refusing to overwrite " <> tshow (length paths) <> " file(s) at Generated paths that lack the '-- @generated' banner"-      ]-        <> map ("  " <>) (map T.pack paths)-        <> ["  (adopted as hand code? move it, or re-run with --force-generated-overwrite)", "nothing was written"]-    render (ImportCycle path) =-      [ "error: generated/consumer import cycle -- refusing to scaffold; nothing was written",-        "  " <> T.intercalate " -> " path,-        "  keep bindings in a leaf module that imports only Structural.Shape.* and Keiro.Codec.Structural"-      ]-    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-    render (NameMigrationRequired moves) =-      [ "error: name migration required: legacy-v1 -> idiomatic-v1; nothing was written",-        "re-run scaffold with --apply-name-migrations after reviewing these source moves:"-      ]-        <> map renderMove moves-    render (NameMigrationRefusal reasons) =-      ["error: name migration could not be applied safely; nothing was written"]-        <> map ("  " <>) reasons-    render (SidecarMigrationRequired moves) =-      [ "error: sidecar migration required; nothing was written",-        "re-run scaffold with --apply-name-migrations after reviewing these sidecar renames:"-      ]-        <> map (("  " <>) . renderSidecarMove) moves-    render (SidecarMigrationRefusal reasons) =-      ["error: sidecar migration could not be applied safely; nothing was written"]-        <> map ("  " <>) reasons-    render (SidecarMovesAlreadyApplied moves) =-      [ "note: this run had already applied "-          <> tshow (length moves)-          <> " sidecar rename(s) before the refusal above, so \"nothing was written\" excludes them:"-      ]-        <> map (("  " <>) . renderSidecarMove) moves-        <> [ "The renames are idempotent and carry no spec content, so re-running scaffold",-             "after fixing the refusal is correct; nothing needs to be undone."-           ]-    render (FoldSurfaceRefusal surfaceError) =-      [ "error: aggregate fold identity could not be resolved -- refusing to scaffold; nothing was written",-        "  " <> renderFoldSurfaceError surfaceError-      ]-    render (SemanticContractMismatch detail) =-      [ "error: semantic language contract mismatch -- refusing to scaffold; nothing was written",-        "  " <> detail-      ]-    render (GoldenRootDivergence root paths) =-      [ "error: golden payload fixtures live beside a workspace member instead of under the workspace golden root -- refusing to scaffold"-      ]-        <> ["  " <> T.pack path | path <- paths]-        <> [ "  move these files under " <> T.pack root <> "; keiro-dsl reads one golden root per workspace",-             "  (a fixture the root lacks would be silently replaced by a synthesized stand-in)",-             "nothing was written"-           ]-    render (DuplicateConformanceFactKeys duplicates) =-      ["error: duplicate normalized service conformance fact keys -- refusing to scaffold; nothing was written"]-        <> ["  " <> duplicateServiceFactKey duplicate | duplicate <- duplicates]-    render (ConformancePackageRefusal failure) = renderConformancePackageFailure failure-    renderMove move =-      "  "-        <> (case moveKind move of Generated -> "generated "; HoleStub -> "hole      ")-        <> moveOldModule move-        <> " -> "-        <> moveNewModule move-        <> "  backup: "-        <> T.pack (moveBackupPath move)--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 <> ")"-  ]-    <> map moduleLine dispositions-    <> inertNodeSection-    <> [ "firewall: OK (" <> tshow generatedCount <> " generated modules scanned, 0 forbidden operators)",-         harnessLine,-         dependencyLine,-         "fragment: " <> T.pack (reportManifestPath report),-         "ledger:   " <> T.pack (reportRecordPath report)-       ]-    <> previousSpecNote-    <> constraintSection-    <> newHolesSection-    <> queryContractSection-    <> queryContractMigrationSection-    <> mappingDriftSection-    <> renderSemanticImpactReport (reportSemanticImpact report)-    <> renderRouterSelectionDrift (reportRouterSelectionDrift report)-    <> maybe [] renderProjectionMappedImpact (reportProjectionMappedImpact report)-    <> renderGeneratedArtifactImpact (reportSemanticImpact report) (reportGeneratedArtifactImpact report)-    <> sourceLanguageDriftSection-    <> behaviorDriftSection-    <> obsoleteOutputSection-    <> sidecarMoveSection-    <> nameMoveSection-    <> staleSection-    <> maybe [] renderConformancePackageReport (reportConformancePackage report)-  where-    ctx = reportContext report-    dispositions = reportDispositions report-    rootLabel = if T.null (moduleRoot ctx) then "(none)" else moduleRoot ctx-    layoutLabel = case placement ctx of GeneratedPrefix -> "prefixed"; CollocatedLeaf -> "collocated"-    names = [moduleNameOf (modulePath m) | (m, _) <- dispositions]-    nameWidth = maximum (1 : map T.length names)-    moduleLine (m, disposition) =-      "  " <> kindTag (kind m) <> "  " <> pad (moduleNameOf (modulePath m)) <> "  " <> dispositionTag disposition-    kindTag Generated = "generated"-    kindTag HoleStub = "hole     "-    dispositionTag Overwritten = "(overwritten)"-    dispositionTag Created = "(created)"-    dispositionTag Skipped = "(skipped: already present)"-    dispositionTag Unchanged = "(unchanged)"-    pad name = name <> T.replicate (nameWidth - T.length name) " "-    generatedCount = length [() | (m, _) <- dispositions, kind m == Generated]-    inertNodeSection = renderInertNodeSection (reportInertNodes report)-    harnesses =-      sortOn-        id-        [ moduleNameOf (modulePath m)-        | (m, _) <- dispositions,-          any (`T.isSuffixOf` moduleNameOf (modulePath m)) [".Harness", ".ProcessHarness", ".WorkflowFacts"]-        ]-    harnessLine = case harnesses of-      [] -> "harness:  (none emitted)"-      _ -> "harness:  run `cabal test <your-component>` over " <> T.unwords harnesses-    dependencyLine =-      "dependency plan: consumer packages "-        <> renderBracketed (consumerPackages (reportConsumerPlan report))-        <> ", consumer modules "-        <> renderBracketed (consumerModules (reportConsumerPlan report))-    constraintSection = case reportConstraintPlan report of-      [] -> []-      constraints -> "constraint plan:" : map ("  " <>) constraints-    newHolesSection = case reportNewHoles report of-      [] -> []-      obligations ->-        ["newly required holes since last scaffold: " <> tshow (length obligations)]-          <> concatMap obligationLines obligations-    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-        | previous /= T.pack (reportSpecPath report) ->-            [ "note: the previous scaffold record used spec " <> previous,-              "      specs sharing context " <> contextName ctx <> " in one --out also share " <> T.pack (reportManifestPath report)-            ]-      _ -> []-    mappingDriftSection = case reportMappingDrift report of-      [] -> []-      drifts ->-        ["mapping drift: " <> tshow (length drifts) <> " declaration(s) changed since the previous scaffold:"]-          <> concatMap driftLines drifts-    driftLines drift =-      [ "  " <> driftSpecName drift,-        "    previous: " <> maybe "(absent)" renderMappingIdentity (driftPrevious drift),-        "    current:  " <> maybe "(absent)" renderMappingIdentity (driftCurrent drift)-      ]-    sourceLanguageDriftSection = case reportSourceLanguageDrift report of-      Nothing -> []-      Just drift ->-        [ "source-language drift: "-            <> sourceLanguageLabel (languageDriftPrevious drift)-            <> " -> "-            <> sourceLanguageLabel (languageDriftCurrent drift)-            <> " (generated module bytes are semantic and unaffected)"-        ]-    behaviorDriftSection =-      renderBehaviorRows "new behavior obligations" (reportAddedBehavior report)-        <> renderBehaviorRows "removed behavior obligations (consumer rows become stale)" (reportRemovedBehavior report)-    renderBehaviorRows _ [] = []-    renderBehaviorRows label rows =-      [label <> ": " <> tshow (length rows)] <> concatMap behaviorLines rows-    behaviorLines row =-      [ "  "-          <> behaviorRecordAggregate row-          <> ":"-          <> behaviorRecordSource row-          <> " -- "-          <> behaviorRecordCommand row-          <> "  "-          <> unBehaviorKey (behaviorRecordKey row),-        "    Pending (BehaviorKey " <> tshow (unBehaviorKey (behaviorRecordKey row)) <> ")"-      ]-    obsoleteOutputSection = case reportObsoleteOutputHooks report of-      [] -> []-      hooks ->-        ["obsolete identity-copy output hooks (if still present, they are unused and may be removed):"]-          <> ["  " <> aggregate <> ".Holes." <> hook | (aggregate, hook) <- hooks]-    sidecarMoveSection = case reportSidecarMoves report of-      [] -> []-      moves ->-        ["sidecar migration: applied (" <> tshow (length moves) <> " move(s))"]-          <> map (("  " <>) . renderSidecarMove) moves-    nameMoveSection = case reportNameMoves report of-      [] -> []-      moves ->-        ["name migration: applied (" <> tshow (length moves) <> " source move(s))"]-          <> ["  backup: " <> T.pack (moveBackupPath move) | move <- moves]-    staleSection = case reportStale report of-      [] -> []-      stale ->-        [ "stale: " <> tshow (length stale) <> " file(s) from a previous scaffold of context " <> contextName ctx <> " are no longer produced by this spec:"-        ]-          <> map staleLine stale-          <> ["note: keiro-dsl never deletes files."]-    staleLine stale = case (staleKind stale, staleGeneratedEvidence stale) of-      (Generated, Just ExactGeneratedBannerPresent) ->-        "  generated " <> T.pack (stalePath stale) <> "  (exact generated banner present; verify unchanged bytes before deleting)"-      (Generated, _) ->-        "  generated " <> T.pack (stalePath stale) <> "  (exact generated banner missing; preserve and review)"-      (HoleStub, _) -> "  hole      " <> T.pack (stalePath stale) <> "  (hand-owned — preserve and review)"--sourceLanguageLabel :: SourceLanguage -> Text-sourceLanguageLabel sourceLanguage =-  sourceFormText sourceLanguage-    <> "/effective-v"-    <> languageVersionText (effectiveLanguageVersion sourceLanguage)--obligationKindLabel :: BindingObligationKind -> Text-obligationKindLabel BindingValue = "binding"-obligationKindLabel FixtureValue = "fixtures"-obligationKindLabel InitialValue = "initial-value"--renderBracketed :: [Text] -> Text-renderBracketed values = "[" <> T.intercalate ", " values <> "]"--renderMappingIdentity :: MappingIdentity -> Text-renderMappingIdentity StructuralMapping {mappingPackage, mappingModule, mappingType, mappingBindingSymbol, mappingBindingVersion} =-  "structural "-    <> mappingPackage-    <> ":"-    <> mappingModule-    <> "."-    <> mappingType-    <> " binding="-    <> mappingBindingSymbol-    <> " version="-    <> mappingBindingVersion-renderMappingIdentity OpaqueMapping {mappingPackage, mappingModule, mappingType, mappingCodecIdentity, mappingCodecVersion} =-  "opaque "-    <> mappingPackage-    <> ":"-    <> mappingModule-    <> "."-    <> mappingType-    <> " codec="-    <> mappingCodecIdentity-    <> " version="-    <> mappingCodecVersion-renderMappingIdentity NominalMapping {mappingNominalCategory, mappingNominalRepresentation, mappingPackage, mappingModule, mappingType, mappingBindingSymbol, mappingBindingVersion} =-  "nominal-"-    <> mappingNominalCategory-    <> " "-    <> mappingPackage-    <> ":"-    <> mappingModule-    <> "."-    <> mappingType-    <> " representation="-    <> mappingNominalRepresentation-    <> " binding="-    <> mappingBindingSymbol-    <> " version="-    <> mappingBindingVersion+    LedgerRead (..),+    WriteDisposition (..),+    GeneratedArtifactCategory (..),+    GeneratedArtifactImpact (..),+    GeneratedHaskellEditionImpact (..),+    GeneratedHaskellEditionUse (..),+    HoleUseForm (..),+    PreparedGeneratedHaskellEditionMigration,+    preparedGeneratedHaskellEditionImpact,+    StaleGeneratedEvidence (..),+    StaleModule (..),+    MappingDrift (..),+    QueryContractMigration (..),+    SourceLanguageDrift (..),+    ScaffoldReport (..),+    scaffoldServiceModules,+    scaffoldServiceModulesWithGoldens,+    scaffoldModules,+    scaffoldModulesWithGoldens,+    planIndexedServiceScaffold,+    planIndexedServiceScaffoldWithGoldens,+    planIndexedServiceScaffoldWithRuntimePackage,+    planIndexedServiceScaffoldWithRuntimePackageAndGoldens,+    executeServiceScaffold,+    executeServiceScaffoldWithRuntimePackage,+    executeServiceScaffoldWithRuntimePackageAndNameMigrations,+    executeServiceScaffoldWithRuntimePackageAndMigrations,+    executeScaffold,+    executeScaffoldWithLanguage,+    renderRefusals,+    renderScaffoldReport,+    checkedSemanticImpactSnapshot,+    semanticImpactForMappingDrift,+    generatedArtifactImpact,+    renderSemanticImpactReport,+    renderGeneratedArtifactImpact,+    renderRouterSelectionDrift,++    -- * Shared with whole-workspace scaffolding ("Keiro.Dsl.WorkspaceScaffold")++    --+    -- $shared+    planningGatePipeline,+    planningRefusalDiagnostics,+    checkIndexedServiceDiagnostics,+    inertNodesOf,+    renderInertNodeSection,+    withSidecarMovesApplied,+    originLine,+    pureRefusalsForService,+    auditGeneratedHaskell,+    missingGeneratedBanners,+    staleAgainst,+    PreparedSourceMove,+    preparedSourceMove,+    preflightSourceMoves,+    applyPreparedSourceMoves,+    preflightGeneratedHaskellEditionMigration,+    applyPreparedGeneratedHaskellEditionMigration,+    withGeneratedHaskellEditionSourceMoves,+    generatedHaskellEditionBackupRoot,+    readRecord,+    ledgerToMaybe,+    constraintPlanForService,+    mappingDrift,+    behaviorDrift,+    newBindingObligations,+    queryContractMigrations,+    obligationKindLabel,+    renderMappingIdentity,+  )+where++import Data.ByteString qualified as BS+import Data.List (sort, sortOn)+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Keiro.Dsl.BehaviorCoverage (BehaviorDerivationError, BehaviorKey (..), BehaviorRecordRow (..), behaviorRecordRows, 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,+    ConformanceServiceKey (StandaloneConformanceService),+    executePreparedConformancePackage,+    planConformancePackage,+    preflightConformancePackage,+    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.GeneratedHaskellLanguage (idiomaticV2LabelMigrations)+import Keiro.Dsl.Goldens (GoldenPayload)+import Keiro.Dsl.Grammar (EmitNode (..), Loc (..), Node (..), OperationNode (..), PgmqDispatchNode (..), Spec (..))+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 (..), 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, 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, legacyContextRecordFileName)+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 (copyFile, createDirectoryIfMissing, doesFileExist, removeFile, renameFile)+import System.FilePath (takeDirectory, (</>))+import Text.Read (readMaybe)++-- $shared+-- These are the pieces whole-workspace scaffolding reuses verbatim rather than+-- reimplementing, so a workspace and a single spec can never disagree about what+-- counts as a refusal, what counts as stale, or how an identity renders.+-- "Keiro.Dsl.WorkspaceScaffold" cannot live in this module because+-- "Keiro.Dsl.Workspace" already imports it (its cross-member collision check asks+-- the planner), so the seam is exports rather than shared privates.++data Refusal+  = PathCollision !FilePath ![Text]+  | FirewallBreach ![(FilePath, Text, Int)]+  | LoweringRefusal ![Text]+  | 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.+    --       This is an internal/API misuse refusal and is detected before writes.+    SemanticContractMismatch !Text+  | -- | Golden payload fixtures found beside a workspace member that the one+    --       workspace golden root does not have. Raised only by the workspace path.+    GoldenRootDivergence !FilePath ![FilePath]+  | DuplicateConformanceFactKeys ![DuplicateServiceFactKey]+  | ConformancePackageRefusal !ConformancePackageFailure+  | GeneratedNameInvariantViolation ![Text]+  | NameMigrationRequired ![SourceMove]+  | NameMigrationRefusal ![Text]+  | SidecarMigrationRequired ![SidecarMove]+  | SidecarMigrationRefusal ![Text]+  | GeneratedHaskellEditionRequired !GeneratedHaskellEditionImpact+  | GeneratedHaskellEditionRefusal ![Text]+  | LedgerUnreadable !FilePath+  | -- | Not a refusal on its own: an accompanying note that the run had already+    --       applied its sidecar renames before a later gate refused. Every other+    --       refusal says "nothing was written", which without this note is false.+    --       The renames are idempotent and forward-consistent, so re-running after+    --       fixing the refusal is correct and needs no undo.+    SidecarMovesAlreadyApplied ![SidecarMove]+  deriving stock (Eq, Show)++data LedgerRead a+  = LedgerAbsent+  | LedgerParsed !a+  | LedgerReadUnreadable !FilePath+  deriving stock (Eq, Show)++data GeneratedHaskellEditionUse = GeneratedHaskellEditionUse+  { path :: !FilePath,+    line :: !Int,+    current :: !Text,+    replacement :: !Text,+    form :: !HoleUseForm+  }+  deriving stock (Eq, Ord, Show)++data HoleUseForm+  = PrefixApplication+  | QualifiedApplication+  | RecordDotRenamed+  | RecordFieldBinding+  | OperatorOperand+  deriving stock (Eq, Ord, Show)++data GeneratedHaskellEditionImpact = GeneratedHaskellEditionImpact+  { fromEdition :: !HaskellName.GeneratedHaskellNamingEdition,+    generatedPaths :: ![FilePath],+    sidecarPaths :: ![FilePath],+    handOwnedUses :: ![GeneratedHaskellEditionUse]+  }+  deriving stock (Eq, Show)++data PreparedGeneratedHaskellEditionMigration = PreparedGeneratedHaskellEditionMigration+  { impact :: !GeneratedHaskellEditionImpact,+    backups :: ![(FilePath, FilePath)],+    reportPath :: !FilePath,+    reportText :: !Text,+    sourceMoves :: ![SourceMove]+  }+  deriving stock (Eq, Show)++preparedGeneratedHaskellEditionImpact :: PreparedGeneratedHaskellEditionMigration -> GeneratedHaskellEditionImpact+preparedGeneratedHaskellEditionImpact = (.impact)++-- | 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+  { category :: !GeneratedArtifactCategory,+    role :: !ModuleRole,+    path :: !FilePath,+    disposition :: !WriteDisposition+  }+  deriving stock (Eq, Show)++data StaleGeneratedEvidence+  = ExactGeneratedBannerPresent+  | ExactGeneratedBannerMissing+  deriving stock (Eq, Show)++data StaleModule = StaleModule+  { kind :: !ModuleKind,+    path :: !FilePath,+    generatedEvidence :: !(Maybe StaleGeneratedEvidence)+  }+  deriving stock (Eq, Show)++data MappingDrift = MappingDrift+  { specName :: !Text,+    previous :: !(Maybe MappingIdentity),+    current :: !(Maybe MappingIdentity)+  }+  deriving stock (Eq, Show)++data SourceLanguageDrift = SourceLanguageDrift+  { previous :: !SourceLanguage,+    current :: !SourceLanguage+  }+  deriving stock (Eq, Show)++data ScaffoldReport = ScaffoldReport+  { specPath :: !FilePath,+    outDir :: !FilePath,+    context :: !Context,+    dispositions :: ![(ScaffoldModule, WriteDisposition)],+    inertNodes :: ![(Text, Text)],+    manifestPath :: !FilePath,+    recordPath :: !FilePath,+    previousSpecPath :: !(Maybe Text),+    stale :: ![StaleModule],+    consumerPlan :: !ConsumerPlan,+    constraintPlan :: ![Text],+    mappingDrift :: ![MappingDrift],+    queryContractBaselineUnavailable :: !Bool,+    queryContractDrift :: ![QueryContractDrift],+    queryContractMigrations :: ![QueryContractMigration],+    semanticImpact :: !SemanticImpactReport,+    routerSelectionDrift :: ![RouterSelectionDrift],+    projectionMappedImpact :: !(Maybe ProjectionMappedImpact),+    generatedArtifactImpact :: ![GeneratedArtifactImpact],+    sourceLanguageDrift :: !(Maybe SourceLanguageDrift),+    newHoles :: ![BindingHole],+    addedBehavior :: ![BehaviorRecordRow],+    removedBehavior :: ![BehaviorRecordRow],+    obsoleteOutputHooks :: ![(Text, Text)],+    conformancePackage :: !(Maybe ConformancePackageReport),+    nameMoves :: ![SourceMove],+    sidecarMoves :: ![SidecarMove]+  }+  deriving stock (Eq, Show)++data QueryContractMigration = QueryContractMigration+  { owner :: !Text,+    path :: !FilePath,+    requiredImport :: !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.+scaffoldServiceModules :: Context -> CheckedService -> [ScaffoldModule]+scaffoldServiceModules = scaffoldServiceModulesWithGoldens []++scaffoldServiceModulesWithGoldens :: [GoldenPayload] -> Context -> CheckedService -> [ScaffoldModule]+scaffoldServiceModulesWithGoldens goldens = scaffoldServiceModulesWithBehaviorSource goldens []++scaffoldServiceModulesWithBehaviorSource :: [GoldenPayload] -> [BehaviorSource.BehaviorSourceEntry] -> Context -> CheckedService -> [ScaffoldModule]+scaffoldServiceModulesWithBehaviorSource goldens sourceEntries ctx service =+  map modernizeScaffoldModule $+    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 -> 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 -> 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 _ -> []+            NOperation _ -> []+        | node <- (.nodes) spec+        ]+  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 []++scaffoldModulesWithGoldens :: [GoldenPayload] -> Context -> Spec -> [ScaffoldModule]+scaffoldModulesWithGoldens goldens ctx = scaffoldServiceModulesWithGoldens goldens ctx . legacyCheckedService++-- | 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++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.+planIndexedServiceScaffoldWithRuntimePackage :: Maybe RuntimePackageName -> SemanticSourceIndex -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule]+planIndexedServiceScaffoldWithRuntimePackage = planIndexedServiceScaffoldWithRuntimePackageAndGoldens []++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)+    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)+              (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+-- drift by input shape.+planningGatePipeline ::+  Context ->+  CheckedService ->+  Either [Refusal] [ScaffoldModule] ->+  Either [Refusal] () ->+  Either [Refusal] [ScaffoldModule]+planningGatePipeline ctx service modulePlan packagePlan =+  case traverse (aggregateFoldSurfaceForService service) [aggregate | NAggregate aggregate <- (.nodes) spec] of+    Left surfaceError -> Left [FoldSurfaceRefusal surfaceError]+    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 pureRefusalsForService ctx service modules of+            [] -> Right modules+            refusals -> Left refusals+  where+    spec = checkedSpec service++-- | The nodes a spec declares that contribute no generated module.+--+-- They are still parsed, validated, and diff-classified; naming them in the+-- scaffold report is what stops an author from concluding the toolchain lost+-- their declaration. Shared by the single-spec and workspace planners so a+-- workspace — the recommended layout — reports exactly what one spec reports.+inertNodesOf :: Spec -> [(Text, Text)]+inertNodesOf spec =+  [ (kindLabel, nodeName)+  | node <- (.nodes) spec,+    (kindLabel, nodeName) <- case node of+      NEmit emitNode -> [("emit", (.name) emitNode)]+      NPgmqDispatch dispatchNode -> [("dispatch", (.name) dispatchNode)]+      NOperation operationNode -> [("operation", (.name) operationNode)]+      _ -> []+  ]++-- | The report line naming 'inertNodesOf', or nothing when every declaration+-- produced a module.+renderInertNodeSection :: [(Text, Text)] -> [Text]+renderInertNodeSection = \case+  [] -> []+  nodes ->+    [ "no-modules: "+        <> T.intercalate ", " [kindLabel <> " " <> nodeName | (kindLabel, nodeName) <- nodes]+        <> " (validated and diff-classified; no generated modules)"+    ]++-- | 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 planIndexedServiceScaffoldWithRuntimePackage runtimePackage sourceIndex ctx service of+          Right _ -> []+          Left refusals -> planningRefusalDiagnostics refusals+  where+    validationDiagnostics = validateService service+    blocksPlanning diagnostic =+      (.severity) diagnostic == Error+        && (.code) diagnostic /= GeneratedOccurrenceCollision++-- | Present pure planning refusals through check's stable located diagnostic+-- vocabulary. Planner-invariant failures retain the detailed scaffold refusal+-- text in their message while receiving one machine code.+planningRefusalDiagnostics :: [Refusal] -> [Diagnostic]+planningRefusalDiagnostics = concatMap diagnosticsFor+  where+    diagnosticsFor (PathCollision path origins) = [pathCollisionDiagnostic path origins]+    diagnosticsFor (ImportCycle path) =+      [ planningError 1 GeneratedImportCycle $+          "generated/consumer import cycle "+            <> T.intercalate " -> " path+            <> "; keep bindings in a leaf module that imports only Structural.Shape.* and Keiro.Codec.Structural"+      ]+    diagnosticsFor (BehaviorRefusal errors) =+      [ planningError (behaviorErrorLine behaviorError) BehaviorDerivationInvalid $+          "behavior obligations cannot be derived soundly: " <> T.pack (show behaviorError)+      | behaviorError <- errors+      ]+    diagnosticsFor (BehaviorSourceRefusal failures) =+      [ planningError (behaviorSourceFailureLine failure) (behaviorSourceDiagnosticCode failure) $+          "behavior source map cannot be planned for "+            <> Behavior.unBehaviorKey ((.key) failure)+            <> " ("+            <> (.aggregate) failure+            <> ":"+            <> (.state) failure+            <> " -- "+            <> (.command) failure+            <> ", subject="+            <> T.pack (show ((.sourceSubject) failure))+            <> "): "+            <> (.message) failure+      | failure <- failures+      ]+    diagnosticsFor (DuplicateConformanceFactKeys duplicates) =+      [ planningError 1 ConformanceFactKeyCollision $+          "normalized service conformance fact key '"+            <> (.duplicateServiceFactKey) duplicate+            <> "' is produced more than once"+      | duplicate <- duplicates+      ]+    diagnosticsFor refusal =+      [ planningError 1 GeneratedPlanningInvariantViolation $+          "validated service failed an internal scaffold-planning invariant: "+            <> T.intercalate " | " (renderRefusals [refusal])+      ]++    pathCollisionDiagnostic path origins =+      Diagnostic+        { line = primaryLine,+          severity = Error,+          code = GeneratedPathCollision,+          relatedLocations =+            [ (claimLine, "claimed here by " <> claimOrigin)+            | (claimLine, claimOrigin) <- remainingClaims+            ],+          message =+            "generated module path '"+              <> T.pack path+              <> "' is claimed more than once; on a case-insensitive filesystem these are one file; claimants: "+              <> T.intercalate "; " origins+        }+      where+        orderedClaims = reverse (sortOn fst [(claimLine, claimOrigin) | claimOrigin <- origins, Just claimLine <- [originLine claimOrigin]])+        (primaryLine, remainingClaims) = case orderedClaims of+          (claimLine, _) : rest -> (claimLine, rest)+          [] -> (1, [])++    behaviorErrorLine (Behavior.DuplicateBehaviorIdentity _ locations) = maximum (1 : map (.unLoc) locations)+    behaviorErrorLine _ = 1++    behaviorSourceFailureLine failure = case (.span) failure of+      Just SourceSpan {start = SourcePoint {line = sourceLine}} -> sourceLine+      Nothing -> 1+    behaviorSourceDiagnosticCode failure = case (.code) failure of+      BehaviorSource.BehaviorSourceAnchorMissing -> BehaviorSourceAnchorMissing+      BehaviorSource.BehaviorSourceAnchorInexact -> BehaviorSourceAnchorInexact+      BehaviorSource.BehaviorSourceAnchorCollision -> BehaviorSourceAnchorCollision++    planningError diagnosticLine diagnosticCode diagnosticMessage =+      Diagnostic+        { line = diagnosticLine,+          severity = Error,+          code = diagnosticCode,+          relatedLocations = [],+          message = diagnosticMessage+        }++-- | Recover the source line embedded in a generated module's origin text,+-- which scaffold formats as @<kind> <name> (line N)@.+originLine :: Text -> Maybe Int+originLine originText = do+  withoutClose <- T.stripSuffix ")" originText+  let (before, after) = T.breakOnEnd " (line " withoutClose+  if T.null before then Nothing else readMaybe (T.unpack after)++-- | 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.+pureRefusalsForService :: Context -> CheckedService -> [ScaffoldModule] -> [Refusal]+pureRefusalsForService ctx service modules =+  collisionRefusals modules+    <> dependencyRefusalsForService ctx service modules+    <> [FirewallBreach breaches | not (null breaches)]+    <> [GeneratedNameInvariantViolation namingViolations | not (null namingViolations)]+    <> [LoweringRefusal lowering | let lowering = scaffoldRefusalsForService service, not (null lowering)]+    <> [BehaviorRefusal errors | Left errors <- [deriveBehaviorRequirementsForService service]]+  where+    breaches = firewallBreaches modules+    namingViolations = generatedNameInvariantViolations modules++generatedNameInvariantViolations :: [ScaffoldModule] -> [Text]+generatedNameInvariantViolations = concatMap auditGeneratedHaskell++-- | Inventory and check declarations in one generated source file.  The+-- lexical mask keeps comments and literals out of the declaration inventory;+-- this is deliberately a final defense after the typed naming plan, so a+-- literal template declaration cannot bypass the checked constructors.+auditGeneratedHaskell :: ScaffoldModule -> [Text]+auditGeneratedHaskell scaffoldModule = lexicalErrors <> declarationErrors <> duplicateDeclarationErrors <> occurrenceErrors+  where+    expectedModule = moduleNameOf ((.path) scaffoldModule)+    (lexicalErrors, codeSource) = case maskNonCode ((.text) scaffoldModule) of+      Left message -> ([prefix 1 <> message], "")+      Right masked -> ([], masked)+    sourceLines = zip [1 :: Int ..] (T.lines codeSource)+    declarationErrors = moduleDeclarationErrors <> moduleSegmentErrors+    moduleDeclarationErrors = case declaredModuleName codeSource of+      Nothing -> [T.pack ((.path) scaffoldModule) <> ": missing Haskell module declaration"]+      Just declared+        | declared == expectedModule -> []+        | otherwise ->+            [ T.pack ((.path) scaffoldModule)+                <> ": declares "+                <> declared+                <> " but its planned module is "+                <> expectedModule+            ]+    moduleSegmentErrors =+      [ prefix 1 <> "module segment '" <> segment <> "' is not UpperCamelCase"+      | segment <- T.splitOn "." expectedModule,+        isLeftName (HaskellName.checkedModuleSegment (auditSite HaskellName.NodeModuleSite segment 1) segment)+      ]+    occurrenceErrors =+      concat+        [ checkCandidates lineNumber (signatureCandidates sourceLine)+            <> checkCandidates lineNumber (typeCandidates sourceLine)+            <> checkCandidates lineNumber (constructorCandidates sourceLine)+            <> checkCandidates lineNumber (topLevelValueCandidates sourceLine)+        | (lineNumber, sourceLine) <- sourceLines+        ]++    duplicateDeclarationErrors = duplicateErrors "top-level type signature" signatureCandidates <> duplicateErrors "top-level type declaration" typeCandidates+    duplicateErrors label candidates =+      [ prefix laterLine+          <> "repeated "+          <> label+          <> " '"+          <> candidate+          <> "' (first declared at line "+          <> tshow firstLine+          <> ")"+      | (candidate, declarationLines) <- Map.toAscList declarations,+        firstLine : laterLines <- [declarationLines],+        laterLine <- laterLines+      ]+      where+        declarations =+          Map.fromListWith+            (flip (++))+            [ (candidate, [lineNumber])+            | (lineNumber, sourceLine) <- sourceLines,+              sourceLine == T.stripStart sourceLine,+              candidate <- candidates sourceLine+            ]++    checkCandidates lineNumber = concatMap (checkCandidate lineNumber)+    checkCandidate lineNumber candidate+      | T.null candidate = []+      | asciiUpperInitial candidate =+          [prefix lineNumber <> "generated declaration '" <> candidate <> "' is not UpperCamelCase" | isLeftName (HaskellName.checkedUpperOccurrence (auditSite HaskellName.GeneratedTypeSite candidate lineNumber) candidate)]+      | otherwise =+          [prefix lineNumber <> "generated declaration '" <> candidate <> "' is not lowerCamelCase" | isLeftName (HaskellName.checkedLowerOccurrence (auditSite HaskellName.GeneratedValueSite candidate lineNumber) candidate)]++    prefix lineNumber = T.pack ((.path) scaffoldModule) <> ":" <> tshow lineNumber <> ": "++    auditSite kind candidate lineNumber =+      HaskellName.NameSite+        { HaskellName.kind = kind,+          HaskellName.logicalName = candidate,+          HaskellName.owner = T.pack ((.path) scaffoldModule),+          HaskellName.line = lineNumber+        }++isLeftName :: Either left right -> Bool+isLeftName = \case Left _ -> True; Right _ -> False++declaredModuleName :: Text -> Maybe Text+declaredModuleName source =+  case [T.takeWhile moduleCharacter (T.drop 7 sourceLine) | sourceLine <- T.lines source, "module " `T.isPrefixOf` sourceLine] of+    declaration : _ | not (T.null declaration) -> Just declaration+    _ -> Nothing+  where+    moduleCharacter character = identifierCharacter character || character == '.'++signatureCandidates :: Text -> [Text]+signatureCandidates sourceLine+  | T.null suffix || T.any (`elem` ['=', '(', ')', '[', ']']) prefix = []+  | otherwise = filter isIdentifier (map T.strip (T.splitOn "," prefix))+  where+    (prefix, suffix) = T.breakOn "::" (T.strip sourceLine)++typeCandidates :: Text -> [Text]+typeCandidates sourceLine = case T.words (T.strip sourceLine) of+  keyword : candidate : _+    | keyword `elem` ["data", "newtype", "type"], candidate /= "family", candidate /= "instance" -> [cleanIdentifier candidate]+  _ -> []++constructorCandidates :: Text -> [Text]+constructorCandidates sourceLine+  | "|" `T.isPrefixOf` stripped = takeFollowingIdentifier (T.drop 1 stripped)+  | any (`T.isPrefixOf` stripped) ["data ", "newtype "] = takeFollowingIdentifier (T.drop 1 (snd (T.breakOn "=" stripped)))+  | otherwise = []+  where+    stripped = T.strip sourceLine+    takeFollowingIdentifier value = case T.words value of+      candidate : _ | asciiUpperInitial (cleanIdentifier candidate) -> [cleanIdentifier candidate]+      _ -> []++topLevelValueCandidates :: Text -> [Text]+topLevelValueCandidates sourceLine+  | T.null sourceLine || T.head sourceLine == ' ' || T.head sourceLine == '\t' = []+  | T.null suffix = []+  | otherwise = case T.words prefix of+      candidate : _+        | candidate `notElem` declarationKeywords,+          isIdentifier candidate ->+            [candidate]+      _ -> []+  where+    (prefix, suffix) = T.breakOn "=" sourceLine+    declarationKeywords = ["data", "newtype", "type", "class", "instance", "module", "import", "deriving", "infix", "infixl", "infixr"]++cleanIdentifier :: Text -> Text+cleanIdentifier = T.takeWhile identifierCharacter . T.dropWhile (not . identifierCharacter)++isIdentifier :: Text -> Bool+isIdentifier candidate = not (T.null candidate) && T.all identifierCharacter candidate++identifierCharacter :: Char -> Bool+identifierCharacter character =+  (character >= 'A' && character <= 'Z')+    || (character >= 'a' && character <= 'z')+    || (character >= '0' && character <= '9')+    || character == '_'+    || character == '\''++asciiUpperInitial :: Text -> Bool+asciiUpperInitial candidate = case T.uncons candidate of+  Just (first, _) -> first >= 'A' && first <= 'Z'+  Nothing -> False++data AuditLexState = AuditCode | AuditLineComment | AuditBlockComment !Int | AuditString | AuditCharacter++maskNonCode :: Text -> Either Text Text+maskNonCode = fmap T.pack . go AuditCode . T.unpack+  where+    go state input = case (state, input) of+      (AuditCode, []) -> Right []+      (AuditLineComment, []) -> Right []+      (AuditBlockComment _, []) -> Left "unterminated block comment in generated source"+      (AuditString, []) -> Left "unterminated string literal in generated source"+      (AuditCharacter, []) -> Left "unterminated character literal in generated source"+      (AuditCode, '-' : '-' : rest) -> prependSpaces 2 <$> go AuditLineComment rest+      (AuditCode, '{' : '-' : rest) -> prependSpaces 2 <$> go (AuditBlockComment 1) rest+      (AuditCode, '"' : rest) -> (' ' :) <$> go AuditString rest+      (AuditCode, '\'' : rest)+        | looksLikeCharacterLiteral rest -> (' ' :) <$> go AuditCharacter rest+      (AuditCode, character : rest) -> (character :) <$> go AuditCode rest+      (AuditLineComment, '\n' : rest) -> ('\n' :) <$> go AuditCode rest+      (AuditLineComment, _ : rest) -> (' ' :) <$> go AuditLineComment rest+      (AuditBlockComment depth, '{' : '-' : rest) -> prependSpaces 2 <$> go (AuditBlockComment (depth + 1)) rest+      (AuditBlockComment 1, '-' : '}' : rest) -> prependSpaces 2 <$> go AuditCode rest+      (AuditBlockComment depth, '-' : '}' : rest) -> prependSpaces 2 <$> go (AuditBlockComment (depth - 1)) rest+      (AuditBlockComment depth, '\n' : rest) -> ('\n' :) <$> go (AuditBlockComment depth) rest+      (AuditBlockComment depth, _ : rest) -> (' ' :) <$> go (AuditBlockComment depth) rest+      (AuditString, '\\' : _escaped : rest) -> prependSpaces 2 <$> go AuditString rest+      (AuditString, '"' : rest) -> (' ' :) <$> go AuditCode rest+      (AuditString, '\n' : _) -> Left "newline in generated string literal"+      (AuditString, _ : rest) -> (' ' :) <$> go AuditString rest+      (AuditCharacter, '\\' : _escaped : rest) -> prependSpaces 2 <$> go AuditCharacter rest+      (AuditCharacter, '\'' : rest) -> (' ' :) <$> go AuditCode rest+      (AuditCharacter, '\n' : _) -> Left "newline in generated character literal"+      (AuditCharacter, _ : rest) -> (' ' :) <$> go AuditCharacter rest++    prependSpaces count suffix = replicate count ' ' <> suffix+    looksLikeCharacterLiteral = \case+      '\\' : _escaped : '\'' : _ -> True+      _character : '\'' : _ -> True+      _ -> False++dependencyRefusalsForService :: Context -> CheckedService -> [ScaffoldModule] -> [Refusal]+dependencyRefusalsForService ctx service modules = collisionWithConsumers <> namespaceCycles+  where+    plan = consumerPlanForService service+    generatedByName = Map.fromList [(moduleNameOf ((.path) moduleValue), moduleValue) | moduleValue <- modules, (.kind) moduleValue == Generated]+    collisionWithConsumers =+      [ PathCollision+          ((.path) generated)+          [(.origin) generated, "consumer module " <> consumerModule]+      | consumerModule <- (.modules) plan,+        Just generated <- [Map.lookup consumerModule generatedByName]+      ]+    namespaceCycles =+      [ ImportCycle [importer, consumerModule, importer]+      | consumerModule <- (.modules) plan,+        generatedNamespaceOwned ctx consumerModule,+        importer <- take 1 (importersOf consumerModule modules <> [contextGeneratedRoot ctx])+      ]++generatedNamespaceOwned :: Context -> Text -> Bool+generatedNamespaceOwned ctx consumerModule = case (.placement) ctx of+  GeneratedPrefix -> contextGeneratedRoot ctx `T.isPrefixOf` consumerModule+  CollocatedLeaf ->+    (root <> contextSegment <> ".") `T.isPrefixOf` consumerModule+      && ".Generated" `T.isInfixOf` consumerModule+  where+    root = if T.null ((.moduleRoot) ctx) then "" else (.moduleRoot) ctx <> "."+    contextSegment = pascalFromKebab ((.name) ctx)++contextGeneratedRoot :: Context -> Text+contextGeneratedRoot 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 ((.name) ctx)++importersOf :: Text -> [ScaffoldModule] -> [Text]+importersOf imported =+  map (moduleNameOf . (.path))+    . filter (any (importsModule imported) . T.lines . (.text))++importsModule :: Text -> Text -> Bool+importsModule expected line = case T.words (T.strip line) of+  "import" : rest -> expected `elem` rest+  _ -> False++collisionRefusals :: [ScaffoldModule] -> [Refusal]+collisionRefusals modules =+  [ PathCollision ((.path) first) (map (.origin) (first : rest))+  | first : rest <- Map.elems grouped,+    not (null rest)+  ]+  where+    grouped =+      Map.fromListWith+        (flip (<>))+        [(T.toCaseFold (T.pack ((.path) m)), [m]) | m <- modules]++generatedHaskellEditionBackupRoot :: HaskellName.GeneratedHaskellNamingEdition -> FilePath+generatedHaskellEditionBackupRoot fromEdition =+  ".keiro-dsl-generated-haskell-migrations"+    </> ( T.unpack (HaskellName.renderGeneratedHaskellNamingEdition fromEdition)+            <> "-to-"+            <> T.unpack (HaskellName.renderGeneratedHaskellNamingEdition HaskellName.currentGeneratedHaskellNamingEdition)+        )++preflightGeneratedHaskellEditionMigration :: FilePath -> Maybe HaskellName.GeneratedHaskellNamingEdition -> [(ModuleKind, FilePath)] -> [FilePath] -> IO (Either [Text] (Maybe PreparedGeneratedHaskellEditionMigration))+preflightGeneratedHaskellEditionMigration out previousEdition recordedFiles sidecars+  | previousEdition == Nothing || previousEdition == Just HaskellName.currentGeneratedHaskellNamingEdition = pure (Right Nothing)+  | otherwise = do+      let fromEdition = maybe HaskellName.LegacyNamingV1 id previousEdition+          backupRoot = generatedHaskellEditionBackupRoot fromEdition+          generatedPaths = sort [path | (Generated, path) <- recordedFiles]+          handOwnedPaths = sort [path | (HoleStub, path) <- recordedFiles]+          sidecarPaths = sort sidecars+          sourcePaths = generatedPaths <> sidecarPaths+      existingSources <- fmap (map fst . filter snd) (mapM existing sourcePaths)+      let labels = map fst idiomaticV2LabelMigrations+      uses <- fmap (sort . concat) (mapM (scanFile labels) handOwnedPaths)+      let impact = GeneratedHaskellEditionImpact fromEdition generatedPaths sidecarPaths uses+          backups = [(path, backupRoot </> path) | path <- existingSources]+          reportPath = backupRoot </> "remediation-report.txt"+          reportText = renderGeneratedHaskellEditionRemediation impact []+      conflicts <- fmap concat (mapM checkBackup backups)+      pure $+        if null conflicts+          then Right (Just (PreparedGeneratedHaskellEditionMigration impact backups reportPath reportText []))+          else Left conflicts+  where+    relative path = out </> path+    existing path = do+      exists <- doesFileExist (relative path)+      pure (path, exists)+    checkBackup (sourcePath, backupPath) = do+      exists <- doesFileExist (relative backupPath)+      if not exists+        then pure []+        else do+          sourceBytes <- BS.readFile (relative sourcePath)+          backupBytes <- BS.readFile (relative backupPath)+          pure ["edition backup conflict for " <> T.pack sourcePath <> ": " <> T.pack backupPath <> " contains different bytes" | sourceBytes /= backupBytes]+    scanFile labels path = do+      exists <- doesFileExist (relative path)+      if not exists+        then pure []+        else do+          contents <- TIO.readFile (relative path)+          pure+            [ GeneratedHaskellEditionUse path lineNumber label (replacementFor label form) form+            | (lineNumber, sourceLine) <- zip [1 ..] (T.lines contents),+              label <- labels,+              form <- holeUsesOnLine label (replacementLabel label) sourceLine+            ]+    replacementLabel label = maybe label id (lookup label idiomaticV2LabelMigrations)+    replacementFor label = \case+      RecordFieldBinding -> replacementLabel label <> " = ..."+      RecordDotRenamed -> "record." <> replacementLabel label+      _ ->+        "record."+          <> replacementLabel label+          <> " (or a positional constructor pattern for dual-edition code)"++applyPreparedGeneratedHaskellEditionMigration :: FilePath -> Maybe PreparedGeneratedHaskellEditionMigration -> IO ()+applyPreparedGeneratedHaskellEditionMigration _ Nothing = pure ()+applyPreparedGeneratedHaskellEditionMigration out (Just prepared) = do+  mapM_ copyBackup ((.backups) prepared)+  let reportPath = out </> (.reportPath) prepared+  createDirectoryIfMissing True (takeDirectory reportPath)+  TIO.writeFile reportPath ((.reportText) prepared)+  where+    copyBackup (sourcePath, backupPath) = do+      let source = out </> sourcePath+          backup = out </> backupPath+      backupExists <- doesFileExist backup+      if backupExists+        then pure ()+        else do+          createDirectoryIfMissing True (takeDirectory backup)+          copyFile source backup++withGeneratedHaskellEditionSourceMoves :: [SourceMove] -> Maybe PreparedGeneratedHaskellEditionMigration -> Maybe PreparedGeneratedHaskellEditionMigration+withGeneratedHaskellEditionSourceMoves moves =+  fmap+    ( \prepared ->+        prepared+          { sourceMoves = moves,+            reportText = renderGeneratedHaskellEditionRemediation ((.impact) prepared) moves+          }+    )++renderGeneratedHaskellEditionRemediation :: GeneratedHaskellEditionImpact -> [SourceMove] -> Text+renderGeneratedHaskellEditionRemediation impact sourceMoves =+  T.unlines $+    [ "keiro-dsl generated Haskell edition migration",+      "from: " <> HaskellName.renderGeneratedHaskellNamingEdition ((.fromEdition) impact),+      "to: " <> HaskellName.renderGeneratedHaskellNamingEdition HaskellName.currentGeneratedHaskellNamingEdition,+      "generated-files: " <> tshow (length ((.generatedPaths) impact)),+      "sidecars: " <> tshow (length ((.sidecarPaths) impact)),+      "hand-owned-selector-uses: " <> tshow (length ((.handOwnedUses) impact)),+      "source-moves: " <> tshow (length sourceMoves)+    ]+      <> map renderUse ((.handOwnedUses) impact)+      <> map renderSourceMove sourceMoves+      <> [attributableUsesCaveat]+  where+    renderUse use =+      T.pack ((.path) use)+        <> ":"+        <> tshow ((.line) use)+        <> ": "+        <> (.current) use+        <> " ("+        <> T.pack (show ((.form) use))+        <> ") -> "+        <> (.replacement) use+    renderSourceMove move = T.pack ((.oldPath) move) <> " -> " <> T.pack ((.newPath) move)++attributableUsesCaveat :: Text+attributableUsesCaveat =+  "attributable uses only: unchanged concise labels and files outside the recorded Hole paths are not scanned; compile errors after adoption are the authority"++holeUsesOnLine :: Text -> Text -> Text -> [HoleUseForm]+holeUsesOnLine label target sourceLine+  | "--" `T.isPrefixOf` T.stripStart sourceLine = []+  | otherwise = go sourceLine+  where+    go remaining | T.null remaining = []+    go remaining = case T.breakOn label remaining of+      (_, suffix) | T.null suffix -> []+      (prefix, suffix) ->+        let before = snd <$> T.unsnoc prefix+            after = T.drop (T.length label) suffix+            next = T.dropWhile (== ' ') after+            leftBoundary = maybe True (not . isHaskellIdentifier) before+            rightBoundary = maybe True (not . isHaskellIdentifier) (fst <$> T.uncons after)+            application = maybe False (\character -> character == '(' || isHaskellIdentifier character) (fst <$> T.uncons next)+            qualifier = T.takeWhileEnd isHaskellIdentifier (T.dropEnd 1 prefix)+            qualified = before == Just '.' && maybe False isUpperAscii (fst <$> T.uncons qualifier) && application+            recordDot =+              before == Just '.'+                && maybe False isLowerIdentifier (snd <$> T.unsnoc (T.dropEnd 1 prefix))+                && target /= label+            fieldBinding = unmatchedOpeningBrace prefix && "=" `T.isPrefixOf` next+            operatorOperand = any (`T.isPrefixOf` next) ["<$>", "<&>", "$", ".", "&", "`"]+            prefixApplication = before /= Just '.' && application+            found+              | leftBoundary && rightBoundary && qualified = [QualifiedApplication]+              | leftBoundary && rightBoundary && recordDot = [RecordDotRenamed]+              | leftBoundary && rightBoundary && fieldBinding = [RecordFieldBinding]+              | leftBoundary && rightBoundary && operatorOperand = [OperatorOperand]+              | leftBoundary && rightBoundary && prefixApplication = [PrefixApplication]+              | otherwise = []+         in found <> go (T.drop 1 suffix)+    unmatchedOpeningBrace prefix = T.count "{" prefix > T.count "}" prefix+    isUpperAscii character = character >= 'A' && character <= 'Z'+    isLowerIdentifier character = character == '_' || character >= 'a' && character <= 'z' || character >= '0' && character <= '9'+    isHaskellIdentifier character = character == '_' || character == '\'' || character >= 'A' && character <= 'Z' || character >= 'a' && character <= 'z' || character >= '0' && character <= '9'++-- | Check existing generated paths, then perform the deterministic writes and+-- manifest rewrite. Banner refusal is evaluated for the complete set before the+-- output directory is created or any file is changed.+executeScaffold :: FilePath -> Bool -> FilePath -> Context -> Spec -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport)+executeScaffold out forceGeneratedOverwrite specPath ctx spec modules =+  executeScaffoldWithLanguage out forceGeneratedOverwrite specPath LegacyUnversioned ctx spec modules++-- | Source-aware execution used by the CLI; semantic planning still receives only 'Spec'.+executeScaffoldWithLanguage :: FilePath -> Bool -> FilePath -> SourceLanguage -> Context -> Spec -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport)+executeScaffoldWithLanguage out forceGeneratedOverwrite specPath sourceLanguage ctx spec modules =+  executeServiceScaffold out forceGeneratedOverwrite specPath sourceLanguage ctx (checkedService sourceLanguage spec) modules++-- | Execute a module plan while retaining both the effective semantic contract+-- and the source declaration provenance written to history. A mismatch refuses+-- before checking or creating any output path.+executeServiceScaffold :: FilePath -> Bool -> FilePath -> SourceLanguage -> Context -> CheckedService -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport)+executeServiceScaffold = executeServiceScaffoldWithRuntimePackage Nothing++executeServiceScaffoldWithRuntimePackage :: Maybe RuntimePackageName -> FilePath -> Bool -> FilePath -> SourceLanguage -> Context -> CheckedService -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport)+executeServiceScaffoldWithRuntimePackage runtimePackage =+  executeServiceScaffoldWithRuntimePackageAndNameMigrations runtimePackage False++executeServiceScaffoldWithRuntimePackageAndNameMigrations :: Maybe RuntimePackageName -> Bool -> FilePath -> Bool -> FilePath -> SourceLanguage -> Context -> CheckedService -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport)+executeServiceScaffoldWithRuntimePackageAndNameMigrations runtimePackage applyNameMigrations =+  executeServiceScaffoldWithRuntimePackageAndMigrations runtimePackage applyNameMigrations False++executeServiceScaffoldWithRuntimePackageAndMigrations :: Maybe RuntimePackageName -> Bool -> Bool -> FilePath -> Bool -> FilePath -> SourceLanguage -> Context -> CheckedService -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport)+executeServiceScaffoldWithRuntimePackageAndMigrations runtimePackage applyNameMigrations applyGeneratedHaskellEdition out forceGeneratedOverwrite specPath sourceLanguage ctx service plannedModules+  | effectiveLanguageContract sourceLanguage /= checkedLanguageContract service =+      pure (Left [SemanticContractMismatch "source provenance and checked service selected different effective language contracts"])+  | otherwise = case packagePlan of+      Left failures -> pure (Left (map ConformancePackageRefusal failures))+      Right plannedPackage -> do+        sidecarResult <- planSidecarMigrations out (ContextSidecars ((.context) spec)) plannedPackage+        case sidecarResult of+          Left reasons -> pure (Left [SidecarMigrationRefusal reasons])+          Right preparedSidecars -> do+            previousBefore <- readMigrationRecord+            editionBefore <- preflightEdition previousBefore+            case editionBefore of+              Left refusals -> pure (Left refusals)+              Right preparedBefore+                | not (null preparedSidecars) && not applyNameMigrations ->+                    pure . Left $+                      [SidecarMigrationRequired (map preparedSidecarMove preparedSidecars)]+                        <> [GeneratedHaskellEditionRequired ((.impact) prepared) | Just prepared <- [preparedBefore]]+                | otherwise -> do+                    applyPreparedSidecarMoves out preparedSidecars+                    let moves = map preparedSidecarMove preparedSidecars+                        -- Past this point the renames are on disk, so a later+                        -- refusal's "nothing was written" needs qualifying.+                        noteApplied = withSidecarMovesApplied moves+                    previousAfter <- if null preparedSidecars then pure previousBefore else readRecord currentRecordPath+                    editionAfter <- preflightEdition previousAfter+                    result <- case editionAfter of+                      Left refusals -> pure (Left refusals)+                      Right preparedEdition -> case plannedPackage of+                        Nothing -> executeCheckedScaffold preparedEdition moves Nothing+                        Just package -> do+                          preparedPackage <- preflightConformancePackage out forceGeneratedOverwrite package+                          case preparedPackage of+                            Left failures -> pure (Left (map ConformancePackageRefusal failures))+                            Right packageReady -> executeCheckedScaffold preparedEdition moves (Just packageReady)+                    pure (either (Left . noteApplied) Right result)+  where+    spec = checkedSpec service+    modules = stampGeneratedModules (checkedLanguageContract service) plannedModules+    currentRecordPath = out </> recordFileName ((.context) spec)+    legacyRecordPath = out </> legacyContextRecordFileName ((.context) spec)+    facadeModule = case runtimePackage of+      Nothing -> Nothing+      Just _ -> Just (serviceConformanceModuleName ctx)+    packagePlan =+      traverse+        (\packageName -> planConformancePackage (StandaloneConformanceService ((.name) ctx)) packageName (serviceConformanceModuleName ctx) service)+        runtimePackage+    readMigrationRecord = do+      current <- readRecord currentRecordPath+      case current of+        LedgerAbsent -> readRecord legacyRecordPath+        _ -> pure current+    preflightEdition previousRead = case ledgerReadRefusals previousRead of+      refusals@(_ : _) -> pure (Left refusals)+      [] -> do+        let previousRecord = ledgerToMaybe previousRead+        prepared <-+          preflightGeneratedHaskellEditionMigration+            out+            ((.namingEdition) <$> previousRecord)+            (maybe [] (.files) previousRecord)+            [contextCabalFragmentFileName ((.context) spec), recordFileName ((.context) spec)]+        pure (either (Left . pure . GeneratedHaskellEditionRefusal) Right prepared)+    executeCheckedScaffold editionMigration sidecarMoves preparedPackage =+      case deriveBehaviorRequirementsForService service of+        Left errors -> pure (Left [BehaviorRefusal errors])+        Right requirements -> do+          bannerless <- if forceGeneratedOverwrite then pure [] else missingGeneratedBanners out modules+          if not (null bannerless)+            then pure (Left [MissingGeneratedBanner bannerless])+            else do+              let recordPath = out </> recordFileName ((.context) spec)+              previousRead <- readRecord recordPath+              let previousRecord = ledgerToMaybe previousRead+              case (ledgerReadRefusals previousRead, planRecordedSourceMoves previousRecord modules) of+                (refusals@(_ : _), _) -> pure (Left refusals)+                (_, Left moveErrors) -> pure (Left [NameMigrationRefusal [T.pack (show moveError) | moveError <- NE.toList moveErrors]])+                (_, Right moves) -> do+                  preparedMoves <- preflightSourceMoves out moves+                  case preparedMoves of+                    Left moveErrors -> pure (Left [NameMigrationRefusal moveErrors])+                    Right prepared+                      | Just edition <- editionWithMoves,+                        (not (null prepared) || not (null sidecarMoves)),+                        not (applyNameMigrations && applyGeneratedHaskellEdition) ->+                          pure (Left [NameMigrationRequired sourceMoves, GeneratedHaskellEditionRequired ((.impact) edition)])+                      | Just edition <- editionWithMoves,+                        not applyGeneratedHaskellEdition ->+                          pure (Left [GeneratedHaskellEditionRequired ((.impact) edition)])+                      | not (null prepared) && not applyNameMigrations ->+                          pure (Left [NameMigrationRequired sourceMoves])+                      | otherwise -> do+                          applyPreparedGeneratedHaskellEditionMigration out editionWithMoves+                          applyPreparedSourceMoves out prepared+                          stale <- maybe (pure []) (existingStale out modules) previousRecord+                          queryMigrations <- queryContractMigrations out modules+                          let currentConsumerPlan = consumerPlanForService service+                              drift = maybe [] (mappingDrift ((.mappings) currentConsumerPlan) . (.mappings)) previousRecord+                              currentQueryContracts = either (const []) id (queryContractIdentitiesForService service)+                              queryHistoryBaseline =+                                not (null currentQueryContracts)+                                  || maybe False (.queryContractBaseline) previousRecord+                              queryBaselineUnavailable =+                                not (null currentQueryContracts)+                                  && maybe False (not . (.queryContractBaseline)) previousRecord+                              queryDrift = case previousRecord of+                                Just previous | (.queryContractBaseline) previous -> queryContractDrift currentQueryContracts ((.queryContracts) previous)+                                _ -> []+                              currentSemanticImpact = checkedSemanticImpactSnapshot service+                              semanticReport = semanticImpactForMappingDrift (previousRecord >>= (.semanticImpact)) currentSemanticImpact drift+                              currentRouterSelections = routerSelectionSnapshots service+                              selectionDrift = maybe [] (\previous -> routerSelectionDrift ((.routerSelections) previous) currentRouterSelections) previousRecord+                              languageDrift = do+                                previous <- previousRecord+                                if (.sourceLanguage) previous == sourceLanguage+                                  then Nothing+                                  else Just (SourceLanguageDrift ((.sourceLanguage) previous) sourceLanguage)+                              currentObligations = either (const []) id (bindingHolesForService service)+                              newHoles = maybe [] (newBindingObligations currentObligations . (.bindingObligations)) previousRecord+                              currentBehavior = behaviorRecordRows requirements+                              (addedBehavior, removedBehavior) = maybe (currentBehavior, []) (behaviorDrift currentBehavior . (.behaviorRequirements)) previousRecord+                          createDirectoryIfMissing True out+                          dispositions <- mapM (writeModule out) modules+                          let manifestPath = out </> contextCabalFragmentFileName ((.context) spec)+                          TIO.writeFile manifestPath (renderManifestForServiceWithFacade facadeModule (T.pack specPath) modules service)+                          TIO.writeFile recordPath (renderRecord (currentRecord specPath sourceLanguage ctx service modules queryHistoryBaseline currentBehavior currentSemanticImpact))+                          packageReport <- traverse executePreparedConformancePackage preparedPackage+                          pure $+                            Right+                              ScaffoldReport+                                { specPath = specPath,+                                  outDir = out,+                                  context = ctx,+                                  dispositions = dispositions,+                                  inertNodes = inertNodesOf spec,+                                  manifestPath = manifestPath,+                                  recordPath = recordPath,+                                  previousSpecPath = (.specPath) <$> previousRecord,+                                  stale = stale,+                                  consumerPlan = currentConsumerPlan,+                                  constraintPlan = constraintPlanForService service currentConsumerPlan,+                                  mappingDrift = drift,+                                  queryContractBaselineUnavailable = queryBaselineUnavailable,+                                  queryContractDrift = queryDrift,+                                  queryContractMigrations = queryMigrations,+                                  semanticImpact = semanticReport,+                                  routerSelectionDrift = selectionDrift,+                                  projectionMappedImpact = projectionMappedImpactForService service,+                                  generatedArtifactImpact = generatedArtifactImpact dispositions,+                                  sourceLanguageDrift = languageDrift,+                                  newHoles = newHoles,+                                  addedBehavior = addedBehavior,+                                  removedBehavior = removedBehavior,+                                  obsoleteOutputHooks = obsoleteGeneratedOutputHooksForService service,+                                  conformancePackage = packageReport,+                                  nameMoves = map preparedSourceMove prepared,+                                  sidecarMoves = sidecarMoves+                                }+                      where+                        sourceMoves = map preparedSourceMove prepared+                        editionWithMoves = withGeneratedHaskellEditionSourceMoves sourceMoves editionMigration++planRecordedSourceMoves :: Maybe ScaffoldRecord -> [ScaffoldModule] -> Either (NE.NonEmpty SourceMoveError) [SourceMove]+planRecordedSourceMoves Nothing _ = Right []+planRecordedSourceMoves (Just previous) current =+  planSourceMoves priorArtifacts current+  where+    priorArtifacts = case (.moduleRoles) previous of+      [] -> [(Nothing, fileKind, path) | (fileKind, path) <- (.files) previous]+      rows -> [(Just ((.role) row), (.kind) row, (.path) row) | row <- rows]++data PreparedSourceMove+  = SourceMoveReady !SourceMove !Text+  | SourceMoveAlreadyApplied !SourceMove++preparedSourceMove :: PreparedSourceMove -> SourceMove+preparedSourceMove = \case+  SourceMoveReady move _ -> move+  SourceMoveAlreadyApplied move -> move++preflightSourceMoves :: FilePath -> [SourceMove] -> IO (Either [Text] [PreparedSourceMove])+preflightSourceMoves out moves = do+  prepared <- mapM preflight moves+  let errors = [message | Left message <- prepared]+  pure $ if null errors then Right [value | Right value <- prepared] else Left errors+  where+    replacements = Map.fromList [((.oldModule) move, (.newModule) move) | move <- moves]+    preflight move = do+      let oldPath = out </> (.oldPath) move+          newPath = out </> (.newPath) move+          backupPath = out </> (.backupPath) move+          preparedPath = preparedSourcePath out move+          statePath = sourceMoveStatePath out move+      oldExists <- doesFileExist oldPath+      newExists <- doesFileExist newPath+      backupExists <- doesFileExist backupPath+      preparedExists <- doesFileExist preparedPath+      stateExists <- doesFileExist statePath+      case (oldExists, backupExists) of+        (True, True) -> conflict move newExists backupExists preparedExists "both legacy source and backup exist"+        (False, False) ->+          if newExists+            then conflict move newExists backupExists preparedExists "target exists without a recoverable legacy source"+            else pure (Left (T.pack ((.oldPath) move) <> ": recorded legacy source is missing"))+        _ -> do+          source <- TIO.readFile (if oldExists then oldPath else backupPath)+          if (.kind) move == Generated && not (any isGeneratedBannerLine (T.lines source))+            then pure (Left (T.pack ((.oldPath) move) <> ": generated source lacks an exact generated banner"))+            else case rewriteHaskellModuleReferences replacements source of+              Left lexicalError -> pure (Left (T.pack ((.oldPath) move) <> ": " <> T.pack (show lexicalError)))+              Right rewritten+                | not (declaresExpectedModule ((.newModule) move) rewritten) ->+                    pure+                      ( Left+                          ( T.pack ((.oldPath) move)+                              <> ": transformed source does not declare expected module "+                              <> (.newModule) move+                          )+                      )+                | otherwise -> do+                    let hydrated =+                          SourceMove+                            { role = move.role,+                              kind = move.kind,+                              oldModule = move.oldModule,+                              newModule = move.newModule,+                              oldPath = move.oldPath,+                              newPath = move.newPath,+                              backupPath = move.backupPath,+                              contentDigest = Just (contentDigest source),+                              transformedDigest = Just (contentDigest rewritten)+                            }+                        expectedState = renderSourceMoveState hydrated+                    stateError <- verifyOptionalText stateExists statePath expectedState "migration state"+                    preparedError <- verifyOptionalDigest preparedExists preparedPath (contentDigest rewritten) "prepared source"+                    targetError <- verifyOptionalDigest newExists newPath (contentDigest rewritten) "target source"+                    case [message | Just message <- [stateError, preparedError, targetError]] of+                      message : _ -> pure (Left (T.pack ((.oldPath) move) <> ": " <> message))+                      []+                        | newExists && not backupExists && not oldExists -> conflict hydrated newExists backupExists preparedExists "target has no recoverable backup"+                        | newExists && backupExists && not oldExists -> pure (Right (SourceMoveAlreadyApplied hydrated))+                        | otherwise -> pure (Right (SourceMoveReady hydrated rewritten))++    conflict move newExists backupExists preparedExists reason =+      pure+        ( Left+            ( T.pack ((.oldPath) move)+                <> ": migration state conflicts ("+                <> reason+                <> "; target="+                <> T.pack (show newExists)+                <> ", backup="+                <> T.pack (show backupExists)+                <> ", prepared="+                <> T.pack (show preparedExists)+                <> ")"+            )+        )++    verifyOptionalText False _ _ _ = pure Nothing+    verifyOptionalText True path expected label = do+      actual <- TIO.readFile path+      pure $ if actual == expected then Nothing else Just (label <> " digest/path evidence does not match")++    verifyOptionalDigest False _ _ _ = pure Nothing+    verifyOptionalDigest True path expected label = do+      actual <- contentDigest <$> TIO.readFile path+      pure $ if actual == expected then Nothing else Just (label <> " digest does not match " <> expected)++    declaresExpectedModule expected source =+      any (T.isPrefixOf ("module " <> expected <> " ")) (T.lines source)+        || any (== ("module " <> expected)) (T.lines source)++applyPreparedSourceMoves :: FilePath -> [PreparedSourceMove] -> IO ()+applyPreparedSourceMoves out prepared = do+  -- Prepare every transformed file and durable digest record before moving a+  -- single active source.  The temporary file lives beside its destination,+  -- so installation is a same-filesystem rename.+  mapM_ prepareMove prepared+  mapM_ backupMove prepared+  mapM_ installMove prepared+  where+    prepareMove preparedMove = do+      let move = preparedSourceMove preparedMove+          statePath = sourceMoveStatePath out move+      createDirectoryIfMissing True (takeDirectory statePath)+      TIO.writeFile statePath (renderSourceMoveState move)+      case preparedMove of+        SourceMoveAlreadyApplied _ -> pure ()+        SourceMoveReady _ rewritten -> do+          let path = preparedSourcePath out move+          createDirectoryIfMissing True (takeDirectory path)+          exists <- doesFileExist path+          if exists then pure () else TIO.writeFile path rewritten++    backupMove (SourceMoveAlreadyApplied _) = pure ()+    backupMove (SourceMoveReady move _) = do+      let oldPath = out </> (.oldPath) move+          backupPath = out </> (.backupPath) move+      oldExists <- doesFileExist oldPath+      if oldExists+        then do+          createDirectoryIfMissing True (takeDirectory backupPath)+          renameFile oldPath backupPath+        else pure ()++    installMove preparedMove = do+      let move = preparedSourceMove preparedMove+          preparedPath = preparedSourcePath out move+          newPath = out </> (.newPath) move+      newExists <- doesFileExist newPath+      preparedExists <- doesFileExist preparedPath+      if newExists+        then if preparedExists then removeFile preparedPath else pure ()+        else do+          createDirectoryIfMissing True (takeDirectory newPath)+          renameFile preparedPath newPath++preparedSourcePath :: FilePath -> SourceMove -> FilePath+preparedSourcePath out move = out </> ((.newPath) move <> ".keiro-dsl-name-migration-prepared")++sourceMoveStatePath :: FilePath -> SourceMove -> FilePath+sourceMoveStatePath out move = out </> ((.backupPath) move <> ".keiro-dsl-name-migration-state")++renderSourceMoveState :: SourceMove -> Text+renderSourceMoveState move =+  T.unlines+    [ "keiro-dsl-name-migration-state v1",+      "old-path " <> T.pack ((.oldPath) move),+      "new-path " <> T.pack ((.newPath) move),+      "old-module " <> (.oldModule) move,+      "new-module " <> (.newModule) move,+      "source-digest " <> maybe "<missing>" id ((.contentDigest) move),+      "transformed-digest " <> maybe "<missing>" id ((.transformedDigest) move)+    ]++constraintPlanForService :: CheckedService -> ConsumerPlan -> [Text]+constraintPlanForService service plan = case checkedTypeGraph service of+  Left _ -> []+  Right graph ->+    let registerRoots =+          Set.fromList+            [ key+            | RootRegister _ _ key <- (.useSites) graph+            ]+     in map (constraintFor registerRoots) ((.mappings) plan)+  where+    constraintFor registerRoots mapping =+      (.specName) mapping+        <> ": "+        <> T.intercalate ", " (baseConstraints mapping <> registerConstraints registerRoots mapping)+    baseConstraints StructuralMapping {} = ["Eq", "Show", "CanonicalTypeName", "StructuralBinding"]+    baseConstraints OpaqueMapping {} = ["Eq", "Show", "ToJSON", "FromJSON"]+    baseConstraints NominalMapping {} = ["Eq", "Show", "NominalBinding"]+    registerConstraints roots mapping+      | MappedKey ((.specName) mapping) `Set.member` roots = ["register initial", "snapshot ToJSON", "snapshot FromJSON"]+      | otherwise = []++mappingDrift :: [MappingIdentity] -> [MappingIdentity] -> [MappingDrift]+mappingDrift current previous =+  [ MappingDrift name old new+  | name <- Set.toAscList (Map.keysSet oldByName <> Map.keysSet newByName),+    let old = Map.lookup name oldByName,+    let new = Map.lookup name newByName,+    old /= new+  ]+  where+    oldByName = Map.fromList [((.specName) mapping, mapping) | mapping <- previous]+    newByName = Map.fromList [((.specName) 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 ((.specName) drift) | drift <- drifts]+    snapshotDeclarations = maybe [] (map (.declaration) . (`diffSemanticImpact` current)) previous+    changedDeclarations = driftDeclarations <> snapshotDeclarations++generatedArtifactImpact :: [(ScaffoldModule, WriteDisposition)] -> [GeneratedArtifactImpact]+generatedArtifactImpact dispositions =+  sortOn+    (.path)+    [ GeneratedArtifactImpact+        { category = categoryFor role,+          role = role,+          path = (.path) scaffoldModule,+          disposition = disposition+        }+    | (scaffoldModule, disposition) <- dispositions,+      (.kind) scaffoldModule == Generated,+      disposition `elem` [Overwritten, Created],+      let role = moduleRole scaffoldModule+    ]+  where+    categoryFor role+      | (.family) role == "StructuralConformance" = ServiceStructuralConformanceArtifact+      | (.family) role == "BehaviorSourceMap" = BehaviorSourceMapArtifact+      | (.ownerKind) role == "aggregate"+          || ": aggregate " `T.isInfixOf` (.ownerName) role =+          AggregateGeneratedArtifact+      | otherwise = OtherGeneratedArtifact++newBindingObligations :: [BindingHole] -> [BindingHole] -> [BindingHole]+newBindingObligations current previous =+  [ obligation+  | obligation <- current,+    obligation `Set.notMember` previousSet+  ]+  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,+        (.family) (moduleRole hole) == "ReadModelHoles",+        requiredImport <- T.lines ((.text) hole),+        "import " `T.isPrefixOf` requiredImport,+        ".QueryContract (" `T.isInfixOf` requiredImport+      ]+    inspect (hole, requiredImport) = do+      let path = out </> (.path) 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+                { owner = queryOwner (moduleRole hole),+                  path = (.path) hole,+                  requiredImport = 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 ((.ownerName) role) of+      "readmodel" : owner : _ -> owner+      _ -> (.ownerName) role++behaviorDrift :: [BehaviorRecordRow] -> [BehaviorRecordRow] -> ([BehaviorRecordRow], [BehaviorRecordRow])+behaviorDrift current previous =+  ( [row | row <- sortOn (.key) current, (.key) row `Set.notMember` previousKeys],+    [row | row <- sortOn (.key) previous, (.key) row `Set.notMember` currentKeys]+  )+  where+    currentKeys = Set.fromList (map (.key) current)+    previousKeys = Set.fromList (map (.key) previous)++readRecord :: FilePath -> IO (LedgerRead ScaffoldRecord)+readRecord path = do+  exists <- doesFileExist path+  if not exists+    then pure LedgerAbsent+    else do+      parsed <- parseRecord <$> TIO.readFile path+      pure (maybe (LedgerReadUnreadable path) LedgerParsed parsed)++ledgerToMaybe :: LedgerRead a -> Maybe a+ledgerToMaybe LedgerAbsent = Nothing+ledgerToMaybe (LedgerParsed value) = Just value+ledgerToMaybe (LedgerReadUnreadable _) = Nothing++ledgerReadRefusals :: LedgerRead a -> [Refusal]+ledgerReadRefusals (LedgerReadUnreadable path) = [LedgerUnreadable path]+ledgerReadRefusals _ = []++existingStale :: FilePath -> [ScaffoldModule] -> ScaffoldRecord -> IO [StaleModule]+existingStale out modules record = staleAgainst out (map (.path) modules) ((.files) record)++-- | The files a previous run recorded that the current plan no longer produces+-- and that are still on disk. keiro-dsl never deletes; this is what the report+-- lists for a human to review.+staleAgainst :: FilePath -> [FilePath] -> [(ModuleKind, FilePath)] -> IO [StaleModule]+staleAgainst out currentPathList previous = fmap concat $ mapM stillExists removed+  where+    currentPaths = Set.fromList currentPathList+    removed = [(fileKind, path) | (fileKind, path) <- previous, path `Set.notMember` currentPaths]+    stillExists (fileKind, path) = do+      let fullPath = out </> path+      exists <- doesFileExist fullPath+      if not exists+        then pure []+        else do+          evidence <- case fileKind of+            HoleStub -> pure Nothing+            Generated -> do+              contents <- TIO.readFile fullPath+              pure . Just $+                if any isGeneratedBannerLine (T.lines contents)+                  then ExactGeneratedBannerPresent+                  else ExactGeneratedBannerMissing+          pure [StaleModule fileKind path evidence]++currentRecord :: FilePath -> SourceLanguage -> Context -> CheckedService -> [ScaffoldModule] -> Bool -> [BehaviorRecordRow] -> SemanticImpactSnapshot -> ScaffoldRecord+currentRecord specPath sourceLanguage ctx service modules queryHistoryBaseline currentBehavior currentSemanticImpact =+  ScaffoldRecord+    { specPath = T.pack specPath,+      moduleRoot = (.moduleRoot) ctx,+      layout = case (.placement) ctx of GeneratedPrefix -> "prefixed"; CollocatedLeaf -> "collocated",+      sourceLanguage = sourceLanguage,+      languageContract = checkedLanguageContract service,+      namingEdition = currentGeneratedHaskellNamingEdition,+      moduleRoles = [ScaffoldModuleRoleRow (moduleRole m) ((.kind) m) ((.path) m) | m <- modules],+      files = [((.kind) m, (.path) m) | m <- modules],+      mappings = (.mappings) (consumerPlanForService service),+      idDomains = idDomainIdentitiesForService service,+      nominalEqualities = nominalEqualityIdentitiesForService service,+      bindingObligations = either (const []) id (bindingHolesForService service),+      behaviorRequirements = currentBehavior,+      projectionCatalogFacts = projectionCatalogFactsForService service,+      queryContractBaseline = queryHistoryBaseline,+      queryContracts = either (const []) id (queryContractIdentitiesForService service),+      routerSelections = routerSelectionSnapshots service,+      semanticImpact = Just currentSemanticImpact+    }++missingGeneratedBanners :: FilePath -> [ScaffoldModule] -> IO [FilePath]+missingGeneratedBanners out modules = fmap concat $ mapM check generated+  where+    generated = [m | m <- modules, (.kind) m == Generated]+    check m = do+      let path = out </> (.path) m+      exists <- doesFileExist path+      if not exists+        then pure []+        else do+          contents <- TIO.readFile path+          pure [(.path) m | not (any isGeneratedBannerLine (T.lines contents))]++writeModule :: FilePath -> ScaffoldModule -> IO (ScaffoldModule, WriteDisposition)+writeModule out m = do+  let path = out </> (.path) m+  createDirectoryIfMissing True (takeDirectory path)+  case (.kind) m of+    Generated -> do+      exists <- doesFileExist path+      if exists+        then do+          existing <- TIO.readFile path+          if existing == (.text) m+            then pure (m, Unchanged)+            else TIO.writeFile path ((.text) m) >> pure (m, Overwritten)+        else TIO.writeFile path ((.text) m) >> pure (m, Overwritten)+    HoleStub -> do+      exists <- doesFileExist path+      if exists+        then pure (m, Skipped)+        else TIO.writeFile path ((.text) m) >> pure (m, Created)++-- | Qualify a refusal set raised after the run's sidecar renames were applied.+--+-- Every refusal message says "nothing was written", which is true of the module+-- tree but not of the renames, so the note is appended rather than the claim+-- being weakened everywhere. A refusal set that is empty stays empty.+withSidecarMovesApplied :: [SidecarMove] -> [Refusal] -> [Refusal]+withSidecarMovesApplied [] refusals = refusals+withSidecarMovesApplied _ [] = []+withSidecarMovesApplied moves refusals = refusals <> [SidecarMovesAlreadyApplied moves]++renderRefusals :: [Refusal] -> [Text]+renderRefusals allRefusals =+  concatMap render allRefusals+    <> [ "this tree needs both --apply-name-migrations and --apply-generated-haskell-edition in one run"+       | any requiresNameMigration allRefusals,+         any requiresEditionMigration allRefusals+       ]+  where+    requiresNameMigration = \case+      NameMigrationRequired _ -> True+      SidecarMigrationRequired _ -> True+      _ -> False+    requiresEditionMigration = \case+      GeneratedHaskellEditionRequired _ -> True+      _ -> False+    render (PathCollision path origins) =+      [ "error: module path collision -- refusing to scaffold; nothing was written",+        "  " <> T.pack path+      ]+        <> ["    from " <> source | source <- origins]+    render (FirewallBreach breaches) =+      [ "error: firewall breach -- refusing to scaffold; nothing was written",+        "firewall: BREACH (" <> tshow (length breaches) <> " forbidden token occurrence(s)):"+      ]+        <> ["  " <> T.pack path <> ":" <> tshow line <> " contains " <> token | (path, token, line) <- breaches]+    render (LoweringRefusal refusals) =+      ["error: scaffold cannot lower this spec faithfully -- refusing; nothing was written"]+        <> map ("  " <>) refusals+    render (MissingGeneratedBanner paths) =+      [ "error: refusing to overwrite " <> tshow (length paths) <> " file(s) at Generated paths that lack the '-- @generated' banner"+      ]+        <> map ("  " <>) (map T.pack paths)+        <> ["  (adopted as hand code? move it, or re-run with --force-generated-overwrite)", "nothing was written"]+    render (ImportCycle path) =+      [ "error: generated/consumer import cycle -- refusing to scaffold; nothing was written",+        "  " <> T.intercalate " -> " path,+        "  keep bindings in a leaf module that imports only Structural.Shape.* and Keiro.Codec.Structural"+      ]+    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 ((.code) failure))+               <> " "+               <> Behavior.unBehaviorKey ((.key) failure)+               <> ": "+               <> (.message) failure+           | failure <- failures+           ]+    render (GeneratedNameInvariantViolation violations) =+      ["error: generated Haskell name invariant violated -- refusing to scaffold; nothing was written"]+        <> map ("  " <>) violations+    render (NameMigrationRequired moves) =+      [ "error: name migration required: legacy-v1 -> idiomatic-v1; nothing was written",+        "re-run scaffold with --apply-name-migrations after reviewing these source moves:"+      ]+        <> map renderMove moves+    render (NameMigrationRefusal reasons) =+      ["error: name migration could not be applied safely; nothing was written"]+        <> map ("  " <>) reasons+    render (SidecarMigrationRequired moves) =+      [ "error: sidecar migration required; nothing was written",+        "re-run scaffold with --apply-name-migrations after reviewing these sidecar renames:"+      ]+        <> map (("  " <>) . renderSidecarMove) moves+    render (SidecarMigrationRefusal reasons) =+      ["error: sidecar migration could not be applied safely; nothing was written"]+        <> map ("  " <>) reasons+    render (GeneratedHaskellEditionRequired impact) =+      [ "error: generated Haskell edition migration required: "+          <> HaskellName.renderGeneratedHaskellNamingEdition ((.fromEdition) impact)+          <> " -> "+          <> HaskellName.renderGeneratedHaskellNamingEdition HaskellName.currentGeneratedHaskellNamingEdition+          <> "; nothing was written",+        "re-run scaffold with --apply-generated-haskell-edition after reviewing this impact:",+        "  generated files: " <> tshow (length ((.generatedPaths) impact))+      ]+        <> map (("    " <>) . T.pack) ((.generatedPaths) impact)+        <> ["  sidecars: " <> tshow (length ((.sidecarPaths) impact))]+        <> map (("    " <>) . T.pack) ((.sidecarPaths) impact)+        <> ["  hand-owned selector uses: " <> tshow (length ((.handOwnedUses) impact))]+        <> map renderEditionUse ((.handOwnedUses) impact)+        <> ["  " <> attributableUsesCaveat]+    render (GeneratedHaskellEditionRefusal reasons) =+      ["error: generated Haskell edition migration could not be applied safely; nothing was written"]+        <> map ("  " <>) reasons+    render (LedgerUnreadable path) =+      [ "error: scaffold ledger " <> T.pack path <> " exists but could not be parsed; nothing was written",+        "  restore it from version control or from the edition backup before scaffolding again"+      ]+    render (SidecarMovesAlreadyApplied moves) =+      [ "note: this run had already applied "+          <> tshow (length moves)+          <> " sidecar rename(s) before the refusal above, so \"nothing was written\" excludes them:"+      ]+        <> map (("  " <>) . renderSidecarMove) moves+        <> [ "The renames are idempotent and carry no spec content, so re-running scaffold",+             "after fixing the refusal is correct; nothing needs to be undone."+           ]+    render (FoldSurfaceRefusal surfaceError) =+      [ "error: aggregate fold identity could not be resolved -- refusing to scaffold; nothing was written",+        "  " <> renderFoldSurfaceError surfaceError+      ]+    render (SemanticContractMismatch detail) =+      [ "error: semantic language contract mismatch -- refusing to scaffold; nothing was written",+        "  " <> detail+      ]+    render (GoldenRootDivergence root paths) =+      [ "error: golden payload fixtures live beside a workspace member instead of under the workspace golden root -- refusing to scaffold"+      ]+        <> ["  " <> T.pack path | path <- paths]+        <> [ "  move these files under " <> T.pack root <> "; keiro-dsl reads one golden root per workspace",+             "  (a fixture the root lacks would be silently replaced by a synthesized stand-in)",+             "nothing was written"+           ]+    render (DuplicateConformanceFactKeys duplicates) =+      ["error: duplicate normalized service conformance fact keys -- refusing to scaffold; nothing was written"]+        <> ["  " <> (.duplicateServiceFactKey) duplicate | duplicate <- duplicates]+    render (ConformancePackageRefusal failure) = renderConformancePackageFailure failure+    renderMove move =+      "  "+        <> (case (.kind) move of Generated -> "generated "; HoleStub -> "hole      ")+        <> (.oldModule) move+        <> " -> "+        <> (.newModule) move+        <> "  backup: "+        <> T.pack ((.backupPath) move)+    renderEditionUse use =+      "    "+        <> T.pack ((.path) use)+        <> ":"+        <> tshow ((.line) use)+        <> ": "+        <> (.current) use+        <> " ("+        <> T.pack (show ((.form) use))+        <> ")"+        <> " -> "+        <> (.replacement) use++renderSemanticImpactReport :: SemanticImpactReport -> [Text]+renderSemanticImpactReport report = case (.declarations) report of+  [] -> []+  declarations ->+    ["semantic impact:"]+      <> case (.previous) report of+        Nothing ->+          ["  baseline: unavailable (legacy ledger)"]+            <> concatMap renderCurrent declarations+        Just _ -> concatMap renderDelta ((.deltas) report)+  where+    renderCurrent declaration =+      [ "  " <> (.unMappedKey) declaration,+        "    current aggregate consumers: " <> renderConsumers (Map.findWithDefault Set.empty declaration ((.mappedConsumers) ((.current) report))),+        "    current roots: " <> maybe "baseline unavailable" (renderEvidence . Map.findWithDefault Set.empty declaration) ((.mappedEvidence) ((.current) report)),+        "    current consequences: " <> maybe "baseline unavailable" (renderConsequences . Map.findWithDefault Set.empty declaration) ((.mappedConsequences) ((.current) report)),+        "    service-conformance: impacted"+      ]+    renderDelta delta =+      [ "  " <> (.unMappedKey) ((.declaration) delta),+        "    previous aggregate consumers: " <> renderConsumers ((.previousConsumers) delta),+        "    current aggregate consumers:  " <> renderConsumers ((.currentConsumers) delta),+        "    previous roots: " <> maybe "baseline unavailable" renderEvidence ((.previousEvidence) delta),+        "    current roots:  " <> maybe "baseline unavailable" renderEvidence ((.currentEvidence) delta),+        "    previous consequences: " <> maybe "baseline unavailable" renderConsequences ((.previousConsequences) delta),+        "    current consequences:  " <> maybe "baseline unavailable" renderConsequences ((.currentConsequences) delta),+        "    service-conformance: " <> if (.serviceConformance) 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 ((.rootKind) evidence), mappedConsumerIdentity ((.consumer) evidence), (.path) evidence]+        <> maybe "" ("|" <>) ((.operation) 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 ((.category) impact)+        <> " "+        <> T.pack ((.path) impact)+        <> " ("+        <> dispositionLabel ((.disposition) impact)+        <> ")"+    categoryLabel AggregateGeneratedArtifact+      | null ((.deltas) 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 ((.specPath) report) <> " -> " <> T.pack ((.outDir) report) <> " (module-root=" <> rootLabel <> ", layout=" <> layoutLabel <> ")"+  ]+    <> map moduleLine dispositions+    <> inertNodeSection+    <> [ "firewall: OK (" <> tshow generatedCount <> " generated modules scanned, 0 forbidden operators)",+         harnessLine,+         dependencyLine,+         "fragment: " <> T.pack ((.manifestPath) report),+         "ledger:   " <> T.pack ((.recordPath) report)+       ]+    <> previousSpecNote+    <> constraintSection+    <> newHolesSection+    <> queryContractSection+    <> queryContractMigrationSection+    <> mappingDriftSection+    <> renderSemanticImpactReport ((.semanticImpact) report)+    <> renderRouterSelectionDrift ((.routerSelectionDrift) report)+    <> maybe [] renderProjectionMappedImpact ((.projectionMappedImpact) report)+    <> renderGeneratedArtifactImpact ((.semanticImpact) report) ((.generatedArtifactImpact) report)+    <> sourceLanguageDriftSection+    <> behaviorDriftSection+    <> obsoleteOutputSection+    <> sidecarMoveSection+    <> nameMoveSection+    <> staleSection+    <> maybe [] renderConformancePackageReport ((.conformancePackage) report)+  where+    ctx = (.context) report+    dispositions = (.dispositions) report+    rootLabel = if T.null ((.moduleRoot) ctx) then "(none)" else (.moduleRoot) ctx+    layoutLabel = case (.placement) ctx of GeneratedPrefix -> "prefixed"; CollocatedLeaf -> "collocated"+    names = [moduleNameOf ((.path) m) | (m, _) <- dispositions]+    nameWidth = maximum (1 : map T.length names)+    moduleLine (m, disposition) =+      "  " <> kindTag ((.kind) m) <> "  " <> pad (moduleNameOf ((.path) m)) <> "  " <> dispositionTag disposition+    kindTag Generated = "generated"+    kindTag HoleStub = "hole     "+    dispositionTag Overwritten = "(overwritten)"+    dispositionTag Created = "(created)"+    dispositionTag Skipped = "(skipped: already present)"+    dispositionTag Unchanged = "(unchanged)"+    pad name = name <> T.replicate (nameWidth - T.length name) " "+    generatedCount = length [() | (m, _) <- dispositions, (.kind) m == Generated]+    inertNodeSection = renderInertNodeSection ((.inertNodes) report)+    harnesses =+      sortOn+        id+        [ moduleNameOf ((.path) m)+        | (m, _) <- dispositions,+          any (`T.isSuffixOf` moduleNameOf ((.path) m)) [".Harness", ".ProcessHarness", ".WorkflowFacts"]+        ]+    harnessLine = case harnesses of+      [] -> "harness:  (none emitted)"+      _ -> "harness:  run `cabal test <your-component>` over " <> T.unwords harnesses+    dependencyLine =+      "dependency plan: consumer packages "+        <> renderBracketed ((.packages) ((.consumerPlan) report))+        <> ", consumer modules "+        <> renderBracketed ((.modules) ((.consumerPlan) report))+    constraintSection = case (.constraintPlan) report of+      [] -> []+      constraints -> "constraint plan:" : map ("  " <>) constraints+    newHolesSection = case (.newHoles) report of+      [] -> []+      obligations ->+        ["newly required holes since last scaffold: " <> tshow (length obligations)]+          <> concatMap obligationLines obligations+    obligationLines hole =+      [ "  " <> (.moduleName) hole,+        "    " <> (.signature) hole <> " (" <> obligationKindLabel ((.kind) hole) <> ")"+      ]+    queryContractSection =+      [ "query contract history: baseline unavailable in the previous ledger; no legacy `()` API was inferred"+      | (.queryContractBaselineUnavailable) report+      ]+        <> case (.queryContractDrift) 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 ((.previous) drift),+        "    current:  " <> maybe "(absent)" renderQueryIdentity ((.current) drift)+      ]+      where+        (readModel, position) = (.key) drift+    renderQueryIdentity identity =+      (.typeExpression) identity+        <> " mapped=["+        <> T.intercalate ", " ((.mappedDependencies) identity)+        <> "]"+    queryPositionLabel QueryInputConsumer = "input"+    queryPositionLabel QueryResultConsumer = "result"+    queryContractMigrationSection = case (.queryContractMigrations) report of+      [] -> []+      migrations ->+        ["query contract migration required: " <> tshow (length migrations) <> " hand-owned hole module(s)"]+          <> concatMap migrationLines migrations+    migrationLines migration =+      [ "  " <> (.owner) migration,+        "    edit " <> T.pack ((.path) migration),+        "    remove the local QueryInput/QueryResult type aliases",+        "    add " <> (.requiredImport) migration+      ]+    previousSpecNote = case (.previousSpecPath) report of+      Just previous+        | previous /= T.pack ((.specPath) report) ->+            [ "note: the previous scaffold record used spec " <> previous,+              "      specs sharing context " <> (.name) ctx <> " in one --out also share " <> T.pack ((.manifestPath) report)+            ]+      _ -> []+    mappingDriftSection = case (.mappingDrift) report of+      [] -> []+      drifts ->+        ["mapping drift: " <> tshow (length drifts) <> " declaration(s) changed since the previous scaffold:"]+          <> concatMap driftLines drifts+    driftLines drift =+      [ "  " <> (.specName) drift,+        "    previous: " <> maybe "(absent)" renderMappingIdentity ((.previous) drift),+        "    current:  " <> maybe "(absent)" renderMappingIdentity ((.current) drift)+      ]+    sourceLanguageDriftSection = case (.sourceLanguageDrift) report of+      Nothing -> []+      Just drift ->+        [ "source-language drift: "+            <> sourceLanguageLabel ((.previous) drift)+            <> " -> "+            <> sourceLanguageLabel ((.current) drift)+            <> " (generated module bytes are semantic and unaffected)"+        ]+    behaviorDriftSection =+      renderBehaviorRows "new behavior obligations" ((.addedBehavior) report)+        <> renderBehaviorRows "removed behavior obligations (consumer rows become stale)" ((.removedBehavior) report)+    renderBehaviorRows _ [] = []+    renderBehaviorRows label rows =+      [label <> ": " <> tshow (length rows)] <> concatMap behaviorLines rows+    behaviorLines row =+      [ "  "+          <> (.aggregate) row+          <> ":"+          <> (.source) row+          <> " -- "+          <> (.command) row+          <> "  "+          <> (.unBehaviorKey) ((.key) row),+        "    Pending (BehaviorKey " <> tshow ((.unBehaviorKey) ((.key) row)) <> ")"+      ]+    obsoleteOutputSection = case (.obsoleteOutputHooks) report of+      [] -> []+      hooks ->+        ["obsolete identity-copy output hooks (if still present, they are unused and may be removed):"]+          <> ["  " <> aggregate <> ".Holes." <> hook | (aggregate, hook) <- hooks]+    sidecarMoveSection = case (.sidecarMoves) report of+      [] -> []+      moves ->+        ["sidecar migration: applied (" <> tshow (length moves) <> " move(s))"]+          <> map (("  " <>) . renderSidecarMove) moves+    nameMoveSection = case (.nameMoves) report of+      [] -> []+      moves ->+        ["name migration: applied (" <> tshow (length moves) <> " source move(s))"]+          <> ["  backup: " <> T.pack ((.backupPath) move) | move <- moves]+    staleSection = case (.stale) report of+      [] -> []+      stale ->+        [ "stale: " <> tshow (length stale) <> " file(s) from a previous scaffold of context " <> (.name) ctx <> " are no longer produced by this spec:"+        ]+          <> map staleLine stale+          <> ["note: keiro-dsl never deletes files."]+    staleLine stale = case ((.kind) stale, (.generatedEvidence) stale) of+      (Generated, Just ExactGeneratedBannerPresent) ->+        "  generated " <> T.pack ((.path) stale) <> "  (exact generated banner present; verify unchanged bytes before deleting)"+      (Generated, _) ->+        "  generated " <> T.pack ((.path) stale) <> "  (exact generated banner missing; preserve and review)"+      (HoleStub, _) -> "  hole      " <> T.pack ((.path) stale) <> "  (hand-owned — preserve and review)"++sourceLanguageLabel :: SourceLanguage -> Text+sourceLanguageLabel sourceLanguage =+  sourceFormText sourceLanguage+    <> "/effective-v"+    <> languageVersionText (effectiveLanguageVersion sourceLanguage)++obligationKindLabel :: BindingObligationKind -> Text+obligationKindLabel BindingValue = "binding"+obligationKindLabel FixtureValue = "fixtures"+obligationKindLabel InitialValue = "initial-value"++renderBracketed :: [Text] -> Text+renderBracketed values = "[" <> T.intercalate ", " values <> "]"++renderMappingIdentity :: MappingIdentity -> Text+renderMappingIdentity StructuralMapping {package, moduleName, valueType, bindingSymbol, bindingVersion} =+  "structural "+    <> package+    <> ":"+    <> moduleName+    <> "."+    <> valueType+    <> " binding="+    <> bindingSymbol+    <> " version="+    <> bindingVersion+renderMappingIdentity OpaqueMapping {package, moduleName, valueType, codecIdentity, codecVersion} =+  "opaque "+    <> package+    <> ":"+    <> moduleName+    <> "."+    <> valueType+    <> " codec="+    <> codecIdentity+    <> " version="+    <> codecVersion+renderMappingIdentity NominalMapping {nominalCategory, nominalRepresentation, package, moduleName, valueType, bindingSymbol, bindingVersion} =+  "nominal-"+    <> nominalCategory+    <> " "+    <> package+    <> ":"+    <> moduleName+    <> "."+    <> valueType+    <> " representation="+    <> nominalRepresentation+    <> " binding="+    <> bindingSymbol+    <> " version="+    <> bindingVersion  tshow :: (Show a) => a -> Text tshow = T.pack . show

src/Keiro/Dsl/SemanticContract.hs view

@@ -6,9 +6,7 @@ -- normalized service-level input used after parsing and workspace composition. -- It deliberately wraps 'Spec' rather than becoming part of the graph. module Keiro.Dsl.SemanticContract-  ( EffectiveLanguageContract,-    effectiveContractLanguageVersion,-    effectiveRuntimeProfile,+  ( EffectiveLanguageContract (..),     effectiveRuntimeSemantics,     effectiveLanguageSupport,     languageContractNotice,@@ -35,13 +33,13 @@ import Data.Text qualified as T import Keiro.Dsl.Grammar (Spec) import Keiro.Dsl.LanguageVersion-  ( LanguageSupport (..),+  ( LanguageDefinition (..),+    LanguageSupport (..),     LanguageVersion,     ParsedSource (..),     RuntimeSemanticsProfile,     SourceLanguage (..),     currentStableLanguageVersion,-    definitionRuntimeSemanticsProfile,     effectiveLanguageVersion,     languageSupportForVersion,     languageSupportText,@@ -62,22 +60,22 @@ -- fold, replay, diff, and generation planners consume that discriminator rather -- than re-deriving policy from source text. data EffectiveLanguageContract = EffectiveLanguageContract-  { effectiveContractLanguageVersion :: !LanguageVersion,-    effectiveRuntimeProfile :: !RuntimeSemanticsProfile+  { contractLanguageVersion :: !LanguageVersion,+    runtimeProfile :: !RuntimeSemanticsProfile   }   deriving stock (Eq, Ord, Show)  -- | Stable compatibility projection for records, JSON, and diagnostics. -- Runtime behavior queries 'effectiveRuntimeProfile' capabilities instead. effectiveRuntimeSemantics :: EffectiveLanguageContract -> Text-effectiveRuntimeSemantics = runtimeProfileIdentifier . effectiveRuntimeProfile+effectiveRuntimeSemantics = runtimeProfileIdentifier . (.runtimeProfile)  -- | Lifecycle classification derived from the authoritative language registry. effectiveLanguageSupport :: EffectiveLanguageContract -> LanguageSupport effectiveLanguageSupport contract =   fromMaybe     (error "keiro-dsl internal invariant: effective contract selected an unregistered language version")-    (languageSupportForVersion (effectiveContractLanguageVersion contract))+    (languageSupportForVersion ((.contractLanguageVersion) contract))  -- | One stderr line naming a compatibility-only effective contract. Published -- stable and active candidate sources stay silent.@@ -88,7 +86,7 @@       Just         ( T.pack subject             <> ": language contract: effective keiro-dsl "-            <> languageVersionText (effectiveContractLanguageVersion contract)+            <> languageVersionText ((.contractLanguageVersion) contract)             <> " ("             <> sourceFormSummary             <> ", "@@ -105,7 +103,7 @@ instance ToJSON EffectiveLanguageContract where   toJSON contract =     object-      [ "languageVersion" .= languageVersionNumber (effectiveContractLanguageVersion contract),+      [ "languageVersion" .= languageVersionNumber ((.contractLanguageVersion) contract),         "runtimeSemantics" .= effectiveRuntimeSemantics contract,         "languageSupport" .= languageSupportText (effectiveLanguageSupport contract)       ]@@ -145,42 +143,42 @@   definition <- lookupLanguageDefinition version   pure     EffectiveLanguageContract-      { effectiveContractLanguageVersion = version,-        effectiveRuntimeProfile = definitionRuntimeSemanticsProfile definition+      { contractLanguageVersion = version,+        runtimeProfile = (.runtimeSemanticsProfile) definition       }  -- | Deduplicated, stable replay-fold segments explicitly declared by the -- effective runtime capabilities. Grammar-, validation-, and codec-only -- changes deliberately contribute no segment. runtimeSemanticsFingerprintSegments :: EffectiveLanguageContract -> [Text]-runtimeSemanticsFingerprintSegments = runtimeProfileFoldSegments . effectiveRuntimeProfile+runtimeSemanticsFingerprintSegments = runtimeProfileFoldSegments . (.runtimeProfile)  -- | A normalized service graph paired with the effective contract under which -- it was checked. Member-level declared/legacy provenance intentionally stays -- on 'ParsedSource' or 'Keiro.Dsl.Workspace.WorkspaceMember'. data CheckedService = CheckedService-  { serviceLanguageContract :: !EffectiveLanguageContract,-    serviceSpec :: !Spec,-    serviceTypeGraph :: Either (NonEmpty TypeGraphError) TypeGraph,-    serviceProjectionSupplies :: ProjectionSupplyAnalysis+  { languageContract :: !EffectiveLanguageContract,+    spec :: !Spec,+    typeGraph :: Either (NonEmpty TypeGraphError) TypeGraph,+    projectionSupplies :: ProjectionSupplyAnalysis   }  checkedLanguageContract :: CheckedService -> EffectiveLanguageContract-checkedLanguageContract = serviceLanguageContract+checkedLanguageContract = (.languageContract)  checkedSpec :: CheckedService -> Spec-checkedSpec = serviceSpec+checkedSpec = (.spec)  -- | 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+checkedTypeGraph = (.typeGraph)  -- | 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+checkedProjectionSupplies = (.projectionSupplies)  -- | Replace a service's spec while preserving its effective language contract -- and rebuilding the lazy whole-spec analysis cache for the replacement.@@ -205,7 +203,7 @@ -- selected contract. checkedSource :: ParsedSource -> CheckedService checkedSource parsed =-  checkedService (parsedSourceLanguage parsed) (parsedSpec parsed)+  checkedService ((.sourceLanguage) parsed) ((.spec) parsed)  -- | Construct a service from a source-language selection and normalized graph. -- Workspace composition uses this only after proving that every member has the@@ -219,10 +217,10 @@ checkedServiceForContract :: EffectiveLanguageContract -> Spec -> CheckedService checkedServiceForContract languageContract spec =   CheckedService-    { serviceLanguageContract = languageContract,-      serviceSpec = spec,-      serviceTypeGraph = resolveTypeGraph spec,-      serviceProjectionSupplies = analyzeProjectionSupplies spec+    { languageContract = languageContract,+      spec = spec,+      typeGraph = resolveTypeGraph spec,+      projectionSupplies = analyzeProjectionSupplies spec     }  -- | Compatibility bridge for callers that historically supplied only 'Spec'.

src/Keiro/Dsl/SemanticImpact.hs view

@@ -97,10 +97,10 @@  -- | One checked aggregate root before transitive declaration expansion. data MappedRoot = MappedRoot-  { mappedRootConsumer :: !MappedConsumer,-    mappedRootKind :: !MappedRootKind,-    mappedRootUseSite :: !UseSite,-    mappedRootDeclaration :: !MappedKey+  { consumer :: !MappedConsumer,+    kind :: !MappedRootKind,+    useSite :: !UseSite,+    declaration :: !MappedKey   }   deriving stock (Eq, Ord, Show, Generic) @@ -108,10 +108,10 @@ -- 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)+  { consumer :: !MappedConsumer,+    rootKind :: !MappedRootKind,+    path :: !Text,+    operation :: !(Maybe Text)   }   deriving stock (Eq, Ord, Show, Generic) @@ -138,15 +138,15 @@ -- 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]+  { roots :: ![MappedRoot],+    usePaths :: !(Map MappedKey [UsePath]),+    aggregateDeclarations :: !(Map MappedConsumer (Set MappedKey)),+    declarationConsumers :: !(Map MappedKey (Set MappedConsumer)),+    declarationEvidence :: !(Map MappedKey (Set MappedRootEvidence)),+    declarationConsequences :: !(Map MappedKey (Set MappedConsequence)),+    serviceDeclarations :: !(Set MappedKey),+    declarationIdentities :: !(Map MappedKey Text),+    unsupportedProjectionSources :: ![UnsupportedProjectionSource]   }   deriving stock (Eq, Show, Generic) @@ -156,25 +156,25 @@ -- 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)+  { mappedConsumers :: !(Map MappedKey (Set MappedConsumer)),+    mappedEvidence :: !(Maybe (Map MappedKey (Set MappedRootEvidence))),+    mappedConsequences :: !(Maybe (Map MappedKey (Set MappedConsequence))),+    serviceInventory :: !(Set MappedKey),+    declarationIdentities :: !(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+  { declaration :: !MappedKey,+    previousConsumers :: !(Set MappedConsumer),+    currentConsumers :: !(Set MappedConsumer),+    previousEvidence :: !(Maybe (Set MappedRootEvidence)),+    currentEvidence :: !(Maybe (Set MappedRootEvidence)),+    previousConsequences :: !(Maybe (Set MappedConsequence)),+    currentConsequences :: !(Maybe (Set MappedConsequence)),+    serviceConformance :: !Bool   }   deriving stock (Eq, Show, Generic) @@ -182,10 +182,10 @@ -- 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]+  { previous :: !(Maybe SemanticImpactSnapshot),+    current :: !SemanticImpactSnapshot,+    declarations :: ![MappedKey],+    deltas :: ![MappedImpactDelta]   }   deriving stock (Eq, Show, Generic) @@ -199,18 +199,18 @@           .= [ object                  ( [ "declaration" .= unMappedKey declaration,                      "consumers" .= map mappedConsumerIdentity (Set.toAscList declarationConsumers),-                     "identity" .= Map.findWithDefault "" declaration (snapshotDeclarationIdentities snapshot)+                     "identity" .= Map.findWithDefault "" declaration ((.declarationIdentities) 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)+                     <> maybe [] (\evidence -> ["consumerEvidence" .= Set.toAscList (Map.findWithDefault Set.empty declaration evidence)]) ((.mappedEvidence) snapshot)+                     <> maybe [] (\consequences -> ["consequences" .= Set.toAscList (Map.findWithDefault Set.empty declaration consequences)]) ((.mappedConsequences) snapshot)                  )-             | (declaration, declarationConsumers) <- Map.toAscList (snapshotMappedConsumers snapshot)+             | (declaration, declarationConsumers) <- Map.toAscList ((.mappedConsumers) snapshot)              ],-        "serviceInventory" .= map unMappedKey (Set.toAscList (snapshotServiceInventory snapshot))+        "serviceInventory" .= map unMappedKey (Set.toAscList ((.serviceInventory) snapshot))       ]         <> [ "mappedSurfaceEvidenceVersion" .= (1 :: Int)-           | isJust (snapshotMappedEvidence snapshot)-               || isJust (snapshotMappedConsequences snapshot)+           | isJust ((.mappedEvidence) snapshot)+               || isJust ((.mappedConsequences) snapshot)            ]  instance FromJSON SemanticImpactSnapshot where@@ -244,11 +244,11 @@     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+        { mappedConsumers = declarationMap,+          mappedEvidence = evidence,+          mappedConsequences = consequences,+          serviceInventory = inventory,+          declarationIdentities = declarationIdentities         }     where       parseDeclaration = withObject "SemanticImpactDeclaration" $ \row -> do@@ -266,13 +266,13 @@       distinct values = length values == Set.size (Set.fromList values)       evidenceAgrees consumers evidence =         and-          [ Set.map evidenceConsumer (Map.findWithDefault Set.empty declaration evidence) == declarationConsumers+          [ Set.map (.consumer) (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+      operationAgrees evidence = case (.rootKind) evidence of+        MappedProjectionEventRoot -> maybe False (not . T.null) ((.operation) evidence)+        _ -> (.operation) evidence == Nothing       consequencesAgree consumers consequences =         and           [ Set.fromList@@ -293,10 +293,10 @@ instance ToJSON MappedRootEvidence where   toJSON evidence =     object-      [ "consumer" .= mappedConsumerIdentity (evidenceConsumer evidence),-        "surface" .= mappedRootKindIdentity (evidenceRootKind evidence),-        "path" .= evidencePath evidence,-        "operation" .= evidenceOperation evidence+      [ "consumer" .= mappedConsumerIdentity ((.consumer) evidence),+        "surface" .= mappedRootKindIdentity ((.rootKind) evidence),+        "path" .= (.path) evidence,+        "operation" .= (.operation) evidence       ]  instance FromJSON MappedRootEvidence where@@ -337,14 +337,14 @@ 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+      [ "declaration" .= unMappedKey ((.declaration) delta),+        "previousConsumers" .= map mappedConsumerIdentity (Set.toAscList ((.previousConsumers) delta)),+        "currentConsumers" .= map mappedConsumerIdentity (Set.toAscList ((.currentConsumers) delta)),+        "previousConsumerEvidence" .= fmap Set.toAscList ((.previousEvidence) delta),+        "currentConsumerEvidence" .= fmap Set.toAscList ((.currentEvidence) delta),+        "previousConsequences" .= fmap Set.toAscList ((.previousConsequences) delta),+        "currentConsequences" .= fmap Set.toAscList ((.currentConsequences) delta),+        "serviceConformance" .= (.serviceConformance) delta       ]  instance FromJSON MappedImpactDelta where@@ -352,9 +352,9 @@     declaration <- MappedKey <$> fields .: "declaration"     previousNames <- fields .: "previousConsumers"     currentNames <- fields .: "currentConsumers"-    previousEvidence <- fields .:? "previousConsumerEvidence"+    decodedPreviousEvidence <- fields .:? "previousConsumerEvidence"     currentEvidence <- fields .:? "currentConsumerEvidence"-    previousConsequences <- fields .:? "previousConsequences"+    decodedPreviousConsequences <- fields .:? "previousConsequences"     currentConsequences <- fields .:? "currentConsequences"     serviceConformance <- fields .: "serviceConformance"     previous <- traverse parseConsumerName previousNames@@ -363,14 +363,14 @@     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+        { declaration = declaration,+          previousConsumers = Set.fromList previous,+          currentConsumers = Set.fromList current,+          previousEvidence = Set.fromList <$> decodedPreviousEvidence,+          currentEvidence = Set.fromList <$> currentEvidence,+          previousConsequences = Set.fromList <$> decodedPreviousConsequences,+          currentConsequences = Set.fromList <$> currentConsequences,+          serviceConformance = serviceConformance         }     where       distinct values = length values == Set.size (Set.fromList values)@@ -381,41 +381,41 @@ 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+    { roots = roots,+      usePaths = pathsByDeclaration,+      aggregateDeclarations = aggregateDeclarations,+      declarationConsumers = declarationConsumers,+      declarationEvidence = declarationEvidence,+      declarationConsequences = Map.map (Set.unions . map consequencesForEvidence . Set.toAscList) declarationEvidence,+      serviceDeclarations = allServiceDeclarations,+      declarationIdentities = Map.mapWithKey (declarationIdentity graph) ((.declarations) graph),+      unsupportedProjectionSources = (.unsupportedProjectionSources) graph     }   where-    directRoots = map mappedRootFromUseSite (tgUseSites graph)-    roots = sort (directRoots <> concatMap derivedRoots (tgDerivedMappedConsumers graph))+    directRoots = map mappedRootFromUseSite ((.useSites) graph)+    roots = sort (directRoots <> concatMap derivedRoots ((.derivedMappedConsumers) graph))     derivedRoots consumer =       [ MappedRoot-          { mappedRootConsumer = DerivedProjectionConsumer consumer,-            mappedRootKind = MappedProjectionEventRoot,-            mappedRootUseSite = site,-            mappedRootDeclaration = declaration+          { consumer = DerivedProjectionConsumer consumer,+            kind = MappedProjectionEventRoot,+            useSite = site,+            declaration = declaration           }-      | site@(RootEventField aggregate _ _ declaration) <- tgUseSites graph,+      | site@(RootEventField aggregate _ _ declaration) <- (.useSites) graph,         aggregate == derivedAuthority consumer       ]     aggregateDeclarations =       Map.fromListWith         Set.union-        [ (mappedRootConsumer root, declarationClosure graph (mappedRootDeclaration root))+        [ ((.consumer) root, declarationClosure graph ((.declaration) root))         | root <- roots         ]-    serviceDeclarations = Map.keysSet (tgDeclarations graph)-    pathsByDeclaration = Map.fromSet (sort . usePaths graph . unMappedKey) serviceDeclarations+    allServiceDeclarations = Map.keysSet ((.declarations) graph)+    pathsByDeclaration = Map.fromSet (sort . usePaths graph . unMappedKey) allServiceDeclarations     declarationConsumers =       Map.unionWith         Set.union-        (Map.fromSet (const Set.empty) serviceDeclarations)+        (Map.fromSet (const Set.empty) allServiceDeclarations)         ( Map.fromListWith             Set.union             [ (declaration, Set.singleton consumer)@@ -428,23 +428,23 @@         (\_ paths -> Set.fromList (concatMap evidenceForPath paths))         pathsByDeclaration     evidenceForPath usePath =-      let directRoot = mappedRootFromUseSite (upRoot usePath)+      let directRoot = mappedRootFromUseSite ((.root) usePath)           direct =             MappedRootEvidence-              { evidenceConsumer = mappedRootConsumer directRoot,-                evidenceRootKind = mappedRootKind directRoot,-                evidencePath = renderUsePath usePath,-                evidenceOperation = Nothing+              { consumer = (.consumer) directRoot,+                rootKind = (.kind) directRoot,+                path = renderUsePath usePath,+                operation = Nothing               }           projections =             [ MappedRootEvidence-                { evidenceConsumer = DerivedProjectionConsumer derived,-                  evidenceRootKind = MappedProjectionEventRoot,-                  evidencePath = renderUsePath usePath,-                  evidenceOperation = Map.lookup derived (tgProjectionOperationalIdentities graph)+                { consumer = DerivedProjectionConsumer derived,+                  rootKind = MappedProjectionEventRoot,+                  path = renderUsePath usePath,+                  operation = Map.lookup derived ((.projectionOperationalIdentities) graph)                 }             | aggregate <- maybeToList (eventAuthority usePath),-              derived <- tgDerivedMappedConsumers graph,+              derived <- (.derivedMappedConsumers) graph,               derivedAuthority derived == aggregate             ]        in direct : projections@@ -455,20 +455,24 @@ -- 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+  SemanticImpact+    { roots = sort (base.roots <> map (.root) extraEvidence),+      usePaths = base.usePaths,+      aggregateDeclarations = Map.unionWith Set.union base.aggregateDeclarations declarationsByConsumer,+      declarationConsumers = Map.unionWith Set.union base.declarationConsumers consumersByDeclaration,+      declarationEvidence = Map.unionWith Set.union base.declarationEvidence evidenceByDeclaration,+      declarationConsequences = Map.unionWith Set.union base.declarationConsequences consequencesByDeclaration,+      serviceDeclarations = base.serviceDeclarations,+      declarationIdentities = base.declarationIdentities,+      unsupportedProjectionSources = base.unsupportedProjectionSources     }   where     base = semanticImpact graph     extraEvidence = concatMap checkedRouterEvidence checkedSelections     checkedSelections =-      [ (rtId router, checked)-      | NRouter router <- specNodes (checkedSpec service),-        ResolveDeclarative {} <- [rvSource (rtResolve router)],+      [ ((.id) router, checked)+      | NRouter router <- (.nodes) (checkedSpec service),+        ResolveDeclarative {} <- [(.source) ((.resolve) 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)@@ -476,15 +480,15 @@     declarationsByConsumer =       Map.fromListWith         Set.union-        [ (mappedRootConsumer root, declarationClosure graph (mappedRootDeclaration root))+        [ ((.consumer) root, declarationClosure graph ((.declaration) root))         | SelectionEvidence root _ <- extraEvidence         ]     consumersByDeclaration =       Map.fromListWith         Set.union-        [ (declaration, Set.singleton (mappedRootConsumer root))+        [ (declaration, Set.singleton ((.consumer) root))         | SelectionEvidence root _ <- extraEvidence,-          declaration <- Set.toList (declarationClosure graph (mappedRootDeclaration root))+          declaration <- Set.toList (declarationClosure graph ((.declaration) root))         ]     evidenceByDeclaration =       Map.fromListWith@@ -492,14 +496,14 @@         [ ( declaration,             Set.singleton               MappedRootEvidence-                { evidenceConsumer = mappedRootConsumer root,-                  evidenceRootKind = mappedRootKind root,-                  evidencePath = path,-                  evidenceOperation = Nothing+                { consumer = (.consumer) root,+                  rootKind = (.kind) root,+                  path = path,+                  operation = Nothing                 }           )         | SelectionEvidence root path <- extraEvidence,-          declaration <- Set.toList (declarationClosure graph (mappedRootDeclaration root))+          declaration <- Set.toList (declarationClosure graph ((.declaration) root))         ]     consequencesByDeclaration =       Map.map@@ -507,8 +511,8 @@         evidenceByDeclaration  data SelectionEvidence = SelectionEvidence-  { selectionEvidenceRoot :: !MappedRoot,-    selectionEvidencePath :: !Text+  { root :: !MappedRoot,+    path :: !Text   }  checkedRouterEvidence :: (Name, CheckedRouterSelection) -> [SelectionEvidence]@@ -516,14 +520,14 @@   where     queryInputEvidence =       [ selectionEvidence router SelectionQueryInput MappedRouterSelectionQueryInputRoot site ("router " <> router <> " selection query input")-      | site@RootReadModelQueryInput {} <- checkedUseSites selection+      | site@RootReadModelQueryInput {} <- (.useSites) selection       ]     expressionEvidence =-      checkedExpressionEvidence router selection SelectionPredicate MappedRouterSelectionPredicateRoot "predicate" (checkedPredicate selection)-        <> checkedExpressionEvidence router selection SelectionRecipient MappedRouterSelectionRecipientRoot "recipient" (checkedRecipient selection)+      checkedExpressionEvidence router selection SelectionPredicate MappedRouterSelectionPredicateRoot "predicate" ((.predicate) selection)+        <> checkedExpressionEvidence router selection SelectionRecipient MappedRouterSelectionRecipientRoot "recipient" ((.recipient) selection)         <> concat           [ checkedExpressionEvidence router selection (SelectionCommandField field) MappedRouterSelectionCommandFieldRoot ("command field " <> field) expression-          | (field, expression) <- Map.toAscList (checkedCommandFields selection)+          | (field, expression) <- Map.toAscList ((.commandFields) selection)           ]  checkedExpressionEvidence :: Name -> CheckedRouterSelection -> RouterSelectionPosition -> MappedRootKind -> Text -> CheckedScalarExpr -> [SelectionEvidence]@@ -536,20 +540,20 @@ selectionEvidence :: Name -> RouterSelectionPosition -> MappedRootKind -> UseSite -> Text -> SelectionEvidence selectionEvidence router position rootKind site path =   SelectionEvidence-    { selectionEvidenceRoot =+    { root =         MappedRoot-          { mappedRootConsumer = RouterSelectionConsumer router position,-            mappedRootKind = rootKind,-            mappedRootUseSite = site,-            mappedRootDeclaration = useSiteDeclaration site+          { consumer = RouterSelectionConsumer router position,+            kind = rootKind,+            useSite = site,+            declaration = useSiteDeclaration site           },-      selectionEvidencePath = path+      path = path     }  selectionRootSites :: SelectionRoot -> CheckedRouterSelection -> [UseSite] selectionRootSites root selection =   [ site-  | site <- checkedUseSites selection,+  | site <- (.useSites) selection,     case (root, site) of       (SelectionInput, RootReadModelQueryInput {}) -> True       (SelectionRow, RootReadModelQueryResult {}) -> True@@ -557,7 +561,7 @@   ]  checkedScalarPaths :: CheckedScalarExpr -> [(SelectionRoot, [CheckedSelectionPathSegment])]-checkedScalarPaths expression = case checkedScalarNode expression of+checkedScalarPaths expression = case (.node) expression of   CheckedPath root segments -> [(root, segments)]   CheckedTextLiteral _ -> []   CheckedIntegralLiteral _ -> []@@ -568,12 +572,12 @@  renderCheckedPath :: SelectionRoot -> [CheckedSelectionPathSegment] -> Text renderCheckedPath root segments =-  rootLabel <> T.concat ["." <> checkedPathField segment <> wireLabel segment | segment <- segments]+  rootLabel <> T.concat ["." <> (.field) segment <> wireLabel segment | segment <- segments]   where     rootLabel = case root of SelectionInput -> "input"; SelectionRow -> "row"     wireLabel segment-      | checkedPathField segment == checkedPathWireKey segment = ""-      | otherwise = " as '" <> checkedPathWireKey segment <> "'"+      | (.field) segment == (.wireKey) segment = ""+      | otherwise = " as '" <> (.wireKey) segment <> "'"  useSiteDeclaration :: UseSite -> MappedKey useSiteDeclaration = \case@@ -586,35 +590,35 @@  consequencesForMappedEvidence :: TypeGraph -> MappedRootEvidence -> Set MappedConsequence consequencesForMappedEvidence graph evidence =-  Set.fromList (MappedConsumerBuild (evidenceConsumer evidence) : surfaceConsequences)+  Set.fromList (MappedConsumerBuild ((.consumer) evidence) : surfaceConsequences)   where-    surfaceConsequences = case evidenceRootKind evidence of+    surfaceConsequences = case (.rootKind) evidence of       MappedCommandFieldRoot -> []-      MappedEventFieldRoot -> case evidenceConsumer evidence of+      MappedEventFieldRoot -> case (.consumer) evidence of         AggregateConsumer aggregate -> [MappedPrivateEventHistory aggregate]         _ -> []-      MappedRegisterRoot -> case evidenceConsumer evidence of+      MappedRegisterRoot -> case (.consumer) evidence of         AggregateConsumer aggregate -> [MappedSnapshotHydration aggregate]         _ -> []-      MappedWorkqueueFieldRoot -> case evidenceConsumer evidence of+      MappedWorkqueueFieldRoot -> case (.consumer) evidence of         WorkqueueConsumer workqueue -> [MappedWorkqueueHistory workqueue]         _ -> []-      MappedReadModelQueryInputRoot -> case evidenceConsumer evidence of+      MappedReadModelQueryInputRoot -> case (.consumer) evidence of         ReadModelQueryConsumer readModel MappedQueryInput -> [MappedQueryApi readModel MappedQueryInput]         _ -> []-      MappedReadModelQueryResultRoot -> case evidenceConsumer evidence of+      MappedReadModelQueryResultRoot -> case (.consumer) evidence of         ReadModelQueryConsumer readModel MappedQueryResult -> [MappedQueryApi readModel MappedQueryResult]         _ -> []       MappedRouterSelectionQueryInputRoot -> selectionConsequences       MappedRouterSelectionPredicateRoot -> selectionConsequences       MappedRouterSelectionRecipientRoot -> selectionConsequences       MappedRouterSelectionCommandFieldRoot -> selectionConsequences-      MappedProjectionEventRoot -> case evidenceConsumer evidence of+      MappedProjectionEventRoot -> case (.consumer) evidence of         DerivedProjectionConsumer derived ->           MappedProjectionHandlerReview derived-            : [MappedProjectionRebuild derived groupName | groupName <- maybeToList (Map.lookup derived (tgReplayableProjectionGroups graph))]+            : [MappedProjectionRebuild derived groupName | groupName <- maybeToList (Map.lookup derived ((.replayableProjectionGroups) graph))]         _ -> []-    selectionConsequences = case evidenceConsumer evidence of+    selectionConsequences = case (.consumer) evidence of       RouterSelectionConsumer router _ -> [MappedRouterSelectionBuild router, MappedRouterSelectionCoordinationReview router]       _ -> [] @@ -622,11 +626,11 @@ semanticImpactSnapshot :: SemanticImpact -> SemanticImpactSnapshot semanticImpactSnapshot impact =   SemanticImpactSnapshot-    { snapshotMappedConsumers = impactDeclarationConsumers impact,-      snapshotMappedEvidence = Just (impactDeclarationEvidence impact),-      snapshotMappedConsequences = Just (impactDeclarationConsequences impact),-      snapshotServiceInventory = impactServiceDeclarations impact,-      snapshotDeclarationIdentities = impactDeclarationIdentities impact+    { mappedConsumers = (.declarationConsumers) impact,+      mappedEvidence = Just ((.declarationEvidence) impact),+      mappedConsequences = Just ((.declarationConsequences) impact),+      serviceInventory = (.serviceDeclarations) impact,+      declarationIdentities = (.declarationIdentities) impact     }  -- | Compare consumer membership, service-inventory membership, and canonical@@ -635,28 +639,28 @@ 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)+    (.previousConsumers) delta /= (.currentConsumers) delta+      || (.previousEvidence) delta /= (.currentEvidence) delta+      || (.previousConsequences) delta /= (.currentConsequences) delta+      || serviceMember previous ((.declaration) delta) /= serviceMember current ((.declaration) delta)+      || declarationIdentityAt previous ((.declaration) delta) /= declarationIdentityAt current ((.declaration) delta)   ]   where-    allDeclarations = Set.toAscList (snapshotServiceInventory previous <> snapshotServiceInventory current)+    allDeclarations = Set.toAscList ((.serviceInventory) previous <> (.serviceInventory) 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 = declaration,+        previousConsumers = snapshotConsumers previous declaration,+        currentConsumers = snapshotConsumers current declaration,+        previousEvidence = snapshotEvidence previous declaration,+        currentEvidence = snapshotEvidence current declaration,+        previousConsequences = snapshotConsequences previous declaration,+        currentConsequences = snapshotConsequences current declaration,+        serviceConformance = serviceMember previous declaration || serviceMember current declaration       }   | declaration <- Set.toAscList (Set.fromList declarations),     serviceMember previous declaration || serviceMember current declaration@@ -667,28 +671,28 @@ 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+    { previous = previous,+      current = current,+      declarations = canonicalDeclarations,+      deltas = 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)+snapshotConsumers snapshot declaration = Map.findWithDefault Set.empty declaration ((.mappedConsumers) snapshot)  snapshotEvidence :: SemanticImpactSnapshot -> MappedKey -> Maybe (Set MappedRootEvidence)-snapshotEvidence snapshot declaration = (Map.findWithDefault Set.empty declaration) <$> snapshotMappedEvidence snapshot+snapshotEvidence snapshot declaration = (Map.findWithDefault Set.empty declaration) <$> (.mappedEvidence) snapshot  snapshotConsequences :: SemanticImpactSnapshot -> MappedKey -> Maybe (Set MappedConsequence)-snapshotConsequences snapshot declaration = (Map.findWithDefault Set.empty declaration) <$> snapshotMappedConsequences snapshot+snapshotConsequences snapshot declaration = (Map.findWithDefault Set.empty declaration) <$> (.mappedConsequences) snapshot  serviceMember :: SemanticImpactSnapshot -> MappedKey -> Bool-serviceMember snapshot declaration = declaration `Set.member` snapshotServiceInventory snapshot+serviceMember snapshot declaration = declaration `Set.member` (.serviceInventory) snapshot  declarationIdentityAt :: SemanticImpactSnapshot -> MappedKey -> Maybe Text-declarationIdentityAt snapshot declaration = Map.lookup declaration (snapshotDeclarationIdentities snapshot)+declarationIdentityAt snapshot declaration = Map.lookup declaration ((.declarationIdentities) snapshot)  -- | Canonical identity for mapped declaration facts that 'MappedDiff' treats -- as changes. Source locations and declaration order are deliberately absent.@@ -700,31 +704,31 @@   where     structuralParts structural shape =       [ "structural",-        sourceIdentity (sdHaskell structural),-        unQualifiedValueName (sdBinding structural),-        unBindingVersion (sdBindingVersion structural),-        unCanonicalTypeId (sdCanonical structural),-        unQualifiedValueName (sdFixtures structural),-        maybe "" unQualifiedValueName (sdInitial structural),+        sourceIdentity ((.haskell) structural),+        unQualifiedValueName ((.binding) structural),+        unBindingVersion ((.bindingVersion) structural),+        unCanonicalTypeId ((.canonical) structural),+        unQualifiedValueName ((.fixtures) structural),+        maybe "" unQualifiedValueName ((.initial) 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),+        sourceIdentity ((.haskell) opaque),+        unCodecIdentity ((.codecIdentity) opaque),+        unCodecVersion ((.codecVersion) opaque),+        unQualifiedValueName ((.fixtures) opaque),+        maybe "" unQualifiedValueName ((.initial) opaque),         wireFingerprint graph (unMappedKey key)       ]-    sourceIdentity source = T.intercalate ":" [hsPackage source, hsModule source, hsType source]+    sourceIdentity source = T.intercalate ":" [(.package) source, (.moduleName) source, (.valueType) source]     structuralPresentation (RRecord constructor _ fields) =-      "record:" <> constructor <> ":" <> T.intercalate "," [rwfHaskell field <> "=" <> rwfKey field | field <- sortOn rwfKey fields]+      "record:" <> constructor <> ":" <> T.intercalate "," [(.haskell) field <> "=" <> (.key) field | field <- sortOn (\field -> field.key) fields]     structuralPresentation (REnum entries) =-      "enum:" <> T.intercalate "," [weCtor entry <> "=" <> weTag entry | entry <- sortOn weTag entries]+      "enum:" <> T.intercalate "," [(.ctor) entry <> "=" <> (.tag) entry | entry <- sortOn (.tag) entries]     structuralPresentation (RUnion _ arms) =-      "union:" <> T.intercalate "," [rwaTag arm | arm <- sortOn rwaTag arms]+      "union:" <> T.intercalate "," [(.tag) arm | arm <- sortOn (.tag) arms]  mappedConsumerIdentity :: MappedConsumer -> Name mappedConsumerIdentity (AggregateConsumer aggregate) = aggregate@@ -824,17 +828,17 @@   [ ( T.intercalate         "/"         [ "mapped-surface",-          mappedRootKindIdentity (evidenceRootKind evidence),-          mappedConsumerIdentity (evidenceConsumer evidence),+          mappedRootKindIdentity ((.rootKind) evidence),+          mappedConsumerIdentity ((.consumer) evidence),           unMappedKey declaration,-          evidencePath evidence+          (.path) evidence         ],       T.intercalate "," (map mappedConsequenceIdentity (Set.toAscList consequences))-        <> maybe "" (";projection-operation:" <>) (evidenceOperation evidence)+        <> maybe "" (";projection-operation:" <>) ((.operation) evidence)     )-  | (declaration, evidenceValues) <- Map.toAscList (impactDeclarationEvidence impact),+  | (declaration, evidenceValues) <- Map.toAscList ((.declarationEvidence) impact),     evidence <- Set.toAscList evidenceValues,-    let consequences = Map.findWithDefault Set.empty declaration (impactDeclarationConsequences impact)+    let consequences = Map.findWithDefault Set.empty declaration ((.declarationConsequences) impact)   ]  derivedAuthority :: DerivedMappedConsumer -> Name@@ -845,78 +849,78 @@ aggregateMappedRoots :: SemanticImpact -> Name -> [MappedRoot] aggregateMappedRoots impact aggregate =   [ root-  | root <- impactRoots impact,-    mappedRootConsumer root == AggregateConsumer aggregate+  | root <- (.roots) impact,+    (.consumer) 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))+  maybe [] Set.toAscList (Map.lookup (AggregateConsumer aggregate) ((.aggregateDeclarations) 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))+  maybe [] Set.toAscList (Map.lookup declaration ((.declarationConsumers) impact))  -- | Return every checked declaration, including declarations with no current -- aggregate consumer, in stable order. serviceMappedInventory :: SemanticImpact -> [MappedKey]-serviceMappedInventory = Set.toAscList . impactServiceDeclarations+serviceMappedInventory = Set.toAscList . (.serviceDeclarations)  declarationClosure :: TypeGraph -> MappedKey -> Set MappedKey declarationClosure graph root =-  Set.insert root (Map.findWithDefault Set.empty root (tgReachability graph))+  Set.insert root (Map.findWithDefault Set.empty root ((.reachability) graph))  mappedRootFromUseSite :: UseSite -> MappedRoot mappedRootFromUseSite site@(RootCommandField aggregate _ _ declaration) =   MappedRoot-    { mappedRootConsumer = AggregateConsumer aggregate,-      mappedRootKind = MappedCommandFieldRoot,-      mappedRootUseSite = site,-      mappedRootDeclaration = declaration+    { consumer = AggregateConsumer aggregate,+      kind = MappedCommandFieldRoot,+      useSite = site,+      declaration = declaration     } mappedRootFromUseSite site@(RootEventField aggregate _ _ declaration) =   MappedRoot-    { mappedRootConsumer = AggregateConsumer aggregate,-      mappedRootKind = MappedEventFieldRoot,-      mappedRootUseSite = site,-      mappedRootDeclaration = declaration+    { consumer = AggregateConsumer aggregate,+      kind = MappedEventFieldRoot,+      useSite = site,+      declaration = declaration     } mappedRootFromUseSite site@(RootRegister aggregate _ declaration) =   MappedRoot-    { mappedRootConsumer = AggregateConsumer aggregate,-      mappedRootKind = MappedRegisterRoot,-      mappedRootUseSite = site,-      mappedRootDeclaration = declaration+    { consumer = AggregateConsumer aggregate,+      kind = MappedRegisterRoot,+      useSite = site,+      declaration = declaration     } mappedRootFromUseSite site@(RootWorkqueueField workqueue _ declaration) =   MappedRoot-    { mappedRootConsumer = WorkqueueConsumer workqueue,-      mappedRootKind = MappedWorkqueueFieldRoot,-      mappedRootUseSite = site,-      mappedRootDeclaration = declaration+    { consumer = WorkqueueConsumer workqueue,+      kind = MappedWorkqueueFieldRoot,+      useSite = site,+      declaration = declaration     } mappedRootFromUseSite site@(RootReadModelQueryInput readModel declaration) =   MappedRoot-    { mappedRootConsumer = ReadModelQueryConsumer readModel MappedQueryInput,-      mappedRootKind = MappedReadModelQueryInputRoot,-      mappedRootUseSite = site,-      mappedRootDeclaration = declaration+    { consumer = ReadModelQueryConsumer readModel MappedQueryInput,+      kind = MappedReadModelQueryInputRoot,+      useSite = site,+      declaration = declaration     } mappedRootFromUseSite site@(RootReadModelQueryResult readModel declaration) =   MappedRoot-    { mappedRootConsumer = ReadModelQueryConsumer readModel MappedQueryResult,-      mappedRootKind = MappedReadModelQueryResultRoot,-      mappedRootUseSite = site,-      mappedRootDeclaration = declaration+    { consumer = ReadModelQueryConsumer readModel MappedQueryResult,+      kind = MappedReadModelQueryResultRoot,+      useSite = site,+      declaration = declaration     }  eventAuthority :: UsePath -> Maybe Name-eventAuthority UsePath {upRoot = RootEventField aggregate _ _ _} = Just aggregate+eventAuthority UsePath {root = RootEventField aggregate _ _ _} = Just aggregate eventAuthority _ = Nothing  maybeToList :: Maybe value -> [value]

src/Keiro/Dsl/ServiceHarness.hs view

@@ -17,7 +17,7 @@ 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, checkedLanguageContract, checkedSpec, checkedTypeGraph, effectiveContractLanguageVersion)+import Keiro.Dsl.SemanticContract (CheckedService, EffectiveLanguageContract (..), checkedLanguageContract, checkedSpec, checkedTypeGraph) import Keiro.Dsl.SemanticImpact (mappedSurfaceFactValues, semanticImpactForService) import Keiro.Dsl.StructuralConformance (hasStructuralConformance, structuralConformanceModuleName) import Keiro.Dsl.Validate (nodeIdentity)@@ -59,10 +59,10 @@     moduleName = serviceConformanceModuleName ctx     facade =       ScaffoldModule-        { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),-          moduleText = renderServiceHarness ctx service,+        { path = T.unpack (T.replace "." "/" moduleName <> ".hs"),+          text = renderServiceHarness ctx service,           kind = Generated,-          origin = "context " <> specContext (checkedSpec service) <> " service conformance facade"+          origin = "context " <> (.context) (checkedSpec service) <> " service conformance facade"         }  renderServiceHarness :: Context -> CheckedService -> Text@@ -112,11 +112,11 @@  harnessModuleName :: Context -> Node -> Text harnessModuleName ctx = \case-  NAggregate aggregate -> genPrefixFor ctx (aggName aggregate) <> ".Harness"-  NProcess process -> genPrefixFor ctx (procId process) <> ".ProcessHarness"-  NRouter router -> genPrefixFor ctx (rtId router) <> ".RouterHarness"-  NReadModel readModel -> genPrefixFor ctx (pascal (rmName readModel)) <> ".ReadModelHarness"-  NWorkflow workflow -> genPrefixFor ctx (wfId workflow) <> ".WorkflowFacts"+  NAggregate aggregate -> genPrefixFor ctx ((.name) aggregate) <> ".Harness"+  NProcess process -> genPrefixFor ctx ((.id) process) <> ".ProcessHarness"+  NRouter router -> genPrefixFor ctx ((.id) router) <> ".RouterHarness"+  NReadModel readModel -> genPrefixFor ctx (pascal ((.name) readModel)) <> ".ReadModelHarness"+  NWorkflow workflow -> genPrefixFor ctx ((.id) workflow) <> ".WorkflowFacts"   node -> error ("service harness requested a module for unsupported node " <> show (nodeIdentity node))  renderChecks :: Bool -> [(Node, Text)] -> [Text]@@ -140,9 +140,9 @@ checkExpression :: (Node, Text) -> Text checkExpression (node, alias) = case node of   NAggregate aggregate ->-    "[(\"aggregate/" <> aggName aggregate <> "/\" <> fact, passed) | (fact, passed) <- " <> alias <> ".harnessAssertions]"+    "[(\"aggregate/" <> (.name) aggregate <> "/\" <> fact, passed) | (fact, passed) <- " <> alias <> ".harnessAssertions]"   NReadModel readModel ->-    "[(\"readmodel/" <> rmName readModel <> "/\" <> fact, passed) | (fact, passed) <- " <> alias <> ".readModelFactResults]"+    "[(\"readmodel/" <> (.name) readModel <> "/\" <> fact, passed) | (fact, passed) <- " <> alias <> ".readModelFactResults]"   _ -> error "checkExpression called for a fact-only node"  renderFacts :: [(Text, Text)] -> [(Node, Text)] -> [Text]@@ -182,7 +182,7 @@  serviceHarnessNodes :: CheckedService -> [Node] serviceHarnessNodes =-  sortOn sortKey . filter (\node -> producesChecks node || producesFacts node) . specNodes . checkedSpec+  sortOn sortKey . filter (\node -> producesChecks node || producesFacts node) . (.nodes) . checkedSpec   where     sortKey node = let (kindName, nodeName, _) = nodeIdentity node in (kindName, nodeName) @@ -212,7 +212,7 @@ surfaceFactValues service   | not       ( languageSupportsFeature-          (effectiveContractLanguageVersion (checkedLanguageContract service))+          ((.contractLanguageVersion) (checkedLanguageContract service))           MappedConsumerSurfaceSyntax       ) =       []

src/Keiro/Dsl/SidecarMigration.hs view

@@ -23,7 +23,7 @@ import Data.Text qualified as T import Data.Text.IO qualified as TIO import Keiro.Dsl.ConformancePackage-  ( ConformancePackagePlan (cppDirectory),+  ( ConformancePackagePlan (..),     parseLegacyConformancePackageRecord,     renderConformancePackageRecord,   )@@ -45,19 +45,25 @@   deriving stock (Eq, Show)  data SidecarMove = SidecarMove-  { sidecarOldPath :: !FilePath,-    sidecarNewPath :: !FilePath,-    sidecarBackupPath :: !(Maybe FilePath),-    sidecarMoveDisposition :: !SidecarMoveDisposition+  { oldPath :: !FilePath,+    newPath :: !FilePath,+    backupPath :: !(Maybe FilePath),+    moveDisposition :: !SidecarMoveDisposition   }   deriving stock (Eq, Show) -data PreparedSidecarMove = PreparedSidecarMove-  { preparedSidecarMove :: !SidecarMove,-    preparedConvertedContents :: !(Maybe Text)-  }+data PreparedSidecarMove+  = PreparedSidecarRename !SidecarMove+  | PreparedSidecarRetirement !SidecarMove !FilePath+  | PreparedSidecarConversion !SidecarMove !FilePath !Text   deriving stock (Eq, Show) +preparedSidecarMove :: PreparedSidecarMove -> SidecarMove+preparedSidecarMove = \case+  PreparedSidecarRename move -> move+  PreparedSidecarRetirement move _ -> move+  PreparedSidecarConversion move _ _ -> move+ -- | Inspect the two scope-specific sidecars and the optional generated -- conformance package. An old-name file always produces a move: either a direct -- rename when the new path is absent, or retirement when the new path is already@@ -85,7 +91,7 @@       moves = [move | Right (Just move) <- results]   pure $ if null errors then Right moves else Left errors   where-    plannedDirectory = fmap cppDirectory conformancePlan+    plannedDirectory = fmap (.directory) conformancePlan     plannedDirectories = maybe [] (: []) plannedDirectory  -- | Directories under @out@ holding a legacy conformance record, excluding the@@ -149,16 +155,13 @@         then prepareRetirement out oldRelative newRelative         else           pure . Right . Just $-            PreparedSidecarMove-              { preparedSidecarMove =-                  SidecarMove-                    { sidecarOldPath = oldRelative,-                      sidecarNewPath = newRelative,-                      sidecarBackupPath = Nothing,-                      sidecarMoveDisposition = RenameSidecar-                    },-                preparedConvertedContents = Nothing-              }+            PreparedSidecarRename+              SidecarMove+                { oldPath = oldRelative,+                  newPath = newRelative,+                  backupPath = Nothing,+                  moveDisposition = RenameSidecar+                }  planConformance :: FilePath -> FilePath -> FilePath -> IO (Either Text (Maybe PreparedSidecarMove)) planConformance out oldRelative newRelative = do@@ -180,16 +183,15 @@                 then pure (Left (T.pack oldRelative <> ": sidecar migration backup already exists at " <> T.pack backupRelative))                 else                   pure . Right . Just $-                    PreparedSidecarMove-                      { preparedSidecarMove =-                          SidecarMove-                            { sidecarOldPath = oldRelative,-                              sidecarNewPath = newRelative,-                              sidecarBackupPath = Just backupRelative,-                              sidecarMoveDisposition = ConvertLegacyConformanceLedger-                            },-                        preparedConvertedContents = Just (preserveBanner legacyContents <> renderConformancePackageRecord record)-                      }+                    PreparedSidecarConversion+                      SidecarMove+                        { oldPath = oldRelative,+                          newPath = newRelative,+                          backupPath = Just backupRelative,+                          moveDisposition = ConvertLegacyConformanceLedger+                        }+                      backupRelative+                      (preserveBanner legacyContents <> renderConformancePackageRecord record)  prepareRetirement :: FilePath -> FilePath -> FilePath -> IO (Either Text (Maybe PreparedSidecarMove)) prepareRetirement out oldRelative newRelative = do@@ -199,16 +201,14 @@     then pure (Left (T.pack oldRelative <> ": sidecar migration backup already exists at " <> T.pack backupRelative))     else       pure . Right . Just $-        PreparedSidecarMove-          { preparedSidecarMove =-              SidecarMove-                { sidecarOldPath = oldRelative,-                  sidecarNewPath = newRelative,-                  sidecarBackupPath = Just backupRelative,-                  sidecarMoveDisposition = RetireLegacySidecar-                },-            preparedConvertedContents = Nothing-          }+        PreparedSidecarRetirement+          SidecarMove+            { oldPath = oldRelative,+              newPath = newRelative,+              backupPath = Just backupRelative,+              moveDisposition = RetireLegacySidecar+            }+          backupRelative  sidecarBackupRelative :: FilePath -> FilePath sidecarBackupRelative oldRelative = sidecarBackupRootName </> "sidecar-v1" </> oldRelative@@ -223,27 +223,22 @@ applyPreparedSidecarMoves :: FilePath -> [PreparedSidecarMove] -> IO () applyPreparedSidecarMoves out = mapM_ applyOne   where-    applyOne prepared = case sidecarMoveDisposition move of-      RenameSidecar -> do+    applyOne = \case+      PreparedSidecarRename move -> do+        let oldPath = out </> (.oldPath) move+            newPath = out </> (.newPath) move         createDirectoryIfMissing True (takeDirectory newPath)         renameFile oldPath newPath-      RetireLegacySidecar -> retire move oldPath-      ConvertLegacyConformanceLedger -> case preparedConvertedContents prepared of-        Nothing -> error "prepared conformance sidecar conversion lacks converted contents"-        Just converted -> do-          writeTextAtomic newPath converted-          retire move oldPath-      where-        move = preparedSidecarMove prepared-        oldPath = out </> sidecarOldPath move-        newPath = out </> sidecarNewPath move+      PreparedSidecarRetirement move backupRelative ->+        retire (out </> (.oldPath) move) backupRelative+      PreparedSidecarConversion move backupRelative converted -> do+        writeTextAtomic (out </> (.newPath) move) converted+        retire (out </> (.oldPath) move) backupRelative -    retire move oldPath = case sidecarBackupPath move of-      Nothing -> error "prepared sidecar retirement lacks a backup path"-      Just backupRelative -> do-        let backupPath = out </> backupRelative-        createDirectoryIfMissing True (takeDirectory backupPath)-        renameFile oldPath backupPath+    retire oldPath backupRelative = do+      let backupPath = out </> backupRelative+      createDirectoryIfMissing True (takeDirectory backupPath)+      renameFile oldPath backupPath  writeTextAtomic :: FilePath -> Text -> IO () writeTextAtomic path contents = do@@ -261,10 +256,10 @@   when exists (removeFile temporary)  renderSidecarMove :: SidecarMove -> Text-renderSidecarMove move = case sidecarMoveDisposition move of-  RenameSidecar -> path (sidecarOldPath move) <> " -> " <> path (sidecarNewPath move)-  RetireLegacySidecar -> path (sidecarOldPath move) <> " -> retired to " <> backup-  ConvertLegacyConformanceLedger -> path (sidecarOldPath move) <> " -> " <> path (sidecarNewPath move) <> "; original retired to " <> backup+renderSidecarMove move = case (.moveDisposition) move of+  RenameSidecar -> path ((.oldPath) move) <> " -> " <> path ((.newPath) move)+  RetireLegacySidecar -> path ((.oldPath) move) <> " -> retired to " <> backup+  ConvertLegacyConformanceLedger -> path ((.oldPath) move) <> " -> " <> path ((.newPath) move) <> "; original retired to " <> backup   where     path = T.pack-    backup = maybe "<missing-backup>" path (sidecarBackupPath move)+    backup = maybe "<missing-backup>" path ((.backupPath) move)

src/Keiro/Dsl/Source.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE NoFieldSelectors #-}- -- | Source locations used by the Keiro language frontend. -- -- Offsets count tokens in the parsed 'Text' stream. Spans are half-open: the

src/Keiro/Dsl/SourceIndex.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE NoFieldSelectors #-}- -- | Exact source provenance for semantic aggregate subjects. -- -- The index deliberately lives beside 'Keiro.Dsl.Grammar.Spec'. Source@@ -71,8 +69,8 @@  -- | The semantic parse result and its independently comparable source index. data ParsedSourceDocument = ParsedSourceDocument-  { documentParsedSource :: !ParsedSource,-    documentSourceIndex :: !SemanticSourceIndex+  { parsedSource :: !ParsedSource,+    sourceIndex :: !SemanticSourceIndex   }   deriving stock (Eq, Show, Generic) @@ -84,10 +82,10 @@   deriving stock (Eq, Ord, Show, Generic)  data SourceIndexFailure = SourceIndexFailure-  { failureCode :: !SourceIndexFailureCode,-    failureSubject :: !(Maybe SourceSubject),-    failureSpan :: !(Maybe SourceSpan),-    failureMessage :: !Text+  { code :: !SourceIndexFailureCode,+    subject :: !(Maybe SourceSubject),+    span :: !(Maybe SourceSpan),+    message :: !Text   }   deriving stock (Eq, Show, Generic) @@ -96,13 +94,13 @@ semanticSourceSubjects :: Spec -> [SourceSubject] semanticSourceSubjects spec = concatMap aggregateSubjects aggregates   where-    aggregates = [aggregate | NAggregate aggregate <- specNodes spec]+    aggregates = [aggregate | NAggregate aggregate <- (.nodes) spec]     aggregateSubjects aggregate =-      [ AggregateStateSubject (aggName aggregate) (stName state)-      | state <- aggStates aggregate+      [ AggregateStateSubject ((.name) aggregate) ((.name) state)+      | state <- (.states) aggregate       ]-        <> [ AggregateTransitionSubject (aggName aggregate) (TransitionOrdinal ordinal)-           | (ordinal, _) <- zip [0 ..] (aggTransitions aggregate)+        <> [ AggregateTransitionSubject ((.name) aggregate) (TransitionOrdinal ordinal)+           | (ordinal, _) <- zip [0 ..] ((.transitions) aggregate)            ]  -- | Construct a complete exact index for one parsed file. The expected@@ -118,10 +116,10 @@     Just (subject, sourceSpan) ->       Left         SourceIndexFailure-          { failureCode = SourceIndexFileMismatch,-            failureSubject = Just subject,-            failureSpan = Just sourceSpan,-            failureMessage = "source-index span belongs to a different source file"+          { code = SourceIndexFileMismatch,+            subject = Just subject,+            span = Just sourceSpan,+            message = "source-index span belongs to a different source file"           }     Nothing -> pure ()   checkedIndex ExactSourcePosition expected entries@@ -135,13 +133,13 @@   checkedIndex CompatibilityLineOnly expected entries   where     expected = semanticSourceSubjects spec-    entries = concatMap aggregateEntries [aggregate | NAggregate aggregate <- specNodes spec]+    entries = concatMap aggregateEntries [aggregate | NAggregate aggregate <- (.nodes) spec]     aggregateEntries aggregate =-      [ (AggregateStateSubject (aggName aggregate) (stName state), lineSpan (stLoc state))-      | state <- aggStates aggregate+      [ (AggregateStateSubject ((.name) aggregate) ((.name) state), lineSpan ((.loc) state))+      | state <- (.states) aggregate       ]-        <> [ (AggregateTransitionSubject (aggName aggregate) (TransitionOrdinal ordinal), lineSpan (tLoc transition))-           | (ordinal, transition) <- zip [0 ..] (aggTransitions aggregate)+        <> [ (AggregateTransitionSubject ((.name) aggregate) (TransitionOrdinal ordinal), lineSpan ((.loc) transition))+           | (ordinal, transition) <- zip [0 ..] ((.transitions) aggregate)            ]     lineSpan (Loc lineNumber) =       SourceSpan@@ -165,10 +163,10 @@     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"+          { code = SourceIndexFileMismatch,+            subject = Just subject,+            span = Just (spanOf position),+            message = "source-index span does not match the workspace member source path"           }     Nothing ->       Right@@ -178,8 +176,11 @@   where     spanOf IndexedSourcePosition {span = sourceSpan} = sourceSpan     sourceOf SourceSpan {source} = source-    replaceSource position@IndexedSourcePosition {span = sourceSpan} =-      position {span = sourceSpan {source = replacement}}+    replaceSource IndexedSourcePosition {quality, span = SourceSpan {start, end}} =+      IndexedSourcePosition+        { quality,+          span = SourceSpan {source = replacement, start, end}+        }  -- | Union complete member indices, refusing any duplicate semantic subject. unionSemanticSourceIndexes :: [SemanticSourceIndex] -> Either SourceIndexFailure SemanticSourceIndex@@ -217,20 +218,20 @@     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"+          { code = UnexpectedSourceSubject,+            subject = Just subject,+            span = snd <$> find ((== subject) . fst) entries,+            message = "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"+          { code = MissingSourceSubject,+            subject = Just subject,+            span = Nothing,+            message = "semantic graph subject has no source-index entry"           }     Nothing -> Right index @@ -242,10 +243,10 @@     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"+          { code = DuplicateSourceSubject,+            subject = Just duplicate,+            span = spanOf <$> find ((== duplicate) . fst) entries,+            message = "source index contains more than one entry for a semantic subject"           }     Nothing -> Right (SemanticSourceIndex (Map.fromList entries))   where

src/Keiro/Dsl/StructuralConformance.hs view

@@ -58,7 +58,7 @@     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)]+      missing = [key | key <- inventory, Map.notMember key ((.declarations) graph)]   case missing of     key : keys -> Left (map StructuralConformanceInventoryMissing (key : keys))     [] -> case inventory of@@ -68,39 +68,39 @@             moduleName = structuralConformanceModuleName ctx          in Right . Just $               ScaffoldModule-                { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"),-                  moduleText = renderStructuralConformance rendering,+                { path = T.unpack (T.replace "." "/" moduleName <> ".hs"),+                  text = renderStructuralConformance rendering,                   kind = Generated,-                  origin = "context " <> specContext (checkedSpec service) <> " structural conformance"+                  origin = "context " <> (.context) (checkedSpec service) <> " structural conformance"                 }  data ConformanceRendering = ConformanceRendering-  { renderingContext :: !Context,-    renderingGraph :: !TypeGraph,-    renderingDeclarations :: ![ResolvedMappedDecl],-    renderingProjections :: ![StructuralProjection],-    renderingImportPlan :: !HaskellImportPlan+  { context :: !Context,+    graph :: !TypeGraph,+    declarations :: ![ResolvedMappedDecl],+    projections :: ![StructuralProjection],+    importPlan :: !HaskellImportPlan   }  conformanceRendering :: Context -> TypeGraph -> [MappedKey] -> ConformanceRendering conformanceRendering ctx graph inventory = rendering   where-    declarations = [declaration | key <- inventory, Just declaration <- [Map.lookup key (tgDeclarations graph)]]+    declarations = [declaration | key <- inventory, Just declaration <- [Map.lookup key ((.declarations) graph)]]     projections = map (resolveProjectionModules ctx) (projectionSpecs graph)     rendering =       ConformanceRendering-        { renderingContext = ctx,-          renderingGraph = graph,-          renderingDeclarations = declarations,-          renderingProjections = projections,-          renderingImportPlan = conformanceImportPlan ctx declarations projections+        { context = ctx,+          graph = graph,+          declarations = declarations,+          projections = projections,+          importPlan = conformanceImportPlan ctx declarations projections         }  renderStructuralConformance :: ConformanceRendering -> Text renderStructuralConformance rendering =   T.unlines $     [ generatedBanner,-      "module " <> structuralConformanceModuleName (renderingContext rendering),+      "module " <> structuralConformanceModuleName ((.context) rendering),       "  ( structuralConformanceAssertions",       "  ) where",       ""@@ -124,19 +124,19 @@       <> concatMap (coverageDecl rendering) structural       <> projectionAssertionDecls rendering structural   where-    structural = [(declaration, shape) | ResolvedStructural declaration shape <- renderingDeclarations rendering]-    opaque = [declaration | ResolvedOpaque declaration <- renderingDeclarations rendering]+    structural = [(declaration, shape) | ResolvedStructural declaration shape <- (.declarations) rendering]+    opaque = [declaration | ResolvedOpaque declaration <- (.declarations) rendering]     assertionLists =-      [lowerFirst (sdName declaration) <> "BindingAssertions" | (declaration, _) <- structural]-        <> [lowerFirst (odName declaration) <> "OpaqueAssertions" | declaration <- opaque]+      [lowerFirst ((.name) declaration) <> "BindingAssertions" | (declaration, _) <- structural]+        <> [lowerFirst ((.name) declaration) <> "OpaqueAssertions" | declaration <- opaque]         <> [ "[(\"fixture coverage: "-               <> unCanonicalTypeId (sdCanonical declaration)+               <> unCanonicalTypeId ((.canonical) declaration)                <> "\", coverage"-               <> sdName declaration+               <> (.name) declaration                <> ")]"            | (declaration, _) <- structural            ]-        <> ["structuralProjectionAssertions" | not (null (renderingProjections rendering))]+        <> ["structuralProjectionAssertions" | not (null ((.projections) rendering))]  conformanceImports :: ConformanceRendering -> [Text] conformanceImports rendering =@@ -148,27 +148,48 @@     <> ["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"+    <> [ "import " <> structuralProjectionModuleName ((.context) rendering) <> " qualified as StructuralProjections"        | not (null projections)        ]-    <> T.lines (renderPlannedImports (renderingImportPlan rendering))+    <> fieldScopeImports+    <> T.lines (renderPlannedImports ((.importPlan) rendering))   where-    declarations = renderingDeclarations rendering+    declarations = (.declarations) rendering     structural = [(declaration, shape) | ResolvedStructural declaration shape <- declarations]     opaque = [declaration | ResolvedOpaque declaration <- declarations]-    projections = renderingProjections rendering+    projections = (.projections) rendering+    fieldScopeImports =+      [ "import " <> shapeModule <> " (" <> lastSegment shapeModule <> "Shape(" <> T.intercalate ", " (Set.toAscList selectors) <> "))"+      | (shapeModule, selectors) <- Map.toAscList selectorsByModule+      ]+    selectorsByModule =+      Map.fromListWith+        Set.union+        ( [ (structuralShapeModuleName ((.context) rendering) ((.name) declaration), Set.singleton ((.haskell) field))+          | (declaration, RRecord _ _ fields) <- structural,+            field <- fields,+            isOptional ((.valueType) field)+          ]+            <> [ (shapeModule, Set.singleton selector)+               | projection <- projections,+                 (shapeModule, selector) <- (.selectors) projection+               ]+        )     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+      RRecord _ _ fields -> any (isOptional . (.valueType)) fields+      RUnion _ arms -> any (maybe False isOptional . (.payload)) arms       REnum {} -> False     isOptional ROptional {} = True     isOptional _ = False +lastSegment :: Text -> Text+lastSegment = last . T.splitOn "."+ conformanceImportPlan :: Context -> [ResolvedMappedDecl] -> [StructuralProjection] -> HaskellImportPlan-conformanceImportPlan ctx declarations projections =+conformanceImportPlan ctx declarations _projections =   either     (error . ("validated structural conformance import planning failed: " <>) . show)     id@@ -187,9 +208,9 @@         | declaration <- declarations,           reference <- case declaration of             ResolvedStructural structural _ ->-              conformanceTypeReference (sdHaskell structural)-                : map conformanceQualifiedValueReference [sdBinding structural, sdFixtures structural]-            ResolvedOpaque opaque -> [conformanceQualifiedValueReference (odFixtures opaque)]+              conformanceTypeReference ((.haskell) structural)+                : map conformanceQualifiedValueReference [(.binding) structural, (.fixtures) structural]+            ResolvedOpaque opaque -> [conformanceQualifiedValueReference ((.fixtures) opaque)]         ]     shapeReferences =       Set.fromList@@ -197,17 +218,11 @@         | 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+    references = declarationReferences <> shapeReferences  conformanceTypeReference :: HaskellSource -> HaskellReference conformanceTypeReference source =-  HaskellReference (hsModule source) (hsType source) TypeNamespace PreferUnqualified+  HaskellReference ((.moduleName) source) ((.valueType) source) TypeNamespace PreferUnqualified  conformanceQualifiedValueReference :: QualifiedValueName -> HaskellReference conformanceQualifiedValueReference qualified =@@ -224,21 +239,20 @@ structuralShapeReferences ctx declaration =   foldMappedShape     MappedShapeAlgebra-      { onRecord = \constructor _ fields -> constructorRef constructor : map (valueRef . rwfHaskell) fields,-        onEnum = map (constructorRef . weCtor),-        onUnion = \_ -> map (constructorRef . rwaCtor)+      { onRecord = \_constructor _ _fields -> [],+        onEnum = map (constructorRef . (.ctor)),+        onUnion = \_ -> map (constructorRef . (.ctor))       }   where-    moduleName = structuralShapeModuleName ctx (sdName declaration)+    moduleName = structuralShapeModuleName ctx ((.name) 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)+    (renderPlannedReference ((.importPlan) rendering) reference)  bindingAssertionDecl :: ConformanceRendering -> (StructuralDecl, ResolvedMappedShape) -> [Text] bindingAssertionDecl rendering (declaration, _shape) =@@ -257,11 +271,11 @@     "    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))+    valueName = lowerFirst ((.name) declaration) <> "BindingAssertions"+    canonical = unCanonicalTypeId ((.canonical) declaration)+    consumerType = renderReference rendering (conformanceTypeReference ((.haskell) declaration))+    binding = renderReference rendering (conformanceQualifiedValueReference ((.binding) declaration))+    fixtures = renderReference rendering (conformanceQualifiedValueReference ((.fixtures) declaration))  opaqueAssertionDecl :: ConformanceRendering -> OpaqueDecl -> [Text] opaqueAssertionDecl rendering declaration =@@ -276,15 +290,15 @@     "    cases = fixtureCases " <> fixtures   ]   where-    valueName = lowerFirst (odName declaration) <> "OpaqueAssertions"-    label = unCodecIdentity (odCodecIdentity declaration) <> "@" <> unCodecVersion (odCodecVersion declaration)-    fixtures = renderReference rendering (conformanceQualifiedValueReference (odFixtures declaration))+    valueName = lowerFirst ((.name) declaration) <> "OpaqueAssertions"+    label = unCodecIdentity ((.codecIdentity) declaration) <> "@" <> unCodecVersion ((.codecVersion) declaration)+    fixtures = renderReference rendering (conformanceQualifiedValueReference ((.fixtures) declaration))  coverageDecl :: ConformanceRendering -> (StructuralDecl, ResolvedMappedShape) -> [Text] coverageDecl rendering (declaration, shape) =   [ "",-    "coverage" <> sdName declaration <> " :: Bool",-    "coverage" <> sdName declaration <> " = " <> coverageExpression rendering declaration shape+    "coverage" <> (.name) declaration <> " :: Bool",+    "coverage" <> (.name) declaration <> " = " <> coverageExpression rendering declaration shape   ]  coverageExpression :: ConformanceRendering -> StructuralDecl -> ResolvedMappedShape -> Text@@ -292,34 +306,34 @@   [] -> "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))+    shapeModule = structuralShapeModuleName ((.context) rendering) ((.name) declaration)+    binding = renderReference rendering (conformanceQualifiedValueReference ((.binding) declaration))+    fixtures = renderReference rendering (conformanceQualifiedValueReference ((.fixtures) 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"+        [ "any (\\case " <> renderReference rendering (HaskellReference shapeModule ((.ctor) 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+recordFieldObligation _rendering _shapeModule field = case (.valueType) field of   ROptional _ ->     [ "any (isNothing . " <> selector <> ") shapes",       "any (isJust . " <> selector <> ") shapes"     ]   _ -> []   where-    selector = renderReference rendering (HaskellReference shapeModule (rwfHaskell field) ValueNamespace RequireQualified)+    selector = "(." <> (.haskell) field <> ")"  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+    constructor = renderReference rendering (HaskellReference shapeModule ((.ctor) arm) ConstructorNamespace RequireQualified)+    patternText = constructor <> maybe "" (const "{}") ((.payload) arm)+    optionalPayload = case (.payload) arm of       Just (ROptional _) ->         [ "any (\\case " <> constructor <> " Nothing -> True; _ -> False) shapes",           "any (\\case " <> constructor <> " (Just _) -> True; _ -> False) shapes"@@ -337,52 +351,52 @@         "  ]"       ]   where-    specs = renderingProjections rendering+    specs = (.projections) rendering     assertion spec =       "(\"projection witness agreement: "-        <> unCanonicalTypeId (spCanonical spec)-        <> spPointer spec+        <> unCanonicalTypeId ((.canonical) spec)+        <> (.pointer) spec         <> "\", all (\\(_, owner) -> fieldWitnessAgrees StructuralProjections."-        <> spWitness spec+        <> (.witness) 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))+    ownerFixtures spec = case find (\(declaration, _) -> (.canonical) declaration == (.canonical) spec) structural of+      Just (declaration, _) -> renderReference rendering (conformanceQualifiedValueReference ((.fixtures) 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 (_shapeModule, selector) ->+        "("           <> value-          <> ")"+          <> ")."+          <> selector     )-    ("bindingToShape " <> renderReference rendering (conformanceQualifiedValueReference (spBinding spec)) <> " " <> owner)-    (spSelectors spec)+    ("bindingToShape " <> renderReference rendering (conformanceQualifiedValueReference ((.binding) spec)) <> " " <> owner)+    ((.selectors) spec)  structuralShapeModuleName :: Context -> Name -> Text-structuralShapeModuleName ctx name = case placement ctx of+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)+    root = if T.null ((.moduleRoot) ctx) then "" else (.moduleRoot) ctx <> "."+    contextSegment = pascalFromKebab ((.name) ctx)  structuralProjectionModuleName :: Context -> Text structuralProjectionModuleName ctx = contextStructuralPrefix ctx <> ".StructuralProjections"  contextStructuralPrefix :: Context -> Text-contextStructuralPrefix ctx = case placement ctx of+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)+    root = if T.null ((.moduleRoot) ctx) then "" else (.moduleRoot) ctx <> "."+    contextSegment = pascalFromKebab ((.name) ctx)  tshow :: (Show value) => value -> Text tshow = T.pack . show

src/Keiro/Dsl/Syntax.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE NoFieldSelectors #-}- -- | Located, non-lossless surface syntax for a Keiro source document. -- -- The surface layer preserves document order and source ownership while

src/Keiro/Dsl/TypeGraph.hs view

@@ -6,10 +6,15 @@ -- unrepresentable. module Keiro.Dsl.TypeGraph   ( QualifiedValueName (..),+    unQualifiedValueName,     CanonicalTypeId (..),+    unCanonicalTypeId,     BindingVersion (..),+    unBindingVersion,     CodecIdentity (..),+    unCodecIdentity,     CodecVersion (..),+    unCodecVersion,     mkQualifiedValueName,     mkCanonicalTypeId,     mkBindingVersion,@@ -21,6 +26,7 @@     OpaqueDecl (..),     checkMappedDecl,     MappedKey (..),+    unMappedKey,     ResolvedTypeExpr (..),     ResolvedWireField (..),     ResolvedWireArm (..),@@ -71,18 +77,33 @@ newtype QualifiedValueName = QualifiedValueName {unQualifiedValueName :: Text}   deriving stock (Eq, Ord, Show, Generic) +unQualifiedValueName :: QualifiedValueName -> Text+unQualifiedValueName (QualifiedValueName value) = value+ newtype CanonicalTypeId = CanonicalTypeId {unCanonicalTypeId :: Text}   deriving stock (Eq, Ord, Show, Generic) +unCanonicalTypeId :: CanonicalTypeId -> Text+unCanonicalTypeId (CanonicalTypeId value) = value+ newtype BindingVersion = BindingVersion {unBindingVersion :: Text}   deriving stock (Eq, Ord, Show, Generic) +unBindingVersion :: BindingVersion -> Text+unBindingVersion (BindingVersion value) = value+ newtype CodecIdentity = CodecIdentity {unCodecIdentity :: Text}   deriving stock (Eq, Ord, Show, Generic) +unCodecIdentity :: CodecIdentity -> Text+unCodecIdentity (CodecIdentity value) = value+ newtype CodecVersion = CodecVersion {unCodecVersion :: Text}   deriving stock (Eq, Ord, Show, Generic) +unCodecVersion :: CodecVersion -> Text+unCodecVersion (CodecVersion value) = value+ data MappedDeclError   = MissingHaskellSource !Name   | MissingStructuralBinding !Name@@ -124,25 +145,25 @@   | otherwise = Right (CodecVersion value)  data StructuralDecl = StructuralDecl-  { sdName :: !Name,-    sdHaskell :: !HaskellSource,-    sdBinding :: !QualifiedValueName,-    sdBindingVersion :: !BindingVersion,-    sdCanonical :: !CanonicalTypeId,-    sdFixtures :: !QualifiedValueName,-    sdInitial :: !(Maybe QualifiedValueName),-    sdLoc :: !Loc+  { name :: !Name,+    haskell :: !HaskellSource,+    binding :: !QualifiedValueName,+    bindingVersion :: !BindingVersion,+    canonical :: !CanonicalTypeId,+    fixtures :: !QualifiedValueName,+    initial :: !(Maybe QualifiedValueName),+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  data OpaqueDecl = OpaqueDecl-  { odName :: !Name,-    odHaskell :: !HaskellSource,-    odCodecIdentity :: !CodecIdentity,-    odCodecVersion :: !CodecVersion,-    odFixtures :: !QualifiedValueName,-    odInitial :: !(Maybe QualifiedValueName),-    odLoc :: !Loc+  { name :: !Name,+    haskell :: !HaskellSource,+    codecIdentity :: !CodecIdentity,+    codecVersion :: !CodecVersion,+    fixtures :: !QualifiedValueName,+    initial :: !(Maybe QualifiedValueName),+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -162,14 +183,14 @@   pure     ( CheckedStructural         StructuralDecl-          { sdName = name,-            sdHaskell = checkedHaskell,-            sdBinding = checkedBinding,-            sdBindingVersion = checkedBindingVersion,-            sdCanonical = checkedCanonical,-            sdFixtures = checkedFixtures,-            sdInitial = checkedInitial,-            sdLoc = loc+          { name = name,+            haskell = checkedHaskell,+            binding = checkedBinding,+            bindingVersion = checkedBindingVersion,+            canonical = checkedCanonical,+            fixtures = checkedFixtures,+            initial = checkedInitial,+            loc = loc           }         shape     )@@ -182,13 +203,13 @@   pure     ( CheckedOpaque         OpaqueDecl-          { odName = name,-            odHaskell = checkedHaskell,-            odCodecIdentity = checkedCodecIdentity,-            odCodecVersion = checkedCodecVersion,-            odFixtures = checkedFixtures,-            odInitial = checkedInitial,-            odLoc = loc+          { name = name,+            haskell = checkedHaskell,+            codecIdentity = checkedCodecIdentity,+            codecVersion = checkedCodecVersion,+            fixtures = checkedFixtures,+            initial = checkedInitial,+            loc = loc           }     ) @@ -201,6 +222,9 @@ newtype MappedKey = MappedKey {unMappedKey :: Name}   deriving stock (Eq, Ord, Show, Generic) +unMappedKey :: MappedKey -> Name+unMappedKey (MappedKey value) = value+ data ResolvedTypeExpr   = RText   | RInt@@ -216,20 +240,20 @@   deriving stock (Eq, Show, Generic)  data ResolvedWireField = ResolvedWireField-  { rwfHaskell :: !Name,-    rwfKey :: !Text,-    rwfType :: !ResolvedTypeExpr,-    rwfPresence :: !Presence,-    rwfOnMissing :: !(Maybe OnMissing),-    rwfLoc :: !Loc+  { haskell :: !Name,+    key :: !Text,+    valueType :: !ResolvedTypeExpr,+    presence :: !Presence,+    onMissing :: !(Maybe OnMissing),+    loc :: !Loc   }   deriving stock (Eq, Show, Generic)  data ResolvedWireArm = ResolvedWireArm-  { rwaCtor :: !Name,-    rwaTag :: !Text,-    rwaPayload :: !(Maybe ResolvedTypeExpr),-    rwaLoc :: !Loc+  { ctor :: !Name,+    tag :: !Text,+    payload :: !(Maybe ResolvedTypeExpr),+    loc :: !Loc   }   deriving stock (Eq, Show, Generic) @@ -271,8 +295,8 @@   deriving stock (Eq, Ord, Show, Generic)  data UsePath = UsePath-  { upRoot :: !UseSite,-    upSegments :: ![PathSeg]+  { root :: !UseSite,+    segments :: ![PathSeg]   }   deriving stock (Eq, Ord, Show, Generic) @@ -292,20 +316,20 @@   deriving stock (Eq, Ord, Show, Generic)  data TypeGraph = TypeGraph-  { tgDeclarations :: !(Map MappedKey ResolvedMappedDecl),-    tgReachability :: !(Map MappedKey (Set MappedKey)),-    tgUseSites :: ![UseSite],-    tgRootSegments :: !(Map UseSite [PathSeg]),-    tgDerivedMappedConsumers :: ![DerivedMappedConsumer],-    tgReplayableProjectionGroups :: !(Map DerivedMappedConsumer Name),-    tgProjectionOperationalIdentities :: !(Map DerivedMappedConsumer Text),-    tgUnsupportedProjectionSources :: ![UnsupportedProjectionSource]+  { declarations :: !(Map MappedKey ResolvedMappedDecl),+    reachability :: !(Map MappedKey (Set MappedKey)),+    useSites :: ![UseSite],+    rootSegments :: !(Map UseSite [PathSeg]),+    derivedMappedConsumers :: ![DerivedMappedConsumer],+    replayableProjectionGroups :: !(Map DerivedMappedConsumer Name),+    projectionOperationalIdentities :: !(Map DerivedMappedConsumer Text),+    unsupportedProjectionSources :: ![UnsupportedProjectionSource]   }   deriving stock (Eq, Show, Generic)  resolveTypeGraph :: Spec -> Either (NonEmpty TypeGraphError) TypeGraph resolveTypeGraph spec = do-  checked <- collectChecked (specMapped spec)+  checked <- collectChecked ((.mapped) spec)   rejectMany (ambiguityErrors spec checked)   let keyByName = Map.fromList [(checkedName decl, MappedKey (checkedName decl)) | decl <- checked]       (resolveErrors, resolvedPairs) = partitionEithers (map (resolveCheckedDecl keyByName) checked)@@ -317,62 +341,62 @@   rejectMany rootErrors   pure     TypeGraph-      { tgDeclarations = declarations,-        tgReachability = reachability,-        tgUseSites = map fst (catMaybes rootSites),-        tgRootSegments = Map.fromList (catMaybes rootSites),-        tgDerivedMappedConsumers = sort (derivedMappedConsumers spec),-        tgReplayableProjectionGroups = replayableProjectionGroups spec,-        tgProjectionOperationalIdentities = projectionOperationalIdentities spec,-        tgUnsupportedProjectionSources = sort (unsupportedProjectionSources spec)+      { declarations = declarations,+        reachability = reachability,+        useSites = map fst (catMaybes rootSites),+        rootSegments = Map.fromList (catMaybes rootSites),+        derivedMappedConsumers = sort (derivedMappedConsumers spec),+        replayableProjectionGroups = replayableProjectionGroups spec,+        projectionOperationalIdentities = projectionOperationalIdentities spec,+        unsupportedProjectionSources = sort (unsupportedProjectionSources spec)       }  derivedMappedConsumers :: Spec -> [DerivedMappedConsumer] derivedMappedConsumers spec =-  [ AggregateInlineProjectionConsumer (aggName aggregate) (projTable projection)-  | NAggregate aggregate <- specNodes spec,-    Just projection <- [aggProjection aggregate]+  [ AggregateInlineProjectionConsumer ((.name) aggregate) ((.table) projection)+  | NAggregate aggregate <- (.nodes) spec,+    Just projection <- [(.projection) aggregate]   ]-    <> [ CatalogProjectionConsumer (poName owner) aggregate-       | NProjectionOwner owner <- specNodes spec,-         CatalogAggregate aggregate <- poSources owner+    <> [ CatalogProjectionConsumer ((.name) owner) aggregate+       | NProjectionOwner owner <- (.nodes) spec,+         CatalogAggregate aggregate <- (.sources) 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+    [ (CatalogProjectionConsumer ((.name) owner) aggregate, (.group) owner)+    | NProjectionOwner owner <- (.nodes) spec,+      (.replay) owner == ProjectionReplayExplicit,+      CatalogAggregate aggregate <- (.sources) owner     ]  projectionOperationalIdentities :: Spec -> Map DerivedMappedConsumer Text projectionOperationalIdentities spec =   Map.fromList (inlineRows <> catalogRows)   where-    readModels = [readModel | NReadModel readModel <- specNodes spec]+    readModels = [readModel | NReadModel readModel <- (.nodes) spec]     inlineRows =-      [ ( AggregateInlineProjectionConsumer (aggName aggregate) (projTable projection),-          renderOperation Nothing [projTable projection] [rmName readModel | readModel <- readModels, rmName readModel == projTable projection] False+      [ ( AggregateInlineProjectionConsumer ((.name) aggregate) ((.table) projection),+          renderOperation Nothing [(.table) projection] [(.name) readModel | readModel <- readModels, (.name) readModel == (.table) projection] False         )-      | NAggregate aggregate <- specNodes spec,-        Just projection <- [aggProjection aggregate]+      | NAggregate aggregate <- (.nodes) spec,+        Just projection <- [(.projection) aggregate]       ]     catalogRows =-      [ ( CatalogProjectionConsumer (poName owner) aggregate,+      [ ( CatalogProjectionConsumer ((.name) owner) aggregate,           renderOperation-            (Just (poGroup owner))-            (poTargets owner)-            [ rmName readModel+            (Just ((.group) owner))+            ((.targets) owner)+            [ (.name) readModel             | readModel <- readModels,-              rmGroup readModel == Just (poGroup owner),-              not (Set.disjoint (Set.fromList (rmObservedTargets readModel)) (Set.fromList (poTargets owner)))+              (.group) readModel == Just ((.group) owner),+              not (Set.disjoint (Set.fromList ((.observedTargets) readModel)) (Set.fromList ((.targets) owner)))             ]-            (poReplay owner == ProjectionReplayExplicit)+            ((.replay) owner == ProjectionReplayExplicit)         )-      | NProjectionOwner owner <- specNodes spec,-        CatalogAggregate aggregate <- poSources owner+      | NProjectionOwner owner <- (.nodes) spec,+        CatalogAggregate aggregate <- (.sources) owner       ]     renderOperation groupName targets observers canReplay =       T.intercalate@@ -386,12 +410,12 @@ unsupportedProjectionSources :: Spec -> [UnsupportedProjectionSource] unsupportedProjectionSources spec =   [ boundary-  | NProjectionOwner owner <- specNodes spec,-    source <- poSources owner,+  | NProjectionOwner owner <- (.nodes) spec,+    source <- (.sources) owner,     boundary <- case source of       CatalogAggregate _ -> []-      CatalogCategory category -> [UnsupportedCatalogCategory (poName owner) category]-      CatalogAll -> [UnsupportedCatalogAll (poName owner)]+      CatalogCategory category -> [UnsupportedCatalogCategory ((.name) owner) category]+      CatalogAll -> [UnsupportedCatalogAll ((.name) owner)]   ]  collectChecked :: [MappedDecl] -> Either (NonEmpty TypeGraphError) [CheckedMappedDecl]@@ -414,8 +438,8 @@ rawName MappedOpaque {moName = name} = name  checkedName :: CheckedMappedDecl -> Name-checkedName (CheckedStructural declaration _) = sdName declaration-checkedName (CheckedOpaque declaration) = odName declaration+checkedName (CheckedStructural declaration _) = (.name) declaration+checkedName (CheckedOpaque declaration) = (.name) declaration  ambiguityErrors :: Spec -> [CheckedMappedDecl] -> [TypeGraphError] ambiguityErrors spec declarations =@@ -427,17 +451,17 @@     builtins = ["Text", "Int", "Bool", "Natural", "Time", "UTCTime", "Json", "Optional", "List", "Map"]     originPairs =       [(checkedName declaration, "mapped") | declaration <- declarations]-        ++ [(idName declaration, "id") | declaration <- specIds spec]-        ++ [(enumName declaration, "enum") | declaration <- specEnums spec]+        ++ [((.name) declaration, "id") | declaration <- (.ids) spec]+        ++ [((.name) declaration, "enum") | declaration <- (.enums) spec]         ++ [(name, "built-in") | name <- builtins]     allOrigins = Map.fromListWith (++) [(name, [origin]) | (name, origin) <- originPairs]  resolveCheckedDecl :: Map Name MappedKey -> CheckedMappedDecl -> Either TypeGraphError (MappedKey, ResolvedMappedDecl) resolveCheckedDecl _ (CheckedOpaque declaration) =-  Right (MappedKey (odName declaration), ResolvedOpaque declaration)+  Right (MappedKey ((.name) declaration), ResolvedOpaque declaration) resolveCheckedDecl keyByName (CheckedStructural declaration shape) = do-  resolvedShape <- resolveShape keyByName (sdName declaration) shape-  pure (MappedKey (sdName declaration), ResolvedStructural declaration resolvedShape)+  resolvedShape <- resolveShape keyByName ((.name) declaration) shape+  pure (MappedKey ((.name) declaration), ResolvedStructural declaration resolvedShape)  resolveShape :: Map Name MappedKey -> Name -> MappedShape -> Either TypeGraphError ResolvedMappedShape resolveShape keyByName owner (ShapeRecord constructor unknownFields fields) =@@ -445,11 +469,11 @@   where     resolveField field =       ResolvedWireField-        (wfHaskell field)-        (wfKey field)-        <$> resolveExpr keyByName owner (wireFieldLoc field) (wfType field)-        <*> pure (wfPresence field)-        <*> pure (wfOnMissing field)+        ((.haskell) field)+        ((.key) field)+        <$> resolveExpr keyByName owner (wireFieldLoc field) ((.valueType) field)+        <*> pure ((.presence) field)+        <*> pure ((.onMissing) field)         <*> pure (wireFieldLoc field) resolveShape _ _ (ShapeEnum entries) = Right (REnum entries) resolveShape keyByName owner (ShapeUnion encoding arms) =@@ -457,10 +481,10 @@   where     resolveArm arm =       ResolvedWireArm-        (waCtor arm)-        (waTag arm)-        <$> traverse (resolveExpr keyByName owner (waLoc arm)) (waPayload arm)-        <*> pure (waLoc arm)+        ((.ctor) arm)+        ((.tag) arm)+        <$> traverse (resolveExpr keyByName owner ((.loc) arm)) ((.payload) arm)+        <*> pure ((.loc) arm)  resolveExpr :: Map Name MappedKey -> Name -> Loc -> TypeExpr -> Either TypeGraphError ResolvedTypeExpr resolveExpr _ _ _ TText = Right RText@@ -482,7 +506,7 @@ 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)]+    keyByName = Map.fromList [(unMappedKey key, key) | key <- Map.keys ((.declarations) graph)]  cycleErrors :: Map MappedKey ResolvedMappedDecl -> [TypeGraphError] cycleErrors declarations =@@ -507,9 +531,9 @@ refsInShape =   foldMappedShape     MappedShapeAlgebra-      { onRecord = \_ _ fields -> Set.unions (map (refsInExpr . rwfType) fields),+      { onRecord = \_ _ fields -> Set.unions (map (refsInExpr . (.valueType)) fields),         onEnum = const Set.empty,-        onUnion = \_ arms -> Set.unions (map (maybe Set.empty refsInExpr . rwaPayload) arms)+        onUnion = \_ arms -> Set.unions (map (maybe Set.empty refsInExpr . (.payload)) arms)       }  refsInExpr :: ResolvedTypeExpr -> Set MappedKey@@ -545,47 +569,47 @@     <> 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]+    aggregates = [aggregate | NAggregate aggregate <- (.nodes) spec]+    workqueues = [workqueue | NWorkqueue workqueue <- (.nodes) spec]+    readModels = [readModel | NReadModel readModel <- (.nodes) spec]     aggregateSites aggregate =-      [ (RootCommandField (aggName aggregate) (cmdName command) (aggregateFieldName field) key, [])-      | command <- aggCommands aggregate,-        field <- cmdFields command,-        key <- maybeToList (aggregateFieldType field >>= typeRefName >>= (`Map.lookup` keyByName))+      [ (RootCommandField ((.name) aggregate) ((.name) command) ((.name) field) key, [])+      | command <- (.commands) aggregate,+        field <- (.fields) command,+        key <- maybeToList ((.valueType) field >>= typeRefName >>= (`Map.lookup` keyByName))       ]-        ++ [ (RootEventField (aggName aggregate) (evName event) (aggregateFieldName field) key, [])-           | event <- aggEvents aggregate,+        ++ [ (RootEventField ((.name) aggregate) ((.name) event) ((.name) field) key, [])+           | event <- (.events) aggregate,              field <- eventFields aggregate event,-             key <- maybeToList (aggregateFieldType field >>= typeRefName >>= (`Map.lookup` keyByName))+             key <- maybeToList ((.valueType) field >>= typeRefName >>= (`Map.lookup` keyByName))            ]-        ++ [ (RootRegister (aggName aggregate) (regName register) key, [])-           | register <- aggRegs aggregate,-             key <- maybeToList (typeRefName (regType register) >>= (`Map.lookup` keyByName))+        ++ [ (RootRegister ((.name) aggregate) ((.name) register) key, [])+           | register <- (.regs) aggregate,+             key <- maybeToList (typeRefName ((.valueType) register) >>= (`Map.lookup` keyByName))            ]      workqueueSites workqueue =       [ consumerSite-          ("workqueue '" <> wqName workqueue <> "' payload field '" <> wqfName field <> "'")-          (wqfLoc field)-          (RootWorkqueueField (wqName workqueue) (wqfName field))+          ("workqueue '" <> (.name) workqueue <> "' payload field '" <> (.name) field <> "'")+          ((.loc) field)+          (RootWorkqueueField ((.name) workqueue) ((.name) field))           expression-      | field <- wqPayload workqueue,-        TypedQueueExpression expression <- [wqfType field]+      | field <- (.payload) workqueue,+        TypedQueueExpression expression <- [(.valueType) field]       ] -    readModelSites readModel = case queryTypes readModel of+    readModelSites readModel = case (.queryTypes) readModel of       Nothing -> []       Just ReadModelQueryTypes {input, result, inputLoc, resultLoc} ->         [ consumerSite-            ("readmodel '" <> rmName readModel <> "' query input")+            ("readmodel '" <> (.name) readModel <> "' query input")             inputLoc-            (RootReadModelQueryInput (rmName readModel))+            (RootReadModelQueryInput ((.name) readModel))             input,           consumerSite-            ("readmodel '" <> rmName readModel <> "' query result")+            ("readmodel '" <> (.name) readModel <> "' query result")             resultLoc-            (RootReadModelQueryResult (rmName readModel))+            (RootReadModelQueryResult ((.name) readModel))             result         ] @@ -611,21 +635,21 @@       RRef key -> Just (key, [])     prepend segment = fmap (\(key, segments) -> (key, segment : segments)) -    eventFields aggregate event = case evBody event of+    eventFields aggregate event = case (.body) event of       EventFields fields -> fields       EventFromCommand commandName ->-        concat [cmdFields command | command <- aggCommands aggregate, cmdName command == commandName]+        concat [(.fields) command | command <- (.commands) aggregate, (.name) command == commandName]      maybeToList = maybe [] pure     typeRefName (TRef name) = Just name     typeRefName _ = Nothing  usePaths :: TypeGraph -> Name -> [UsePath]-usePaths graph targetName = case Map.lookup (MappedKey targetName) (tgDeclarations graph) of+usePaths graph targetName = case Map.lookup (MappedKey targetName) ((.declarations) graph) of   Nothing -> []   Just _ ->     [ UsePath site segments-    | site <- tgUseSites graph,+    | site <- (.useSites) graph,       segments <- sitePaths site     ]   where@@ -638,7 +662,7 @@      pathsFromDecl visited current       | current `Set.member` visited = []-      | otherwise = case Map.lookup current (tgDeclarations graph) of+      | otherwise = case Map.lookup current ((.declarations) graph) of           Nothing -> []           Just declaration ->             foldMappedDecl@@ -653,13 +677,13 @@         MappedShapeAlgebra           { onRecord = \_ _ fields ->               concat-                [ map (SegField (rwfHaskell field) (rwfKey field) :) (pathsInExpr visited (rwfType field))+                [ map (SegField ((.haskell) field) ((.key) field) :) (pathsInExpr visited ((.valueType) field))                 | field <- fields                 ],             onEnum = const [],             onUnion = \_ arms ->               concat-                [ map (SegArm (rwaCtor arm) (rwaTag arm) :) (maybe [] (pathsInExpr visited) (rwaPayload arm))+                [ map (SegArm ((.ctor) arm) ((.tag) arm) :) (maybe [] (pathsInExpr visited) ((.payload) arm))                 | arm <- arms                 ]           }@@ -690,7 +714,7 @@ -- | 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)+useSiteSegments graph site = Map.findWithDefault [] site ((.rootSegments) graph)  renderUsePath :: UsePath -> Text renderUsePath (UsePath root segments) = renderRoot root <> T.concat (map renderSegment segments)@@ -734,17 +758,17 @@  foldTypeExpr :: TypeExprAlgebra a -> ResolvedTypeExpr -> a foldTypeExpr algebra = \case-  RText -> onText algebra-  RInt -> onInt algebra-  RInteger -> onInteger algebra-  RBool -> onBool algebra-  RNatural -> onNatural algebra-  RTime -> onTime algebra-  RJson -> onJson algebra-  ROptional value -> onOptional algebra (foldTypeExpr algebra value)-  RList value -> onList algebra (foldTypeExpr algebra value)-  RMap value -> onMap algebra (foldTypeExpr algebra value)-  RRef key -> onRef algebra key+  RText -> (.onText) algebra+  RInt -> (.onInt) algebra+  RInteger -> (.onInteger) algebra+  RBool -> (.onBool) algebra+  RNatural -> (.onNatural) algebra+  RTime -> (.onTime) algebra+  RJson -> (.onJson) algebra+  ROptional value -> (.onOptional) algebra (foldTypeExpr algebra value)+  RList value -> (.onList) algebra (foldTypeExpr algebra value)+  RMap value -> (.onMap) algebra (foldTypeExpr algebra value)+  RRef key -> (.onRef) algebra key  data MappedShapeAlgebra a = MappedShapeAlgebra   { onRecord :: Name -> UnknownFields -> [ResolvedWireField] -> a,@@ -754,9 +778,9 @@  foldMappedShape :: MappedShapeAlgebra a -> ResolvedMappedShape -> a foldMappedShape algebra = \case-  RRecord constructor unknownFields fields -> onRecord algebra constructor unknownFields fields-  REnum entries -> onEnum algebra entries-  RUnion encoding arms -> onUnion algebra encoding arms+  RRecord constructor unknownFields fields -> (.onRecord) algebra constructor unknownFields fields+  REnum entries -> (.onEnum) algebra entries+  RUnion encoding arms -> (.onUnion) algebra encoding arms  data MappedDeclAlgebra a = MappedDeclAlgebra   { onStructuralDecl :: StructuralDecl -> ResolvedMappedShape -> a,@@ -765,13 +789,13 @@  foldMappedDecl :: MappedDeclAlgebra a -> ResolvedMappedDecl -> a foldMappedDecl algebra = \case-  ResolvedStructural declaration shape -> onStructuralDecl algebra declaration shape-  ResolvedOpaque declaration -> onOpaqueDecl algebra declaration+  ResolvedStructural declaration shape -> (.onStructuralDecl) algebra declaration shape+  ResolvedOpaque declaration -> (.onOpaqueDecl) algebra declaration  wireFingerprint :: TypeGraph -> Name -> Text wireFingerprint graph name = fnv1a64 (wireDecl Set.empty (MappedKey name))   where-    declarations = tgDeclarations graph+    declarations = (.declarations) graph      wireDecl visited key       | key `Set.member` visited = "recursive"@@ -782,7 +806,7 @@               MappedDeclAlgebra                 { onStructuralDecl = \_ shape -> wireShape (Set.insert key visited) shape,                   onOpaqueDecl = \opaque ->-                    "opaque(" <> atom (unCodecIdentity (odCodecIdentity opaque)) <> "," <> atom (unCodecVersion (odCodecVersion opaque)) <> ")"+                    "opaque(" <> atom (unCodecIdentity ((.codecIdentity) opaque)) <> "," <> atom (unCodecVersion ((.codecVersion) opaque)) <> ")"                 }               declaration @@ -790,31 +814,31 @@       foldMappedShape         MappedShapeAlgebra           { onRecord = \_ unknownFields fields ->-              "record(" <> renderUnknown unknownFields <> ";" <> T.intercalate ";" (map (wireField visited) (sortOn rwfKey fields)) <> ")",+              "record(" <> renderUnknown unknownFields <> ";" <> T.intercalate ";" (map (wireField visited) (sortOn (.key) fields)) <> ")",             onEnum = \entries ->-              "enum(" <> T.intercalate ";" (map (atom . weTag) (sortOn weTag entries)) <> ")",+              "enum(" <> T.intercalate ";" (map (atom . (.tag)) (sortOn (.tag) entries)) <> ")",             onUnion = \encoding arms ->               "union("-                <> atom (ueTagField encoding)+                <> atom ((.tagField) encoding)                 <> ","-                <> atom (ueContentsField encoding)+                <> atom ((.contentsField) encoding)                 <> ","-                <> renderUnknown (ueUnknownFields encoding)+                <> renderUnknown ((.unknownFields) encoding)                 <> ";"-                <> T.intercalate ";" (map (wireArm visited) (sortOn rwaTag arms))+                <> T.intercalate ";" (map (wireArm visited) (sortOn (.tag) arms))                 <> ")"           }      wireField visited field =-      atom (rwfKey field)+      atom ((.key) field)         <> ":"-        <> wireExpr visited (rwfType field)+        <> wireExpr visited ((.valueType) field)         <> ":"-        <> renderPresence (rwfPresence field)+        <> renderPresence ((.presence) field)         <> ":"-        <> maybe "none" (renderDefault field) (rwfOnMissing field)+        <> maybe "none" (renderDefault field) ((.onMissing) field) -    wireArm visited arm = atom (rwaTag arm) <> maybe ":unit" ((":" <>) . wireExpr visited) (rwaPayload arm)+    wireArm visited arm = atom ((.tag) arm) <> maybe ":unit" ((":" <>) . wireExpr visited) ((.payload) arm)      wireExpr visited = \case       RText -> "text"@@ -830,10 +854,10 @@       RRef key -> wireDecl visited key      renderDefault field (OmCtor constructor) =-      case rwfType field of+      case (.valueType) field of         RRef key -> case Map.lookup key declarations of           Just (ResolvedStructural _ (REnum entries)) ->-            maybe ("ctor:" <> atom constructor) ("enum:" <>) (lookup constructor [(weCtor entry, atom (weTag entry)) | entry <- entries])+            maybe ("ctor:" <> atom constructor) ("enum:" <>) (lookup constructor [((.ctor) entry, atom ((.tag) entry)) | entry <- entries])           _ -> "ctor:" <> atom constructor         _ -> "ctor:" <> atom constructor     renderDefault _ value = T.pack (show value)

src/Keiro/Dsl/Validate.hs view

@@ -54,4789 +54,4789 @@ 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--- PGMQ backing table. Parity is pinned by the queue-runtime conformance suite.-derivedQueueTrio :: Text -> (Text, Text, Text)-derivedQueueTrio logical = (physical, physical <> "_dlq", "pgmq.q_" <> physical)-  where-    physical = physicalBase logical--physicalBase :: Text -> Text-physicalBase logical-  | T.length base <= 43 && not ("_dlq" `T.isSuffixOf` base) = base-  | otherwise = hashedBase logical base-  where-    base = sanitizeQueueName logical--sanitizeQueueName :: Text -> Text-sanitizeQueueName =-  ensureLeadingLetter-    . T.intercalate "_"-    . filter (not . T.null)-    . T.splitOn "_"-    . T.map toLegal-    . T.toLower-  where-    toLegal c-      | (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9') || c == '_' = c-      | otherwise = '_'-    ensureLeadingLetter value = case T.uncons value of-      Nothing -> "q"-      Just (c, _)-        | c >= 'a' && c <= 'z' -> value-        | otherwise -> T.cons 'q' value--hashedBase :: Text -> Text -> Text-hashedBase logical base = prefix <> "_" <> fnv1a64Hex logical-  where-    trimmedPrefix = T.dropWhileEnd (== '_') (T.take 26 base)-    prefix-      | T.null trimmedPrefix = "q"-      | otherwise = trimmedPrefix--fnv1a64Hex :: Text -> Text-fnv1a64Hex logical = T.pack (replicate (16 - length rendered) '0' <> rendered)-  where-    rendered = showHex (T.foldl' step offset logical) ""-    offset :: Word64-    offset = 0xcbf29ce484222325-    prime :: Word64-    prime = 0x100000001b3-    step hash character = (hash `xor` fromIntegral (ord character)) * prime--tInt :: Int -> Text-tInt = T.pack . show--mkErr :: Int -> DiagnosticCode -> Text -> Diagnostic-mkErr l c m = Diagnostic {line = l, severity = Error, code = c, relatedLocations = [], message = m}---- | A dispatch disposition as the author spelled it.-dispText :: Disp -> Text-dispText DAckOk = "AckOk"-dispText DRetry = "Retry"-dispText (DDeadLetter reason) = "DeadLetter " <> T.pack (show reason)---- | A spec surface the grammar accepts but no runtime implements.------ Released languages below 4 keep their acceptance and only warn, so an--- existing source does not stop checking when it is pinned to an older--- language. From language 4 — which promised strict spec-surface validation —--- the same sentence is an error. The message never changes with the severity, so--- an author reads one explanation before and after the tightening.-mkSurfaceRefusal :: EffectiveLanguageContract -> Int -> DiagnosticCode -> Text -> Diagnostic-mkSurfaceRefusal languageContract l c m =-  Diagnostic-    { line = l,-      severity = if enforcesSpecSurfaceClosures languageContract then Error else Warning,-      code = c,-      relatedLocations = [],-      message = m-    }--wireKeyRulesForRecord :: Text -> Maybe (Text, Text) -> [ResolvedFieldIdentity] -> [Diagnostic]-wireKeyRulesForRecord owner reservedKey fields = invalidKeys <> duplicateKeys <> reservedCollisions-  where-    -- Structural safety only. An alias exists to preserve a brownfield key that-    -- the current naming convention would reject, so checking alias *style*-    -- would defeat the feature. What is checked is that the key can be a key at-    -- all: a stray space or control character in `as "family "` ships a-    -- permanently mis-keyed public field that no later rename can fix without a-    -- wire break. See ADR 0021.-    invalidKeys = concatMap invalidKeyRule fields-    invalidKeyRule field-      | T.null key = [refuse "resolves to an empty wire key"]-      | key /= T.strip key =-          [ refuse-              ( "resolves to wire key "-                  <> T.pack (show key)-                  <> ", which has leading or trailing whitespace; the wire key is the exact bytes on the wire, so the surrounding space would be part of every encoded field name"-              )-          ]-      | Just offending <- firstMatching isControl (T.unpack key) =-          [ refuse-              ( "resolves to wire key "-                  <> T.pack (show key)-                  <> ", which contains the control character U+"-                  <> T.justifyRight 4 '0' (T.toUpper (T.pack (showHex (ord offending) "")))-              )-          ]-      | otherwise = []-      where-        key = fieldWireKey field-        refuse detail =-          mkErr (locLine (fieldLoc field)) FieldWireKeyInvalid $-            owner <> " field '" <> fieldDslName field <> "' " <> detail-    duplicateKeys =-      [ Diagnostic-          { line = locLine (fieldLoc field),-            severity = Error,-            code = FieldWireKeyCollision,-            relatedLocations = [(locLine (fieldLoc earlier), "wire key '" <> fieldWireKey field <> "' is first declared here")],-            message = owner <> " fields resolve to duplicate wire key '" <> fieldWireKey field <> "'"-          }-      | (index, field) <- zip [0 :: Int ..] fields,-        earlier : _ <- [[candidate | candidate <- take index fields, fieldWireKey candidate == fieldWireKey field]]-      ]-    reservedCollisions =-      [ mkErr (locLine (fieldLoc field)) FieldWireKeyCollision $-          owner-            <> " field '"-            <> fieldDslName field-            <> "' resolves to wire key '"-            <> key-            <> "', which collides with the "-            <> description-      | Just (key, description) <- [reservedKey],-        field <- fields,-        fieldWireKey field == key+import Keiro.Dsl.SemanticContract (CheckedService, EffectiveLanguageContract (..), checkedLanguageContract, checkedProjectionSupplies, checkedSpec, checkedTypeGraph, 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) ((.nodes) 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 ((.runtimeProfile) languageContract) StrictSpecSurfaceValidation++hasProjectionCatalog :: EffectiveLanguageContract -> Bool+hasProjectionCatalog languageContract =+  runtimeProfileHasCapability ((.runtimeProfile) languageContract) ProjectionCatalogRuntime++hasSeparatedProjectionQueryPolicy :: EffectiveLanguageContract -> Bool+hasSeparatedProjectionQueryPolicy languageContract =+  runtimeProfileHasCapability ((.runtimeProfile) languageContract) SeparatedProjectionQueryPolicy++validateNominal :: EffectiveLanguageContract -> Spec -> [Diagnostic]+validateNominal languageContract spec = domainErrors <> resolutionErrors+  where+    domainErrors =+      [ mkErr (locLine ((.loc) declaration)) NominalInvalidIdPrefix $+          "id '" <> (.name) declaration <> "' has invalid TypeID prefix '" <> (.prefix) declaration <> "': " <> T.pack (show reason)+      | declaration <- (.ids) spec,+        Just _ <- [idDomainContractFor languageContract ((.prefix) declaration)],+        Just reason <- [TypeID.checkPrefix ((.prefix) 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 <- (.nodes) spec]++    aggregateRules aggregate =+      outcomeTypeRules aggregate+        ++ concatMap commandRules ((.commands) aggregate)+        ++ concatMap eventRules ((.events) aggregate)+        ++ concatMap registerRules ((.regs) aggregate)+        ++ concatMap (transitionRules aggregate) ((.transitions) aggregate)+      where+        commandRules command = concatMap (fieldRule aggregate CommandFieldUse) ((.fields) command)+        eventRules event = case (.body) event of+          EventFields fields -> concatMap (fieldRule aggregate EventFieldUse) fields+          EventFromCommand _ -> []+        registerRules register = case resolveAggregateType symbols ((.loc) register) RegisterUse ((.valueType) register) of+          Left typeError -> [aggregateTypeDiagnostic typeError]+          Right AggregateMapped {} -> []+          Right resolved -> case resolveRegisterInitial symbols ((.loc) register) resolved ((.initial) register) of+            Left initialError -> [aggregateTypeDiagnostic initialError]+            Right _ -> []++    fieldRule aggregate useSite field =+      either (pure . aggregateTypeDiagnostic) (const []) (inferAggregateFieldType symbols aggregate useSite field)++    outcomeTypeRules aggregate = case (.domainOutcomeTypes) 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 '" <> (.name) aggregate <> "' declares unknown or unsupported " <> label <> " outcome type '" <> name <> "'"+              ]++    transitionRules aggregate transition = ownershipRules ++ outcomeExpressionRules+      where+        environment = expressionEnvironmentFromGraphResult typeGraphResult spec aggregate transition+        ownershipRules = case (.implementation) transition of+          LegacyHoleImplementation ->+            concatMap (comparisonRule aggregate transition) (maybe [] comparisons ((.guard) transition))+          GeneratedImplementation ->+            maybe [] (expressionDiagnostics . resolveGuardExpr environment) ((.guard) transition)+              ++ concatMap (expressionDiagnostics . uncurry (resolveWriteExpr environment)) ((.writes) transition)+          HoleImplementation ->+            [ mkErr (locLine ((.loc) transition)) AggregateTransitionOwnershipConflict $+                "transition '"+                  <> (.source) transition+                  <> " -- "+                  <> (.command) transition+                  <> "' selects implementation hole and therefore cannot also declare guard or write clauses"+            | (.guard) transition /= Nothing || not (null ((.writes) transition))+            ]+        outcomeExpressionRules = case ((.domainOutcomeTypes) aggregate, (.outcome) 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 (.domainOutcomeTypes) aggregate of+              Just value -> value+              Nothing -> error "unreachable: outcome reason without declaration"++    outcomeExpressionDiagnostic label diagnostic =+      mkErr+        (locLine ((.loc) diagnostic))+        ( if (.code) diagnostic `elem` [ScalarOperandTypeMismatch, ScalarBooleanOperandRequired]+            then DomainOutcomeReasonTypeMismatch+            else expressionCode ((.code) diagnostic)+        )+        ("typed " <> label <> " outcome reason is invalid: " <> (.message) diagnostic)++    expressionDiagnostics = either (map expressionDiagnostic . NE.toList) (const [])++    expressionDiagnostic diagnostic =+      mkErr+        (locLine ((.loc) diagnostic))+        (expressionCode ((.code) diagnostic))+        ((.message) 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 ((.loc) transition)) AggregateGuardTypeMismatch $+                  "comparison operands have different aggregate types '"+                    <> aggregateCanonicalName leftType+                    <> "' and '"+                    <> aggregateCanonicalName rightType+                    <> "'"+              ]+          | aggregateCapability useSite leftType == Unsupported ->+              [ mkErr (locLine ((.loc) 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 <- (.regs) aggregate, (.name) register == name] of+      register : _ -> resolveAggregateType symbols ((.loc) register) RegisterUse ((.valueType) register)+      [] -> case [field | command <- (.commands) aggregate, (.name) command == (.command) transition, field <- (.fields) command, (.name) field == name] of+        field : _ -> inferAggregateFieldType symbols aggregate CommandFieldUse field+        [] -> case [(.name) declaration | declaration <- (.enums) spec, name `elem` map fst ((.ctors) declaration)] of+          enumType : _ -> resolveAggregateType symbols ((.loc) transition) CommandFieldUse (TRef enumType)+          []+            | name `elem` map (.name) ((.states) aggregate) -> pure (AggregateVertex ((.name) aggregate <> "Vertex"))+            | Just rule <- firstMatching ((== name) . (.name)) ((.rules) spec) ->+                resolveAggregateType symbols ((.loc) rule) EqualityGuardUse (nameTypeExpr ((.codomain) rule))+            | otherwise -> Left (AggregateTypeError ((.loc) 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 ((.loc) aggregateError)) diagnosticCode diagnosticMessage+  where+    diagnosticCode = case (.reason) aggregateError of+      UnknownAggregateType {} -> AggregateTypeUnknown+      UnsupportedAggregateShape {} -> AggregateTypeUnsupportedAtUse+      UnsupportedAggregateCapability {} -> case (.useSite) aggregateError of+        EqualityGuardUse -> AggregateGuardCapabilityUnsupported+        OrderingGuardUse -> AggregateGuardCapabilityUnsupported+        _ -> AggregateTypeUnsupportedAtUse+      InvalidRegisterInitial {} -> AggregateRegisterInitialInvalid+    diagnosticMessage = case (.reason) aggregateError of+      UnknownAggregateType name ->+        "unknown aggregate type '" <> name <> "' at " <> renderAggregateUseSite ((.useSite) aggregateError)+      UnsupportedAggregateShape expression ->+        "direct aggregate type '"+          <> typeExprCanonicalName expression+          <> "' is unsupported at "+          <> renderAggregateUseSite ((.useSite) aggregateError)+          <> "; use a mapped structural declaration for Json or container shapes"+      UnsupportedAggregateCapability resolved ->+        renderAggregateUseSite ((.useSite) 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) ((.mapped) 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 ((.mapped) 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 '" <> (.package) source <> "' does not follow Cabal package-name grammar"+      | not (isCabalPackageName ((.package) source))+      ]+        ++ [ invalid declaration $ "Haskell module '" <> (.moduleName) source <> "' must be dot-separated Upper identifiers"+           | not (moduleNameSafe ((.moduleName) source))+           ]+        ++ [ invalid declaration $ "Haskell type '" <> (.valueType) source <> "' must be an Upper identifier"+           | not (constructorSafe ((.valueType) 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 '" <> (.haskell) field <> "' must be a lower-initial Haskell identifier"+             | field <- fields,+               not (lowerIdentifierSafe ((.haskell) field))+             ]+      MappedStructural {msShape = ShapeEnum entries} ->+        [ invalidAt ((.loc) entry) $ "enum constructor '" <> (.ctor) entry <> "' must be an Upper identifier"+        | entry <- entries,+          not (constructorSafe ((.ctor) entry))+        ]+      MappedStructural {msShape = ShapeUnion _ arms} ->+        [ invalidAt ((.loc) arm) $ "union constructor '" <> (.ctor) arm <> "' must be an Upper identifier"+        | arm <- arms,+          not (constructorSafe ((.ctor) 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 <- (.mapped) 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 = (.mapped) spec+    sourceFacts = [(declaration, source) | declaration <- declarations, source <- maybeToList (mappedHaskell declaration)]+    sourceCollisions =+      [ conflict declaration $+          "Haskell target '" <> (.moduleName) source <> "." <> (.valueType) source <> "' is claimed by more than one mapped declaration"+      | (declaration, source) <- duplicatesBy (\(_, value) -> ((.moduleName) value, (.valueType) 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, (.moduleName) source, (.package) 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 ((.declarations) graph))+    ++ mappedRegisterInitialRules spec graph+  where+    declarationRules =+      foldMappedDecl+        MappedDeclAlgebra+          { onStructuralDecl = \declaration shape ->+              foldMappedShape (shapeRules declaration) shape,+            onOpaqueDecl = const []+          }++    shapeRules declaration =+      MappedShapeAlgebra+        { onRecord = \_ _ fields ->+            [ mappedError ((.loc) field) MappedDuplicateFieldName declaration $+                "record selector '" <> (.haskell) field <> "' is declared more than once"+            | field <- duplicatesBy (.haskell) fields+            ]+              ++ [ mappedError ((.loc) field) MappedDuplicateWireKey declaration $+                     "record wire key '" <> (.key) field <> "' is declared more than once"+                 | field <- duplicatesBy (.key) fields+                 ]+              ++ [ mappedError ((.loc) field) MappedUnsupportedEncoding declaration "record wire keys must be non-empty"+                 | field <- fields,+                   T.null ((.key) field)+                 ]+              ++ concatMap (fieldRules declaration) fields,+          onEnum = \entries ->+            [ mappedError ((.loc) entry) MappedDuplicateArmName declaration $+                "enum constructor '" <> (.ctor) entry <> "' is declared more than once"+            | entry <- duplicatesBy (.ctor) entries+            ]+              ++ [ mappedError ((.loc) entry) MappedDuplicateWireTag declaration $+                     "enum wire spelling '" <> (.tag) entry <> "' is declared more than once"+                 | entry <- duplicatesBy (.tag) entries+                 ]+              ++ [ mappedError ((.loc) entry) MappedUnsupportedEncoding declaration "enum wire spellings must be non-empty"+                 | entry <- entries,+                   T.null ((.tag) entry)+                 ],+          onUnion = \encoding arms ->+            [ mappedError ((.loc) declaration) MappedUnsupportedEncoding declaration "tagged-object tag and contents keys must be distinct"+            | (.tagField) encoding == (.contentsField) encoding+            ]+              ++ [ mappedError ((.loc) declaration) MappedUnsupportedEncoding declaration "tagged-object tag and contents keys must be non-empty"+                 | T.null ((.tagField) encoding) || T.null ((.contentsField) encoding)+                 ]+              ++ [ mappedError ((.loc) arm) MappedDuplicateArmName declaration $+                     "union constructor '" <> (.ctor) arm <> "' is declared more than once"+                 | arm <- duplicatesBy (.ctor) arms+                 ]+              ++ [ mappedError ((.loc) arm) MappedDuplicateWireTag declaration $+                     "union wire tag '" <> (.tag) arm <> "' is declared more than once"+                 | arm <- duplicatesBy (.tag) arms+                 ]+              ++ [ mappedError ((.loc) arm) MappedUnsupportedEncoding declaration "union wire tags must be non-empty"+                 | arm <- arms,+                   T.null ((.tag) arm)+                 ]+              ++ concatMap (armRules declaration) arms+        }++    fieldRules declaration field =+      defaultRules declaration field+        ++ [ mappedError ((.loc) field) MappedNonInjectiveNullability declaration $+               "field '" <> (.haskell) field <> "' contains Optional around a null-capable Json, Optional, or opaque mapped value"+           | hasNonInjectiveOptional graph ((.valueType) field)+           ]++    armRules declaration arm =+      [ mappedError ((.loc) arm) MappedNonInjectiveNullability declaration $+          "union arm '" <> (.ctor) arm <> "' contains Optional around a null-capable Json, Optional, or opaque mapped value"+      | payload <- maybeToList ((.payload) arm),+        hasNonInjectiveOptional graph payload+      ]++    defaultRules declaration field = case ((.presence) field, (.onMissing) field) of+      (PRequired, Just _) -> [illTyped "required fields cannot declare on-missing"]+      (POptional, Nothing) ->+        [ mappedError ((.loc) field) MappedMissingIngredient declaration $+            "optional field '" <> (.haskell) field <> "' is missing its on-missing policy"+        ]+      (POptional, Just value)+        | not (defaultMatches graph ((.valueType) field) value) -> [illTyped "on-missing value does not match the field type or numeric bounds"]+      _ -> []+      where+        illTyped detail =+          mappedError ((.loc) field) MappedDefaultIllTyped declaration $+            "field '" <> (.haskell) field <> "': " <> detail++    mappedError loc diagnosticCode declaration detail =+      mkErr (locLine loc) diagnosticCode $+        "mapped declaration '" <> (.name) 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 ((.declarations) graph) of+  Nothing -> DefaultOther+  Just declaration ->+    foldMappedDecl+      MappedDeclAlgebra+        { onStructuralDecl = \_ shape ->+            foldMappedShape+              MappedShapeAlgebra+                { onRecord = \_ _ _ -> DefaultOther,+                  onEnum = DefaultEnum . Set.fromList . map (.ctor),+                  onUnion = \_ _ -> DefaultOther+                }+              shape,+          onOpaqueDecl = const DefaultOther+        }+      declaration++data NullabilityFacts = NullabilityFacts+  { topNull :: !Bool,+    badOptional :: !Bool+  }++hasNonInjectiveOptional :: TypeGraph -> ResolvedTypeExpr -> Bool+hasNonInjectiveOptional graph =+  (.badOptional)+    . foldTypeExpr+      TypeExprAlgebra+        { onText = nonNull,+          onInt = nonNull,+          onInteger = nonNull,+          onBool = nonNull,+          onNatural = nonNull,+          onTime = nonNull,+          onJson = nullable,+          onOptional = \child -> NullabilityFacts True ((.topNull) child || (.badOptional) 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 ((.badOptional) child)++mappedRefIsOpaque :: TypeGraph -> MappedKey -> Bool+mappedRefIsOpaque graph key = case Map.lookup key ((.declarations) 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 <- (.nodes) spec]+  where+    aggregateRules aggregate = concatMap registerRule ((.regs) aggregate)+    registerRule register = case (.valueType) register of+      TRef typeName -> case Map.lookup (MappedKey typeName) ((.declarations) graph) of+        Nothing -> []+        Just declaration -> case (.initial) register of+          RegInitBare "initial"+            | mappedInitial declaration == Nothing ->+                [ mkErr (locLine ((.loc) register)) MappedMissingInitialValue $+                    "mapped register '" <> (.name) register <> "' requires declaration '" <> typeName <> "' to name an explicit initial value"+                ]+            | otherwise -> []+          _ ->+            [ mkErr (locLine ((.loc) register)) RegisterInitialOutOfScope $+                "mapped register '" <> (.name) register <> "' must use the bare initial token; the declaration-owned symbol is verified by GHC"+            ]+      _ -> []+    mappedInitial =+      foldMappedDecl+        MappedDeclAlgebra+          { onStructuralDecl = \declaration _ -> (.initial) declaration,+            onOpaqueDecl = (.initial)+          }++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 ((.ids) spec),+      concatMap enumNames ((.enums) spec),+      concatMap nominalNames ((.nominalScalars) spec),+      concatMap nodeNames ((.nodes) spec),+      normalizedCollisions+    ]+  where+    idNames declaration =+      constructorName "id name" ((.name) declaration) ((.loc) declaration)++    enumNames declaration =+      constructorName "enum name" ((.name) declaration) ((.loc) declaration)+        ++ concatMap+          (\(ctor, _) -> constructorName ("constructor of enum '" <> (.name) declaration <> "'") ctor ((.loc) declaration))+          ((.ctors) declaration)++    nominalNames declaration =+      constructorName "nominal scalar name" ((.name) declaration) ((.loc) declaration)++    nodeNames = \case+      NAggregate aggregate -> aggregateNames aggregate+      NProcess process -> processNames process+      NRouter router -> routerNames router+      NContract contract ->+        pascalizedNodeName "contract" ((.name) contract) ((.loc) contract)+          ++ concatMap+            (\event -> constructorName "contract event name" ((.name) event) ((.loc) contract) ++ concatMap contractFieldName ((.fields) event))+            ((.events) contract)+      NIntake intake -> pascalizedNodeName "intake" ((.name) intake) ((.loc) intake)+      NEmit emitNode -> pascalizedNodeName "emit" ((.name) emitNode) ((.loc) emitNode)+      NPublisher publisher -> pascalizedNodeName "publisher" ((.name) publisher) ((.loc) publisher)+      NWorkqueue workqueue ->+        pascalizedNodeName "workqueue" ((.name) workqueue) ((.loc) workqueue)+          ++ constructorName "workqueue payload name" ((.payloadName) workqueue) ((.loc) workqueue)+          ++ concatMap (\field -> fieldNameRule "workqueue payload field" ((.name) field) ((.loc) workqueue)) ((.payload) workqueue)+      NPgmqDispatch dispatch -> pascalizedNodeName "dispatch" ((.name) dispatch) ((.loc) dispatch)+      NReadModel readModel -> pascalizedNodeName "readmodel" ((.name) readModel) ((.loc) readModel)+      NProjectionTarget target -> pascalizedNodeName "target" ((.name) target) ((.loc) target)+      NRebuildGroup groupNode -> pascalizedNodeName "rebuild group" ((.name) groupNode) ((.loc) groupNode)+      NProjectionRevision revision -> pascalizedNodeName "projection revision" ((.name) revision) ((.loc) revision)+      NExternalRead externalRead -> pascalizedNodeName "external read" (externalReadNodeIdentity externalRead) ((.loc) externalRead)+      NProjectionOwner owner -> pascalizedNodeName "projection owner" ((.name) owner) ((.loc) owner)+      NWorkflow workflow -> workflowNames workflow+      NOperation _ -> []++    aggregateNames aggregate =+      constructorName "aggregate name" ((.name) aggregate) ((.loc) aggregate)+        ++ concatMap+          (\register -> fieldNameRule "register name" ((.name) register) ((.loc) register))+          ((.regs) aggregate)+        ++ concatMap commandNames ((.commands) aggregate)+        ++ concatMap eventNames ((.events) aggregate)+        ++ maybe [] (\projection -> fieldNameRule "projection key" ((.key) projection) ((.loc) projection)) ((.projection) aggregate)+        ++ vertexCollisions aggregate+      where+        commandNames command =+          constructorName "command name" ((.name) command) ((.loc) command)+            ++ concatMap (aggregateFieldNameRule "command field") ((.fields) command)+        eventNames event =+          constructorName "event name" ((.name) event) ((.loc) event)+            ++ case (.body) event of+              EventFields fields -> concatMap (aggregateFieldNameRule "event field") fields+              EventFromCommand _ -> []++    processNames process =+      constructorName "process name" ((.id) process) ((.loc) process)+        ++ constructorName "process input name" ((.name) input) ((.loc) process)+        ++ concatMap (\field -> fieldNameRule "process input field" ((.name) field) ((.loc) process)) ((.fields) input)+        ++ concatMap (bindingName "advance field binding" ((.loc) process)) ((.advFields) ((.advance) handle))+        ++ concatMap dispatchBindings ((.dispatch) handle)+        ++ concatMap (bindingName "timer payload field binding" ((.loc) timer)) ((.payload) timer)+        ++ concatMap (bindingName "timer fire field binding" ((.loc) timer)) ((.fields) ((.fire) timer))+      where+        input = (.input) process+        handle = (.handle) process+        timer = (.timer) process+        dispatchBindings dispatch = concatMap (bindingName "dispatch field binding" ((.loc) dispatch)) ((.fields) dispatch)++    routerNames router =+      constructorName "router name" ((.id) router) ((.loc) router)+        ++ constructorName "router input name" ((.name) input) ((.loc) router)+        ++ concatMap (\field -> fieldNameRule "router input field" ((.name) field) ((.loc) router)) ((.fields) input)+        ++ concatMap (\field -> fieldNameRule "router resolve-row field" field ((.loc) resolve)) ((.row) resolve)+        ++ concatMap (bindingName "router dispatch field binding" ((.loc) dispatch)) ((.fields) dispatch)+      where+        input = (.input) router+        resolve = (.resolve) router+        dispatch = (.dispatch) router++    bindingName category anchor binding = fieldNameRule category ((.name) binding) anchor+    contractFieldName = contractFieldNameRule "contract field"++    aggregateFieldNameRule category field =+      case (.selector) field of+        Nothing -> fieldNameRule category ((.name) field) ((.loc) field)+        Just selector -> explicitFieldSelectorRule category ((.name) field) selector ((.loc) field)++    contractFieldNameRule category field =+      case (.selector) field of+        Nothing -> fieldNameRule category ((.name) field) ((.loc) field)+        Just selector -> explicitFieldSelectorRule category ((.name) field) selector ((.loc) field)++    explicitFieldSelectorRule category dslName selector anchor =+      case HaskellName.checkedLowerOccurrence site selector of+        Right _ -> []+        Left nameError -> [nameErrorDiagnostic (category <> " selector") nameError]+      where+        site =+          HaskellName.NameSite+            { HaskellName.kind = HaskellName.GeneratedFieldSite,+              HaskellName.logicalName = selector,+              HaskellName.owner = category <> ":" <> dslName,+              HaskellName.line = locLine anchor+            }++    constructorName category name anchor = checkedLogicalName HaskellName.GeneratedTypeSite category name anchor++    workflowNames workflow =+      constructorName "workflow name" ((.id) workflow) (workflowNodeLoc workflow)+        <> concat+          [ case HaskellName.deriveLowerHelperName HaskellName.LogicalWireWord "Await" site of+              Right _ -> []+              Left nameError -> [nameErrorDiagnostic "workflow await binding" nameError]+          | (label, loc) <- workflowAwaits ((.body) 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.kind = kind,+          HaskellName.logicalName = name,+          HaskellName.owner = category <> ":" <> name,+          HaskellName.line = locLine anchor+        }++    nameErrorDiagnostic category = \case+      HaskellName.EmptyNameSegment site ->+        mkErr ((.line) site) IdentUnsafeNormalization $+          category <> " '" <> (.logicalName) site <> "' has an empty generated-Haskell word"+      HaskellName.UnsafeNameSeparator site reason ->+        mkErr ((.line) site) IdentUnsafeNormalization $+          category <> " '" <> (.logicalName) site <> "' cannot be normalized safely: " <> reason+      HaskellName.ReservedGeneratedOccurrence site occurrence ->+        mkErr ((.line) site) GeneratedOccurrenceReserved $+          category <> " '" <> (.logicalName) site <> "' normalizes to reserved Haskell occurrence '" <> occurrence <> "'"+      HaskellName.InvalidExplicitHaskellName site occurrence ->+        mkErr ((.line) site) IdentUnsafeNormalization $+          category <> " '" <> (.logicalName) 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 <- (.nodes) spec]+    contracts = [contract | NContract contract <- (.nodes) spec]+    workflows = [workflow | NWorkflow workflow <- (.nodes) spec]++    contextSegment =+      case deriveAt HaskellName.LogicalWireWord HaskellName.ContextModuleSite "context" ((.context) spec) (Loc 1) of+        Right derived -> HaskellName.renderUpperCamelName ((.upperCamel) derived)+        Left _ -> (.context) spec++    nodeModuleOccurrences =+      [ HaskellName.plannedOccurrence contextSegment HaskellName.ModuleSpace "" rendered site+      | node <- (.nodes) 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 ((.upperCamel) derived)+      ]++    sharedTypeOccurrences =+      [ HaskellName.plannedOccurrence ("Generated." <> contextSegment <> ".Nominals") HaskellName.TypeSpace "" rendered site+      | (category, raw, anchor) <-+          [("id", (.name) declaration, (.loc) declaration) | declaration <- (.ids) spec]+            <> [("enum", (.name) declaration, (.loc) declaration) | declaration <- (.enums) spec]+            <> [("nominal", (.name) declaration, (.loc) declaration) | declaration <- (.nominalScalars) spec],+        let site = nameSite HaskellName.GeneratedTypeSite category raw anchor,+        Right derived <- [HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site],+        let rendered = HaskellName.renderUpperCamelName ((.upperCamel) derived)+      ]++    aggregateFieldOccurrences aggregate = commandFields <> eventFields+      where+        targetModule = "Generated." <> contextSegment <> "." <> normalizedUpper "aggregate" ((.name) aggregate) ((.loc) aggregate) <> ".Domain"+        commandFields =+          [ fieldOccurrence targetModule ((.name) command) "command field" field+          | command <- (.commands) aggregate,+            field <- (.fields) command+          ]+        eventFields =+          [ fieldOccurrence targetModule ((.name) event) "event field" field+          | event <- (.events) aggregate,+            field <- eventFieldsFor aggregate event+          ]++    eventFieldsFor aggregate event =+      case (.body) event of+        EventFields fields -> fields+        EventFromCommand commandName ->+          [ field+          | command <- (.commands) aggregate,+            (.name) command == commandName,+            field <- (.fields) 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 ((.dslName) identity) ((.loc) field)+       in HaskellName.plannedOccurrence targetModule HaskellName.FieldSpace scope ((.selector) identity) site++    aggregateHarnessOccurrences aggregate =+      transitionHelpers <> sampleConstants+      where+        transitionHelpers =+          concat+            [ [helperOccurrence "accept" ("accept" <> commandName) transition]+                <> [helperOccurrence "forward/replay" ("forwardReplay" <> commandName) transition | not (null ((.emits) transition))]+            | transition <- (.transitions) aggregate,+              (.source) transition == initialState,+              (.mode) transition == TmLive,+              let commandName = (.command) 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 $+            [ ((.name) nominal, nominal)+            | (_, AggregateNominal nominal) <- resolvedHarnessFields,+              Nominal.GeneratedNominal <- [(.ownership) nominal],+              Nominal.IdRepresentation prefix <- [(.representation) nominal],+              idDomainContractFor languageContract prefix /= Nothing+            ]+        timeFields = [field | (field, AggregateTime) <- resolvedHarnessFields]+        timeSample = case filter ((== "observedAt") . (.name)) timeFields of+          field : _ -> Just ("sampleObservedAt", field)+          [] -> case timeFields of+            field : _ -> Just ("sampleTime", field)+            [] -> Nothing+        initialState = case (.states) aggregate of+          state : _ -> (.name) state+          [] -> ""+        symbols = aggregateSymbolsFromGraphResult typeGraphResult spec+        targetModule =+          "Generated."+            <> contextSegment+            <> "."+            <> normalizedUpper "aggregate" ((.name) aggregate) ((.loc) aggregate)+            <> ".Harness"+        helperOccurrence helperKind rendered transition =+          HaskellName.plannedOccurrence targetModule HaskellName.ValueSpace "" rendered site+          where+            site =+              HaskellName.NameSite+                { HaskellName.kind = HaskellName.GeneratedHelperSite,+                  HaskellName.logicalName = (.command) transition,+                  HaskellName.owner = "aggregate:" <> (.name) aggregate <> ":" <> helperKind <> ":line:" <> T.pack (show (locLine ((.loc) transition))),+                  HaskellName.line = locLine ((.loc) transition)+                }+        idSampleOccurrence nominal =+          HaskellName.plannedOccurrence targetModule HaskellName.ValueSpace "" ("sample" <> nominalName) site+          where+            nominalName = (.name) nominal+            loc = (.loc) nominal+            site =+              HaskellName.NameSite+                { HaskellName.kind = HaskellName.GeneratedHelperSite,+                  HaskellName.logicalName = nominalName,+                  HaskellName.owner = "aggregate:" <> (.name) aggregate <> ":sample-id:" <> nominalName,+                  HaskellName.line = locLine loc+                }+        timeSampleOccurrence (rendered, field) =+          HaskellName.plannedOccurrence targetModule HaskellName.ValueSpace "" rendered site+          where+            site =+              HaskellName.NameSite+                { HaskellName.kind = HaskellName.GeneratedHelperSite,+                  HaskellName.logicalName = (.name) field,+                  HaskellName.owner = "aggregate:" <> (.name) aggregate <> ":sample-time",+                  HaskellName.line = locLine ((.loc) field)+                }++    workflowRuntimeOccurrences workflow =+      [ HaskellName.plannedOccurrence targetModule HaskellName.ValueSpace "" rendered site+      | (label, loc) <- workflowAwaits ((.body) 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" ((.id) workflow) (workflowNodeLoc workflow)+            <> ".WorkflowRuntime"++    workflowAwaitBindingSite workflow label loc =+      HaskellName.NameSite+        { HaskellName.kind = HaskellName.GeneratedValueSite,+          HaskellName.logicalName = label,+          HaskellName.owner = "workflow:" <> (.id) workflow <> ":await:" <> label,+          HaskellName.line = locLine loc+        }++    workflowAwaits = concatMap go+      where+        go (WfAwait label _ loc) = [(label, loc)]+        go (WfPatch _ items _) = workflowAwaits items+        go _ = []++    harnessFields aggregate =+      [(CommandFieldUse, field) | command <- (.commands) aggregate, field <- (.fields) command]+        <> [ (EventFieldUse, field)+           | event <- (.events) aggregate,+             field <- eventFieldsFor aggregate event+           ]++    contractFieldOccurrences contract =+      [ contractFieldOccurrence targetModule ((.name) event <> "Data") field+      | event <- (.events) contract,+        field <- (.fields) event+      ]+      where+        targetModule =+          "Generated."+            <> contextSegment+            <> "."+            <> normalizedUpper "contract" ((.name) contract) ((.loc) contract)+            <> ".Contract"++    contractFieldOccurrence targetModule scope field =+      let identity = resolveContractFieldIdentity field+          site = nameSite HaskellName.GeneratedFieldSite "contract field" ((.dslName) identity) ((.loc) identity)+          rendered = case (.selector) field of+            Just selector -> selector+            Nothing -> case HaskellName.deriveHaskellName HaskellName.LogicalIdentifier site of+              Right derived -> HaskellName.renderLowerCamelName ((.lowerCamel) derived)+              Left _ -> (.selector) 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 ((.upperCamel) derived)+        Left _ -> raw++    nodeNameAndLoc = \case+      NAggregate value -> ("aggregate", (.name) value, (.loc) value)+      NProcess value -> ("process", (.id) value, (.loc) value)+      NRouter value -> ("router", (.id) value, (.loc) value)+      NContract value -> ("contract", (.name) value, (.loc) value)+      NIntake value -> ("intake", (.name) value, (.loc) value)+      NEmit value -> ("emit", (.name) value, (.loc) value)+      NPublisher value -> ("publisher", (.name) value, (.loc) value)+      NWorkqueue value -> ("workqueue", (.name) value, (.loc) value)+      NPgmqDispatch value -> ("dispatch", (.name) value, (.loc) value)+      NReadModel value -> ("readmodel", (.name) value, (.loc) value)+      NProjectionTarget value -> ("target", (.name) value, (.loc) value)+      NRebuildGroup value -> ("rebuild-group", (.name) value, (.loc) value)+      NProjectionRevision value -> ("projection-revision", (.name) value, (.loc) value)+      NExternalRead value -> ("external-read", externalReadNodeIdentity value, (.loc) value)+      NProjectionOwner value -> ("projection-owner", (.name) value, (.loc) value)+      NWorkflow value -> ("workflow", (.id) value, workflowNodeLoc value)+      NOperation value -> ("operation", (.name) value, (.loc) value)++    collisionDiagnostic (HaskellName.NormalizedNameCollision key sites) =+      case reverse (NE.toList sites) of+        primary : reversedEarlier ->+          Diagnostic+            { line = (.line) primary,+              severity = Error,+              code = GeneratedOccurrenceCollision,+              relatedLocations =+                [ ((.line) site, "'" <> (.logicalName) site <> "' also normalizes here")+                | site <- reverse reversedEarlier+                ],+              message =+                "logical declarations "+                  <> T.intercalate ", " ["'" <> (.logicalName) site <> "'" | site <- NE.toList sites]+                  <> " normalize to the same Haskell occurrence '"+                  <> (.name) key+                  <> "' in "+                  <> (.moduleName) key+                  <> " ("+                  <> T.pack (show ((.space) key))+                  <> ")"+            }+        [] -> mkErr 1 GeneratedOccurrenceCollision "internal error: normalized collision without source sites"+    collisionDiagnostic nameError = nameErrorDiagnostic "generated declaration" nameError++    vertexCollisions aggregate =+      [ mkErr (locLine ((.loc) aggregate)) VertexCtorCollision $+          "aggregate '"+            <> (.name) aggregate+            <> "' state '"+            <> (.name) state+            <> "' generates vertex constructor '"+            <> vertex+            <> "', which collides with "+            <> declarationKind+            <> " '"+            <> vertex+            <> "' in the generated Domain constructor namespace"+      | state <- (.states) aggregate,+        let vertex = normalizedUpper "aggregate" ((.name) aggregate) ((.loc) aggregate) <> normalizedUpper "state" ((.name) state) ((.loc) state),+        declarationKind <- collisionKinds aggregate vertex+      ]++    collisionKinds aggregate vertex =+      ["event" | vertex `elem` [normalizedUpper "event" ((.name) event) ((.loc) event) | event <- (.events) aggregate]]+        ++ ["command" | vertex `elem` [normalizedUpper "command" ((.name) command) ((.loc) command) | command <- (.commands) aggregate]]+        ++ ["enum constructor" | vertex `elem` [normalizedUpper "enum constructor" ctor ((.loc) enum) | enum <- (.enums) spec, (ctor, _) <- (.ctors) 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 ((.nodes) spec),+        let (kind, name, loc) = nodeIdentity node+      ]+    nodeKey node = let (kind, name, _) = nodeIdentity node in (kind, name)+    duplicateEnumMembers = concatMap enumDuplicates ((.enums) spec)+    enumDuplicates e =+      [ mkErr (locLine ((.loc) e)) DuplicateEnumCtor $+          "enum '" <> (.name) e <> "' declares constructor '" <> ctor <> "' more than once"+      | (ctor, _) <- duplicatesBy fst ((.ctors) e)+      ]+        ++ [ mkErr (locLine ((.loc) e)) DuplicateEnumWire $+               "enum '" <> (.name) e <> "' declares wire spelling '" <> wire <> "' more than once"+           | (_, wire) <- duplicatesBy snd ((.ctors) e)+           ]+    duplicateIdPrefixes =+      [ mkErr (locLine ((.loc) d)) DuplicateIdPrefix $+          "id '" <> (.name) d <> "' reuses prefix '" <> (.prefix) d <> "'"+      | d <- duplicatesBy (.prefix) ((.ids) 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", (.name) value, (.loc) value) | value <- (.ids) spec]+        <> [("enum", (.name) value, (.loc) value) | value <- (.enums) spec]+        <> [("nominal scalar", (.name) value, (.loc) value) | value <- (.nominalScalars) spec]+        <> [("mapped", mappedName value, mappedLoc value) | value <- (.mapped) spec]+        <> [("rule", (.name) value, (.loc) value) | value <- (.rules) 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", (.stable) workflow, workflowNodeLoc workflow) | NWorkflow workflow <- (.nodes) spec]+        <> [("process", (.name) process, (.loc) process) | NProcess process <- (.nodes) spec]+        <> [("router", (.name) router, (.loc) router) | NRouter router <- (.nodes) spec]+    catalogRules+      | hasProjectionCatalog languageContract = validateProjectionCatalogFleet supplyAnalysis spec+      | otherwise = []+    ruleDiagnostics = concatMap (validateRule spec) ((.rules) spec)++nodeIdentity :: Node -> (Text, Name, Loc)+nodeIdentity (NAggregate a) = ("aggregate", (.name) a, (.loc) a)+nodeIdentity (NProcess p) = ("process", (.id) p, (.loc) p)+nodeIdentity (NRouter r) = ("router", (.id) r, (.loc) r)+nodeIdentity (NContract c) = ("contract", (.name) c, (.loc) c)+nodeIdentity (NIntake i) = ("intake", (.name) i, (.loc) i)+nodeIdentity (NEmit e) = ("emit", (.name) e, (.loc) e)+nodeIdentity (NPublisher p) = ("publisher", (.name) p, (.loc) p)+nodeIdentity (NWorkqueue w) = ("workqueue", (.name) w, (.loc) w)+nodeIdentity (NPgmqDispatch d) = ("dispatch", (.name) d, (.loc) d)+nodeIdentity (NReadModel r) = ("readmodel", (.name) r, (.loc) r)+nodeIdentity (NProjectionTarget target) = ("target", (.name) target, (.loc) target)+nodeIdentity (NRebuildGroup groupNode) = ("rebuild-group", (.name) groupNode, (.loc) groupNode)+nodeIdentity (NProjectionRevision revision) = ("projection-revision", (.name) revision, (.loc) revision)+nodeIdentity (NExternalRead externalRead) = ("external-read", externalReadNodeIdentity externalRead, (.loc) externalRead)+nodeIdentity (NProjectionOwner owner) = ("projection-owner", (.name) owner, (.loc) owner)+nodeIdentity (NWorkflow w) = ("workflow", (.id) w, workflowNodeLoc w)+nodeIdentity (NOperation o) = ("operation", (.name) o, (.loc) 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 ((.loc) contract)) ContractEmpty $+          "contract '"+            <> (.name) contract+            <> "' declares no events; scaffold cannot lower an empty contract -- declare at least one event"+      | null ((.events) contract)+      ]+    typeIdPrefixErrors =+      [ mkErr (locLine ((.loc) field)) ContractInvalidTypeIdPrefix $+          "contract '"+            <> (.name) contract+            <> "' event '"+            <> (.name) event+            <> "' field '"+            <> (.name) field+            <> "' has invalid TypeID prefix '"+            <> prefix+            <> "': "+            <> T.pack (show reason)+      | event <- (.events) contract,+        field <- (.fields) event,+        CTypeId prefix <- [(.valueType) field],+        Just _ <- [contractIdDomainContractFor languageContract prefix],+        Just reason <- [TypeID.checkPrefix prefix]+      ]+    schemaVersionFloor =+      [ mkErr (locLine ((.loc) contract)) ContractSchemaVersionBelowMinimum $+          "contract '" <> (.name) contract <> "' schemaVersion must be at least 1"+      | enforcesSpecSurfaceClosures languageContract,+        (.schemaVersion) contract < 1+      ]+    topicNames =+      [ mkErr (locLine ((.loc) contract)) ContractTopicNameInvalid $+          "contract '" <> (.name) contract <> "' topic alias '" <> alias <> "' has invalid Kafka topic " <> T.pack (show topic) <> ": " <> reason+      | (alias, topic) <- (.topics) contract,+        T.null topic || enforcesSpecSurfaceClosures languageContract,+        Just reason <- [kafkaTopicError topic]+      ]+    duplicateEvents =+      [ mkErr (locLine ((.loc) contract)) ContractDuplicateEvent $+          "contract '" <> (.name) contract <> "' declares event '" <> (.name) event <> "' more than once"+      | event <- duplicatesBy (.name) ((.events) contract)+      ]+    duplicateTopicAliases =+      [ mkErr (locLine ((.loc) contract)) ContractDuplicateTopicAlias $+          "contract '" <> (.name) contract <> "' declares topic alias '" <> alias <> "' more than once"+      | (alias, _) <- duplicatesBy fst ((.topics) contract)+      ]+    duplicateFields =+      [ mkErr (locLine ((.loc) field)) ContractDuplicateFieldName $+          "contract '" <> (.name) contract <> "' event '" <> (.name) event <> "' declares field '" <> (.name) field <> "' more than once"+      | event <- (.events) contract,+        field <- duplicatesBy (.name) ((.fields) event)+      ]+    discriminatorShadows =+      [ mkErr (locLine ((.loc) field)) ContractFieldShadowsDiscriminator $+          "contract '"+            <> (.name) contract+            <> "' event '"+            <> (.name) event+            <> "' field '"+            <> (.name) field+            <> "' shadows the payload discriminator"+      | enforcesSpecSurfaceClosures languageContract,+        event <- (.events) contract,+        field <- (.fields) event,+        (.wireKey) (resolveContractFieldIdentity field) == (.discriminator) contract+      ]+    fieldWireKeyRules =+      concat+        [ wireKeyRulesForRecord+            ("contract '" <> (.name) contract <> "' event '" <> (.name) event <> "'")+            (Just ((.discriminator) contract, "payload discriminator"))+            (map resolveContractFieldIdentity ((.fields) event))+        | event <- (.events) contract+        ]+    unresolvedTopicAliases =+      [ mkErr (locLine ((.loc) contract)) ContractTopicAliasUnresolved $+          "contract '" <> (.name) contract <> "' event '" <> (.name) event <> "' names undeclared topic alias '" <> (.topic) event <> "'"+      | enforcesSpecSurfaceClosures languageContract,+        event <- (.events) contract,+        (.topic) event `notElem` map fst ((.topics) 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 (.name) ((.inputFields) w)+    labelledItems = workflowLabelledItems ((.body) w)+    patchItems = workflowPatchItems ((.body) w)+    duplicateLabels =+      [ mkErr (locLine (wfBodyLoc item)) WorkflowDuplicateLabel $+          "workflow '" <> (.id) 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 '" <> (.id) w <> "' sleep '" <> label <> "' references undeclared input field '" <> delay <> "'"+      | WfSleep label delay loc <- map snd labelledItems,+        delay `notElem` inputFields+      ]+    patchDuplicates =+      [ mkErr (locLine loc) WorkflowPatchDuplicate $+          "workflow '" <> (.id) 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 '" <> (.id) 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 '" <> (.id) w <> "' continueAsNew must be the last top-level body item and may not appear inside a patch"+      | (isTopLevelTerminal, loc) <- workflowContinueItems ((.body) w),+        not isTopLevelTerminal+      ]+    idField = case (.idField) w of+      Just field+        | field `notElem` inputFields ->+            [ mkErr (locLine (workflowNodeLoc w)) WorkflowIdFieldUnresolved $+                "workflow '" <> (.id) 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 <- (.enums) spec, (.name) e == (.domain) rule] of+  [] ->+    [ mkErr rl RuleDomainUnresolved $+        "rule '" <> (.name) rule <> "' has undeclared enum domain '" <> (.domain) rule <> "'"+    ]+  (domain : _) -> totality domain ++ unknownCases domain ++ bodyDiagnostics+  where+    rl = locLine ((.loc) rule)+    caseNames = map fst ((.cases) rule)+    allEnumCtors = Set.fromList [ctor | e <- (.enums) spec, (ctor, _) <- (.ctors) e]+    totality domain =+      let missing = [ctor | (ctor, _) <- (.ctors) domain, ctor `notElem` caseNames]+       in [ mkErr rl RuleNotTotal $+              "rule '" <> (.name) rule <> "' is not total over enum '" <> (.name) domain <> "'; missing cases {" <> T.intercalate ", " missing <> "}"+          | not (null missing)+          ]+    unknownCases domain =+      [ mkErr rl RuleCaseUnknownCtor $+          "rule '" <> (.name) rule <> "' has case '" <> ctor <> "' which is not a constructor of enum '" <> (.name) domain <> "'"+      | (ctor, _) <- (.cases) rule,+        ctor `notElem` map fst ((.ctors) domain)+      ]+    bodyDiagnostics = concatMap validateBody ((.cases) rule)+    validateBody (ctor, expr) =+      [ mkErr rl ClockSampled $+          "rule '" <> (.name) 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 '" <> (.name) 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 (.shape) o of+  CommandOp aggregate streamField _ projections ->+    aggregateRef aggregate streamField ++ projectionRefs projections+  QueryOp readModel _ _ consistency ->+    resolveReadModelRef QueryUnresolvedReadModel spec ((.loc) o) ("query operation '" <> (.name) o <> "'") readModel+      ++ [ mkErr ol QueryConsistencyInvalid $+             "query operation '" <> (.name) 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 '" <> (.name) o <> "' targets undeclared workflow '" <> wf <> "'")]+      Just w -> case [(resultType, loc) | (_, WfAwait label resultType loc) <- workflowLabelledItems ((.body) 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 '" <> (.name) o <> "' targets undeclared workflow '" <> wf <> "'")+    | wf `notElem` map (.id) workflows+    ]+  where+    ol = locLine ((.loc) o)+    workflows = [w | NWorkflow w <- (.nodes) spec]+    aggregates = [a | NAggregate a <- (.nodes) spec]+    projectionTables = [(.table) p | a <- aggregates, Just p <- [(.projection) a]]+    lookupWorkflow n = case [w | w <- workflows, (.id) w == n] of (w : _) -> Just w; [] -> Nothing+    awaitLabels w = [l | (_, WfAwait l _ _) <- workflowLabelledItems ((.body) w)]+    aggregateRef name streamField = case [a | a <- aggregates, (.name) a == name] of+      [] ->+        [ mkErr ol OperationUnresolvedRef $+            "command operation '" <> (.name) o <> "' targets undeclared aggregate '" <> name <> "'"+        ]+      (aggregate : _) ->+        [ mkErr ol OperationUnresolvedRef $+            "command operation '" <> (.name) o <> "' stream field '" <> streamField <> "' is not declared by any command of aggregate '" <> name <> "'"+        | streamField `notElem` [(.name) field | command <- (.commands) aggregate, field <- (.fields) command]+        ]+    projectionRefs projections =+      [ mkErr ol OperationUnresolvedRef $+          "command operation '" <> (.name) 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` [(.name) readModel | NReadModel readModel <- (.nodes) spec]+  ]++validateProjectionCatalogFleet :: ProjectionSupplyAnalysis -> Spec -> [Diagnostic]+validateProjectionCatalogFleet supplyAnalysis spec = physicalDuplicates <> groupOwnership <> projectionOwnership <> targetDependencies <> handlerOrders <> sourceOrdering <> supplyDiagnostics+  where+    targets = [target | NProjectionTarget target <- (.nodes) spec]+    groups = [groupNode | NRebuildGroup groupNode <- (.nodes) spec]+    owners = [owner | NProjectionOwner owner <- (.nodes) spec]+    physicalDuplicates =+      [ mkErr (locLine ((.loc) target)) CatalogPhysicalTargetDuplicate $+          "target '" <> (.name) target <> "' reuses physical table " <> (.schema) target <> "." <> (.table) target+      | target <- duplicatesBy (\target -> ((.schema) target, (.table) target)) targets+      ]+    targetClaims = [(targetName, (.name) groupNode, (.loc) groupNode) | groupNode <- groups, targetName <- (.targets) groupNode]+    groupOwnership =+      [ mkErr (locLine ((.loc) target)) CatalogTargetUnowned $+          "target '" <> (.name) target <> "' is not owned by any rebuild group"+      | target <- targets,+        null [() | (targetName, _, _) <- targetClaims, targetName == (.name) target]+      ]+        <> [ mkErr (locLine claimLoc) CatalogTargetMultiplyOwned $+               "target '" <> targetName <> "' is owned by more than one rebuild group"+           | (targetName, _, claimLoc) <- duplicatesBy (\(targetName, _, _) -> targetName) targetClaims+           ]+    projectionClaims = [(targetName, (.name) owner, (.loc) owner) | owner <- owners, targetName <- (.targets) owner]+    projectionOwnership =+      [ mkErr (locLine ((.loc) target)) CatalogTargetUnowned $+          "target '" <> (.name) target <> "' has no projection owner"+      | target <- targets,+        null [() | (targetName, _, _) <- projectionClaims, targetName == (.name) 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 ((.loc) target)) CatalogTargetDependencyUnknown $+          "target '" <> (.name) target <> "' depends on undeclared target '" <> dependency <> "'"+      | target <- targets,+        dependency <- (.dependsOn) target,+        dependency `notElem` map (.name) targets+      ]+        <> [ mkErr (locLine ((.loc) target)) CatalogTargetDependencyOutsideGroup $+               "target '" <> (.name) target <> "' depends on target '" <> dependency <> "' in another rebuild group"+           | target <- targets,+             dependency <- (.dependsOn) target,+             Just ownerGroup <- [Map.lookup ((.name) target) groupForTarget],+             Just dependencyGroup <- [Map.lookup dependency groupForTarget],+             ownerGroup /= dependencyGroup+           ]+        <> [ mkErr (locLine ((.loc) target)) CatalogTargetDependencyCycle $+               "target dependency cycle includes '" <> (.name) target <> "'"+           | CyclicSCC cycleTargets <- stronglyConnComp [(target, (.name) target, (.dependsOn) target) | target <- targets],+             target <- cycleTargets+           ]+    handlerOrders =+      [ mkErr (locLine ((.loc) owner)) CatalogDuplicateHandlerOrder $+          "projection owner '" <> (.name) owner <> "' reuses handler order " <> T.pack (show ((.order) owner)) <> " in group '" <> (.group) owner <> "'"+      | owner <- duplicatesBy (\owner -> ((.group) owner, (.order) owner)) owners+      ]+    sourceOrdering =+      [ Diagnostic+          { line = locLine ((.loc) groupNode),+            severity = Error,+            code = CatalogAmbiguousSourceOrdering,+            relatedLocations =+              [ (locLine ((.loc) owner), "projection owner '" <> (.name) owner <> "' contributes " <> sourceScopeText owner <> " events")+              | owner <- groupOwners+              ],+            message =+              "rebuild group '"+                <> (.name) groupNode+                <> "' cannot combine an all-stream source with category-scoped sources; split them into separate rebuild groups"+          }+      | groupNode <- groups,+        let groupOwners = sortOn (.name) [owner | owner <- owners, (.group) owner == (.name) groupNode],+        any ownerUsesAllStreams groupOwners,+        any ownerUsesCategoryScope groupOwners+      ]+    ownerUsesAllStreams owner = CatalogAll `elem` (.sources) owner+    ownerUsesCategoryScope owner = any isCategoryScope ((.sources) 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 ((.loc) readModel)) CatalogReadModelBindingMissing $+        "readmodel '" <> (.name) readModel <> "' must observe at least one target in its projection catalog group"+    ]+  SupplyObservedTargetUnknown readModel targetName ->+    [ mkErr (locLine ((.loc) readModel)) CatalogTargetUnknown $+        "readmodel '" <> (.name) readModel <> "' observes undeclared target '" <> targetName <> "'"+    ]+  SupplyObservedTargetOutsideGroup readModel targetName ->+    [ mkErr (locLine ((.loc) readModel)) CatalogReadModelTargetOutsideGroup $+        "readmodel '" <> (.name) readModel <> "' observes target '" <> targetName <> "' outside its bound group"+    ]+  SupplyObservedTargetWithoutOwner _ _ -> []+  SupplyObservedTargetWithMultipleOwners _ _ _ -> []+  SupplyOwnerGroupMismatch _ _ _ -> []+  SupplyQueryWithoutOwner readModel ->+    [ mkErr (locLine ((.loc) readModel)) CatalogReadModelSupplierMissing $+        "readmodel '" <> (.name) readModel <> "' does not resolve to one projection owner through its observed targets"+    ]+  SupplyQueryWithMultipleOwners readModel owners ->+    [ Diagnostic+        { line = locLine ((.loc) readModel),+          severity = Error,+          code = CatalogReadModelMultipleSuppliers,+          relatedLocations =+            [ (locLine ((.loc) owner), "projection owner '" <> (.name) owner <> "' supplies part of the observed target set")+            | owner <- sortOn (.name) owners+            ],+          message =+            "readmodel '"+              <> (.name) readModel+              <> "' spans several projection owners ("+              <> T.intercalate ", " (map (.name) (sortOn (.name) owners))+              <> "); split the query or declare one owner for the complete observed target set"+        }+    ]+  SupplyLegacyProjectionConflict readModel aggregate projection ->+    [ Diagnostic+        { line = locLine ((.loc) readModel),+          severity = Error,+          code = CatalogReadModelLegacyProjectionConflict,+          relatedLocations =+            [ ( locLine ((.loc) projection),+                "aggregate '" <> (.name) aggregate <> "' also names this readmodel in its legacy projection clause"+              )+            ],+          message =+            "catalog-bound readmodel '"+              <> (.name) readModel+              <> "' derives its supplier from projection-owner target ownership; remove the legacy aggregate projection clause"+        }+    ]++validateProjectionTarget :: EffectiveLanguageContract -> ProjectionTargetNode -> [Diagnostic]+validateProjectionTarget languageContract target =+  [ mkErr (locLine ((.loc) target)) ReadModelIdentifierInvalid $+      "target '" <> (.name) target <> "' " <> kind <> " " <> T.pack (show identifier) <> " is not a PostgreSQL unquoted identifier"+  | hasProjectionCatalog languageContract,+    (kind, identifier) <- [("schema", (.schema) target), ("table", (.table) target)],+    not (validPostgresIdentifier identifier)+  ]++validateRebuildGroup :: EffectiveLanguageContract -> Spec -> RebuildGroupNode -> [Diagnostic]+validateRebuildGroup languageContract spec groupNode+  | not (hasProjectionCatalog languageContract) = []+  | otherwise = emptyTargets <> unknownTargets <> invalidOrder+  where+    targetNames = [(.name) target | NProjectionTarget target <- (.nodes) spec]+    emptyTargets =+      [ mkErr (locLine ((.loc) groupNode)) CatalogGroupEmpty $+          "rebuild group '" <> (.name) groupNode <> "' must own at least one target"+      | null ((.targets) groupNode)+      ]+    unknownTargets =+      [ mkErr (locLine ((.loc) groupNode)) CatalogTargetUnknown $+          "rebuild group '" <> (.name) groupNode <> "' references undeclared target '" <> targetName <> "'"+      | targetName <- (.targets) groupNode,+        targetName `notElem` targetNames+      ]+    invalidOrder =+      [ mkErr (locLine ((.loc) groupNode)) CatalogGroupOrderMismatch $+          "rebuild group '" <> (.name) groupNode <> "' order must contain each owned target exactly once"+      | Set.fromList ((.order) groupNode) /= Set.fromList ((.targets) groupNode)+          || length ((.order) groupNode) /= Set.size (Set.fromList ((.order) groupNode))+          || length ((.targets) groupNode) /= Set.size (Set.fromList ((.targets) groupNode))+      ]++validateProjectionRevision :: EffectiveLanguageContract -> Spec -> ProjectionRevisionNode -> [Diagnostic]+validateProjectionRevision languageContract spec revisionNode+  | not (hasProjectionCatalog languageContract) = []+  | otherwise = noTargets <> unknownGroup <> unknownTargets <> duplicateTargets <> targetSetMismatch <> invalidIdentities <> invalidPromotionNames+  where+    declaredTargets = [(.name) target | NProjectionTarget target <- (.nodes) spec]+    matchingGroups = [groupNode | NRebuildGroup groupNode <- (.nodes) spec, (.name) groupNode == (.group) revisionNode]+    revisionTargets = (.targets) revisionNode+    revisionTargetNames = map (.target) revisionTargets+    noTargets =+      [ mkErr (locLine ((.loc) revisionNode)) CatalogRevisionNoTarget $+          "projection revision '" <> (.name) revisionNode <> "' must declare every target in its rebuild group"+      | null revisionTargets+      ]+    unknownGroup =+      [ mkErr (locLine ((.loc) revisionNode)) CatalogRevisionGroupUnknown $+          "projection revision '" <> (.name) revisionNode <> "' references undeclared rebuild group '" <> (.group) revisionNode <> "'"+      | null matchingGroups+      ]+    unknownTargets =+      [ mkErr (locLine ((.loc) revisionNode)) CatalogRevisionTargetUnknown $+          "projection revision '" <> (.name) revisionNode <> "' references undeclared target '" <> (.target) revisionTarget <> "'"+      | revisionTarget <- revisionTargets,+        (.target) revisionTarget `notElem` declaredTargets+      ]+    duplicateTargets =+      [ mkErr (locLine ((.loc) revisionNode)) CatalogRevisionDuplicateTarget $+          "projection revision '" <> (.name) revisionNode <> "' declares target '" <> targetName <> "' more than once"+      | targetName <- duplicatesBy id revisionTargetNames+      ]+    targetSetMismatch =+      [ mkErr (locLine ((.loc) revisionNode)) CatalogRevisionTargetSetMismatch $+          "projection revision '" <> (.name) revisionNode <> "' target set must equal rebuild group '" <> (.group) revisionNode <> "'"+      | groupNode : _ <- [matchingGroups],+        Set.fromList revisionTargetNames /= Set.fromList ((.targets) groupNode)+          || length revisionTargetNames /= Set.size (Set.fromList revisionTargetNames)+      ]+    invalidIdentities =+      [ mkErr (locLine ((.loc) revisionNode)) CatalogRevisionIdentityInvalid $+          "projection revision '" <> (.name) revisionNode <> "' target '" <> (.target) revisionTarget <> "' has invalid " <> identityKind <> " identity/version"+      | revisionTarget <- revisionTargets,+        (identityKind, identity, version) <-+          [ ("schema", (.schemaVersion) revisionTarget, 1),+            ("provisioner", (.provisioner) revisionTarget, (.provisionerVersion) revisionTarget),+            ("expected-shape", (.expectedShape) revisionTarget, 1),+            ("validator", (.validator) revisionTarget, (.validatorVersion) revisionTarget)+          ],+        T.null identity || T.strip identity /= identity || version <= 0+      ]+    invalidPromotionNames =+      [ mkErr (locLine ((.loc) revisionNode)) CatalogRevisionPromotionNameInvalid $+          "projection revision '" <> (.name) revisionNode <> "' target '" <> (.target) revisionTarget <> "' promotion names must be valid, unique PostgreSQL identifiers"+      | revisionTarget <- revisionTargets,+        let objects = (.promotionObjects) revisionTarget+            names = concat [[(.generationName) object, (.canonicalName) 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 ((.loc) externalRead)+    readModels = [readModel | NReadModel readModel <- (.nodes) spec]+    revisions = [revision | NProjectionRevision revision <- (.nodes) spec]+    matchingReadModels = [readModel | readModel <- readModels, (.name) readModel == (.queryModel) externalRead]+    matchingGroup = case matchingReadModels of+      readModel : _ -> (.group) readModel+      [] -> Nothing+    invalidIdentity =+      [ mkErr diagnosticLine CatalogExternalReadIdentityInvalid $+          "external-read '"+            <> (.name) externalRead+            <> "' requires lower-case PostgreSQL identifiers for its contract, result schema, and result type"+      | any+          (not . validPostgresIdentifier)+          [(.name) externalRead, (.resultSchema) externalRead, (.resultType) externalRead]+      ]+    invalidVersion =+      [ mkErr diagnosticLine CatalogExternalReadVersionInvalid $+          "external-read '" <> (.name) externalRead <> "' version must be at least 1"+      | (.version) externalRead <= 0+      ]+    unknownQuery =+      [ mkErr diagnosticLine CatalogExternalReadQueryUnknown $+          "external-read '" <> (.name) externalRead <> "' references undeclared readmodel '" <> (.queryModel) externalRead <> "'"+      | null matchingReadModels+      ]+    invalidTargetCardinality =+      [ mkErr diagnosticLine CatalogExternalReadTargetCardinalityInvalid $+          "external-read '"+            <> (.name) externalRead+            <> "' is the bounded all-row form and its readmodel must observe exactly one target"+      | readModel <- take 1 matchingReadModels,+        length ((.observedTargets) readModel) /= 1+      ]+    compatibleRevisions = (.compatibleRevisions) externalRead+    invalidCompatibility =+      [ mkErr diagnosticLine CatalogExternalReadCompatibilityInvalid $+          "external-read '" <> (.name) 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 '" <> (.name) externalRead <> "' references undeclared projection revision '" <> revisionName <> "'"+      | revisionName <- compatibleRevisions,+        revisionName `notElem` map (.name) revisions+      ]+    revisionGroupMismatch =+      [ mkErr diagnosticLine CatalogExternalReadRevisionGroupMismatch $+          "external-read '"+            <> (.name) externalRead+            <> "' binds readmodel group '"+            <> queryGroup+            <> "' but compatible revision '"+            <> revisionName+            <> "' belongs to group '"+            <> (.group) revision+            <> "'"+      | Just queryGroup <- [matchingGroup],+        revisionName <- compatibleRevisions,+        revision <- revisions,+        (.name) revision == revisionName,+        (.group) revision /= queryGroup+      ]+    invalidSurfaceGeneration =+      [ mkErr diagnosticLine CatalogExternalReadSurfaceGenerationInvalid $+          "external-read '" <> (.name) externalRead <> "' surface-generation must be at least 1"+      | (.surfaceGeneration) 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 <- (.nodes) spec]+    targets = [target | NProjectionTarget target <- (.nodes) spec]+    aggregates = [(.name) aggregate | NAggregate aggregate <- (.nodes) spec]+    selectedGroupTargets = case [(.targets) groupNode | groupNode <- groups, (.name) groupNode == (.group) owner] of+      groupTargets : _ -> groupTargets+      [] -> []+    noSources =+      [mkErr (locLine ((.loc) owner)) CatalogProjectionNoSource ("projection owner '" <> (.name) owner <> "' must declare at least one source") | null ((.sources) owner)]+    noTargets =+      [mkErr (locLine ((.loc) owner)) CatalogProjectionNoTarget ("projection owner '" <> (.name) owner <> "' must declare at least one target") | null ((.targets) owner)]+    unknownGroup =+      [ mkErr (locLine ((.loc) owner)) CatalogGroupUnknown $+          "projection owner '" <> (.name) owner <> "' references undeclared rebuild group '" <> (.group) owner <> "'"+      | (.group) owner `notElem` map (.name) groups+      ]+    outsideGroup =+      [ mkErr (locLine ((.loc) owner)) CatalogProjectionTargetOutsideGroup $+          "projection owner '" <> (.name) owner <> "' writes target '" <> targetName <> "' outside group '" <> (.group) owner <> "'"+      | targetName <- (.targets) owner,+        targetName `notElem` selectedGroupTargets+      ]+    sourceRules =+      [ mkErr (locLine ((.loc) owner)) CatalogSourceUnresolved $+          "projection owner '" <> (.name) owner <> "' references undeclared aggregate source '" <> aggregateName <> "'"+      | CatalogAggregate aggregateName <- (.sources) owner,+        aggregateName `notElem` aggregates+      ]+        <> [ mkErr (locLine ((.loc) owner)) CatalogSourceOverlap $+               "projection owner '" <> (.name) owner <> "' must select exactly one typed replay source; split independent sources into separate owners"+           | length ((.sources) owner) > 1+           ]+        <> [ mkErr (locLine ((.loc) owner)) RuntimeIdentityInvalid $+               "projection owner '" <> (.name) owner <> "' category source " <> T.pack (show categoryName) <> " " <> reason+           | CatalogCategory categoryName <- (.sources) owner,+             Just reason <- [runtimeIdentityError False categoryName]+           ]+    identityRules = case (.delivery) owner of+      DeliverySubscription ->+        [ mkErr (locLine ((.loc) owner)) CatalogAsyncIdentityMissing $+            "projection owner '" <> (.name) owner <> "' with subscription delivery requires both subscription and dedup identities"+        | (.subscription) owner == Nothing || (.dedup) owner == Nothing+        ]+      DeliveryInline ->+        [ mkErr (locLine ((.loc) owner)) CatalogInlineIdentityUnexpected $+            "projection owner '" <> (.name) owner <> "' with inline delivery cannot declare subscription or dedup identities"+        | (.subscription) owner /= Nothing || (.dedup) owner /= Nothing+        ]+    checkpointRules = case (.delivery) owner of+      DeliverySubscription ->+        [ mkErr (locLine ((.loc) owner)) CatalogCheckpointPolicyMissing $+            "projection owner '" <> (.name) owner <> "' with subscription delivery requires exactly one checkpoint-on-missing policy"+        | null ((.checkpointOnMissing) owner)+        ]+          <> [ mkErr (locLine ((.loc) owner)) CatalogCheckpointPolicyDuplicate $+                 "projection owner '" <> (.name) owner <> "' declares checkpoint-on-missing more than once; choose exactly one of from-beginning, from-current-head, or fail"+             | length ((.checkpointOnMissing) owner) > 1+             ]+      DeliveryInline ->+        [ mkErr (locLine ((.loc) owner)) CatalogCheckpointPolicyUnexpected $+            "projection owner '" <> (.name) owner <> "' with inline delivery cannot declare checkpoint-on-missing because inline delivery has no durable subscription checkpoint"+        | not (null ((.checkpointOnMissing) owner))+        ]+    asyncQueryBinding =+      [ mkErr (locLine ((.loc) owner)) CatalogAsyncQueryBindingMissing $+          "projection owner '" <> (.name) owner <> "' has no query model in group '" <> (.group) owner <> "' observing one of its targets"+      | (.delivery) owner == DeliverySubscription,+        null+          [ ()+          | supply <- (.resolvedProjectionSupplies) supplyAnalysis,+            (.projectionOwner) supply == (.name) owner+          ]+      ]+    replayRules =+      [ mkErr (locLine ((.loc) owner)) CatalogClearTargetLiveOnly $+          "projection owner '" <> (.name) owner <> "' is live-only but writes a clear-before-replay target"+      | ProjectionLiveOnly _ <- [(.replay) owner],+        target <- targets,+        (.name) target `elem` (.targets) owner,+        (.reset) target == TargetClear+      ]+        <> [ mkErr (locLine ((.loc) owner)) CatalogCheckpointPolicyReplayUnsafe $+               "projection owner '" <> (.name) owner <> "' uses from-current-head for subscription '" <> fromMaybe "" ((.subscription) owner) <> "' while replayable target '" <> (.name) target <> "' is cleared before replay; use from-beginning or fail"+           | (.delivery) owner == DeliverySubscription,+             (.checkpointOnMissing) owner == [CheckpointFromCurrentHead],+             (.replay) owner == ProjectionReplayExplicit,+             target <- targets,+             (.name) target `elem` (.targets) owner,+             (.reset) 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 ((.loc) readModel)+    expectedShape = deriveShapeHash readModel+    shapeFixture =+      [ mkErr readModelLine RmShapeHashDrift $+          "readmodel '"+            <> (.name) readModel+            <> "': captured shape \""+            <> (.shape) readModel+            <> "\" does not match the declared columns (expected \""+            <> expectedShape+            <> "\"); update the fixture AND bump version if the table shape really changed"+      | (.shape) readModel /= expectedShape+      ]+    allowedColumnTypes = Set.fromList ["text", "int", "bigint", "bool", "timestamptz", "jsonb", "numeric"]+    columnTypes =+      [ mkErr readModelLine RmUnknownColumnType $+          "readmodel '" <> (.name) readModel <> "' column '" <> (.rmcName) columnDecl <> "' has unknown type '" <> (.rmcType) columnDecl <> "'"+      | columnDecl <- (.columns) readModel,+        (.rmcType) columnDecl `Set.notMember` allowedColumnTypes+      ]+    strongFeed =+      [ mkErr readModelLine RmStrongInlineOnly $+          "readmodel '"+            <> (.name) 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 '" <> (.name) 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 '" <> (.name) readModel <> "': subscription override is ignored when feed = inline; remove it or select feed = subscription"+          }+      | legacyReadModelFeed readModel == Just RmInline,+        legacyReadModelSubscription readModel /= Nothing+      ]+    inlineReference+      | hasProjectionCatalog languageContract,+        (.group) readModel /= Nothing =+          []+      | otherwise =+          [ mkErr readModelLine RmInlineFeedUnreferenced $+              "readmodel '" <> (.name) readModel <> "' declares feed = inline but no aggregate projection references it"+          | legacyReadModelFeed readModel == Just RmInline,+            (.name) readModel `notElem` [(.table) projection | NAggregate aggregate <- (.nodes) spec, Just projection <- [(.projection) aggregate]]+          ]+    freshnessCapability+      | not (hasSeparatedProjectionQueryPolicy languageContract) = []+      | otherwise = case (.freshness) 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 '" <> (.name) owner <> "'")+                        (deliveryText ((.delivery) owner))+                        (allCursorCandidates owner)+                        "use freshness = immediate or give the supplying owner one compatible subscription cursor"+                    ]+                  [_] -> []+                  candidates ->+                    [ waitError+                        CatalogQueryWaitWithAmbiguousCursor+                        requested+                        ("projection-owner '" <> (.name) owner <> "'")+                        (deliveryText ((.delivery) owner))+                        candidates+                        "leave exactly one compatible subscription cursor or use freshness = immediate"+                    ]+      where+        resolvedOwner = do+          ownerName <- case [ (.projectionOwner) supply+                            | supply <- (.resolvedProjectionSupplies) supplyAnalysis,+                              (.queryModel) supply == (.name) readModel+                            ] of+            [name] -> Just name+            _ -> Nothing+          case [owner | NProjectionOwner owner <- (.nodes) spec, (.name) owner == ownerName] of+            [owner] -> Just owner+            _ -> Nothing+        implicitProjectionOwners =+          [ aggregate+          | NAggregate aggregate <- (.nodes) spec,+            Just projection <- [(.projection) aggregate],+            (.table) projection == (.name) readModel+          ]+        compatibleCursorCandidates scope owner+          | (.delivery) owner /= DeliverySubscription = []+          | not (any (sourceReaches scope) ((.sources) owner)) = []+          | otherwise = allCursorCandidates owner+        allCursorCandidates owner = case (.subscription) 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 '"+              <> (.name) 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 '" <> (.name) readModel <> "' version must be at least 1"+      | enforcesSpecSurfaceClosures languageContract,+        (.version) readModel < 1+      ]+    identifiers =+      [ mkErr readModelLine ReadModelIdentifierInvalid $+          "readmodel '" <> (.name) readModel <> "' " <> kind <> " " <> T.pack (show identifier) <> " is not a PostgreSQL unquoted identifier"+      | enforcesSpecSurfaceClosures languageContract,+        (kind, identifier) <-+          [ (kind, identifier)+          | (.group) readModel == Nothing,+            (kind, identifier) <- [("schema", (.schema) readModel), ("table", (.table) readModel)]+          ]+            <> [("column", (.rmcName) columnDecl) | columnDecl <- (.columns) readModel],+        not (validPostgresIdentifier identifier)+      ]+    runtimeIdentities =+      [ mkErr readModelLine RuntimeIdentityInvalid $+          "readmodel '" <> (.name) readModel <> "' subscription " <> T.pack (show subscription) <> " " <> reason+      | enforcesSpecSurfaceClosures languageContract,+        Just subscription <- [legacyReadModelSubscription readModel],+        Just reason <- [stableIdentityError subscription]+      ]+        ++ [ mkErr readModelLine RuntimeIdentityInvalid $+               "readmodel '" <> (.name) readModel <> "' scope category " <> T.pack (show category) <> " " <> reason+           | enforcesSpecSurfaceClosures languageContract,+             Just (RmCategory category) <- [readModelScopeForIdentity readModel],+             Just reason <- [runtimeIdentityError False category]+           ]+    readModelScopeForIdentity model = case (.supply) model of+      LegacyReadModelSupply {legacyScope} -> legacyScope+      OwnerDerivedSupply -> case (.freshness) model of+        FreshnessImmediate -> Nothing+        FreshnessWaitForHead scope -> Just scope+    duplicateColumns =+      [ mkErr readModelLine ReadModelDuplicateColumn $+          "readmodel '" <> (.name) readModel <> "' declares column '" <> (.rmcName) columnDecl <> "' more than once"+      | enforcesSpecSurfaceClosures languageContract,+        columnDecl <- duplicatesBy (.rmcName) ((.columns) readModel)+      ]+    catalogBinding+      | not (hasProjectionCatalog languageContract) = []+      | otherwise = missingGroup <> unknownGroup <> physicalOverride <> backingRequired <> backingUnobserved+      where+        groups = [groupNode | NRebuildGroup groupNode <- (.nodes) spec]+        missingGroup =+          [ mkErr readModelLine CatalogReadModelBindingMissing $+              "readmodel '" <> (.name) readModel <> "' must bind to a projection catalog group or be referenced by one legacy aggregate projection"+          | (.group) readModel == Nothing,+            null+              [ ()+              | NAggregate aggregate <- (.nodes) spec,+                Just projection <- [(.projection) aggregate],+                (.table) projection == (.name) readModel+              ]+          ]+        unknownGroup =+          [ mkErr readModelLine CatalogGroupUnknown $+              "readmodel '" <> (.name) readModel <> "' references undeclared rebuild group '" <> groupName <> "'"+          | Just groupName <- [(.group) readModel],+            groupName `notElem` map (.name) groups+          ]+        physicalOverride =+          [ mkErr readModelLine CatalogReadModelPhysicalOverride $+              "readmodel '"+                <> (.name) 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 <- [(.group) readModel],+            (.table) readModel /= "" || (.schema) readModel /= ""+          ]+        backingRequired =+          [ mkErr readModelLine CatalogReadModelBackingRequired $+              "readmodel '"+                <> (.name) readModel+                <> "' observes "+                <> T.pack (show (length ((.observedTargets) readModel)))+                <> " targets; name the physical backing target with 'backing = <target>'"+          | (.group) readModel /= Nothing,+            length ((.observedTargets) readModel) > 1,+            (.backingTarget) readModel == Nothing+          ]+        backingUnobserved =+          [ mkErr readModelLine CatalogReadModelBackingUnobserved $+              "readmodel '"+                <> (.name) readModel+                <> "' names backing target '"+                <> backingTarget+                <> "' but does not observe it"+          | Just backingTarget <- [(.backingTarget) readModel],+            backingTarget `notElem` (.observedTargets) 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 ((.loc) w)+    rows = (.disposition) w+    (derivedPhysical, derivedDlq, derivedTable) = derivedQueueTrio ((.logical) w)+    divergence =+      [ mkErr wl WqPhysicalDivergence $+          "workqueue '" <> (.name) w <> "': captured physical \"" <> (.physical) w <> "\" diverges from queueRef(\"" <> (.logical) w <> "\") = \"" <> derivedPhysical <> "\""+      | (.physical) w /= derivedPhysical+      ]+        ++ [ mkErr wl WqDlqDivergence $+               "workqueue '" <> (.name) w <> "': captured dlq \"" <> (.dlq) w <> "\" diverges from queueRef = \"" <> derivedDlq <> "\""+           | (.dlq) w /= derivedDlq+           ]+        ++ [ mkErr wl WqTableDivergence $+               "workqueue '" <> (.name) w <> "': captured table \"" <> (.table) w <> "\" diverges from queueRef table = \"" <> derivedTable <> "\""+           | (.table) w /= derivedTable+           ]+    requiredOutcomes = ["storeFailure", "commandRejected", "decodeFailure", "onCodecReject"]+    completeness =+      [ mkErr wl WqDispositionIncomplete $+          "workqueue '" <> (.name) w <> "' disposition table is missing outcome '" <> outcome <> "'"+      | outcome <- requiredOutcomes,+        outcome `notElem` map (.outcome) rows+      ]+    duplicateRows =+      [ mkErr (locLine ((.loc) row)) DispositionDuplicateOutcome $+          "workqueue '" <> (.name) w <> "' repeats disposition outcome '" <> (.outcome) row <> "'; the first row would shadow this row"+      | row <- duplicatesBy (.outcome) rows+      ]+    firstRow outcome = case [row | row <- rows, (.outcome) row == outcome] of+      (row : _) -> Just row+      [] -> Nothing+    isRetry row = case (.action) row of IRetry _ -> True; _ -> False+    isDeadLetter row = case (.action) row of IDeadLetter _ -> True; _ -> False+    inversions =+      [ mkErr (locLine ((.loc) row)) WqStoreFailureNotRetry ("workqueue '" <> (.name) w <> "': 'storeFailure' is transient and MUST retry, not dead-letter")+      | Just row <- [firstRow "storeFailure"],+        isDeadLetter row+      ]+        ++ [ mkErr (locLine ((.loc) row)) WqDecodeFailureNotDeadLetter ("workqueue '" <> (.name) w <> "': 'decodeFailure' is poison and MUST dead-letter, not retry")+           | Just row <- [firstRow "decodeFailure"],+             isRetry row+           ]+    retryCeiling =+      [ mkErr wl WqDlqWithoutCeiling ("workqueue '" <> (.name) w <> "': dlq=on requires maxRetries >= 1 (an absent ceiling never dead-letters)")+      | (.dlqOn) w && (.maxRetries) w < 1+      ]+    fifo = (.ordering) w /= WqUnordered+    orderingRules =+      [ mkErr wl WqGroupKeyMissing $+          "workqueue '" <> (.name) w <> "': FIFO delivery is per group, so ordering requires a 'group key' clause that makes enqueueToGroup deterministic"+      | fifo && (.groupKey) w == Nothing+      ]+        ++ [ mkErr wl WqGroupKeyWithoutFifo $+               "workqueue '" <> (.name) w <> "': a group key with unordered reads would be ignored; declare a FIFO ordering or remove the key"+           | not fifo && (.groupKey) w /= Nothing+           ]+    groupKeyRules = case (.groupKey) w of+      Nothing -> []+      Just groupKey ->+        case [field | field <- (.payload) w, (.name) field == (.field) groupKey] of+          [] ->+            [ mkErr wl WqGroupKeyUnresolved $+                "workqueue '" <> (.name) w <> "': group key field '" <> (.field) groupKey <> "' is not declared in its payload"+            ]+          field : _ ->+            [ mkErr wl WqGroupKeyUnresolved $+                "workqueue '" <> (.name) w <> "': group key via raw requires a text payload field, but '" <> (.field) groupKey <> "' has type '" <> queuePayloadTypeText ((.valueType) field) <> "'"+            | (.via) groupKey == "raw" && not (isDirectText ((.valueType) field))+            ]+              ++ [ mkErr wl WqGroupKeyUnresolved $+                     "workqueue '" <> (.name) w <> "': opaque group-key derivation '" <> (.via) groupKey <> "' requires a captured fixture"+                 | (.via) groupKey /= "raw" && (.fixture) groupKey == Nothing+                 ]+    payloadTypes =+      [ mkErr wl WqPayloadTypeUnknown $+          "workqueue '" <> (.name) w <> "' payload field '" <> (.name) field <> "' has unknown type '" <> queueScalarName scalar <> "'; expected text, int, or bool"+      | enforcesSpecSurfaceClosures languageContract,+        field <- (.payload) w,+        LegacyQueueScalar scalar@(QueueOther _) <- [(.valueType) 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 '" <> (.name) w <> "' delay") ((.delay) w)+        ++ concat+          [ windowRangeRule languageContract (locLine ((.loc) row)) ("workqueue '" <> (.name) w <> "' retry") window+          | row <- rows,+            IRetry window <- [(.action) row]+          ]+    provisionRules = case (.provision) w of+      WqStandard -> []+      WqUnlogged ->+        [ Diagnostic+            { line = wl,+              severity = Warning,+              code = WqUnloggedDurability,+              relatedLocations = [],+              message = "workqueue '" <> (.name) 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 '" <> (.name) 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 ((.loc) 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 <- (.nodes) spec, (.name) readModel == (.sourceReadModel) d] of+      [] -> []+      readModel : _ ->+        [ mkSurfaceRefusal languageContract dl DispatchReadModelFieldUnknown $+            "dispatch '"+              <> (.name) d+              <> "' dedup key '"+              <> (.dedupKey) d+              <> "' is not a generated logical selector for a column of source readmodel '"+              <> (.sourceReadModel) d+              <> "'"+        | (.dedupKey) d `notElem` map (logicalFieldSelector . (.rmcName)) ((.columns) 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 '"+            <> (.name) d+            <> "' fanout body '"+            <> (.fanoutBody) d+            <> "' cannot name a Haskell function; it must be a lowercase-initial identifier that is not a reserved word"+      | not (lowerIdentifierSafe ((.fanoutBody) d))+      ]+    workqueues = [w | NWorkqueue w <- (.nodes) spec]+    enqueueRef =+      [ mkErr dl DispatchEnqueueUnresolved ("dispatch '" <> (.name) d <> "' enqueues to undeclared workqueue '" <> (.enqueueTo) d <> "'")+      | (.enqueueTo) d `notElem` map (.name) workqueues+      ]+    dedupQueueRef = case [w | w <- workqueues, (.name) w == (.dedupQueue) d] of+      [] ->+        [ mkErr dl DispatchDedupQueueUnresolved $+            "dispatch '" <> (.name) d <> "' checks an undeclared dedup queue '" <> (.dedupQueue) d <> "'"+        ]+      (queue : _) ->+        [ mkErr dl DispatchDedupFieldUnresolved $+            "dispatch '" <> (.name) d <> "' dedup field '" <> (.dedupQueueField) d <> "' is not a payload wire field of queue '" <> (.dedupQueue) d <> "'"+        | (.dedupQueueField) d `notElem` map (.wire) ((.payload) queue)+        ]+    sourceReadModelRef =+      resolveReadModelRef DispatchReadModelUnresolved spec ((.loc) d) ("dispatch '" <> (.name) d <> "' source") ((.sourceReadModel) d)+    sourceReadModelField = case [readModel | NReadModel readModel <- (.nodes) spec, (.name) readModel == (.sourceReadModel) d] of+      [] -> []+      readModel : _ ->+        [ mkErr dl DispatchReadModelFieldUnknown $+            "dispatch '" <> (.name) d <> "' source key '" <> (.sourceKey) d <> "' is not a generated logical selector for a column of readmodel '" <> (.sourceReadModel) d <> "'"+        | enforcesSpecSurfaceClosures languageContract,+          (.sourceKey) d `notElem` map (logicalFieldSelector . (.rmcName)) ((.columns) readModel)+        ]+    dedupReadModelRef =+      resolveReadModelRef DispatchReadModelUnresolved spec ((.loc) d) ("dispatch '" <> (.name) d <> "' dedup") ((.dedupReadModel) d)+    dedupReadModelField = case [readModel | NReadModel readModel <- (.nodes) spec, (.name) readModel == (.dedupReadModel) d] of+      [] -> []+      (readModel : _) ->+        [ mkErr dl DispatchReadModelFieldUnknown $+            "dispatch '" <> (.name) d <> "' dedup field '" <> (.dedupReadModelField) d <> "' is not a declared column of readmodel '" <> (.dedupReadModel) d <> "'"+        | (.dedupReadModelField) d `notElem` map (.rmcName) ((.columns) readModel)+        ]++-- | The declared contracts in a spec, by name.+specContracts :: Spec -> [ContractNode]+specContracts spec = [c | NContract c <- (.nodes) 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 ((.loc) i)) IntakeBindHeaderUnknown $+          "intake '"+            <> (.name) i+            <> "' binds '"+            <> (.field) 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 <- (.binds) i,+        SrcHeader headerName <- [(.source) binding],+        headerName `notElem` canonicalEnvelopeHeaders+      ]+    contractCoupling = case lookupContract ((.contract) i) of+      Nothing ->+        [mkErr (locLine ((.loc) i)) IntakeUnresolvedContract ("intake '" <> (.name) i <> "' references undeclared contract '" <> (.contract) i <> "'")]+      Just c ->+        concat+          [ [ mkErr (locLine ((.loc) i)) IntakeUnresolvedContract ("intake '" <> (.name) i <> "' topic '" <> (.topic) i <> "' is not a topic of contract '" <> (.contract) i <> "'")+            | (.topic) i `notElem` map fst ((.topics) c)+            ],+            [ mkErr (locLine ((.loc) i)) IntakeUnresolvedContract ("intake '" <> (.name) i <> "' accepts event '" <> ev <> "' not declared in contract '" <> (.contract) i <> "'")+            | ev <- (.accept) i,+              ev `notElem` map (.name) ((.events) c)+            ],+            [ mkErr (locLine ((.loc) i)) TopicAffinityMismatch $+                "intake '" <> (.name) i <> "' subscribes to topic '" <> (.topic) i <> "' but accepted event '" <> (.name) event <> "' is declared on topic '" <> (.topic) event <> "'"+            | event <- (.events) c,+              (.name) event `elem` (.accept) i,+              (.topic) event /= (.topic) i+            ],+            [ mkErr (locLine ((.loc) i)) IntakeBindUnresolved $+                "intake '" <> (.name) i <> "' binds undeclared envelope or accepted-event field '" <> (.field) binding <> "'"+            | enforcesSpecSurfaceClosures languageContract,+              binding <- (.binds) i,+              (.field) binding `Set.notMember` resolvableFields c+            ],+            [ mkErr (locLine ((.loc) i)) IntakeDedupeKeyUnresolved $+                "intake '" <> (.name) i <> "' dedupe key '" <> (.dedupeKey) i <> "' is not an envelope or accepted-event field"+            | enforcesSpecSurfaceClosures languageContract,+              (.dedupeKey) i `Set.notMember` resolvableFields c+            ],+            [ mkErr (locLine ((.loc) i)) IntakeDecodeSchemaVersionMismatch $+                "intake '"+                  <> (.name) i+                  <> "' decode schemaVersion "+                  <> tInt ((.bodySchemaVersion) ((.decode) i))+                  <> " does not match contract '"+                  <> (.name) c+                  <> "' schemaVersion "+                  <> tInt ((.schemaVersion) c)+            | enforcesSpecSurfaceClosures languageContract,+              (.bodySchemaVersion) ((.decode) i) /= (.schemaVersion) c+            ]+          ]+    bindFlagWarnings =+      [ Diagnostic+          { line = locLine ((.loc) i),+            severity = Warning,+            code = IntakeBindFlagUnenforced,+            relatedLocations = [],+            message =+              "intake '"+                <> (.name) i+                <> "' bind for '"+                <> (.field) binding+                <> "' declares "+                <> bindFlagText binding+                <> ", but generated code does not consume envelope bindings"+          }+      | binding <- (.binds) i,+        (.required) binding || (.crossCheck) binding+      ]+    lookupContract n = case [c | c <- specContracts spec, (.name) c == n] of (c : _) -> Just c; [] -> Nothing+    resolvableFields contract =+      canonicalIntakeEnvelopeFields+        <> Set.fromList+          [ (.name) field+          | event <- (.events) contract,+            (.name) event `elem` (.accept) i,+            field <- (.fields) event+          ]+    bindFlagText binding = case ((.required) binding, (.crossCheck) 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 ((.loc) e)+    skipRule =+      [ mkErr el EmitSkipMissing ("emit '" <> (.name) e <> "' map must end with an explicit '_ => skip' catch-all (hole-kind 7 optionality)")+      | not ((.skip) e)+      ]+    duplicateCases =+      [ mkErr (locLine ((.loc) row)) EmitMapDuplicateCase $+          "emit '" <> (.name) e <> "' repeats map discriminant '" <> (.value) row <> "'; the first row would shadow this row"+      | enforcesSpecSurfaceClosures languageContract,+        row <- duplicatesBy (.value) ((.map) e)+      ]+    coupling = case [c | c <- specContracts spec, (.name) c == (.contract) e] of+      [] -> [mkErr el EmitUnresolvedContract ("emit '" <> (.name) e <> "' references undeclared contract '" <> (.contract) e <> "'")]+      (c : _) ->+        [ mkErr el EmitUnresolvedContract ("emit '" <> (.name) e <> "' topic '" <> (.topic) e <> "' is not a topic of contract '" <> (.contract) e <> "'")+        | (.topic) e `notElem` map fst ((.topics) c)+        ]+          ++ [ mkErr (locLine ((.loc) r)) EmitUnresolvedContract ("emit '" <> (.name) e <> "' maps to event '" <> (.event) r <> "' not declared in contract '" <> (.contract) e <> "'")+             | r <- (.map) e,+               (.event) r `notElem` map (.name) ((.events) c)+             ]+          ++ [ mkErr (locLine ((.loc) row)) TopicAffinityMismatch $+                 "emit '" <> (.name) e <> "' publishes on topic '" <> (.topic) e <> "' but mapped event '" <> (.event) row <> "' is declared on topic '" <> (.topic) event <> "'"+             | row <- (.map) e,+               event <- (.events) c,+               (.name) event == (.event) row,+               (.topic) event /= (.topic) e+             ]++validatePublisher :: EffectiveLanguageContract -> Spec -> PublisherNode -> [Diagnostic]+validatePublisher languageContract spec p =+  unresolvedEmit ++ orderingVocabulary ++ backoffPolicy ++ attemptsFloor ++ outboxField ++ windows+  where+    publisherLine = locLine ((.loc) p)+    unresolvedEmit =+      [ mkErr publisherLine PublisherUnresolvedEmit ("publisher '" <> (.name) p <> "' references undeclared emit '" <> (.emit) p <> "'")+      | (.emit) p `notElem` [(.name) e | NEmit e <- (.nodes) spec]+      ]+    orderingVocabulary =+      [ mkErr publisherLine PublisherOrderingUnknown $+          "publisher '"+            <> (.name) p+            <> "' has unknown ordering '"+            <> (.ordering) p+            <> "'; expected PerKeyHeadOfLine, PerSourceStream, StopTheLine, or BestEffort"+      | (.ordering) p `Set.notMember` publisherOrderings+      ]+    backoffPolicy =+      [ mkErr publisherLine PublisherBackoffInvalid $+          "publisher '" <> (.name) p <> "' has an invalid " <> problem+      | Just problem <- [backoffProblemMaybe ((.backoff) p)]+      ]+    attemptsFloor =+      [ mkErr publisherLine PublisherMaxAttemptsBelowMinimum $+          "publisher '" <> (.name) p <> "' maxAttempts must be at least 1"+      | enforcesSpecSurfaceClosures languageContract,+        (.maxAttempts) p < 1+      ]+    outboxField = case [emitNode | NEmit emitNode <- (.nodes) spec, (.name) emitNode == (.emit) p] of+      [] -> []+      emitNode : _ ->+        [ mkErr publisherLine PublisherOutboxFieldUnresolved $+            "publisher '" <> (.name) p <> "' outboxId field '" <> (.outboxField) p <> "' is not messageId, idempotencyKey, or a field of an event mapped by emit '" <> (.emit) p <> "'"+        | enforcesSpecSurfaceClosures languageContract,+          (.outboxField) p `Set.notMember` allowedOutboxFields emitNode+        ]+    allowedOutboxFields emitNode =+      Set.fromList ("messageId" : "idempotencyKey" : mappedContractFields emitNode)+    mappedContractFields emitNode =+      [ (.dslName) (resolveContractFieldIdentity field)+      | contract <- specContracts spec,+        (.name) contract == (.contract) emitNode,+        event <- (.events) contract,+        (.name) event `elem` map (.event) ((.map) emitNode),+        field <- (.fields) event+      ]+    windows =+      windowRangeRule languageContract publisherLine ("publisher '" <> (.name) p <> "' backoff") ((.window) ((.backoff) p))+        ++ maybe [] (windowRangeRule languageContract publisherLine ("publisher '" <> (.name) p <> "' maximum backoff")) ((.max) ((.backoff) p))++publisherOrderings :: Set Name+publisherOrderings = Set.fromList ["PerKeyHeadOfLine", "PerSourceStream", "StopTheLine", "BestEffort"]++backoffProblemMaybe :: BackoffSpec -> Maybe Text+backoffProblemMaybe backoff = case (.kind) backoff of+  "constant" -> Nothing+  "exponential" -> case ((.max) backoff, (.multiplier) backoff) of+    (Just maximumWindow, Just multiplierText) ->+      case (validationWindowSeconds ((.window) 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 ((.loc) 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 '"+            <> (.name) 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 ((.bodyStrict) ((.decode) i))+      ]+    rows = (.disposition) i+    requiredOutcomes =+      ["processed", "duplicate", "inProgress", "previouslyFailed", "decodeFailed", "dedupeFailed", "storeFailed"]+    completeness =+      [ mkErr il DispositionIncomplete $+          "intake '" <> (.name) i <> "' disposition table is missing outcome '" <> o <> "'"+      | o <- requiredOutcomes,+        o `notElem` map (.outcome) rows+      ]+    duplicateRows =+      [ mkErr (locLine ((.loc) row)) DispositionDuplicateOutcome $+          "intake '" <> (.name) i <> "' repeats disposition outcome '" <> (.outcome) row <> "'; the first row would shadow this row"+      | row <- duplicatesBy (.outcome) rows+      ]+    windows =+      concat+        [ windowRangeRule languageContract (locLine ((.loc) row)) ("intake '" <> (.name) i <> "' retry") window+        | row <- rows,+          IRetry window <- [(.action) row]+        ]+    dedupeVocabulary =+      [ mkErr il IntakeDedupePolicyUnknown $+          "intake '"+            <> (.name) i+            <> "' has unknown dedupe policy '"+            <> (.dedupePolicy) i+            <> "'; expected PreferIntegrationMessageId, PreferSourceEventIdentity, or KafkaDeliveryIdentity"+      | (.dedupePolicy) i `Set.notMember` intakeDedupePolicies+      ]+    decodeVersionFloor =+      [ mkErr il IntakeDecodeSchemaVersionBelowMinimum $+          "intake '" <> (.name) i <> "' decode schemaVersion must be at least 1"+      | enforcesSpecSurfaceClosures languageContract,+        (.bodySchemaVersion) ((.decode) i) < 1+      ]+    envelopeVocabulary =+      [ mkErr il IntakeEnvelopePolicyUnknown $+          "intake '" <> (.name) i <> "' has unsupported envelope policy " <> T.pack (show ((.envelope) ((.decode) i))) <> "; expected \"strict-required lenient-optional\""+      | enforcesSpecSurfaceClosures languageContract,+        (.envelope) ((.decode) i) /= "strict-required lenient-optional"+      ]+    firstRow outcome = case [row | row <- rows, (.outcome) row == outcome] of+      (row : _) -> Just row+      [] -> Nothing+    isRetry row = case (.action) row of IRetry _ -> True; _ -> False+    inversions =+      [ mkErr (locLine ((.loc) row)) DispositionDuplicateRetry $+          "intake '" <> (.name) i <> "': a 'duplicate' redelivery must be ackOk (success), not retry"+      | Just row <- [firstRow "duplicate"],+        isRetry row+      ]+        ++ [ mkErr (locLine ((.loc) row)) DispositionPreviouslyFailedRetry $+               "intake '" <> (.name) i <> "': 'previouslyFailed' must dead-letter, not retry (a prior failure won't succeed on replay)"+           | Just row <- [firstRow "previouslyFailed"],+             isRetry row+           ]+        ++ [ mkErr (locLine ((.loc) row)) DispositionDecodeUnboundedRetry $+               "intake '" <> (.name) 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 ((.loc) d)) DispatchOnAppendedUnsupported $+          "dispatch to '"+            <> (.target) d+            <> "' maps on-appended => "+            <> dispText ((.onAppended) ((.disposition) 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 <- (.dispatch) ((.handle) p),+        (.onAppended) ((.disposition) 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 ((.loc) timer)) TimerDecodeStatusUnknown $+          "timer '"+            <> (.name) timer+            <> "' maps decode unknown-status => '"+            <> (.decodeUnknown) timer+            <> "', which is not a timer status; a stored timer row is one of: "+            <> T.intercalate ", " runtimeTimerStatuses+      | (.decodeUnknown) 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 ((.loc) timer)) TimerDeadLetterTextInvalid $+          "timer '"+            <> (.name) 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 ((.deadLetter) 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 ((.loc) timer)) TimerNotMineUnsupported $+          "timer '"+            <> (.name) 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) ((.disposition) ((.fire) timer)) == OFired+      ]+    aggregates = [a | NAggregate a <- (.nodes) spec]+    aggNames = map (.name) aggregates+    projectionTables = [(.table) projection | aggregate <- aggregates, Just projection <- [(.projection) aggregate]]+    inputFields = map (.name) ((.fields) ((.input) p))+    timeFields = [(.name) f | f <- (.fields) ((.input) p), (.valueType) f == Just "Time"]+    timer = (.timer) p+    pl = locLine ((.loc) p)++    sagaCategoryRule =+      [ mkErr pl SagaCategoryIllegal $+          "saga category " <> T.pack (show ((.category) ((.saga) p))) <> " " <> reason+      | Just reason <- [sagaCategoryError ((.category) ((.saga) 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 = (.field) ((.fireAt) timer)+       in if f `notElem` inputFields+            then+              [ mkErr (locLine ((.loc) timer)) ProcessFireAtNotInjected $+                  "timer '" <> (.name) timer <> "' fireAt field '" <> f <> "' is not a field of input '" <> (.name) ((.input) p) <> "'"+              ]+            else+              [ mkErr (locLine ((.loc) timer)) ProcessFireAtNotInjected $+                  "timer '" <> (.name) timer <> "' fireAt references '" <> f <> "', which is not a declared :Time field of input '" <> (.name) ((.input) 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 '" <> (.name) binding <> "'; remove it"+      | let advance = (.advance) ((.handle) p),+        binding <- (.advFields) advance,+        (.name) binding `elem` (["commandId", "id"] :: [Name])+      ]+        ++ [ mkErr (locLine ((.loc) d)) ProcessDispatchIdSupplied $+               "dispatch to '" <> (.target) d <> "' supplies a runtime-owned id field '" <> (.name) b <> "'; remove it"+           | d <- (.dispatch) ((.handle) p),+             b <- (.fields) d,+             (.name) b `elem` (["commandId", "id"] :: [Name])+           ]+        ++ [ mkErr (locLine ((.loc) timer)) ProcessDispatchIdSupplied $+               "timer fire supplies a runtime-owned id field '" <> (.name) b <> "'; remove it"+           | b <- (.fields) ((.fire) timer),+             (.name) b `elem` (["commandId", "id"] :: [Name])+           ]++    -- Aggregate, command, field, timer, and projection references must resolve.+    crossNodeCoupling =+      [ mkErr pl ProcessUnresolvedRef ("saga '" <> (.agg) ((.saga) p) <> "' does not resolve to a declared aggregate")+      | (.agg) ((.saga) p) `notElem` aggNames+      ]+        ++ [ mkErr pl ProcessUnresolvedRef ("target '" <> (.target) p <> "' does not resolve to a declared aggregate")+           | (.target) p `notElem` aggNames+           ]+        ++ [ mkErr (locLine ((.loc) timer)) ProcessUnresolvedRef ("timer fire target '" <> (.target) ((.fire) timer) <> "' must be the saga or the target aggregate")+           | (.target) ((.fire) timer) `notElem` [(.agg) ((.saga) p), (.target) p]+           ]+        ++ resolveCommand pl "advance" ((.agg) ((.saga) p)) ((.advCommand) advance) ((.advFields) advance)+        ++ concatMap resolveDispatch ((.dispatch) ((.handle) p))+        ++ resolveCommand (locLine ((.loc) timer)) "timer fire" ((.target) fire) ((.command) fire) ((.fields) fire)+        ++ [ mkErr pl ProcessUnresolvedRef $+               "process '" <> (.id) p <> "' schedules undeclared timer '" <> (.schedule) ((.handle) p) <> "'; declared timer is '" <> (.name) timer <> "'"+           | (.schedule) ((.handle) p) /= (.name) timer+           ]+        ++ [ mkErr pl ProcessUnresolvedRef $+               "process '" <> (.id) p <> "' references undeclared projection table '" <> projection <> "'"+           | projection <- (.projections) p,+             projection `notElem` projectionTables+           ]+      where+        advance = (.advance) ((.handle) p)+        fire = (.fire) timer+        resolveDispatch dispatch =+          resolveCommand+            (locLine ((.loc) dispatch))+            "dispatch"+            ((.target) dispatch)+            ((.command) dispatch)+            ((.fields) dispatch)+        resolveCommand diagnosticLine context target command bindings = case lookupAggregate target of+          Nothing -> []+          Just aggregate -> case [decl | decl <- (.commands) aggregate, (.name) 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 '" <> (.name) binding <> "'"+              | binding <- bindings,+                (.name) binding `notElem` map (.name) ((.fields) declaration)+              ]+        lookupAggregate name = case [aggregate | aggregate <- aggregates, (.name) aggregate == name] of+          (aggregate : _) -> Just aggregate+          [] -> Nothing++    strictSurfaceResolution+      | not (enforcesSpecSurfaceClosures languageContract) = []+      | otherwise = correlateFieldRule ++ dispatchKeyRules ++ bindingScopeRules ++ idFieldRules ++ fireWindowRule++    correlateFieldRule =+      [ mkErr pl ProcessKeyFieldUnknown $+          "correlate references 'input." <> (.field) ((.correlate) p) <> "' but input '" <> (.name) ((.input) p) <> "' does not declare that field"+      | (.field) ((.correlate) p) `notElem` inputFields+      ]++    dispatchKeyRules =+      [ mkErr (locLine ((.loc) dispatch)) ProcessDispatchKeyUnresolved $+          "dispatch to '" <> (.target) dispatch <> "' uses unresolved key '" <> (.key) dispatch <> "'; expected correlationId or input.<declared-field>"+      | dispatch <- (.dispatch) ((.handle) p),+        not (processKeyInScope ((.key) dispatch))+      ]+        ++ [ mkErr (locLine ((.loc) timer)) ProcessDispatchKeyUnresolved $+               "timer fire to '" <> (.target) ((.fire) timer) <> "' uses unresolved key '" <> (.key) ((.fire) timer) <> "'; expected correlationId or input.<declared-field>"+           | not (processKeyInScope ((.key) ((.fire) timer)))+           ]++    processKeyInScope value =+      value == "correlationId"+        || case T.stripPrefix "input." value of+          Just field -> field `elem` inputFields+          Nothing -> False++    bindingScopeRules =+      bindingRules pl "advance" inputFields ((.advFields) ((.advance) ((.handle) p)))+        ++ concatMap+          (\dispatch -> bindingRules (locLine ((.loc) dispatch)) "dispatch" inputFields ((.fields) dispatch))+          ((.dispatch) ((.handle) p))+        ++ bindingRules+          (locLine ((.loc) timer))+          "timer fire"+          (inputFields <> map (.name) ((.payload) timer) <> ["timerId"])+          ((.fields) ((.fire) timer))++    bindingRules diagnosticLine context bareScope bindings =+      [ mkErr diagnosticLine ProcessBindingUnscoped $+          context <> " binding '" <> (.name) binding <> maybe "" ("=" <>) ((.value) binding) <> "' is outside the process input and timer scopes"+      | binding <- bindings,+        not (bindingInScope bareScope binding)+      ]++    bindingInScope bareScope binding = case (.value) binding of+      Nothing -> (.name) 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 ((.loc) timer)) TimerIdFieldNotCorrelation $+          "timer '" <> (.name) timer <> "' " <> context <> " derives from '" <> (.field) expression <> "'; only correlationId is implemented by generated runtime code"+      | (context, expression) <- [("id", (.id) timer), ("fired-event-id", (.firedEventId) ((.fire) timer))],+        (.field) expression /= "correlationId"+      ]++    fireWindowRule =+      windowRangeRule languageContract (locLine ((.loc) timer)) ("timer '" <> (.name) timer <> "' fireAt") ((.window) ((.fireAt) timer))++    timerCeiling =+      [ mkErr (locLine ((.loc) timer)) ProcessTimerCeilingInvalid $+          "timer '" <> (.name) timer <> "' max-attempts must be at least 1"+      | (.maxAttempts) timer < 1+      ]++    policyRules =+      policyConsistency+        ((.id) p)+        ((.loc) p)+        ((.rejected) p)+        [ ((.command) dispatch, (.loc) dispatch, (.disposition) dispatch)+        | dispatch <- (.dispatch) ((.handle) p)+        ]++    ambiguityRule =+      [ mkErr (locLine ((.loc) timer)) AmbiguousMarkedBenign $+          "timer '" <> (.name) 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) ((.disposition) ((.fire) timer)) == OFired+      ]++    -- Surface the dangerous benign inversions the author confirmed (warnings).+    benignInversions =+      [ Diagnostic (locLine ((.loc) timer)) Warning ProcessBenignInversion [] $+          "timer '" <> (.name) timer <> "' maps on-reject => Fired (a CommandRejected is treated as benign success)"+      | (.onReject) ((.disposition) ((.fire) timer)) == OFired+      ]+        ++ [ Diagnostic (locLine ((.loc) d)) Warning ProcessBenignInversion [] $+               "dispatch to '" <> (.target) d <> "' maps on-duplicate => AckOk (a duplicate is treated as benign success)"+           | d <- (.dispatch) ((.handle) p),+             (.onDuplicate) ((.disposition) 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 ((.lowerCamel) derived)+    Left _ -> raw+  where+    site =+      HaskellName.NameSite+        { HaskellName.kind = HaskellName.GeneratedFieldSite,+          HaskellName.logicalName = raw,+          HaskellName.owner = "validation field resolution",+          HaskellName.line = 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 '"+            <> (.command) dispatch+            <> "' maps on-appended => "+            <> dispText ((.onAppended) ((.disposition) 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) ((.disposition) dispatch) /= DAckOk+      ]+    aggregates = [aggregate | NAggregate aggregate <- (.nodes) spec]+    readModels = [readModel | NReadModel readModel <- (.nodes) spec]+    inputFields = map (.name) ((.fields) ((.input) router))+    resolvedFields = (.row) ((.resolve) router)+    dispatch = (.dispatch) router+    routerLine = locLine ((.loc) router)+    dispatchLine = locLine ((.loc) dispatch)++    targetAggregate = case [aggregate | aggregate <- aggregates, (.name) aggregate == (.target) router] of+      aggregate : _ -> Just aggregate+      [] -> Nothing++    projectionTables = [(.table) projection | aggregate <- aggregates, Just projection <- [(.projection) aggregate]]++    references =+      [ mkErr routerLine RouterUnresolvedRef $+          "router '" <> (.id) router <> "' targets aggregate '" <> (.target) router <> "' but no such aggregate is declared"+      | targetAggregate == Nothing+      ]+        ++ [ mkErr routerLine RouterUnresolvedRef $+               "router '" <> (.id) router <> "' references undeclared projection table '" <> projection <> "'"+           | projection <- (.projections) router,+             projection `notElem` projectionTables+           ]++    keyField = case (.source) ((.resolve) router) of+      ResolveDeclarative {} -> []+      _ ->+        [ mkErr routerLine RouterKeyFieldUnknown $+            "key references 'input." <> (.field) ((.key) router) <> "' but input '" <> (.name) ((.input) router) <> "' does not declare that field"+        | (.field) ((.key) router) `notElem` inputFields+        ]++    bindingScope = case (.source) ((.resolve) router) of+      ResolveDeclarative {} -> []+      _ ->+        [ mkErr dispatchLine RouterBindingUnscoped $+            "dispatch binding '" <> (.name) binding <> maybe "" ("=" <>) ((.value) binding) <> "' is outside the router input and resolve-row scopes"+        | binding <- (.fields) dispatch,+          not (bindingInScope binding)+        ]+      where+        bindingInScope binding = case (.value) binding of+          Nothing -> (.name) 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 <- (.commands) aggregate, (.name) command == (.command) dispatch] of+        [] ->+          [ mkErr dispatchLine RouterCommandUnknown $+              "dispatch command '" <> (.command) dispatch <> "' is not declared by aggregate '" <> (.name) aggregate <> "'"+          ]+        command : _ ->+          [ mkErr dispatchLine RouterCommandUnknown $+              "dispatch command '" <> (.command) dispatch <> "' binds undeclared target field '" <> (.name) binding <> "'"+          | binding <- (.fields) dispatch,+            (.name) binding `notElem` map (.name) ((.fields) command)+          ]++    readModelReference = case (.source) ((.resolve) router) of+      ResolveHole -> []+      ResolveDeclarative {} -> []+      ResolveReadModel name ->+        case [readModel | readModel <- readModels, (.name) readModel == name] of+          [] ->+            [ mkErr (locLine ((.loc) ((.resolve) router))) RouterUnresolvedRef $+                "router '" <> (.id) router <> "' resolve names readmodel '" <> name <> "' but no such readmodel node is declared"+            ]+          readModel : _ ->+            [ mkErr (locLine ((.loc) ((.resolve) router))) RouterReadModelUnverified $+                "router '" <> (.id) router <> "' resolve row field '" <> column <> "' is not a declared column of readmodel '" <> name <> "'"+            | enforcesSpecSurfaceClosures languageContract,+              column <- (.row) ((.resolve) router),+              column `notElem` map (logicalFieldSelector . (.rmcName)) ((.columns) readModel)+            ]++    selectionChecks = case (.source) ((.resolve) 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+        ((.id) router)+        ((.loc) router)+        ((.rejected) router)+        [((.command) dispatch, (.loc) dispatch, (.disposition) dispatch)]++    duplicateNotice =+      [ Diagnostic dispatchLine Warning RouterBenignInversion [] $+          "router dispatch '" <> (.command) dispatch <> "' maps on-duplicate => AckOk; Keiro.Router confirms the event id against the target stream before treating the duplicate as benign"+      | (.onDuplicate) ((.disposition) dispatch) == DAckOk+      ]++routerSelectionDiagnostic :: RouterSelection.RouterSelectionDiagnostic -> Diagnostic+routerSelectionDiagnostic diagnostic =+  mkErr+    (locLine ((.loc) diagnostic))+    (routerSelectionDiagnosticCode ((.code) diagnostic))+    ((.message) 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 ((.loc) agg)) AggregateEmpty $+          "aggregate '"+            <> (.name) 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 ((.commands) agg), "no commands"),+            (null ((.events) agg), "no events"),+            (null ((.transitions) 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 (.name) ((.states) agg))+    terminals = Set.fromList [(.name) s | s <- (.states) agg, (.terminal) s]+    commandFields :: Map Name [Name]+    commandFields = Map.fromList [((.name) c, map (.name) ((.fields) c)) | c <- (.commands) agg]+    commandNames = Map.keysSet commandFields+    eventNames = Set.fromList (map (.name) ((.events) agg))+    enumCtorNames = Set.fromList [c | e <- (.enums) spec, (c, _) <- (.ctors) e]+    ruleNames = Set.fromList (map (.name) ((.rules) spec))+    registerNames = Set.fromList (map (.name) ((.regs) agg))++    eventFieldsFor event =+      case (.body) event of+        EventFields fields -> fields+        EventFromCommand commandName ->+          [ field+          | command <- (.commands) agg,+            (.name) command == commandName,+            field <- (.fields) command+          ]++    fieldWireKeyRules =+      concat+        [ wireKeyRulesForRecord+            ("aggregate '" <> (.name) agg <> "' command '" <> (.name) command <> "'")+            Nothing+            (map resolveAggregateFieldIdentity ((.fields) command))+        | command <- (.commands) agg+        ]+        <> concat+          [ wireKeyRulesForRecord+              ("aggregate '" <> (.name) agg <> "' event '" <> (.name) event <> "'")+              (Just ("kind", "event envelope key"))+              (map resolveAggregateFieldIdentity (eventFieldsFor event))+          | event <- (.events) agg+          ]++    snapshotRules = case (.snapshot) agg of+      Nothing -> []+      Just snapshot ->+        [ mkErr (locLine ((.loc) snapshot)) SnapshotIntervalInvalid $+            "aggregate '" <> (.name) agg <> "': snapshot every requires an interval of at least 1; non-positive runtime intervals silently disable snapshots"+        | SnapEvery interval <- [(.policy) snapshot],+          interval < 1+        ]+          ++ [ mkErr (locLine ((.loc) snapshot)) SnapshotCodecFixtureInvalid $+                 "aggregate '" <> (.name) agg <> "': snapshot state-codec version must be at least 1 and shape-hash must be non-empty"+             | (.codecVersion) snapshot < 1 || T.null ((.shapeHash) snapshot)+             ]++    wirePolicyRules = case (.wire) agg of+      Just wire+        | enforcesSpecSurfaceClosures languageContract,+          (.kind) wire /= "ctorName" || (.fields) wire /= "camelCase" ->+            [ mkErr (locLine ((.loc) agg)) WireClauseUnsupported $+                "aggregate '"+                  <> (.name) agg+                  <> "' wire clause describes kind="+                  <> (.kind) wire+                  <> " fields="+                  <> (.fields) wire+                  <> "; generated bytes currently support only kind=ctorName fields=camelCase"+            ]+      _ -> []++    duplicateMembers =+      [ mkErr (locLine ((.loc) c)) DuplicateCommandName $+          "aggregate '" <> (.name) agg <> "' declares command '" <> (.name) c <> "' more than once"+      | c <- duplicatesBy (.name) ((.commands) agg)+      ]+        ++ [ mkErr (locLine ((.loc) e)) DuplicateEventName $+               "aggregate '" <> (.name) agg <> "' declares event '" <> (.name) e <> "' more than once"+           | e <- duplicatesBy (.name) ((.events) agg)+           ]+        ++ [ mkErr (locLine ((.loc) field)) AggregateDuplicateFieldName $+               "aggregate '" <> (.name) agg <> "' command '" <> (.name) command <> "' declares field '" <> (.name) field <> "' more than once"+           | command <- (.commands) agg,+             field <- duplicatesBy (.name) ((.fields) command)+           ]+        ++ [ mkErr (locLine ((.loc) field)) AggregateDuplicateFieldName $+               "aggregate '" <> (.name) agg <> "' event '" <> (.name) event <> "' declares field '" <> (.name) field <> "' more than once"+           | event <- (.events) agg,+             EventFields fields <- [(.body) event],+             field <- duplicatesBy (.name) fields+           ]+        ++ [ mkErr (locLine ((.loc) state)) AggregateDuplicateState $+               "aggregate '" <> (.name) agg <> "' declares state '" <> (.name) state <> "' more than once"+           | state <- duplicatesBy (.name) ((.states) agg)+           ]+        ++ [ mkErr (locLine ((.loc) register)) AggregateDuplicateRegister $+               "aggregate '" <> (.name) agg <> "' declares register '" <> (.name) register <> "' more than once"+           | enforcesSpecSurfaceClosures languageContract,+             register <- duplicatesBy (.name) ((.regs) agg)+           ]+        ++ [ mkErr (locLine ((.loc) transition)) TransitionDuplicateUnguarded $+               "aggregate '"+                 <> (.name) agg+                 <> "' has more than one live unguarded transition for '"+                 <> (.source) transition+                 <> " -- "+                 <> (.command) transition+                 <> "'; every matching command would be ambiguous"+           | group <- duplicateGroupsBy transitionKey unguardedTransitions,+             transition <- group+           ]+        ++ [ mkErr (locLine ((.loc) guarded)) TransitionUnguardedSibling $+               "aggregate '"+                 <> (.name) agg+                 <> "' guarded transition '"+                 <> (.source) guarded+                 <> " -- "+                 <> (.command) guarded+                 <> "' overlaps an unguarded sibling at line "+                 <> tInt (locLine ((.loc) unguarded))+           | enforcesSpecSurfaceClosures languageContract,+             guarded <- liveTransitions,+             (.guard) guarded /= Nothing,+             unguarded : _ <- [[candidate | candidate <- unguardedTransitions, transitionKey candidate == transitionKey guarded]]+           ]+    liveTransitions = [transition | transition <- (.transitions) agg, (.mode) transition == TmLive]+    unguardedTransitions = [transition | transition <- liveTransitions, (.guard) transition == Nothing]+    transitionKey transition = ((.source) transition, (.command) transition)++    eventBodyRefs =+      [ mkErr (locLine ((.loc) e)) UndeclaredCommand $+          "event '" <> (.name) e <> "' copies fields from undeclared command '" <> command <> "'"+      | e <- (.events) agg,+        EventFromCommand command <- [(.body) e],+        command `Set.notMember` commandNames+      ]++    outputMappingRules =+      [ mkErr (locLine ((.loc) transition)) EventOutputCommandMismatch $+          "transition '"+            <> (.source) transition+            <> " -- "+            <> consuming+            <> "' emits event '"+            <> eventName+            <> "' declared as fields("+            <> declared+            <> "); generated identity output is legal only when the transition consumes that same command"+      | transition <- (.transitions) agg,+        (emitIndex, eventName) <- zip [1 ..] ((.emits) transition),+        Left OutputCommandMismatch {declaredSourceCommand = declared, consumingTransitionCommand = consuming} <- [eventOutputMappingFromGraphResult typeGraphResult spec agg transition emitIndex eventName]+      ]++    registerInitialScope = concatMap checkRegisterInitial ((.regs) agg)+    checkRegisterInitial r = case [e | e <- (.enums) spec, TRef ((.name) e) == (.valueType) r] of+      (e : _) -> case (.binding) e of+        Just _ ->+          [ outOfScope r "declaration-owned symbol selected by" "initial"+          | regInitialBare r /= Just "initial"+          ]+        Nothing ->+          [ outOfScope r "constructor of enum" ((.name) e)+          | regInitialBare r `notElem` map (Just . fst) ((.ctors) e)+          ]+      []+        | (.valueType) r == TRef ((.name) agg <> "Vertex") ->+            [ outOfScope r "state of aggregate" ((.name) agg)+            | maybe True (`Set.notMember` states) (regInitialBare r)+            ]+        | Just identifier <- firstMatching (\declaration -> (.valueType) r == TRef ((.name) declaration)) ((.ids) spec) -> case (.binding) 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 ((.loc) r)) RegisterInitialOutOfScope $+        "register '" <> (.name) r <> "' initial '" <> renderRegInitial ((.initial) r) <> "' is not a " <> expected <> " '" <> domain <> "'"+    regInitialBare r = case (.initial) 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 ((.transitions) agg)+    transitionRefs t =+      [ mkErr (locLine ((.loc) t)) UndeclaredCommand $+          "transition references undeclared command '" <> (.command) t <> "'"+      | not ((.command) t `Set.member` commandNames)+      ]+        ++ [ mkErr (locLine ((.loc) t)) UndeclaredState $+               "transition source '" <> (.source) t <> "' is not a declared state"+           | not ((.source) t `Set.member` states)+           ]+        ++ [ mkErr (locLine ((.loc) t)) UndeclaredState $+               "transition goto '" <> (.goto) t <> "' is not a declared state"+           | not ((.goto) t `Set.member` states)+           ]+        ++ [ mkErr (locLine ((.loc) t)) UndeclaredEvent $+               "emit references undeclared event '" <> ev <> "'"+           | ev <- (.emits) 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 (.name) ((.states) agg) of+      [] -> []+      (initial : _) ->+        let reached = bfs (Set.singleton initial) [initial]+         in [ mkErr (locLine ((.loc) s)) UnreachableState $+                "state '" <> (.name) s <> "' is not reachable from the initial state '" <> initial <> "'"+            | s <- (.states) agg,+              not ((.terminal) s),+              not ((.name) s `Set.member` reached)+            ]+    edgesFrom src = [(.goto) t | t <- (.transitions) agg, (.source) 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 ((.loc) t)) TerminalHasOutgoing $+          "terminal state '" <> (.source) t <> "' has an outgoing transition"+      | t <- (.transitions) agg,+        (.source) 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 ((.transitions) agg)+    transitionScope t =+      let inScope =+            registerNames+              `Set.union` Set.fromList (Map.findWithDefault [] ((.command) 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 ((.guard) t) ++ map snd ((.writes) 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, _) <- (.writes) t, target `Set.notMember` registerNames]+       in [ mkErr (locLine ((.loc) t)) WriteTargetNotRegister $+              "write target '" <> target <> "' is not a register of aggregate '" <> (.name) agg <> "'"+          | target <- dedup badTargets+          ]+            ++ [ mkErr (locLine ((.loc) t)) GuardAtomOutOfScope $+                   "atom '" <> n <> "' in transition '" <> (.source) t <> " -- " <> (.command) 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 ((.transitions) agg)+    transitionClock t =+      let exprs = maybe [] pure ((.guard) t) ++ map snd ((.writes) t)+          sampled = [n | e <- exprs, n <- exprNames e, n `Set.member` clockAtoms]+       in [ mkErr (locLine ((.loc) t)) ClockSampled $+              "transition '" <> (.source) t <> " -- " <> (.command) 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 ((.loc) projection)) AggProjectionKeyUnresolved $+          "projection '" <> (.table) projection <> "' key '" <> (.key) projection <> "' is not a register, command field, or event field of aggregate '" <> (.name) agg <> "'"+      | enforcesSpecSurfaceClosures languageContract,+        Just projection <- [(.projection) agg],+        (.key) projection `Set.notMember` projectionFields+      ]+    projectionFields =+      registerNames+        `Set.union` Set.fromList [(.dslName) (resolveAggregateFieldIdentity field) | command <- (.commands) agg, field <- (.fields) command]+        `Set.union` Set.fromList [(.dslName) (resolveAggregateFieldIdentity field) | event <- (.events) agg, field <- eventFieldsFor event]++    projectionSafety = case (.projection) agg of+      Nothing -> []+      Just projection -> case [readModel | NReadModel readModel <- (.nodes) spec, (.name) readModel == (.table) projection] of+        [] ->+          [ mkErr (locLine ((.loc) projection)) RmStrongInlineOnly $+              "projection '" <> (.table) projection <> "' declares consistency = Strong but has no readmodel node; a standalone projection is inline-only and has no subscription cursor"+          | (.consistency) projection == Just Strong+          ]+            ++ [ Diagnostic+                   { line = locLine ((.loc) projection),+                     severity = Warning,+                     code = RmProjectionWithoutNode,+                     relatedLocations = [],+                     message = "projection '" <> (.table) projection <> "' has no readmodel node; registration, schema identity, consistency, and rebuild helpers are unavailable"+                   }+               ]+        (readModel : _) ->+          [ mkErr (locLine ((.loc) projection)) RmConsistencyConflict $+              "projection '" <> (.table) projection <> "' declares consistency " <> T.pack (show projectionConsistency) <> " but its readmodel node declares " <> T.pack (show readModelConsistency)+          | Just projectionConsistency <- [(.consistency) 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 (.projection) agg of+      Nothing -> []+      Just p ->+        let evs = map (.name) ((.events) agg)+            pairs = maybe [] (.pairs) ((.statusMap) p)+            keys = map fst pairs+            partial = maybe False (.partial) ((.statusMap) p)+            uncovered = [event | event <- evs, event `notElem` keys]+            dangling = [key | key <- keys, key `notElem` evs]+            duplicateKeys = map fst (duplicatesBy fst pairs)+         in [ mkErr (locLine ((.loc) p)) StatusMapDanglingKey $+                "projection '" <> (.table) p <> "' status-map key '" <> key <> "' is not an event name of aggregate '" <> (.name) agg <> "'"+            | key <- dangling+            ]+              ++ [ mkErr (locLine ((.loc) p)) StatusMapDuplicateKey $+                     "projection '" <> (.table) p <> "' repeats status-map key '" <> key <> "'"+                 | key <- duplicateKeys+                 ]+              ++ [ mkErr (locLine ((.loc) p)) StatusMapNotTotal $+                     "projection '" <> (.table) 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 (.emits) [t | t <- (.transitions) agg, (.mode) t == TmLive])+    replayEmittedNames = Set.fromList (concatMap (.emits) [t | t <- (.transitions) agg, (.mode) t == TmReplayOnly])+    maxEventVersion = maximum (1 : map (.version) ((.events) agg))+    upcasterSources =+      Set.fromList+        [ source+        | event <- (.events) agg,+          Just (source, _) <- [(.upcastFrom) event]+        ]++    -- A non-initial event version must carry a contiguous upcaster (from v-1).+    versionUpcasterRule =+      [ mkErr (locLine ((.loc) e)) EvtVersionMissingUpcaster $+          "event '" <> (.name) e <> "' version " <> tInt ((.version) e) <> " has no 'upcast from v" <> tInt ((.version) e - 1) <> "' clause"+      | e <- (.events) agg,+        (.version) e > 1,+        maybe True ((/= (.version) e - 1) . fst) ((.upcastFrom) 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 ((.loc) 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 ((.loc) e)) DeprecatedEventStillEmitted $+          "deprecated event '" <> (.name) e <> "' is still emitted by a transition"+      | e <- (.events) agg,+        (.deprecated) e,+        (.name) 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 ((.events) agg)+    eventRetirementRule event+      | (.retiring) event =+          [ mkErr (locLine ((.loc) event)) EventRetirementInProgress $+              "retiring event '" <> (.name) 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"+          | (.name) event `Set.notMember` liveEmittedNames+          ]+            ++ [ Diagnostic+                   { line = locLine ((.loc) event),+                     severity = Warning,+                     code = EventRetirementInProgress,+                     relatedLocations = [],+                     message =+                       "event '" <> (.name) 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"+                   }+               | (.name) event `Set.member` liveEmittedNames+               ]+      | (.deprecated) event =+          [ Diagnostic+              { line = locLine ((.loc) event),+                severity = Warning,+                code = DeprecatedEventReplayHazard,+                relatedLocations = [],+                message =+                  "deprecated event '" <> (.name) 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 . (.terminal)) ((.states) agg),+            (.name) event `Set.notMember` replayEmittedNames+          ]+            ++ [ Diagnostic+                   { line = locLine ((.loc) event),+                     severity = Warning,+                     code = EventRetirementInProgress,+                     relatedLocations = [],+                     message =+                       "deprecated event '" <> (.name) 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"+                   }+               | (.name) event `Set.member` replayEmittedNames+               ]+      | otherwise = []++    -- The explicit `wire schemaVersion=` (if any) must equal the max event version.+    wireVersionRule = case (.wire) agg of+      Just w+        | (.schemaVersion) w /= maxEventVersion ->+            [ Diagnostic+                { line = locLine ((.loc) agg),+                  severity = Warning,+                  code = WireSchemaVersionMismatch,+                  relatedLocations = [],+                  message =+                    "wire schemaVersion=" <> tInt ((.schemaVersion) 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 ((.transitions) agg)+    replayOnlyRule t+      | (.mode) t /= TmReplayOnly = []+      | otherwise =+          [ mkErr (locLine ((.loc) t)) ReplayOnlyEmitsNothing $+              "replay-only transition '" <> (.source) t <> " -- " <> (.command) t <> "' emits no event; a replay-only transition exists to invert stored events and is dead weight without an emit"+          | null ((.emits) t)+          ]+            ++ [ Diagnostic+                   { line = locLine ((.loc) t),+                     severity = Warning,+                     code = ReplayOnlyCommandStillLive,+                     relatedLocations = [],+                     message =+                       "replay-only transition '" <> (.source) t <> " -- " <> (.command) t <> "' has no live sibling; command '" <> (.command) t <> "' is fully retired at state '" <> (.source) t <> "' — if the intent is to retire its events too, follow the event-retirement procedure (docs/plans/139)"+                   }+               | not (any (\sibling -> (.mode) sibling == TmLive && (.source) sibling == (.source) t && (.command) sibling == (.command) t) ((.transitions) agg))+               ]++    eventlessStateChangeRules =+      [ mkErr (locLine ((.loc) transition)) AggregateEventlessStateChange $+          "transition '"+            <> (.source) transition+            <> " -- "+            <> (.command) 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 <- (.transitions) agg,+        null ((.emits) transition),+        (.source) transition /= (.goto) transition || not (null ((.writes) transition))+      ]+    changeDescription transition+      | (.source) transition /= (.goto) transition && not (null ((.writes) transition)) = "the target vertex and registers"+      | (.source) transition /= (.goto) transition = "the target vertex"+      | otherwise = "registers"++    domainOutcomeRules =+      declarationRules+        ++ concatMap transitionOutcomeRules ((.transitions) agg)+      where+        declarationRules =+          [ mkErr (locLine loc) DomainOutcomeDeclarationDuplicate $+              "aggregate '" <> (.name) agg <> "' declares domain-outcomes more than once"+          | loc <- (.domainOutcomeDuplicateLocs) agg+          ]+            ++ case (.domainOutcomeTypes) agg of+              Nothing ->+                [ mkErr (locLine (transitionOutcomeLoc outcome)) DomainOutcomeDeclarationMissing $+                    "transition '" <> (.source) transition <> " -- " <> (.command) transition <> "' declares an outcome but aggregate '" <> (.name) agg <> "' has no domain-outcomes declaration"+                | transition <- (.transitions) agg,+                  Just outcome <- [(.outcome) transition]+                ]+              Just _ -> []++        transitionOutcomeRules transition =+          [ mkErr (locLine loc) DomainOutcomeClauseDuplicate $+              "transition '" <> (.source) transition <> " -- " <> (.command) transition <> "' declares outcome more than once"+          | loc <- (.outcomeDuplicateLocs) transition+          ]+            ++ case ((.domainOutcomeTypes) agg, (.mode) transition, (.outcome) transition) of+              (Just _, TmLive, Nothing) ->+                [ mkErr (locLine ((.loc) transition)) DomainOutcomeClauseMissing $+                    "live transition '" <> (.source) transition <> " -- " <> (.command) transition <> "' is missing its required outcome clause"+                ]+              (Just _, TmReplayOnly, Just outcome) ->+                [ mkErr (locLine (transitionOutcomeLoc outcome)) DomainOutcomeReplayOnlyClause $+                    "replay-only transition '" <> (.source) transition <> " -- " <> (.command) transition <> "' cannot declare a forward command outcome"+                ]+              (Just _, TmLive, Just (OutcomeAccepted loc)) ->+                [ mkErr (locLine loc) DomainOutcomeAcceptedWithoutEvents $+                    "accepted transition '" <> (.source) transition <> " -- " <> (.command) transition <> "' must emit at least one event"+                | null ((.emits) 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 '" <> (.source) transition <> " -- " <> (.command) transition <> "' cannot emit events"+              | not (null ((.emits) transition))+              ]+                ++ [ mkErr (locLine (transitionOutcomeLoc outcome)) DomainOutcomeSilentWrites $+                       "silent transition '" <> (.source) transition <> " -- " <> (.command) transition <> "' cannot write aggregate registers"+                   | not (null ((.writes) transition))+                   ]+                ++ [ mkErr (locLine (transitionOutcomeLoc outcome)) DomainOutcomeSilentStateChange $+                       "silent transition '" <> (.source) transition <> " -- " <> (.command) transition <> "' must preserve its source state"+                   | (.goto) transition /= (.source) transition+                   ]++-- | The validator's re-derivation of the live+-- 'Keiro.PGMQ.Runtime.queueRef' trio: physical queue, dead-letter queue, and+-- PGMQ backing table. Parity is pinned by the queue-runtime conformance suite.+derivedQueueTrio :: Text -> (Text, Text, Text)+derivedQueueTrio logical = (physical, physical <> "_dlq", "pgmq.q_" <> physical)+  where+    physical = physicalBase logical++physicalBase :: Text -> Text+physicalBase logical+  | T.length base <= 43 && not ("_dlq" `T.isSuffixOf` base) = base+  | otherwise = hashedBase logical base+  where+    base = sanitizeQueueName logical++sanitizeQueueName :: Text -> Text+sanitizeQueueName =+  ensureLeadingLetter+    . T.intercalate "_"+    . filter (not . T.null)+    . T.splitOn "_"+    . T.map toLegal+    . T.toLower+  where+    toLegal c+      | (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9') || c == '_' = c+      | otherwise = '_'+    ensureLeadingLetter value = case T.uncons value of+      Nothing -> "q"+      Just (c, _)+        | c >= 'a' && c <= 'z' -> value+        | otherwise -> T.cons 'q' value++hashedBase :: Text -> Text -> Text+hashedBase logical base = prefix <> "_" <> fnv1a64Hex logical+  where+    trimmedPrefix = T.dropWhileEnd (== '_') (T.take 26 base)+    prefix+      | T.null trimmedPrefix = "q"+      | otherwise = trimmedPrefix++fnv1a64Hex :: Text -> Text+fnv1a64Hex logical = T.pack (replicate (16 - length rendered) '0' <> rendered)+  where+    rendered = showHex (T.foldl' step offset logical) ""+    offset :: Word64+    offset = 0xcbf29ce484222325+    prime :: Word64+    prime = 0x100000001b3+    step hash character = (hash `xor` fromIntegral (ord character)) * prime++tInt :: Int -> Text+tInt = T.pack . show++mkErr :: Int -> DiagnosticCode -> Text -> Diagnostic+mkErr l c m = Diagnostic {line = l, severity = Error, code = c, relatedLocations = [], message = m}++-- | A dispatch disposition as the author spelled it.+dispText :: Disp -> Text+dispText DAckOk = "AckOk"+dispText DRetry = "Retry"+dispText (DDeadLetter reason) = "DeadLetter " <> T.pack (show reason)++-- | A spec surface the grammar accepts but no runtime implements.+--+-- Released languages below 4 keep their acceptance and only warn, so an+-- existing source does not stop checking when it is pinned to an older+-- language. From language 4 — which promised strict spec-surface validation —+-- the same sentence is an error. The message never changes with the severity, so+-- an author reads one explanation before and after the tightening.+mkSurfaceRefusal :: EffectiveLanguageContract -> Int -> DiagnosticCode -> Text -> Diagnostic+mkSurfaceRefusal languageContract l c m =+  Diagnostic+    { line = l,+      severity = if enforcesSpecSurfaceClosures languageContract then Error else Warning,+      code = c,+      relatedLocations = [],+      message = m+    }++wireKeyRulesForRecord :: Text -> Maybe (Text, Text) -> [ResolvedFieldIdentity] -> [Diagnostic]+wireKeyRulesForRecord owner reservedKey fields = invalidKeys <> duplicateKeys <> reservedCollisions+  where+    -- Structural safety only. An alias exists to preserve a brownfield key that+    -- the current naming convention would reject, so checking alias *style*+    -- would defeat the feature. What is checked is that the key can be a key at+    -- all: a stray space or control character in `as "family "` ships a+    -- permanently mis-keyed public field that no later rename can fix without a+    -- wire break. See ADR 0021.+    invalidKeys = concatMap invalidKeyRule fields+    invalidKeyRule field+      | T.null key = [refuse "resolves to an empty wire key"]+      | key /= T.strip key =+          [ refuse+              ( "resolves to wire key "+                  <> T.pack (show key)+                  <> ", which has leading or trailing whitespace; the wire key is the exact bytes on the wire, so the surrounding space would be part of every encoded field name"+              )+          ]+      | Just offending <- firstMatching isControl (T.unpack key) =+          [ refuse+              ( "resolves to wire key "+                  <> T.pack (show key)+                  <> ", which contains the control character U+"+                  <> T.justifyRight 4 '0' (T.toUpper (T.pack (showHex (ord offending) "")))+              )+          ]+      | otherwise = []+      where+        key = (.wireKey) field+        refuse detail =+          mkErr (locLine ((.loc) field)) FieldWireKeyInvalid $+            owner <> " field '" <> (.dslName) field <> "' " <> detail+    duplicateKeys =+      [ Diagnostic+          { line = locLine ((.loc) field),+            severity = Error,+            code = FieldWireKeyCollision,+            relatedLocations = [(locLine ((.loc) earlier), "wire key '" <> (.wireKey) field <> "' is first declared here")],+            message = owner <> " fields resolve to duplicate wire key '" <> (.wireKey) field <> "'"+          }+      | (index, field) <- zip [0 :: Int ..] fields,+        earlier : _ <- [[candidate | candidate <- take index fields, (.wireKey) candidate == (.wireKey) field]]+      ]+    reservedCollisions =+      [ mkErr (locLine ((.loc) field)) FieldWireKeyCollision $+          owner+            <> " field '"+            <> (.dslName) field+            <> "' resolves to wire key '"+            <> key+            <> "', which collides with the "+            <> description+      | Just (key, description) <- [reservedKey],+        field <- fields,+        (.wireKey) field == key       ]  locLine :: Loc -> Int

src/Keiro/Dsl/Workspace.hs view

@@ -137,30 +137,30 @@ -- contradicts it. data WorkspaceManifest = WorkspaceManifest   { -- | The stable workspace identity, e.g. @demo-project@.-    wmfService :: !Text,-    wmfServiceLoc :: !Loc,+    service :: !Text,+    serviceLoc :: !Loc,     -- | The optional Cabal package that compiles this service's runtime.-    wmfRuntimePackage :: !(Maybe RuntimePackageName),+    runtimePackage :: !(Maybe RuntimePackageName),     -- | Meaningful only when 'wmfRuntimePackage' is 'Just'.-    wmfRuntimePackageLoc :: !Loc,+    runtimePackageLoc :: !Loc,     -- | The optional @module@ clause: the workspace's module-root authority.-    wmfModuleRoot :: !(Maybe Text),+    moduleRoot :: !(Maybe Text),     -- | Meaningful only when 'wmfModuleRoot' is 'Just'.-    wmfModuleRootLoc :: !Loc,+    moduleRootLoc :: !Loc,     -- | The optional @layout@ clause: the workspace's placement authority.-    wmfLayout :: !(Maybe Placement),+    layout :: !(Maybe Placement),     -- | Meaningful only when 'wmfLayout' is 'Just'.-    wmfLayoutLoc :: !Loc,+    layoutLoc :: !Loc,     -- | At least one member, in canonical order.-    wmfMembers :: !(NonEmpty WorkspaceMemberRef)+    members :: !(NonEmpty WorkspaceMemberRef)   }   deriving stock (Eq, Show)  -- | One @spec \<path\>@ line: the normalized manifest-relative member path. data WorkspaceMemberRef = WorkspaceMemberRef   { -- | Normalized: forward slashes, no @./@ segments, relative, ends in @.keiro@.-    wmrPath :: !FilePath,-    wmrLoc :: !Loc+    path :: !FilePath,+    loc :: !Loc   }   deriving stock (Eq, Show) @@ -352,15 +352,15 @@   let sorted = sortOn (T.pack . snd3) normalized   pure     WorkspaceManifest-      { wmfService = service,-        wmfServiceLoc = serviceLoc,-        wmfRuntimePackage = runtimePackage,-        wmfRuntimePackageLoc = runtimePackageLoc,-        wmfModuleRoot = moduleRoot,-        wmfModuleRootLoc = moduleLoc,-        wmfLayout = layout,-        wmfLayoutLoc = layoutLoc,-        wmfMembers = NE.fromList [WorkspaceMemberRef path loc | (_, path, loc) <- sorted]+      { service = service,+        serviceLoc = serviceLoc,+        runtimePackage = runtimePackage,+        runtimePackageLoc = runtimePackageLoc,+        moduleRoot = moduleRoot,+        moduleRootLoc = moduleLoc,+        layout = layout,+        layoutLoc = layoutLoc,+        members = NE.fromList [WorkspaceMemberRef path loc | (_, path, loc) <- sorted]       }   where     snd3 (_, path, _) = path@@ -411,12 +411,12 @@ renderWorkspaceManifest :: WorkspaceManifest -> Text renderWorkspaceManifest manifest =   T.intercalate "\n" $-    ["service " <> wmfService manifest]-      ++ maybe [] (\runtimeName -> ["runtime-package " <> unRuntimePackageName runtimeName]) (wmfRuntimePackage manifest)-      ++ maybe [] (\root -> ["module " <> root]) (wmfModuleRoot manifest)-      ++ maybe [] (\placement -> ["layout " <> renderPlacement placement]) (wmfLayout manifest)-      ++ [ "spec " <> T.pack (wmrPath member)-         | member <- sortOn (T.pack . wmrPath) (NE.toList (wmfMembers manifest))+    ["service " <> (.service) manifest]+      ++ maybe [] (\runtimeName -> ["runtime-package " <> (.unRuntimePackageName) runtimeName]) ((.runtimePackage) manifest)+      ++ maybe [] (\root -> ["module " <> root]) ((.moduleRoot) manifest)+      ++ maybe [] (\placement -> ["layout " <> renderPlacement placement]) ((.layout) manifest)+      ++ [ "spec " <> T.pack ((.path) member)+         | member <- sortOn (T.pack . (.path)) (NE.toList ((.members) manifest))          ]  renderPlacement :: Placement -> Text@@ -428,7 +428,7 @@ effectiveRuntimePackage :: Maybe RuntimePackageName -> WorkspaceManifest -> Maybe RuntimePackageName effectiveRuntimePackage cli manifest = case cli of   Just runtimeName -> Just runtimeName-  Nothing -> wmfRuntimePackage manifest+  Nothing -> (.runtimePackage) manifest  -------------------------------------------------------------------------------- -- Generic line relocation@@ -539,9 +539,9 @@ -- relevant ("also declared here", "member declares context 'kotei'"); it is -- unused for the primary position, which carries the diagnostic's own message. data WorkspaceLocation = WorkspaceLocation-  { wlFile :: !WorkspaceFile,-    wlLine :: !Int,-    wlRole :: !Text+  { file :: !WorkspaceFile,+    line :: !Int,+    role :: !Text   }   deriving stock (Eq, Show) @@ -551,11 +551,11 @@ -- single-spec diagnostics ("Keiro.Dsl.Validate"), so every gate stays -- correlatable by code. data WorkspaceDiagnostic = WorkspaceDiagnostic-  { wdLocations :: !(NonEmpty WorkspaceLocation),-    wdSeverity :: !Severity,-    wdCode :: !DiagnosticCode,-    wdSourceLanguageCause :: !(Maybe SourceLanguageDiagnostic),-    wdMessage :: !Text+  { locations :: !(NonEmpty WorkspaceLocation),+    severity :: !Severity,+    code :: !DiagnosticCode,+    sourceLanguageCause :: !(Maybe SourceLanguageDiagnostic),+    message :: !Text   }   deriving stock (Eq, Show) @@ -590,21 +590,21 @@ renderWorkspaceDiagnostic manifestPath diagnostic =   T.intercalate "\n" (primary : notes)   where-    primaryLocation :| secondary = wdLocations diagnostic+    primaryLocation :| secondary = (.locations) diagnostic     primary =       renderAt primaryLocation         <> ": "         <> severityWord         <> "["-        <> T.pack (show (wdCode diagnostic))+        <> T.pack (show ((.code) diagnostic))         <> "]: "-        <> wdMessage diagnostic-    notes = ["  " <> renderAt location <> ": note: " <> wlRole location | location <- secondary]+        <> (.message) diagnostic+    notes = ["  " <> renderAt location <> ": note: " <> (.role) location | location <- secondary]     renderAt location =-      T.pack (workspaceDisplayPath manifestPath (wlFile location))+      T.pack (workspaceDisplayPath manifestPath ((.file) location))         <> ":"-        <> T.pack (show (wlLine location))-    severityWord = case wdSeverity diagnostic of Error -> "error"; Warning -> "warning"+        <> T.pack (show ((.line) location))+    severityWord = case (.severity) diagnostic of Error -> "error"; Warning -> "warning"  -- | Render a whole failure as the lines a command should print to stderr. renderWorkspaceFailure :: FilePath -> WorkspaceFailure -> [Text]@@ -631,34 +631,34 @@ -- same keying the single-spec duplicate-node rule uses. Values are the owning -- member's manifest-relative path and its /original/ (unrelocated) location. data OwnershipIndex = OwnershipIndex-  { oiDeclarations :: !(Map (Text, Name) (FilePath, Loc)),-    oiNodes :: !(Map (Text, Name) (FilePath, Loc))+  { declarations :: !(Map (Text, Name) (FilePath, Loc)),+    nodes :: !(Map (Text, Name) (FilePath, Loc))   }   deriving stock (Eq, Show)  -- | Which member owns a shared declaration, e.g. @declarationOwner index "id" "ProjectId"@. declarationOwner :: OwnershipIndex -> Text -> Name -> Maybe (FilePath, Loc)-declarationOwner index namespace name = Map.lookup (namespace, name) (oiDeclarations index)+declarationOwner index namespace name = Map.lookup (namespace, name) ((.declarations) index)  -- | Which member owns a node, e.g. @nodeOwner index "aggregate" "Project"@. nodeOwner :: OwnershipIndex -> Text -> Name -> Maybe (FilePath, Loc)-nodeOwner index kind name = Map.lookup (kind, name) (oiNodes index)+nodeOwner index kind name = Map.lookup (kind, name) ((.nodes) index)  -- | One member of a composed workspace. data WorkspaceMember = WorkspaceMember   { -- | Normalized, manifest-relative.-    wmPath :: !FilePath,+    path :: !FilePath,     -- | Exactly as parsed: line numbers are the member's own.-    wmSpec :: !Spec,+    spec :: !Spec,     -- | The member's declared-versus-legacy source contract.-    wmSourceLanguage :: !SourceLanguage,+    sourceLanguage :: !SourceLanguage,     -- | Exact member-local semantic source provenance, using the normalized     -- manifest-relative member path.-    wmSourceIndex :: !SemanticSourceIndex,+    sourceIndex :: !SemanticSourceIndex,     -- | Added to this member's lines to place them in the merged spec.-    wmLineBase :: !Int,+    lineBase :: !Int,     -- | Source lines in the member file.-    wmLineCount :: !Int+    lineCount :: !Int   }   deriving stock (Eq, Show) @@ -674,23 +674,23 @@ -- between the single-file and workspace paths. data WorkspaceSpec = WorkspaceSpec   { -- | The stable workspace identity (the manifest's @service@ name).-    wsService :: !Text,-    wsManifestPath :: !FilePath,+    service :: !Text,+    manifestPath :: !FilePath,     -- | The unanimous effective contract selected before graph composition.     -- Member declared/legacy provenance remains in 'wsMembers'.-    wsLanguageContract :: !EffectiveLanguageContract,+    languageContract :: !EffectiveLanguageContract,     -- | The members' unanimous @context@.-    wsContext :: !Name,-    wsRuntimePackage :: !(Maybe RuntimePackageName),-    wsModuleRoot :: !(Maybe Text),-    wsLayout :: !(Maybe Placement),+    context :: !Name,+    runtimePackage :: !(Maybe RuntimePackageName),+    moduleRoot :: !(Maybe Text),+    layout :: !(Maybe Placement),     -- | Canonical order.-    wsMembers :: ![WorkspaceMember],-    wsMergedSpec :: !Spec,+    members :: ![WorkspaceMember],+    mergedSpec :: !Spec,     -- | Checked union of the members' exact, unrelocated source indices.-    wsSourceIndex :: !SemanticSourceIndex,-    wsLineMap :: !LineMap,-    wsOwnership :: !OwnershipIndex+    sourceIndex :: !SemanticSourceIndex,+    lineMap :: !LineMap,+    ownership :: !OwnershipIndex   }   deriving stock (Eq, Show) @@ -702,7 +702,7 @@   | otherwise =       listToMaybe         [ (path, n - low)-        | (low, high, path) <- lmRanges (wsLineMap workspace),+        | (low, high, path) <- (.lmRanges) ((.lineMap) workspace),           n > low,           n <= high         ]@@ -722,43 +722,43 @@   where     relative = takeFileName path     compatibilityIndex =-      either (const emptySemanticSourceIndex) id (compatibilitySemanticSourceIndex relative (parsedSpec parsedSource))+      either (const emptySemanticSourceIndex) id (compatibilitySemanticSourceIndex relative ((.spec) 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+oneMemberParsedDocumentWorkspace path ParsedSourceDocument {parsedSource = parsedSource, sourceIndex = 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,-      wsLanguageContract = checkedLanguageContract service,-      wsContext = specContext spec,-      wsRuntimePackage = Nothing,-      wsModuleRoot = specModuleRoot spec,-      wsLayout = specLayout spec,-      wsMembers =+    { service = T.pack (takeBaseName path),+      manifestPath = path,+      languageContract = checkedLanguageContract service,+      context = (.context) spec,+      runtimePackage = Nothing,+      moduleRoot = (.moduleRoot) spec,+      layout = (.layout) spec,+      members =         [ WorkspaceMember-            { wmPath = relative,-              wmSpec = spec,-              wmSourceLanguage = parsedSourceLanguage parsedSource,-              wmSourceIndex = sourceIndex,-              wmLineBase = 0,-              wmLineCount = maximum (0 : collectLocs spec)+            { path = relative,+              spec = spec,+              sourceLanguage = (.sourceLanguage) parsedSource,+              sourceIndex = sourceIndex,+              lineBase = 0,+              lineCount = maximum (0 : collectLocs spec)             }         ],-      wsMergedSpec = spec,-      wsSourceIndex = sourceIndex,-      wsLineMap = LineMap [(0, maxBound, relative)],-      wsOwnership = ownershipOf [(relative, spec)]+      mergedSpec = spec,+      sourceIndex = sourceIndex,+      lineMap = LineMap [(0, maxBound, relative)],+      ownership = ownershipOf [(relative, spec)]     }   where     service = checkedSource parsedSource-    spec = parsedSpec parsedSource+    spec = (.spec) parsedSource     relative = takeFileName path  -- | Recover the contract-preserving semantic input from a composed workspace.@@ -766,7 +766,7 @@ -- contract, so downstream consumers need not inspect member provenance. checkedWorkspace :: WorkspaceSpec -> CheckedService checkedWorkspace workspace =-  checkedServiceForContract (wsLanguageContract workspace) (wsMergedSpec workspace)+  checkedServiceForContract ((.languageContract) workspace) ((.mergedSpec) workspace)  -- | Validate a composed workspace. This runs the /existing/ whole-spec -- validator over the merged spec once and maps each diagnostic's line back@@ -779,15 +779,15 @@ checkWorkspaceForService :: WorkspaceSpec -> CheckedService -> [WorkspaceDiagnostic] checkWorkspaceForService workspace service =   [ WorkspaceDiagnostic-      { wdLocations =-          locationFor (line diagnostic)-            :| [ (locationFor noteLine) {wlRole = note}-               | (noteLine, note) <- relatedLocations diagnostic+      { locations =+          locationFor ((.line) diagnostic)+            :| [ (locationFor noteLine) {role = note}+               | (noteLine, note) <- (.relatedLocations) diagnostic                ],-        wdSeverity = severity diagnostic,-        wdCode = code diagnostic,-        wdSourceLanguageCause = Nothing,-        wdMessage = message diagnostic+        severity = (.severity) diagnostic,+        code = (.code) diagnostic,+        sourceLanguageCause = Nothing,+        message = (.message) diagnostic       }   | diagnostic <- validateService service   ]@@ -832,40 +832,40 @@   | otherwise = Right composed   where     ordered =-      [ (ref, lookup (wmrPath ref) [(path, (text, document)) | (path, text, document) <- supplied])-      | ref <- NE.toList (wmfMembers manifest)+      [ (ref, lookup ((.path) ref) [(path, (text, document)) | (path, text, document) <- supplied])+      | ref <- NE.toList ((.members) manifest)       ]     unsupplied =       [ WorkspaceDiagnostic-          { wdLocations = pure (manifestLocation (wmrLoc ref) ""),-            wdSeverity = Error,-            wdCode = WorkspaceMemberUnreadable,-            wdSourceLanguageCause = Nothing,-            wdMessage = "workspace member '" <> T.pack (wmrPath ref) <> "' was not supplied to the composer"+          { locations = pure (manifestLocation ((.loc) ref) ""),+            severity = Error,+            code = WorkspaceMemberUnreadable,+            sourceLanguageCause = Nothing,+            message = "workspace member '" <> T.pack ((.path) ref) <> "' was not supplied to the composer"           }       | (ref, Nothing) <- ordered       ]     entries =-      [ (ref, text, parsedSourceLanguage parsedSource, parsedSpec parsedSource, sourceIndex)-      | (ref, Just (text, ParsedSourceDocument {documentParsedSource = parsedSource, documentSourceIndex = sourceIndex})) <- ordered+      [ (ref, text, (.sourceLanguage) parsedSource, (.spec) parsedSource, sourceIndex)+      | (ref, Just (text, ParsedSourceDocument {parsedSource = parsedSource, sourceIndex = sourceIndex})) <- ordered       ]      qualifiedIndexResults =       [ ( ref,           repathSemanticSourceIndex-            (workspaceDisplayPath manifestPath (WorkspaceMemberFile (wmrPath ref)))-            (wmrPath ref)+            (workspaceDisplayPath manifestPath (WorkspaceMemberFile ((.path) ref)))+            ((.path) 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+          { locations = pure (memberLocation ref (sourceIndexFailureLine indexFailure) ""),+            severity = Error,+            code = WorkspaceSourceIndexInvalid,+            sourceLanguageCause = Nothing,+            message = "workspace member source index is incoherent: " <> sourceIndexFailureText indexFailure           }       | (ref, Left indexFailure) <- qualifiedIndexResults       ]@@ -874,17 +874,17 @@     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+            { locations = pure (sourceIndexFailureLocation indexFailure),+              severity = Error,+              code = WorkspaceSourceIndexInvalid,+              sourceLanguageCause = Nothing,+              message = "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])+      fromMaybe emptySemanticSourceIndex (lookup ((.path) ref) [((.path) candidate, index) | (candidate, Right index) <- qualifiedIndexResults])      refusals =       languageRefusals@@ -904,7 +904,7 @@       | length effectiveVersions <= 1 = []       | otherwise =           [ WorkspaceDiagnostic-              { wdLocations =+              { locations =                   NE.fromList                     [ memberLocation                         ref@@ -912,10 +912,10 @@                         ("member selects effective language version " <> languageVersionText (effectiveLanguageVersion sourceLanguage))                     | (ref, text, sourceLanguage, _, _) <- entries                     ],-                wdSeverity = Error,-                wdCode = WorkspaceLanguageVersionMismatch,-                wdSourceLanguageCause = Nothing,-                wdMessage =+                severity = Error,+                code = WorkspaceLanguageVersionMismatch,+                sourceLanguageCause = Nothing,+                message =                   "workspace members select different effective language versions ("                     <> T.intercalate ", " (map languageVersionText effectiveVersions)                     <> "); one semantic graph cannot combine different language contracts"@@ -924,25 +924,25 @@     sourceLanguageLine text LegacyUnversioned = clauseLine "context" text     sourceLanguageLine _ DeclaredLanguage {languageVersionLoc = Loc lineNumber} = Just lineNumber -    declaredContexts = nub [specContext spec | (_, _, _, spec, _) <- entries]+    declaredContexts = nub [(.context) spec | (_, _, _, spec, _) <- entries]     effectiveContext = case entries of-      (_, _, _, spec, _) : _ -> specContext spec+      (_, _, _, spec, _) : _ -> (.context) spec       [] -> ""     contextRefusals       | length declaredContexts <= 1 = []       | otherwise =           [ WorkspaceDiagnostic-              { wdLocations =+              { locations =                   NE.fromList-                    [ memberLocation ref (clauseLine "context" text) ("member declares context '" <> specContext spec <> "'")+                    [ memberLocation ref (clauseLine "context" text) ("member declares context '" <> (.context) spec <> "'")                     | (ref, text, _, spec, _) <- entries                     ],-                wdSeverity = Error,-                wdCode = WorkspaceContextMismatch,-                wdSourceLanguageCause = Nothing,-                wdMessage =+                severity = Error,+                code = WorkspaceContextMismatch,+                sourceLanguageCause = Nothing,+                message =                   "workspace '"-                    <> wmfService manifest+                    <> (.service) manifest                     <> "' members declare different contexts ("                     <> T.intercalate ", " (sort declaredContexts)                     <> "); every member of one workspace must declare the same context"@@ -953,9 +953,9 @@     -- Effective module root and layout     --------------------------------------------------------------------------     (effectiveModuleRoot, moduleRefusals) =-      resolveAuthority "module" id (wmfModuleRoot manifest) (wmfModuleRootLoc manifest) specModuleRoot+      resolveAuthority "module" id ((.moduleRoot) manifest) ((.moduleRootLoc) manifest) (.moduleRoot)     (effectiveLayout, layoutRefusals) =-      resolveAuthority "layout" renderPlacement (wmfLayout manifest) (wmfLayoutLoc manifest) specLayout+      resolveAuthority "layout" renderPlacement ((.layout) manifest) ((.layoutLoc) manifest) (.layout)      -- The absent-or-exactly-equal authority rule, shared by @module@ and     -- @layout@. When the manifest declares the clause it is the authority and@@ -978,15 +978,15 @@         Just authority ->           ( Just authority,             [ WorkspaceDiagnostic-                { wdLocations =+                { locations =                     manifestLocation manifestLoc ""                       :| [ memberLocation ref (clauseLine clauseKeyword text) ("member declares " <> clauseKeyword <> " " <> renderValue value)                          | (ref, text, value) <- disagreeing                          ],-                  wdSeverity = Error,-                  wdCode = WorkspaceAuthorityConflict,-                  wdSourceLanguageCause = Nothing,-                  wdMessage =+                  severity = Error,+                  code = WorkspaceAuthorityConflict,+                  sourceLanguageCause = Nothing,+                  message =                     "workspace manifest declares "                       <> clauseKeyword                       <> " "@@ -1010,15 +1010,15 @@           | otherwise ->               ( Nothing,                 [ WorkspaceDiagnostic-                    { wdLocations =+                    { locations =                         NE.fromList                           [ memberLocation ref (clauseLine clauseKeyword text) ("member declares " <> clauseKeyword <> " " <> renderValue value)                           | (ref, text, value) <- declared                           ],-                      wdSeverity = Error,-                      wdCode = WorkspaceAuthorityConflict,-                      wdSourceLanguageCause = Nothing,-                      wdMessage =+                      severity = Error,+                      code = WorkspaceAuthorityConflict,+                      sourceLanguageCause = Nothing,+                      message =                         "the workspace manifest declares no "                           <> clauseKeyword                           <> " clause, so the members that declare one must agree; they do not"@@ -1040,40 +1040,40 @@       ]     declarationRefusals =       [ WorkspaceDiagnostic-          { wdLocations =+          { locations =               NE.fromList                 [ memberLocation ref (Just (unLoc loc)) ("also declared here, as " <> namespace <> " '" <> name <> "'")                 | (namespace, ref, loc) <- sites                 ],-            wdSeverity = Error,-            wdCode = WorkspaceDuplicateDeclaration,-            wdSourceLanguageCause = Nothing,-            wdMessage =+            severity = Error,+            code = WorkspaceDuplicateDeclaration,+            sourceLanguageCause = Nothing,+            message =               "duplicate declaration '"                 <> name                 <> "': a shared declaration has exactly one owning member (identical duplicates do not merge)"           }       | (name, sites) <- groupSites declarationSites,-        length (nub [wmrPath ref | (_, ref, _) <- sites]) > 1+        length (nub [(.path) ref | (_, ref, _) <- sites]) > 1       ]      nodeSites =       [ ((kind, name), (ref, loc))       | (ref, _, _, spec, _) <- entries,-        node <- specNodes spec,+        node <- (.nodes) spec,         let (kind, name, loc) = nodeIdentity node       ]     nodeRefusals =       [ WorkspaceDiagnostic-          { wdLocations =+          { locations =               NE.fromList                 [ memberLocation ref (Just (unLoc loc)) ("also defined here")                 | (ref, loc) <- sites                 ],-            wdSeverity = Error,-            wdCode = WorkspaceDuplicateNodeName,-            wdSourceLanguageCause = Nothing,-            wdMessage =+            severity = Error,+            code = WorkspaceDuplicateNodeName,+            sourceLanguageCause = Nothing,+            message =               "duplicate "                 <> kind                 <> " node name '"@@ -1081,7 +1081,7 @@                 <> "': a node has exactly one owning member"           }       | ((kind, name), sites) <- groupSites nodeSites,-        length (nub [wmrPath ref | (ref, _) <- sites]) > 1+        length (nub [(.path) ref | (ref, _) <- sites]) > 1       ]      --------------------------------------------------------------------------@@ -1091,35 +1091,35 @@     lineBases = scanl (+) 0 lineCounts     members =       [ WorkspaceMember-          { wmPath = wmrPath ref,-            wmSpec = spec,-            wmSourceLanguage = sourceLanguage,-            wmSourceIndex = sourceIndexFor ref,-            wmLineBase = base,-            wmLineCount = memberLines+          { path = (.path) ref,+            spec = spec,+            sourceLanguage = sourceLanguage,+            sourceIndex = sourceIndexFor ref,+            lineBase = base,+            lineCount = memberLines           }       | ((ref, _, sourceLanguage, spec, _), base, memberLines) <- zip3 entries lineBases lineCounts       ]-    relocatedSpecs = [relocateLocs (shiftBy (wmLineBase member)) (wmSpec member) | member <- members]+    relocatedSpecs = [relocateLocs (shiftBy ((.lineBase) member)) ((.spec) member) | member <- members]     -- The placeholder location 'Loc 0' must stay 0: shifting it would land it     -- inside the previous member's range and mis-attribute the diagnostic.     shiftBy base n = if n <= 0 then n else n + base     lineMap =       LineMap-        [ (wmLineBase member, wmLineBase member + wmLineCount member, wmPath member)+        [ ((.lineBase) member, (.lineBase) member + (.lineCount) member, (.path) member)         | member <- members         ]     mergedSpec =       Spec-        { specContext = effectiveContext,-          specModuleRoot = effectiveModuleRoot,-          specLayout = effectiveLayout,-          specIds = concatMap specIds relocatedSpecs,-          specEnums = concatMap specEnums relocatedSpecs,-          specRules = concatMap specRules relocatedSpecs,-          specNominalScalars = concatMap specNominalScalars relocatedSpecs,-          specMapped = concatMap specMapped relocatedSpecs,-          specNodes = concatMap specNodes relocatedSpecs+        { context = effectiveContext,+          moduleRoot = effectiveModuleRoot,+          layout = effectiveLayout,+          ids = concatMap (.ids) relocatedSpecs,+          enums = concatMap (.enums) relocatedSpecs,+          rules = concatMap (.rules) relocatedSpecs,+          nominalScalars = concatMap (.nominalScalars) relocatedSpecs,+          mapped = concatMap (.mapped) relocatedSpecs,+          nodes = concatMap (.nodes) relocatedSpecs         }      --------------------------------------------------------------------------@@ -1127,7 +1127,7 @@     --------------------------------------------------------------------------     plannerContext =       Context-        { contextName = effectiveContext,+        { name = effectiveContext,           moduleRoot = fromMaybe "" effectiveModuleRoot,           placement = fromMaybe GeneratedPrefix effectiveLayout         }@@ -1139,7 +1139,7 @@       -- 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 collisionService) = []-      | otherwise = case planIndexedServiceScaffoldWithRuntimePackageAndGoldens [] (wmfRuntimePackage manifest) (wsSourceIndex composed) plannerContext collisionService of+      | otherwise = case planIndexedServiceScaffoldWithRuntimePackageAndGoldens [] ((.runtimePackage) manifest) ((.sourceIndex) composed) plannerContext collisionService of           Right _ -> []           Left plannerRefusals -> concatMap planningRefusal plannerRefusals     collisionService = checkedWorkspace composed@@ -1148,30 +1148,30 @@       workspaceDiagnostics -> workspaceDiagnostics     liftPlanningDiagnostic diagnostic =       WorkspaceDiagnostic-        { wdLocations =-            planningLocation (line diagnostic) ""+        { locations =+            planningLocation ((.line) diagnostic) ""               :| [ planningLocation noteLine note-                 | (noteLine, note) <- relatedLocations diagnostic+                 | (noteLine, note) <- (.relatedLocations) diagnostic                  ],-          wdSeverity = severity diagnostic,-          wdCode = code diagnostic,-          wdSourceLanguageCause = Nothing,-          wdMessage = message diagnostic+          severity = (.severity) diagnostic,+          code = (.code) diagnostic,+          sourceLanguageCause = Nothing,+          message = (.message) diagnostic         }     planningLocation mergedLine role = case lookupLine mergedLine of       Just (owner, original) -> WorkspaceLocation (WorkspaceMemberFile owner) original role       Nothing -> WorkspaceLocation WorkspaceManifestFile (max 1 mergedLine) role     crossMemberCollision (PathCollision path origins) =       [ WorkspaceDiagnostic-          { wdLocations =+          { locations =               NE.fromList                 [ WorkspaceLocation (WorkspaceMemberFile owner) original ("claimed here by " <> origin)                 | (origin, owner, original) <- resolved                 ],-            wdSeverity = Error,-            wdCode = WorkspacePathCollision,-            wdSourceLanguageCause = Nothing,-            wdMessage =+            severity = Error,+            code = WorkspacePathCollision,+            sourceLanguageCause = Nothing,+            message =               "generated module path '"                 <> T.pack path                 <> "' is claimed by nodes in more than one member; on a case-insensitive filesystem these are one file"@@ -1187,12 +1187,12 @@           ]     crossMemberCollision _ = []     blocksCollisionPlanning diagnostic =-      severity diagnostic == Error-        && code diagnostic /= GeneratedOccurrenceCollision+      (.severity) diagnostic == Error+        && (.code) diagnostic /= GeneratedOccurrenceCollision     lookupLine n =       listToMaybe         [ (path, n - low)-        | (low, high, path) <- lmRanges lineMap,+        | (low, high, path) <- (.lmRanges) lineMap,           n > low,           n <= high         ]@@ -1202,18 +1202,18 @@     --------------------------------------------------------------------------     composed =       WorkspaceSpec-        { wsService = wmfService manifest,-          wsManifestPath = manifestPath,-          wsLanguageContract = effectiveLanguageContract effectiveSourceLanguage,-          wsContext = effectiveContext,-          wsRuntimePackage = wmfRuntimePackage manifest,-          wsModuleRoot = effectiveModuleRoot,-          wsLayout = effectiveLayout,-          wsMembers = members,-          wsMergedSpec = mergedSpec,-          wsSourceIndex = either (const emptySemanticSourceIndex) id workspaceSourceIndexResult,-          wsLineMap = lineMap,-          wsOwnership = ownershipOf [(wmPath member, wmSpec member) | member <- members]+        { service = (.service) manifest,+          manifestPath = manifestPath,+          languageContract = effectiveLanguageContract effectiveSourceLanguage,+          context = effectiveContext,+          runtimePackage = (.runtimePackage) manifest,+          moduleRoot = effectiveModuleRoot,+          layout = effectiveLayout,+          members = members,+          mergedSpec = mergedSpec,+          sourceIndex = either (const emptySemanticSourceIndex) id workspaceSourceIndexResult,+          lineMap = lineMap,+          ownership = ownershipOf [((.path) member, (.spec) member) | member <- members]         }      effectiveSourceLanguage = case entries of@@ -1222,14 +1222,14 @@      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} =+      WorkspaceLocation (WorkspaceMemberFile ((.path) ref)) (fromMaybe 1 found) role+    sourceIndexFailureLine SourceIndexFailure {span = failureSpan} =       fmap (\SourceSpan {start = SourcePoint {line}} -> line) failureSpan-    sourceIndexFailureLocation indexFailure@SourceIndexFailure {failureSpan} = case failureSpan of+    sourceIndexFailureLocation indexFailure@SourceIndexFailure {span = 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+    sourceIndexFailureText SourceIndexFailure {code, message} =+      T.pack (show code) <> ": " <> message  -- | Group @(key, site)@ pairs by key, preserving first-appearance order. groupSites :: (Ord k) => [(k, v)] -> [(k, [v])]@@ -1244,11 +1244,11 @@ -- | The four shared-declaration namespaces of one spec, with names and lines. sharedDeclarations :: Spec -> [(Text, Name, Loc)] sharedDeclarations spec =-  [("id", idName d, idLoc d) | d <- specIds spec]-    <> [("enum", enumName d, enumLoc d) | d <- specEnums spec]-    <> [("rule", ruleName d, ruleLoc d) | d <- specRules spec]-    <> [("nominal", nominalScalarName d, nominalScalarLoc d) | d <- specNominalScalars spec]-    <> [("mapped", mappedDeclName d, mappedDeclLoc d) | d <- specMapped spec]+  [("id", (.name) d, (.loc) d) | d <- (.ids) spec]+    <> [("enum", (.name) d, (.loc) d) | d <- (.enums) spec]+    <> [("rule", (.name) d, (.loc) d) | d <- (.rules) spec]+    <> [("nominal", (.name) d, (.loc) d) | d <- (.nominalScalars) spec]+    <> [("mapped", mappedDeclName d, mappedDeclLoc d) | d <- (.mapped) spec]  mappedDeclName :: MappedDecl -> Name mappedDeclName MappedStructural {msName = name} = name@@ -1262,17 +1262,17 @@ ownershipOf :: [(FilePath, Spec)] -> OwnershipIndex ownershipOf members =   OwnershipIndex-    { oiDeclarations =+    { declarations =         Map.fromList           [ ((namespace, name), (path, loc))           | (path, spec) <- members,             (namespace, name, loc) <- sharedDeclarations spec           ],-      oiNodes =+      nodes =         Map.fromList           [ ((kind, name), (path, loc))           | (path, spec) <- members,-            node <- specNodes spec,+            node <- (.nodes) spec,             let (kind, name, loc) = nodeIdentity node           ]     }@@ -1330,13 +1330,13 @@ -- being adopted at once. loadWorkspace :: ContentSource -> FilePath -> IO (Either WorkspaceFailure WorkspaceSpec) loadWorkspace source manifestPath = do-  manifestRead <- csRead source (takeFileName manifestPath)+  manifestRead <- (.csRead) source (takeFileName manifestPath)   case manifestRead of     Left reason -> pure (Left (WorkspaceManifestUnreadable reason))     Right manifestText -> case parseWorkspaceManifest manifestPath manifestText of       Left err -> pure (Left (WorkspaceManifestUnparseable err))       Right manifest -> do-        results <- traverse readMember (NE.toList (wmfMembers manifest))+        results <- traverse readMember (NE.toList ((.members) manifest))         case [diagnostic | Left diagnostic <- results] of           (d : ds) -> pure (Left (WorkspaceRefused (d :| ds)))           [] ->@@ -1347,26 +1347,26 @@               )   where     readMember ref = do-      result <- csRead source (wmrPath ref)+      result <- (.csRead) source ((.path) 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 parseSourceDocument (workspaceDisplayPath manifestPath (WorkspaceMemberFile (wmrPath ref))) text of+        Left reason -> Left (memberFailure ref WorkspaceMemberUnreadable ("workspace member '" <> T.pack ((.path) ref) <> "' could not be read: " <> reason) Nothing)+        Right text -> case parseSourceDocument (workspaceDisplayPath manifestPath (WorkspaceMemberFile ((.path) ref))) text of           Left parseFailure ->             Left               ( memberFailure                   ref                   WorkspaceMemberParseFailed-                  ("workspace member '" <> T.pack (wmrPath ref) <> "' failed to parse:\n" <> renderParseFailure parseFailure)+                  ("workspace member '" <> T.pack ((.path) ref) <> "' failed to parse:\n" <> renderParseFailure parseFailure)                   (case parseFailure of SourceLanguageFailure diagnostic -> Just diagnostic; BodyGrammarFailure {} -> Nothing)               )-          Right document -> Right (wmrPath ref, text, document)-    memberFailure ref failureCode note sourceLanguageCause =+          Right document -> Right ((.path) ref, text, document)+    memberFailure ref code note sourceLanguageCause =       WorkspaceDiagnostic-        { wdLocations = pure (WorkspaceLocation WorkspaceManifestFile (max 1 (unLoc (wmrLoc ref))) ""),-          wdSeverity = Error,-          wdCode = failureCode,-          wdSourceLanguageCause = sourceLanguageCause,-          wdMessage = note+        { locations = pure (WorkspaceLocation WorkspaceManifestFile (max 1 (unLoc ((.loc) ref))) ""),+          severity = Error,+          code = code,+          sourceLanguageCause = sourceLanguageCause,+          message = note         }  --------------------------------------------------------------------------------

src/Keiro/Dsl/WorkspaceAdoption.hs view

@@ -60,24 +60,24 @@   deriving stock (Eq, Show)  data ClaimedFile = ClaimedFile-  { cfPath :: !FilePath,-    cfEvidence :: !ClaimEvidence,+  { path :: !FilePath,+    evidence :: !ClaimEvidence,     -- | The legacy record's file name, for @record@ evidence.-    cfSource :: !(Maybe Text),+    source :: !(Maybe Text),     -- | The legacy record's @spec:@ field, for @record@ evidence.-    cfSpec :: !(Maybe Text)+    spec :: !(Maybe Text)   }   deriving stock (Eq, Show)  -- | What one adopting run found. Printed in the scaffold output and persisted -- beside the generated tree as the durable review artifact. data MigrationReport = MigrationReport-  { mrService :: !Text,+  { service :: !Text,     -- | The legacy record consulted, as @(file name, its @spec:@ field)@.-    mrLegacyRecord :: !(Maybe (FilePath, Text)),-    mrClaimed :: ![ClaimedFile],-    mrLikelyStale :: ![StaleModule],-    mrUnclaimed :: ![FilePath]+    legacyRecord :: !(Maybe (FilePath, Text)),+    claimed :: ![ClaimedFile],+    likelyStale :: ![StaleModule],+    unclaimed :: ![FilePath]   }   deriving stock (Eq, Show) @@ -94,25 +94,25 @@   present <- Set.fromList <$> outputTreeFiles out   let legacyName = maybe (contextLedgerFileName context) fst ledger       legacy = snd <$> ledger-      plannedGenerated = [modulePath m | m <- modules, kind m == Generated]-      plannedAll = Set.fromList (map modulePath modules)+      plannedGenerated = [(.path) m | m <- modules, (.kind) m == Generated]+      plannedAll = Set.fromList (map (.path) modules)       onDisk path = path `Set.member` present -      recordedFiles = maybe [] recFiles legacy-      recordSpec = fmap recSpecPath legacy+      recordedFiles = maybe [] (.files) legacy+      recordSpec = fmap (.specPath) legacy        claimedFromRecord =         [ ClaimedFile-            { cfPath = path,-              cfEvidence = ClaimedFromRecord,-              cfSource = Just (T.pack legacyName),-              cfSpec = recordSpec+            { path = path,+              evidence = ClaimedFromRecord,+              source = Just (T.pack legacyName),+              spec = recordSpec             }         | (Generated, path) <- recordedFiles,           path `Set.member` plannedAll,           onDisk path         ]-      recordClaimedPaths = Set.fromList (map cfPath claimedFromRecord)+      recordClaimedPaths = Set.fromList (map (.path) claimedFromRecord)    -- A banner claim reads the file, so it is filtered before the read.   bannerCandidates <-@@ -123,15 +123,15 @@         onDisk path,         path `Set.notMember` recordClaimedPaths       ]-  likelyStale <- staleAgainst out (map modulePath modules) recordedFiles+  likelyStale <- staleAgainst out (map (.path) modules) recordedFiles   let claimedFromBanner =-        [ ClaimedFile {cfPath = path, cfEvidence = ClaimedFromBanner, cfSource = Nothing, cfSpec = Nothing}+        [ ClaimedFile {path = path, evidence = ClaimedFromBanner, source = Nothing, spec = Nothing}         | (path, True) <- bannerCandidates         ]       claimed = claimedFromRecord <> claimedFromBanner        staleOrGenerated =-        Set.fromList (map stalePath likelyStale) <> Set.fromList plannedGenerated+        Set.fromList (map (.path) likelyStale) <> Set.fromList plannedGenerated        -- Everything left on disk that this run neither produces nor       -- attributes. Planned Generated paths are excluded because this run@@ -140,11 +140,11 @@        report =         MigrationReport-          { mrService = service,-            mrLegacyRecord = (,) legacyName <$> recordSpec,-            mrClaimed = claimed,-            mrLikelyStale = likelyStale,-            mrUnclaimed = unclaimed+          { service = service,+            legacyRecord = (,) legacyName <$> recordSpec,+            claimed = claimed,+            likelyStale = likelyStale,+            unclaimed = unclaimed           }   pure $     if null claimed && null likelyStale && null unclaimed && isNothing legacy@@ -155,14 +155,14 @@ adoptedRows :: MigrationReport -> [AdoptedRow] adoptedRows report =   [ AdoptedRow-      { adPath = cfPath claimed,-        adEvidence = case cfEvidence claimed of+      { path = (.path) claimed,+        evidence = case (.evidence) claimed of           ClaimedFromRecord -> "record"           ClaimedFromBanner -> "banner",-        adSource = cfSource claimed,-        adSpec = cfSpec claimed+        source = (.source) claimed,+        spec = (.spec) claimed       }-  | claimed <- mrClaimed report+  | claimed <- (.claimed) report   ]  -- | Append the supersession marker to a legacy record, once. Appending is@@ -228,29 +228,29 @@ -- written to @keiro-dsl-migration-report.workspace.\<service\>.txt@. renderMigrationReport :: MigrationReport -> [Text] renderMigrationReport report =-  [ "migration: adopting pre-workspace scaffold output into workspace " <> mrService report+  [ "migration: adopting pre-workspace scaffold output into workspace " <> (.service) report   ]     <> legacySection     <> claimedSection     <> staleSection     <> unclaimedSection     <> [ "note: keiro-dsl never deletes files. The legacy record was marked superseded, not removed.",-         "note: the full report is kept at " <> T.pack (workspaceMigrationReportFileName (mrService report))+         "note: the full report is kept at " <> T.pack (workspaceMigrationReportFileName ((.service) report))        ]   where-    legacySection = case mrLegacyRecord report of+    legacySection = case (.legacyRecord) report of       Nothing -> ["  legacy record: (none for this context)"]       Just (name, specPath) -> ["  legacy record: " <> T.pack name <> " (spec " <> specPath <> ")"]-    claimedSection = case mrClaimed report of+    claimedSection = case (.claimed) report of       [] -> ["  claimed: nothing was attributable to this workspace"]       claimed ->         ["  claimed " <> tshow (length claimed) <> " file(s) into workspace history:"]-          <> [ "    " <> evidenceTag (cfEvidence entry) <> "  " <> T.pack (cfPath entry)+          <> [ "    " <> evidenceTag ((.evidence) entry) <> "  " <> T.pack ((.path) entry)              | entry <- claimed              ]     evidenceTag ClaimedFromRecord = "record"     evidenceTag ClaimedFromBanner = "banner"-    staleSection = case mrLikelyStale report of+    staleSection = case (.likelyStale) report of       [] -> []       stale ->         [ "  likely stale: "@@ -258,13 +258,13 @@             <> " file(s) the legacy scaffold recorded that this workspace does not produce:"         ]           <> map staleLine stale-    staleLine stale = case (staleKind stale, staleGeneratedEvidence stale) of+    staleLine stale = case ((.kind) stale, (.generatedEvidence) stale) of       (Generated, Just ExactGeneratedBannerPresent) ->-        "    generated " <> T.pack (stalePath stale) <> "  (exact generated banner present; verify unchanged bytes before deleting)"+        "    generated " <> T.pack ((.path) stale) <> "  (exact generated banner present; verify unchanged bytes before deleting)"       (Generated, _) ->-        "    generated " <> T.pack (stalePath stale) <> "  (exact generated banner missing; preserve and review)"-      (HoleStub, _) -> "    hole      " <> T.pack (stalePath stale) <> "  (hand-owned — preserve and review)"-    unclaimedSection = case mrUnclaimed report of+        "    generated " <> T.pack ((.path) stale) <> "  (exact generated banner missing; preserve and review)"+      (HoleStub, _) -> "    hole      " <> T.pack ((.path) stale) <> "  (hand-owned — preserve and review)"+    unclaimedSection = case (.unclaimed) report of       [] -> []       unclaimed ->         [ "  unclaimed: "

src/Keiro/Dsl/WorkspaceDiff.hs view

@@ -45,13 +45,13 @@   where     annotate change =       WorkspaceChange-        { wcChange = change,-          wcDeclarationSite =+        { change = change,+          declarationSite =             ownedSiteForName new (declarationName kind)               <|> ownedSiteForName old (declarationName kind),-          wcUseSites =+          useSites =             [ (path, ownedSiteForName new (pathRoot path) <|> ownedSiteForName old (pathRoot path))-            | path <- ckPaths kind+            | path <- (.paths) kind             ]         }       where@@ -60,50 +60,50 @@ memberLanguageChanges :: WorkspaceSpec -> WorkspaceSpec -> [WorkspaceChange] memberLanguageChanges old new =   [ WorkspaceChange-      { wcChange = change,-        wcDeclarationSite = Just (OwnedSite path (sourceLine (wmSourceLanguage newMember))),-        wcUseSites = []+      { change = change,+        declarationSite = Just (OwnedSite path (sourceLine ((.sourceLanguage) newMember))),+        useSites = []       }   | (path, newMember) <- Map.toAscList newByPath,     Just oldMember <- [Map.lookup path oldByPath],-    change <- sourceLanguageChange (wsService new) (T.pack path) (wmSourceLanguage oldMember) (wmSourceLanguage newMember)+    change <- sourceLanguageChange ((.service) new) (T.pack path) ((.sourceLanguage) oldMember) ((.sourceLanguage) newMember)   ]   where-    oldByPath = Map.fromList [(wmPath member, member) | member <- wsMembers old]-    newByPath = Map.fromList [(wmPath member, member) | member <- wsMembers new]+    oldByPath = Map.fromList [((.path) member, member) | member <- (.members) old]+    newByPath = Map.fromList [((.path) member, member) | member <- (.members) new]     sourceLine LegacyUnversioned = 1     sourceLine DeclaredLanguage {languageVersionLoc = Loc lineNumber} = lineNumber  -- | Preserve the existing headline/vector bytes and append indented citations. renderWorkspaceFinding :: WorkspaceChange -> Text renderWorkspaceFinding workspaceChange =-  T.intercalate "\n" (renderFinding (wcChange workspaceChange) : declarationLine <> useLines)+  T.intercalate "\n" (renderFinding ((.change) workspaceChange) : declarationLine <> useLines)   where-    declarationLine = case wcDeclarationSite workspaceChange of+    declarationLine = case (.declarationSite) workspaceChange of       Nothing -> []       Just site -> ["    declared: " <> renderOwnedSite site]     useLines =       [ "    use-site: " <> path <> " (" <> renderOwnedSite site <> ")"-      | (path, Just site) <- wcUseSites workspaceChange+      | (path, Just site) <- (.useSites) workspaceChange       ]  renderOwnedSite :: OwnedSite -> Text-renderOwnedSite site = T.pack (osFile site) <> ":" <> T.pack (show (osLine site))+renderOwnedSite site = T.pack ((.file) site) <> ":" <> T.pack (show ((.line) site))  ownedSiteForName :: WorkspaceSpec -> Name -> Maybe OwnedSite ownedSiteForName workspace name = do   (_, (file, Loc line)) <- find ((== name) . snd . fst) entries   pure (OwnedSite file line)   where-    ownership = wsOwnership workspace-    entries = Map.toAscList (oiDeclarations ownership) <> Map.toAscList (oiNodes ownership)+    ownership = (.ownership) workspace+    entries = Map.toAscList ((.declarations) ownership) <> Map.toAscList ((.nodes) ownership)  declarationName :: ChangeKind -> Name declarationName kind-  | "mapped-" `T.isPrefixOf` ckFacet kind,-    Just mapped <- mappedNameFromSubject (ckSubject kind) =+  | "mapped-" `T.isPrefixOf` (.facet) kind,+    Just mapped <- mappedNameFromSubject ((.subject) kind) =       mapped-  | otherwise = ckNode kind+  | otherwise = (.node) kind  mappedNameFromSubject :: Text -> Maybe Name mappedNameFromSubject subject =@@ -126,7 +126,7 @@ ownershipMoveChanges :: WorkspaceSpec -> WorkspaceSpec -> [WorkspaceChange] ownershipMoveChanges old new =   [ WorkspaceChange-      { wcChange =+      { change =           advisoryAt             (consumerBuildContext name [])             name@@ -139,40 +139,40 @@                 <> T.pack newFile                 <> "; source ownership changed while wire evolution remains independently classified"             ),-        wcDeclarationSite = Just (OwnedSite newFile (unLoc newLoc)),-        wcUseSites = []+        declarationSite = Just (OwnedSite newFile ((.unLoc) newLoc)),+        useSites = []       }-  | (key@(_, name), (oldFile, _)) <- Map.toAscList (ownershipEntries (wsOwnership old)),-    Just (newFile, newLoc) <- [Map.lookup key (ownershipEntries (wsOwnership new))],+  | (key@(_, name), (oldFile, _)) <- Map.toAscList (ownershipEntries ((.ownership) old)),+    Just (newFile, newLoc) <- [Map.lookup key (ownershipEntries ((.ownership) new))],     oldFile /= newFile   ]  ownershipEntries :: OwnershipIndex -> Map.Map (Text, Name) (FilePath, Loc)-ownershipEntries ownership = oiDeclarations ownership <> oiNodes ownership+ownershipEntries ownership = (.declarations) ownership <> (.nodes) ownership  authorityChanges :: WorkspaceSpec -> WorkspaceSpec -> [WorkspaceChange] authorityChanges old new =   concat-    [ changed "service-identity" (wsService old) (wsService new) serviceDetail,-      changed "context" (wsContext old) (wsContext new) contextDetail,-      changed "module-root" (renderModuleRoot (wsModuleRoot old)) (renderModuleRoot (wsModuleRoot new)) moduleDetail,-      changed "layout" (renderLayout (wsLayout old)) (renderLayout (wsLayout new)) layoutDetail+    [ changed "service-identity" ((.service) old) ((.service) new) serviceDetail,+      changed "context" ((.context) old) ((.context) new) contextDetail,+      changed "module-root" (renderModuleRoot ((.moduleRoot) old)) (renderModuleRoot ((.moduleRoot) new)) moduleDetail,+      changed "layout" (renderLayout ((.layout) old)) (renderLayout ((.layout) new)) layoutDetail     ]   where     changed field before after detail       | before == after = []       | otherwise =           [ WorkspaceChange-              { wcChange =+              { change =                   advisoryAt-                    (consumerBuildContext (wsService new) [])-                    (wsService new)+                    (consumerBuildContext ((.service) new) [])+                    ((.service) new)                     "workspace-authority"                     field                     WorkspaceAuthorityChanged                     (field <> " changed '" <> before <> "' -> '" <> after <> "'; " <> detail),-                wcDeclarationSite = Nothing,-                wcUseSites = []+                declarationSite = Nothing,+                useSites = []               }           ]     serviceDetail = "scaffold and compatibility history are re-keyed; follow the workspace adoption path"

src/Keiro/Dsl/WorkspaceRecord.hs view

@@ -79,23 +79,23 @@ -- directory, and which member file produced it ('Nothing' for context-level -- modules emitted once from the merged graph). data WorkspaceModuleRow = WorkspaceModuleRow-  { wrmKind :: !ModuleKind,-    wrmPath :: !FilePath,-    wrmOwner :: !(Maybe FilePath),-    wrmRole :: !(Maybe ModuleRole)+  { kind :: !ModuleKind,+    path :: !FilePath,+    owner :: !(Maybe FilePath),+    role :: !(Maybe ModuleRole)   }   deriving stock (Eq, Show)  instance ToJSON WorkspaceModuleRow where   toJSON row =     object $-      [ "kind" .= (case wrmKind row of Generated -> "generated" :: Text; HoleStub -> "hole"),-        "path" .= T.pack (wrmPath row)+      [ "kind" .= (case (.kind) row of Generated -> "generated" :: Text; HoleStub -> "hole"),+        "path" .= T.pack ((.path) row)       ]-        <> ["owner" .= T.pack owner | Just owner <- [wrmOwner row]]-        <> ["roleOwnerKind" .= roleOwnerKind role | Just role <- [wrmRole row]]-        <> ["roleOwnerName" .= roleOwnerName role | Just role <- [wrmRole row]]-        <> ["roleFamily" .= roleFamily role | Just role <- [wrmRole row]]+        <> ["owner" .= T.pack owner | Just owner <- [(.owner) row]]+        <> ["roleOwnerKind" .= (.ownerKind) role | Just role <- [(.role) row]]+        <> ["roleOwnerName" .= (.ownerName) role | Just role <- [(.role) row]]+        <> ["roleFamily" .= (.family) role | Just role <- [(.role) row]]  instance FromJSON WorkspaceModuleRow where   parseJSON = withObject "WorkspaceModuleRow" $ \fields -> do@@ -115,29 +115,29 @@       _ -> fail "module role fields must be all present or all absent"     pure       WorkspaceModuleRow-        { wrmKind = moduleKind,-          wrmPath = T.unpack (path :: Text),-          wrmOwner = T.unpack <$> (owner :: Maybe Text),-          wrmRole = moduleRoleValue+        { kind = moduleKind,+          path = T.unpack (path :: Text),+          owner = T.unpack <$> (owner :: Maybe Text),+          role = moduleRoleValue         }  -- | One member's source-language provenance in a workspace record. data WorkspaceSourceLanguageRow = WorkspaceSourceLanguageRow-  { wrslPath :: !FilePath,-    wrslSourceLanguage :: !SourceLanguage+  { path :: !FilePath,+    sourceLanguage :: !SourceLanguage   }   deriving stock (Eq, Show)  instance ToJSON WorkspaceSourceLanguageRow where   toJSON row =     object-      [ "path" .= T.pack (wrslPath row),+      [ "path" .= T.pack ((.path) row),         "sourceForm" .= sourceFormText sourceLanguage,         "declaredLanguageVersion" .= declaredLanguageVersionMaybe sourceLanguage,         "effectiveLanguageVersion" .= effectiveLanguageVersion sourceLanguage       ]     where-      sourceLanguage = wrslSourceLanguage row+      sourceLanguage = (.sourceLanguage) row  instance FromJSON WorkspaceSourceLanguageRow where   parseJSON value@(Aeson.Object fields) = do@@ -145,8 +145,8 @@     sourceLanguage <- parseJSON value     pure       WorkspaceSourceLanguageRow-        { wrslPath = T.unpack (path :: Text),-          wrslSourceLanguage = sourceLanguage+        { path = T.unpack (path :: Text),+          sourceLanguage = sourceLanguage         }   parseJSON _ = fail "WorkspaceSourceLanguageRow must be an object" @@ -156,21 +156,21 @@ -- carries the @-- \@generated@ banner but no surviving record lists it (the orphan -- case created when one legacy record overwrote another). data AdoptedRow = AdoptedRow-  { adPath :: !FilePath,-    adEvidence :: !Text,+  { path :: !FilePath,+    evidence :: !Text,     -- | The legacy record's file name, when the evidence is @record@.-    adSource :: !(Maybe Text),+    source :: !(Maybe Text),     -- | The legacy record's @spec:@ field, when available.-    adSpec :: !(Maybe Text)+    spec :: !(Maybe Text)   }   deriving stock (Eq, Show)  instance ToJSON AdoptedRow where   toJSON row =     object $-      ["path" .= T.pack (adPath row), "evidence" .= adEvidence row]-        <> ["source" .= source | Just source <- [adSource row]]-        <> ["spec" .= specPath | Just specPath <- [adSpec row]]+      ["path" .= T.pack ((.path) row), "evidence" .= (.evidence) row]+        <> ["source" .= source | Just source <- [(.source) row]]+        <> ["spec" .= specPath | Just specPath <- [(.spec) row]]  instance FromJSON AdoptedRow where   parseJSON = withObject "AdoptedRow" $ \fields -> do@@ -180,41 +180,41 @@     specPath <- fields .:? "spec"     pure       AdoptedRow-        { adPath = T.unpack (path :: Text),-          adEvidence = evidence,-          adSource = source,-          adSpec = specPath+        { path = T.unpack (path :: Text),+          evidence = evidence,+          source = source,+          spec = specPath         }  -- | Everything one successful whole-workspace scaffold produced. data WorkspaceRecord = WorkspaceRecord   { -- | The manifest's @service@ name: the workspace's durable identity.-    wrService :: !Text,+    service :: !Text,     -- | The manifest's __file name__, not a path. Members are relative to its     --     directory, so the directory is wherever the manifest currently sits;     --     recording only the name keeps the record independent of the invoking     --     working directory, which is what makes byte-identical output provable.-    wrManifest :: !Text,-    wrContext :: !Text,-    wrModuleRoot :: !Text,-    wrLayout :: !Text,+    manifest :: !Text,+    context :: !Text,+    moduleRoot :: !Text,+    layout :: !Text,     -- | Canonically ordered manifest-relative member paths.-    wrMembers :: ![FilePath],-    wrSourceLanguages :: ![WorkspaceSourceLanguageRow],-    wrLanguageContract :: !EffectiveLanguageContract,-    wrNamingEdition :: !GeneratedHaskellNamingEdition,-    wrModules :: ![WorkspaceModuleRow],-    wrMappings :: ![MappingIdentity],-    wrIdDomains :: ![Text],-    wrNominalEqualities :: ![Text],-    wrBindingObligations :: ![BindingHole],-    wrBehaviorRequirements :: ![BehaviorRecordRow],-    wrProjectionCatalogFacts :: ![Text],-    wrQueryContractBaseline :: !Bool,-    wrQueryContracts :: ![QueryContractIdentity],-    wrRouterSelections :: ![RouterSelectionSnapshot],-    wrAdopted :: ![AdoptedRow],-    wrSemanticImpact :: !(Maybe SemanticImpactSnapshot)+    members :: ![FilePath],+    sourceLanguages :: ![WorkspaceSourceLanguageRow],+    languageContract :: !EffectiveLanguageContract,+    namingEdition :: !GeneratedHaskellNamingEdition,+    modules :: ![WorkspaceModuleRow],+    mappings :: ![MappingIdentity],+    idDomains :: ![Text],+    nominalEqualities :: ![Text],+    bindingObligations :: ![BindingHole],+    requirements :: ![BehaviorRecordRow],+    projectionCatalogFacts :: ![Text],+    queryContractBaseline :: !Bool,+    queryContracts :: ![QueryContractIdentity],+    routerSelections :: ![RouterSelectionSnapshot],+    adopted :: ![AdoptedRow],+    semanticImpact :: !(Maybe SemanticImpactSnapshot)   }   deriving stock (Eq, Show) @@ -225,30 +225,30 @@ renderWorkspaceRecord record =   T.unlines $     [ workspaceRecordHeader,-      "service: " <> wrService record,-      "manifest: " <> wrManifest record,-      "context: " <> wrContext record,+      "service: " <> (.service) record,+      "manifest: " <> (.manifest) record,+      "context: " <> (.context) record,       "module-root: " <> rootLabel,-      "layout: " <> wrLayout record,-      "naming-edition " <> renderGeneratedHaskellNamingEdition (wrNamingEdition record)+      "layout: " <> (.layout) record,+      "naming-edition " <> renderGeneratedHaskellNamingEdition ((.namingEdition) record)     ]-      <> ["member " <> T.pack path | path <- wrMembers record]-      <> ["source-language " <> encodeRow row | row <- wrSourceLanguages record]-      <> ["semantic-contract " <> encodeRow (wrLanguageContract record)]-      <> ["module " <> encodeRow row | row <- wrModules record]-      <> [mappingRowPrefix mapping <> encodeRow mapping | mapping <- wrMappings record]-      <> ["id-domain " <> identity | identity <- wrIdDomains record]-      <> ["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]+      <> ["member " <> T.pack path | path <- (.members) record]+      <> ["source-language " <> encodeRow row | row <- (.sourceLanguages) record]+      <> ["semantic-contract " <> encodeRow ((.languageContract) record)]+      <> ["module " <> encodeRow row | row <- (.modules) record]+      <> [mappingRowPrefix mapping <> encodeRow mapping | mapping <- (.mappings) record]+      <> ["id-domain " <> identity | identity <- (.idDomains) record]+      <> ["nominal-equality " <> identity | identity <- (.nominalEqualities) record]+      <> ["binding " <> encodeRow obligation | obligation <- (.bindingObligations) record]+      <> ["behavior " <> encodeRow requirement | requirement <- (.requirements) record]+      <> ["projection-catalog-fact " <> fact | fact <- (.projectionCatalogFacts) record]+      <> ["query-contract-baseline v1" | (.queryContractBaseline) record]+      <> ["query-contract " <> encodeRow identity | identity <- (.queryContracts) record]+      <> ["router-selection " <> encodeRow selection | selection <- (.routerSelections) record]+      <> ["semantic-impact " <> encodeRow snapshot | Just snapshot <- [(.semanticImpact) record]]+      <> ["adopted " <> encodeRow adopted | adopted <- (.adopted) record]   where-    rootLabel = if T.null (wrModuleRoot record) then "(none)" else wrModuleRoot record+    rootLabel = if T.null ((.moduleRoot) record) then "(none)" else (.moduleRoot) record  encodeRow :: (ToJSON a) => a -> Text encodeRow = Text.decodeUtf8 . BL.toStrict . Aeson.encode@@ -277,49 +277,49 @@         let idDomains = [identity | row <- rows, Just identity <- [T.stripPrefix "id-domain " row]]         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)+        requirements <- 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)+        adopted <- (traverse (decodeRow "adopted ") (rowsWith "adopted " rows) :: Maybe [AdoptedRow])         checkedAdopted <- traverse checkedAdoption adopted         if hasDuplicates members-          || hasDuplicates (map wrmPath checkedModules)-          || hasDuplicates (map mappingSpecName mappings)+          || hasDuplicates (map (.path) checkedModules)+          || hasDuplicates (map (.specName) mappings)           || hasDuplicates idDomains           || hasDuplicates nominalEqualities           || hasDuplicates (map bindingKey obligations)-          || hasDuplicates (map behaviorRecordKey behaviorRequirements)+          || hasDuplicates (map (.key) requirements)           || hasDuplicates catalogFacts           || hasDuplicates (map queryContractIdentityKey queryContracts)-          || hasDuplicates (map selectionRouter routerSelections)+          || hasDuplicates (map (.router) routerSelections)           then Nothing           else             pure               WorkspaceRecord-                { wrService = service,-                  wrManifest = manifest,-                  wrContext = context,-                  wrModuleRoot = if rootLabel == "(none)" then "" else rootLabel,-                  wrLayout = layout,-                  wrMembers = members,-                  wrSourceLanguages = sourceLanguages,-                  wrLanguageContract = languageContract,-                  wrNamingEdition = namingEdition,-                  wrModules = checkedModules,-                  wrMappings = mappings,-                  wrIdDomains = idDomains,-                  wrNominalEqualities = nominalEqualities,-                  wrBindingObligations = obligations,-                  wrBehaviorRequirements = behaviorRequirements,-                  wrProjectionCatalogFacts = catalogFacts,-                  wrQueryContractBaseline = queryContractBaseline,-                  wrQueryContracts = queryContracts,-                  wrRouterSelections = routerSelections,-                  wrAdopted = checkedAdopted,-                  wrSemanticImpact = semanticImpact+                { service = service,+                  manifest = manifest,+                  context = context,+                  moduleRoot = if rootLabel == "(none)" then "" else rootLabel,+                  layout = layout,+                  members = members,+                  sourceLanguages = sourceLanguages,+                  languageContract = languageContract,+                  namingEdition = namingEdition,+                  modules = checkedModules,+                  mappings = mappings,+                  idDomains = idDomains,+                  nominalEqualities = nominalEqualities,+                  bindingObligations = obligations,+                  requirements = requirements,+                  projectionCatalogFacts = catalogFacts,+                  queryContractBaseline = queryContractBaseline,+                  queryContracts = queryContracts,+                  routerSelections = routerSelections,+                  adopted = checkedAdopted,+                  semanticImpact = semanticImpact                 }   _ -> Nothing   where@@ -330,23 +330,37 @@     decodeRow prefix row = do       payload <- T.stripPrefix prefix row       Aeson.decodeStrict' (Text.encodeUtf8 payload)+    checkedModule :: WorkspaceModuleRow -> Maybe WorkspaceModuleRow     checkedModule row = do-      path <- safePath (T.pack (wrmPath row))-      owner <- traverse (safePath . T.pack) (wrmOwner row)-      pure row {wrmPath = path, wrmOwner = owner}+      path <- safePath (T.pack ((.path) row))+      owner <- traverse (safePath . T.pack) ((.owner) row)+      pure+        WorkspaceModuleRow+          { kind = (.kind) row,+            path = path,+            owner = owner,+            role = (.role) row+          }+    checkedAdoption :: AdoptedRow -> Maybe AdoptedRow     checkedAdoption row = do-      path <- safePath (T.pack (adPath row))-      pure row {adPath = path}+      path <- safePath (T.pack ((.path) row))+      pure+        AdoptedRow+          { path = path,+            evidence = (.evidence) row,+            source = (.source) row,+            spec = (.spec) row+          }     parseSourceLanguages members rows = case rowsWith "source-language " rows of       [] -> Just [WorkspaceSourceLanguageRow path LegacyUnversioned | path <- members]       sourceRows -> do         decoded <- traverse (decodeRow "source-language ") sourceRows         checked <- traverse checkedSourceLanguage decoded-        if hasDuplicates (map wrslPath checked) || sort (map wrslPath checked) /= sort members+        if hasDuplicates (map (.path) checked) || sort (map (.path) checked) /= sort members           then Nothing           else Just checked     parseLanguageContract sourceLanguages rows = do-      let inferred = nub [effectiveLanguageContract (wrslSourceLanguage row) | row <- sourceLanguages]+      let inferred = nub [effectiveLanguageContract ((.sourceLanguage) row) | row <- sourceLanguages]       common <- case inferred of         [contract] -> Just contract         [] -> Just (effectiveLanguageContract LegacyUnversioned)@@ -369,9 +383,14 @@       [] -> Just False       ["query-contract-baseline v1"] -> Just True       _ -> Nothing+    checkedSourceLanguage :: WorkspaceSourceLanguageRow -> Maybe WorkspaceSourceLanguageRow     checkedSourceLanguage row = do-      path <- safePath (T.pack (wrslPath row))-      pure row {wrslPath = path}+      path <- safePath (T.pack ((.path) row))+      pure+        WorkspaceSourceLanguageRow+          { path = path,+            sourceLanguage = (.sourceLanguage) row+          }     safePath raw =       let path = T.unpack raw        in if null path || isAbsolute path || ".." `elem` splitDirectories path@@ -380,11 +399,11 @@     hasDuplicates :: (Eq a) => [a] -> Bool     hasDuplicates values = length values /= length (nub values)     bindingKey hole =-      ( holeMappedName hole,-        holeModule hole,-        holeSymbol hole,-        holeKind hole,-        holePath hole+      ( (.mappedName) hole,+        (.moduleName) hole,+        (.symbol) hole,+        (.kind) hole,+        (.path) hole       )  -- | @keiro-dsl-ledger.workspace.\<service\>.txt@ — the machine-owned workspace

src/Keiro/Dsl/WorkspaceScaffold.hs view

@@ -46,6 +46,8 @@     WorkspaceScaffoldReport (..),     executeWorkspaceScaffold,     executeWorkspaceScaffoldWithNameMigrations,+    executeWorkspaceScaffoldWithMigrations,+    readWorkspaceRecord,     renderWorkspaceScaffoldReport,   ) where@@ -92,25 +94,31 @@ import Keiro.Dsl.ScaffoldRecord (projectionCatalogFactsForService) import Keiro.Dsl.ScaffoldRun   ( GeneratedArtifactImpact,+    LedgerRead (..),     MappingDrift (..),+    PreparedGeneratedHaskellEditionMigration,     PreparedSourceMove,     QueryContractMigration (..),     Refusal (..),     StaleGeneratedEvidence (..),     StaleModule (..),     WriteDisposition (..),+    applyPreparedGeneratedHaskellEditionMigration,     applyPreparedSourceMoves,     behaviorDrift,     checkedSemanticImpactSnapshot,     constraintPlanForService,     generatedArtifactImpact,     inertNodesOf,+    ledgerToMaybe,     mappingDrift,     missingGeneratedBanners,     newBindingObligations,     obligationKindLabel,     planningGatePipeline,+    preflightGeneratedHaskellEditionMigration,     preflightSourceMoves,+    preparedGeneratedHaskellEditionImpact,     preparedSourceMove,     queryContractMigrations,     renderGeneratedArtifactImpact,@@ -119,12 +127,14 @@     renderSemanticImpactReport,     semanticImpactForMappingDrift,     staleAgainst,+    withGeneratedHaskellEditionSourceMoves,     withSidecarMovesApplied,   ) 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.SidecarNames (legacyWorkspaceRecordFileName) import Keiro.Dsl.StructuralConformance (structuralConformanceModule) import Keiro.Dsl.Validate (nodeIdentity) import Keiro.Dsl.Workspace (WorkspaceMember (..), WorkspaceSpec (..), checkedWorkspace, declarationOwner, nodeOwner)@@ -154,16 +164,16 @@ -- | The complete, refusal-free write set for one whole-workspace scaffold, with -- each module's producing member attached. data WorkspacePlan = WorkspacePlan-  { wpWorkspace :: !WorkspaceSpec,-    wpCheckedService :: !CheckedService,-    wpContext :: !Context,-    wpRuntimePackage :: !(Maybe RuntimePackageName),-    wpConformancePackage :: !(Maybe ConformancePackagePlan),+  { workspace :: !WorkspaceSpec,+    checkedService :: !CheckedService,+    context :: !Context,+    runtimePackage :: !(Maybe RuntimePackageName),+    conformancePackage :: !(Maybe ConformancePackagePlan),     -- | The one golden-payload root for the whole workspace. Carried here so     --     execution can refuse a member-adjacent fixture the root lacks before it     --     writes anything.-    wpGoldenRoot :: !FilePath,-    wpModules :: ![(ScaffoldModule, ModuleProvenance)]+    goldenRoot :: !FilePath,+    modules :: ![(ScaffoldModule, ModuleProvenance)]   }   deriving stock (Eq, Show) @@ -185,7 +195,7 @@   WorkspaceSpec ->   Either [Refusal] WorkspacePlan planWorkspaceScaffoldWithGoldens goldens goldenRoot ctx workspace =-  planWorkspaceScaffoldWithRuntimePackageAndGoldens goldens (wsRuntimePackage workspace) goldenRoot ctx workspace+  planWorkspaceScaffoldWithRuntimePackageAndGoldens goldens ((.runtimePackage) workspace) goldenRoot ctx workspace  planWorkspaceScaffoldWithRuntimePackageAndGoldens ::   [GoldenPayload] ->@@ -202,19 +212,19 @@     plannedPackage <- either (Left . map ConformancePackageRefusal) Right packagePlan     Right       WorkspacePlan-        { wpWorkspace = workspace,-          wpCheckedService = service,-          wpContext = ctx,-          wpRuntimePackage = runtimePackage,-          wpConformancePackage = plannedPackage,-          wpGoldenRoot = goldenRoot,-          wpModules = tagged+        { workspace = workspace,+          checkedService = service,+          context = ctx,+          runtimePackage = runtimePackage,+          conformancePackage = plannedPackage,+          goldenRoot = goldenRoot,+          modules = tagged         }   where     service = checkedWorkspace workspace     sourceEntries = do       requirements <- either (Left . pure . BehaviorRefusal) Right (deriveBehaviorRequirementsForService service)-      either (Left . pure . BehaviorSourceRefusal) Right (BehaviorSource.planBehaviorSourceMap requirements (wsSourceIndex workspace))+      either (Left . pure . BehaviorSourceRefusal) Right (BehaviorSource.planBehaviorSourceMap requirements ((.sourceIndex) workspace))     taggedModules = do       entries <- sourceEntries       either (Left . pure . DuplicateConformanceFactKeys) Right (workspaceModules goldens runtimePackage entries ctx workspace service)@@ -227,7 +237,7 @@       Right tagged -> Right (map fst tagged)     packagePlan =       traverse-        (\packageName -> planConformancePackage (WorkspaceConformanceService (wsService workspace)) packageName (serviceConformanceModuleName ctx) service)+        (\packageName -> planConformancePackage (WorkspaceConformanceService ((.service) workspace)) packageName (serviceConformanceModuleName ctx) service)         runtimePackage     packageGate = case packagePlan of       Left failures -> Left (map ConformancePackageRefusal failures)@@ -258,12 +268,12 @@       <> [attributedStamped ContextLevel m | m <- scaffoldProjectionCatalogForService ctx service]       <> concat         [ map (attributedStamped (nodeProvenance node)) (emittersFor node)-        | node <- specNodes merged+        | node <- (.nodes) merged         ]       <> facade   where     merged = checkedSpec service-    ownership = wsOwnership workspace+    ownership = (.ownership) workspace     stamp = stampGeneratedModule (checkedLanguageContract service)     attributedStamped provenance moduleValue =       let (annotated, attribution) = attributed provenance moduleValue@@ -312,7 +322,13 @@     -- what keeps it identical to the single-file path down to this field.     attributed provenance m = (annotate provenance m, provenance)     annotate (MemberOwned path) m-      | length (wsMembers workspace) > 1 = m {origin = T.pack path <> ": " <> origin m}+      | length workspace.members > 1 =+          ScaffoldModule+            { path = m.path,+              text = m.text,+              kind = m.kind,+              origin = T.pack path <> ": " <> m.origin+            }     annotate _ m = m  --------------------------------------------------------------------------------@@ -334,13 +350,13 @@ -- diagnostic at all. goldenRootDivergence :: FilePath -> WorkspaceSpec -> IO [Refusal] goldenRootDivergence workspaceRoot workspace = do-  stranded <- concat <$> traverse strandedFor (wsMembers workspace)+  stranded <- concat <$> traverse strandedFor ((.members) workspace)   pure [GoldenRootDivergence workspaceRoot stranded | not (null stranded)]   where-    manifestDir = takeDirectory (wsManifestPath workspace)-    strandedFor member = concat <$> traverse (check member) (upcastFixtures (wmSpec member))+    manifestDir = takeDirectory ((.manifestPath) workspace)+    strandedFor member = concat <$> traverse (check member) (upcastFixtures ((.spec) member))     check member relative = do-      let memberRoot = manifestDir </> takeDirectory (wmPath member) </> "golden-payloads"+      let memberRoot = manifestDir </> takeDirectory ((.path) member) </> "golden-payloads"       besideMember <- firstExisting memberRoot relative       case besideMember of         Nothing -> pure []@@ -362,13 +378,13 @@ -- spec's declared upcasters would load, in spec order. upcastFixtures :: Spec -> [FilePath] upcastFixtures spec =-  [ T.unpack (specContext spec) </> T.unpack (aggName aggregate) </> fixtureName event sourceVersion-  | NAggregate aggregate <- specNodes spec,-    event <- aggEvents aggregate,-    Just (sourceVersion, _) <- [evUpcastFrom event]+  [ T.unpack ((.context) spec) </> T.unpack ((.name) aggregate) </> fixtureName event sourceVersion+  | NAggregate aggregate <- (.nodes) spec,+    event <- (.events) aggregate,+    Just (sourceVersion, _) <- [(.upcastFrom) event]   ]   where-    fixtureName event sourceVersion = T.unpack (evName event) <> ".v" <> show sourceVersion <> ".json"+    fixtureName event sourceVersion = T.unpack ((.name) event) <> ".v" <> show sourceVersion <> ".json"  -------------------------------------------------------------------------------- -- Execution@@ -382,58 +398,58 @@ -- what stops "I moved this aggregate to another file" from looking like "another -- spec's leftovers". Whole-workspace diffing must classify it identically. data OwnershipMove = OwnershipMove-  { omPath :: !FilePath,-    omPrevious :: !(Maybe FilePath),-    omCurrent :: !(Maybe FilePath)+  { path :: !FilePath,+    previous :: !(Maybe FilePath),+    current :: !(Maybe FilePath)   }   deriving stock (Eq, Show)  data WorkspaceSourceLanguageDrift = WorkspaceSourceLanguageDrift-  { wsldPath :: !FilePath,-    wsldPrevious :: !SourceLanguage,-    wsldCurrent :: !SourceLanguage+  { path :: !FilePath,+    previous :: !SourceLanguage,+    current :: !SourceLanguage   }   deriving stock (Eq, Show)  -- | What one successful whole-workspace scaffold did. data WorkspaceScaffoldReport = WorkspaceScaffoldReport-  { wsrManifestPath :: !FilePath,-    wsrOutDir :: !FilePath,-    wsrService :: !Text,-    wsrContext :: !Context,-    wsrMembers :: ![FilePath],-    wsrDispositions :: ![(ScaffoldModule, ModuleProvenance, WriteDisposition)],-    wsrBuildManifestPath :: !FilePath,-    wsrRecordPath :: !FilePath,+  { manifestPath :: !FilePath,+    outDir :: !FilePath,+    service :: !Text,+    context :: !Context,+    members :: ![FilePath],+    dispositions :: ![(ScaffoldModule, ModuleProvenance, WriteDisposition)],+    buildManifestPath :: !FilePath,+    recordPath :: !FilePath,     -- | The manifest file name the previous workspace record was written from,     --     when it differs from this run's.-    wsrPreviousManifest :: !(Maybe Text),-    wsrStale :: ![StaleModule],-    wsrOwnershipMoves :: ![OwnershipMove],-    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],-    wsrRemovedBehavior :: ![BehaviorRecordRow],-    wsrObsoleteOutputHooks :: ![(Text, Text)],+    previousManifest :: !(Maybe Text),+    stale :: ![StaleModule],+    ownershipMoves :: ![OwnershipMove],+    consumerPlan :: !ConsumerPlan,+    constraintPlan :: ![Text],+    mappingDrift :: ![MappingDrift],+    queryContractBaselineUnavailable :: !Bool,+    queryContractDrift :: ![QueryContractDrift],+    queryContractMigrations :: ![QueryContractMigration],+    semanticImpact :: !SemanticImpactReport,+    routerSelectionDrift :: ![RouterSelectionDrift],+    projectionMappedImpact :: !(Maybe ProjectionMappedImpact),+    generatedArtifactImpact :: ![GeneratedArtifactImpact],+    sourceLanguageDrift :: ![WorkspaceSourceLanguageDrift],+    newHoles :: ![BindingHole],+    addedBehavior :: ![BehaviorRecordRow],+    removedBehavior :: ![BehaviorRecordRow],+    obsoleteOutputHooks :: ![(Text, Text)],     -- | Declarations in the merged service that produce no generated module.     --     Same content, same rendering as the single-spec     --     'Keiro.Dsl.ScaffoldRun.reportInertNodes'.-    wsrInertNodes :: ![(Text, Text)],-    wsrConformancePackage :: !(Maybe ConformancePackageReport),-    wsrNameMoves :: ![SourceMove],-    wsrSidecarMoves :: ![SidecarMove],+    inertNodes :: ![(Text, Text)],+    conformancePackage :: !(Maybe ConformancePackageReport),+    nameMoves :: ![SourceMove],+    sidecarMoves :: ![SidecarMove],     -- | Present only on the run that adopted pre-workspace scaffold output.-    wsrMigration :: !(Maybe MigrationReport)+    migration :: !(Maybe MigrationReport)   }   deriving stock (Eq, Show) @@ -461,40 +477,83 @@   executeWorkspaceScaffoldWithNameMigrations out forceGeneratedOverwrite False  executeWorkspaceScaffoldWithNameMigrations :: FilePath -> Bool -> Bool -> WorkspacePlan -> IO (Either [Refusal] WorkspaceScaffoldReport)-executeWorkspaceScaffoldWithNameMigrations out forceGeneratedOverwrite applyNameMigrations plan = do-  sidecarResult <- planSidecarMigrations out (WorkspaceSidecars (wsService (wpWorkspace plan))) (wpConformancePackage plan)+executeWorkspaceScaffoldWithNameMigrations out forceGeneratedOverwrite applyNameMigrations =+  executeWorkspaceScaffoldWithMigrations out forceGeneratedOverwrite applyNameMigrations False++executeWorkspaceScaffoldWithMigrations :: FilePath -> Bool -> Bool -> Bool -> WorkspacePlan -> IO (Either [Refusal] WorkspaceScaffoldReport)+executeWorkspaceScaffoldWithMigrations out forceGeneratedOverwrite applyNameMigrations applyGeneratedHaskellEdition plan = do+  sidecarResult <- planSidecarMigrations out (WorkspaceSidecars service) ((.conformancePackage) plan)   case sidecarResult of     Left reasons -> pure (Left [SidecarMigrationRefusal reasons])-    Right preparedSidecars-      | not (null preparedSidecars) && not applyNameMigrations ->-          pure (Left [SidecarMigrationRequired (map preparedSidecarMove preparedSidecars)])-      | otherwise -> do-          applyPreparedSidecarMoves out preparedSidecars-          -- Past this point the renames are on disk, so a later refusal's-          -- "nothing was written" needs qualifying. Mirrors the single-spec path.-          let sidecarMoves = map preparedSidecarMove preparedSidecars-              noteApplied = withSidecarMovesApplied sidecarMoves-          previous <- readWorkspaceRecord recordPath-          result <- case planWorkspaceSourceMoves previous modules of-            Left moveErrors -> pure (Left [NameMigrationRefusal [T.pack (show moveError) | moveError <- NE.toList moveErrors]])-            Right moves -> do-              preparedMoves <- preflightSourceMoves out moves-              case preparedMoves of-                Left moveErrors -> pure (Left [NameMigrationRefusal moveErrors])-                Right prepared-                  | not (null prepared) && not applyNameMigrations -> pure (Left [NameMigrationRequired (map preparedSourceMove prepared)])-                  | otherwise ->-                      executeWorkspaceScaffoldBase-                        out-                        forceGeneratedOverwrite-                        sidecarMoves-                        (map preparedSourceMove prepared)-                        prepared-                        plan-          pure (either (Left . noteApplied) Right result)+    Right preparedSidecars -> do+      previousBefore <- readMigrationRecord+      editionBefore <- preflightEdition previousBefore+      case editionBefore of+        Left refusals -> pure (Left refusals)+        Right preparedBefore+          | not (null preparedSidecars) && not applyNameMigrations ->+              pure . Left $+                [SidecarMigrationRequired (map preparedSidecarMove preparedSidecars)]+                  <> [GeneratedHaskellEditionRequired (preparedGeneratedHaskellEditionImpact prepared) | Just prepared <- [preparedBefore]]+          | otherwise -> do+              applyPreparedSidecarMoves out preparedSidecars+              -- Past this point the renames are on disk, so a later+              -- refusal's "nothing was written" needs qualifying. Mirrors the single-spec path.+              let sidecarMoves = map preparedSidecarMove preparedSidecars+                  noteApplied = withSidecarMovesApplied sidecarMoves+              previousAfter <- if null preparedSidecars then pure previousBefore else readWorkspaceRecord recordPath+              editionAfter <- preflightEdition previousAfter+              result <- case editionAfter of+                Left refusals -> pure (Left refusals)+                Right preparedEdition -> case planWorkspaceSourceMoves (ledgerToMaybe previousAfter) modules of+                  Left moveErrors -> pure (Left [NameMigrationRefusal [T.pack (show moveError) | moveError <- NE.toList moveErrors]])+                  Right moves -> do+                    preparedMoves <- preflightSourceMoves out moves+                    case preparedMoves of+                      Left moveErrors -> pure (Left [NameMigrationRefusal moveErrors])+                      Right prepared+                        | Just edition <- editionWithMoves,+                          (not (null prepared) || not (null sidecarMoves)),+                          not (applyNameMigrations && applyGeneratedHaskellEdition) ->+                            pure (Left [NameMigrationRequired sourceMoves, GeneratedHaskellEditionRequired (preparedGeneratedHaskellEditionImpact edition)])+                        | Just edition <- editionWithMoves,+                          not applyGeneratedHaskellEdition ->+                            pure (Left [GeneratedHaskellEditionRequired (preparedGeneratedHaskellEditionImpact edition)])+                        | not (null prepared) && not applyNameMigrations -> pure (Left [NameMigrationRequired sourceMoves])+                        | otherwise ->+                            executeWorkspaceScaffoldBase+                              out+                              forceGeneratedOverwrite+                              editionWithMoves+                              sidecarMoves+                              sourceMoves+                              prepared+                              plan+                        where+                          sourceMoves = map preparedSourceMove prepared+                          editionWithMoves = withGeneratedHaskellEditionSourceMoves sourceMoves preparedEdition+              pure (either (Left . noteApplied) Right result)   where-    modules = map fst (wpModules plan)-    recordPath = out </> workspaceRecordFileName (wsService (wpWorkspace plan))+    modules = map fst ((.modules) plan)+    service = (.service) ((.workspace) plan)+    recordPath = out </> workspaceRecordFileName service+    legacyRecordPath = out </> legacyWorkspaceRecordFileName service+    readMigrationRecord = do+      current <- readWorkspaceRecord recordPath+      case current of+        LedgerAbsent -> readWorkspaceRecord legacyRecordPath+        _ -> pure current+    preflightEdition previousRead = case previousRead of+      LedgerReadUnreadable path -> pure (Left [LedgerUnreadable path])+      _ -> do+        let previous = ledgerToMaybe previousRead+        prepared <-+          preflightGeneratedHaskellEditionMigration+            out+            ((.namingEdition) <$> previous)+            [((.kind) row, (.path) row) | row <- maybe [] (.modules) previous]+            [workspaceManifestFileName service, workspaceRecordFileName service]+        pure (either (Left . pure . GeneratedHaskellEditionRefusal) Right prepared)  planWorkspaceSourceMoves :: Maybe WorkspaceRecord -> [ScaffoldModule] -> Either (NE.NonEmpty SourceMoveError) [SourceMove] planWorkspaceSourceMoves previous current =@@ -502,60 +561,65 @@     Nothing -> Right []     Just record ->       planSourceMoves-        [(wrmRole row, wrmKind row, wrmPath row) | row <- wrModules record]+        [((.role) row, (.kind) row, (.path) row) | row <- (.modules) record]         current -executeWorkspaceScaffoldBase :: FilePath -> Bool -> [SidecarMove] -> [SourceMove] -> [PreparedSourceMove] -> WorkspacePlan -> IO (Either [Refusal] WorkspaceScaffoldReport)-executeWorkspaceScaffoldBase out forceGeneratedOverwrite sidecarMoves nameMoves preparedNameMoves plan = do-  stranded <- goldenRootDivergence (wpGoldenRoot plan) workspace+executeWorkspaceScaffoldBase :: FilePath -> Bool -> Maybe PreparedGeneratedHaskellEditionMigration -> [SidecarMove] -> [SourceMove] -> [PreparedSourceMove] -> WorkspacePlan -> IO (Either [Refusal] WorkspaceScaffoldReport)+executeWorkspaceScaffoldBase out forceGeneratedOverwrite editionMigration sidecarMoves nameMoves preparedNameMoves plan = do+  previousRead <- readWorkspaceRecord recordPath+  stranded <- goldenRootDivergence ((.goldenRoot) plan) workspace   bannerless <- if forceGeneratedOverwrite then pure [] else missingGeneratedBanners out modules-  packagePreflight <- case wpConformancePackage plan of+  packagePreflight <- case (.conformancePackage) plan of     Nothing -> pure (Right Nothing)     Just packagePlan -> fmap (fmap Just) (preflightConformancePackage out forceGeneratedOverwrite packagePlan)-  let packageRefusals = either (map ConformancePackageRefusal) (const []) packagePreflight-  case stranded <> [MissingGeneratedBanner bannerless | not (null bannerless)] <> packageRefusals of+  let previous = ledgerToMaybe previousRead+      ledgerRefusals = case previousRead of+        LedgerReadUnreadable path -> [LedgerUnreadable path]+        _ -> []+      packageRefusals = either (map ConformancePackageRefusal) (const []) packagePreflight+  case ledgerRefusals <> stranded <> [MissingGeneratedBanner bannerless | not (null bannerless)] <> packageRefusals of     refusals@(_ : _) -> pure (Left refusals)     [] -> do+      applyPreparedGeneratedHaskellEditionMigration out editionMigration       applyPreparedSourceMoves out preparedNameMoves-      previous <- readWorkspaceRecord recordPath-      stale <- staleAgainst out (map modulePath modules) (previousFiles previous)+      stale <- staleAgainst out (map (.path) 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 = 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+        Nothing -> adoptionReport out ((.context) workspace) service modules+      let currentPlan = consumerPlanForService ((.checkedService) plan)+          drift = maybe [] (mappingDrift ((.mappings) currentPlan) . (.mappings)) previous+          currentSemanticImpact = checkedSemanticImpactSnapshot ((.checkedService) plan)+          semanticReport = semanticImpactForMappingDrift (previous >>= (.semanticImpact)) currentSemanticImpact drift+          currentRouterSelections = routerSelectionSnapshots ((.checkedService) plan)+          selectionDrift = maybe [] (\record -> routerSelectionDrift ((.routerSelections) record) currentRouterSelections) previous           languageDrift = workspaceSourceLanguageDrift workspace previous-          currentQueryContracts = either (const []) id (queryContractIdentitiesForService (wpCheckedService plan))+          currentQueryContracts = either (const []) id (queryContractIdentitiesForService ((.checkedService) plan))           queryHistoryBaseline =             not (null currentQueryContracts)-              || maybe False wrQueryContractBaseline previous+              || maybe False (.queryContractBaseline) previous           queryBaselineUnavailable =             not (null currentQueryContracts)-              && maybe False (not . wrQueryContractBaseline) previous+              && maybe False (not . (.queryContractBaseline)) previous           queryDrift = case previous of-            Just record | wrQueryContractBaseline record -> queryContractDrift currentQueryContracts (wrQueryContracts record)+            Just record | (.queryContractBaseline) record -> queryContractDrift currentQueryContracts ((.queryContracts) record)             _ -> []-          currentObligations = either (const []) id (bindingHolesForService (wpCheckedService plan))-          newHoles = maybe [] (newBindingObligations currentObligations . wrBindingObligations) previous-          currentBehavior = workspaceBehaviorRows (wpCheckedService plan) workspace-          (addedBehavior, removedBehavior) = maybe (currentBehavior, []) (behaviorDrift currentBehavior . wrBehaviorRequirements) previous+          currentObligations = either (const []) id (bindingHolesForService ((.checkedService) plan))+          newHoles = maybe [] (newBindingObligations currentObligations . (.bindingObligations)) previous+          currentBehavior = workspaceBehaviorRows ((.checkedService) plan) workspace+          (addedBehavior, removedBehavior) = maybe (currentBehavior, []) (behaviorDrift currentBehavior . (.requirements)) previous       createDirectoryIfMissing True out-      dispositions <- traverse (writeWorkspaceModule out) (wpModules plan)-      TIO.writeFile buildManifestPath (renderManifestForServiceWithFacade facadeModule (T.pack manifestName) modules (wpCheckedService plan))+      dispositions <- traverse (writeWorkspaceModule out) ((.modules) plan)+      TIO.writeFile buildManifestPath (renderManifestForServiceWithFacade facadeModule (T.pack manifestName) modules ((.checkedService) plan))       -- Adoption provenance is durable history, not a one-run note: a       -- later run that adopts nothing carries the previous rows forward,       -- or the record would silently forget where its files came from.       let adopted = case migration of             Just report -> adoptedRows report-            Nothing -> maybe [] wrAdopted previous+            Nothing -> maybe [] (.adopted) previous       TIO.writeFile recordPath (renderWorkspaceRecord (currentWorkspaceRecord plan adopted queryHistoryBaseline currentSemanticImpact))       packageReport <- case packagePreflight of         Right prepared -> traverse executePreparedConformancePackage prepared@@ -566,61 +630,65 @@           TIO.writeFile             (out </> workspaceMigrationReportFileName service)             (T.unlines (renderMigrationReport report))-          markLegacyRecordSuperseded out (wsContext workspace) service+          markLegacyRecordSuperseded out ((.context) workspace) service       pure $         Right           WorkspaceScaffoldReport-            { wsrManifestPath = wsManifestPath workspace,-              wsrOutDir = out,-              wsrService = wsService workspace,-              wsrContext = wpContext plan,-              wsrMembers = map wmPath (wsMembers workspace),-              wsrDispositions = dispositions,-              wsrBuildManifestPath = buildManifestPath,-              wsrRecordPath = recordPath,-              wsrPreviousManifest = do+            { manifestPath = (.manifestPath) workspace,+              outDir = out,+              service = (.service) workspace,+              context = (.context) plan,+              members = map (.path) ((.members) workspace),+              dispositions = dispositions,+              buildManifestPath = buildManifestPath,+              recordPath = recordPath,+              previousManifest = do                 record <- previous-                if wrManifest record == T.pack manifestName then Nothing else Just (wrManifest record),-              wsrStale = stale,-              wsrOwnershipMoves = ownershipMoves previous (wpModules plan),-              wsrConsumerPlan = 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 = obsoleteGeneratedOutputHooksForService (wpCheckedService plan),-              wsrInertNodes = inertNodesOf merged,-              wsrConformancePackage = packageReport,-              wsrNameMoves = nameMoves,-              wsrSidecarMoves = sidecarMoves,-              wsrMigration = migration+                if (.manifest) record == T.pack manifestName then Nothing else Just ((.manifest) record),+              stale = stale,+              ownershipMoves = ownershipMoves previous ((.modules) plan),+              consumerPlan = currentPlan,+              constraintPlan = constraintPlanForService ((.checkedService) plan) currentPlan,+              mappingDrift = drift,+              queryContractBaselineUnavailable = queryBaselineUnavailable,+              queryContractDrift = queryDrift,+              queryContractMigrations = queryMigrations,+              semanticImpact = semanticReport,+              routerSelectionDrift = selectionDrift,+              projectionMappedImpact = projectionMappedImpactForService ((.checkedService) plan),+              generatedArtifactImpact = generatedArtifactImpact [(scaffoldModule, disposition) | (scaffoldModule, _, disposition) <- dispositions],+              sourceLanguageDrift = languageDrift,+              newHoles = newHoles,+              addedBehavior = addedBehavior,+              removedBehavior = removedBehavior,+              obsoleteOutputHooks = obsoleteGeneratedOutputHooksForService ((.checkedService) plan),+              inertNodes = inertNodesOf merged,+              conformancePackage = packageReport,+              nameMoves = nameMoves,+              sidecarMoves = sidecarMoves,+              migration = migration             }   where-    workspace = wpWorkspace plan-    merged = checkedSpec (wpCheckedService plan)-    modules = map fst (wpModules plan)-    service = wsService workspace-    manifestName = takeFileName (wsManifestPath workspace)+    workspace = (.workspace) plan+    merged = checkedSpec ((.checkedService) plan)+    modules = map fst ((.modules) plan)+    service = (.service) workspace+    manifestName = takeFileName ((.manifestPath) workspace)     recordPath = out </> workspaceRecordFileName service     buildManifestPath = out </> workspaceManifestFileName service-    facadeModule = case wpRuntimePackage plan of+    facadeModule = case (.runtimePackage) plan of       Nothing -> Nothing-      Just _ -> Just (serviceConformanceModuleName (wpContext plan))-    previousFiles previous = [(wrmKind row, wrmPath row) | row <- maybe [] wrModules previous]+      Just _ -> Just (serviceConformanceModuleName ((.context) plan))+    previousFiles previous = [((.kind) row, (.path) row) | row <- maybe [] (.modules) previous] -readWorkspaceRecord :: FilePath -> IO (Maybe WorkspaceRecord)+readWorkspaceRecord :: FilePath -> IO (LedgerRead WorkspaceRecord) readWorkspaceRecord path = do   exists <- doesFileExist path-  if exists then parseWorkspaceRecord <$> TIO.readFile path else pure Nothing+  if not exists+    then pure LedgerAbsent+    else do+      parsed <- parseWorkspaceRecord <$> TIO.readFile path+      pure (maybe (LedgerReadUnreadable path) LedgerParsed parsed)  -- | 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@@ -628,68 +696,68 @@ currentWorkspaceRecord :: WorkspacePlan -> [AdoptedRow] -> Bool -> SemanticImpactSnapshot -> WorkspaceRecord currentWorkspaceRecord plan adopted queryHistoryBaseline currentSemanticImpact =   WorkspaceRecord-    { wrService = wsService workspace,-      wrManifest = T.pack (takeFileName (wsManifestPath workspace)),-      wrContext = wsContext workspace,-      wrModuleRoot = moduleRoot ctx,-      wrLayout = layoutLabel ctx,-      wrMembers = map wmPath (wsMembers workspace),-      wrSourceLanguages =-        [ WorkspaceSourceLanguageRow (wmPath member) (wmSourceLanguage member)-        | member <- wsMembers workspace+    { service = (.service) workspace,+      manifest = T.pack (takeFileName ((.manifestPath) workspace)),+      context = (.context) workspace,+      moduleRoot = (.moduleRoot) ctx,+      layout = layoutLabel ctx,+      members = map (.path) ((.members) workspace),+      sourceLanguages =+        [ WorkspaceSourceLanguageRow ((.path) member) ((.sourceLanguage) member)+        | member <- (.members) workspace         ],-      wrLanguageContract = checkedLanguageContract (wpCheckedService plan),-      wrNamingEdition = currentGeneratedHaskellNamingEdition,-      wrModules =+      languageContract = checkedLanguageContract ((.checkedService) plan),+      namingEdition = currentGeneratedHaskellNamingEdition,+      modules =         [ WorkspaceModuleRow-            { wrmKind = kind m,-              wrmPath = modulePath m,-              wrmOwner = provenanceOwner provenance,-              wrmRole = Just (moduleRole m)+            { kind = (.kind) m,+              path = (.path) m,+              owner = provenanceOwner provenance,+              role = Just (moduleRole m)             }-        | (m, provenance) <- wpModules plan+        | (m, provenance) <- (.modules) plan         ],-      wrMappings = consumerMappings (consumerPlanForService checkedService),-      wrIdDomains = idDomainIdentitiesForService checkedService,-      wrNominalEqualities = nominalEqualityIdentitiesForService checkedService,-      wrBindingObligations = either (const []) id (bindingHolesForService checkedService),-      wrBehaviorRequirements = workspaceBehaviorRows checkedService workspace,-      wrProjectionCatalogFacts = projectionCatalogFactsForService checkedService,-      wrQueryContractBaseline = queryHistoryBaseline,-      wrQueryContracts = either (const []) id (queryContractIdentitiesForService checkedService),-      wrRouterSelections = routerSelectionSnapshots checkedService,-      wrAdopted = adopted,-      wrSemanticImpact = Just currentSemanticImpact+      mappings = (.mappings) (consumerPlanForService checkedService),+      idDomains = idDomainIdentitiesForService checkedService,+      nominalEqualities = nominalEqualityIdentitiesForService checkedService,+      bindingObligations = either (const []) id (bindingHolesForService checkedService),+      requirements = workspaceBehaviorRows checkedService workspace,+      projectionCatalogFacts = projectionCatalogFactsForService checkedService,+      queryContractBaseline = queryHistoryBaseline,+      queryContracts = either (const []) id (queryContractIdentitiesForService checkedService),+      routerSelections = routerSelectionSnapshots checkedService,+      adopted = adopted,+      semanticImpact = Just currentSemanticImpact     }   where-    workspace = wpWorkspace plan-    checkedService = wpCheckedService plan-    ctx = wpContext plan+    workspace = (.workspace) plan+    checkedService = (.checkedService) plan+    ctx = (.context) plan  workspaceBehaviorRows :: CheckedService -> WorkspaceSpec -> [BehaviorRecordRow] workspaceBehaviorRows service workspace =   either (const []) (behaviorRecordRows . map attribute) (deriveBehaviorRequirementsForService service)   where-    attribute = attributeBehaviorOwner (fmap fst . nodeOwner (wsOwnership workspace) "aggregate")+    attribute = attributeBehaviorOwner (fmap fst . nodeOwner ((.ownership) workspace) "aggregate")  workspaceSourceLanguageDrift :: WorkspaceSpec -> Maybe WorkspaceRecord -> [WorkspaceSourceLanguageDrift] workspaceSourceLanguageDrift workspace previous =   [ WorkspaceSourceLanguageDrift path oldLanguage newLanguage-  | member <- wsMembers workspace,-    let path = wmPath member-        newLanguage = wmSourceLanguage member,+  | member <- (.members) workspace,+    let path = (.path) member+        newLanguage = (.sourceLanguage) member,     Just oldLanguage <- [Map.lookup path previousByPath],     oldLanguage /= newLanguage   ]   where     previousByPath =       Map.fromList-        [ (wrslPath row, wrslSourceLanguage row)-        | row <- maybe [] wrSourceLanguages previous+        [ ((.path) row, (.sourceLanguage) row)+        | row <- maybe [] (.sourceLanguages) previous         ]  layoutLabel :: Context -> Text-layoutLabel ctx = case placement ctx of GeneratedPrefix -> "prefixed"; CollocatedLeaf -> "collocated"+layoutLabel ctx = case (.placement) ctx of GeneratedPrefix -> "prefixed"; CollocatedLeaf -> "collocated"  -- | Paths this run still produces whose owning member changed. Computed against -- the previous record before stale detection, and never overlapping it: a moved@@ -697,16 +765,16 @@ ownershipMoves :: Maybe WorkspaceRecord -> [(ScaffoldModule, ModuleProvenance)] -> [OwnershipMove] ownershipMoves previous current =   [ OwnershipMove-      { omPath = modulePath m,-        omPrevious = wrmOwner row,-        omCurrent = provenanceOwner provenance+      { path = (.path) m,+        previous = (.owner) row,+        current = provenanceOwner provenance       }   | (m, provenance) <- current,-    Just row <- [Map.lookup (modulePath m) previousByPath],-    wrmOwner row /= provenanceOwner provenance+    Just row <- [Map.lookup ((.path) m) previousByPath],+    (.owner) row /= provenanceOwner provenance   ]   where-    previousByPath = Map.fromList [(wrmPath row, row) | row <- maybe [] wrModules previous]+    previousByPath = Map.fromList [((.path) row, row) | row <- maybe [] (.modules) previous]  -- | Write one module. Generated modules whose bytes already match are left -- alone and reported 'Unchanged'; hole modules keep the create-once rule. The@@ -717,23 +785,23 @@   (ScaffoldModule, ModuleProvenance) ->   IO (ScaffoldModule, ModuleProvenance, WriteDisposition) writeWorkspaceModule out (m, provenance) = do-  let path = out </> modulePath m+  let path = out </> (.path) m   exists <- doesFileExist path-  case kind m of+  case (.kind) m of     HoleStub       | exists -> pure (m, provenance, Skipped)       | otherwise -> write path Created     Generated       | exists -> do           existing <- TIO.readFile path-          if existing == moduleText m+          if existing == (.text) m             then pure (m, provenance, Unchanged)             else write path Overwritten       | otherwise -> write path Overwritten   where     write path disposition = do       createDirectoryIfMissing True (takeDirectory path)-      TIO.writeFile path (moduleText m)+      TIO.writeFile path ((.text) m)       pure (m, provenance, disposition)  -- | The report a successful whole-workspace scaffold prints, following the@@ -743,24 +811,24 @@ renderWorkspaceScaffoldReport :: WorkspaceScaffoldReport -> [Text] renderWorkspaceScaffoldReport report =   [ "workspace: "-      <> wsrService report+      <> (.service) report       <> " ("-      <> T.pack (wsrManifestPath report)+      <> T.pack ((.manifestPath) report)       <> ") -> "-      <> T.pack (wsrOutDir report)+      <> T.pack ((.outDir) report)       <> " (module-root="       <> rootLabel       <> ", layout="       <> layoutLabel ctx       <> ")",-    "members:  " <> T.intercalate ", " (map T.pack (wsrMembers report))+    "members:  " <> T.intercalate ", " (map T.pack ((.members) report))   ]     <> map moduleLine dispositions     <> [ "firewall: OK (" <> tshow generatedCount <> " generated modules scanned, 0 forbidden operators)",          harnessLine,          dependencyLine,-         "fragment: " <> T.pack (wsrBuildManifestPath report),-         "ledger:   " <> T.pack (wsrRecordPath report)+         "fragment: " <> T.pack ((.buildManifestPath) report),+         "ledger:   " <> T.pack ((.recordPath) report)        ]     <> previousManifestNote     <> migrationSection@@ -771,28 +839,28 @@     <> queryContractSection     <> queryContractMigrationSection     <> mappingDriftSection-    <> renderSemanticImpactReport (wsrSemanticImpact report)-    <> renderRouterSelectionDrift (wsrRouterSelectionDrift report)-    <> maybe [] renderProjectionMappedImpact (wsrProjectionMappedImpact report)-    <> renderGeneratedArtifactImpact (wsrSemanticImpact report) (wsrGeneratedArtifactImpact report)+    <> renderSemanticImpactReport ((.semanticImpact) report)+    <> renderRouterSelectionDrift ((.routerSelectionDrift) report)+    <> maybe [] renderProjectionMappedImpact ((.projectionMappedImpact) report)+    <> renderGeneratedArtifactImpact ((.semanticImpact) report) ((.generatedArtifactImpact) report)     <> sourceLanguageDriftSection     <> behaviorDriftSection     <> obsoleteOutputSection-    <> renderInertNodeSection (wsrInertNodes report)+    <> renderInertNodeSection ((.inertNodes) report)     <> ownershipSection     <> staleSection-    <> maybe [] renderConformancePackageReport (wsrConformancePackage report)+    <> maybe [] renderConformancePackageReport ((.conformancePackage) report)   where-    ctx = wsrContext report-    dispositions = wsrDispositions report-    rootLabel = if T.null (moduleRoot ctx) then "(none)" else moduleRoot ctx-    names = [moduleNameOf (modulePath m) | (m, _, _) <- dispositions]+    ctx = (.context) report+    dispositions = (.dispositions) report+    rootLabel = if T.null ((.moduleRoot) ctx) then "(none)" else (.moduleRoot) ctx+    names = [moduleNameOf ((.path) m) | (m, _, _) <- dispositions]     nameWidth = maximum (1 : map T.length names)     moduleLine (m, provenance, disposition) =       "  "-        <> kindTag (kind m)+        <> kindTag ((.kind) m)         <> "  "-        <> pad (moduleNameOf (modulePath m))+        <> pad (moduleNameOf ((.path) m))         <> "  "         <> dispositionTag disposition         <> "  "@@ -806,159 +874,159 @@     ownerTag ContextLevel = "(context-level)"     ownerTag (MemberOwned path) = T.pack path     pad name = name <> T.replicate (nameWidth - T.length name) " "-    generatedCount = length [() | (m, _, _) <- dispositions, kind m == Generated]+    generatedCount = length [() | (m, _, _) <- dispositions, (.kind) m == Generated]     harnesses =       sortOn         id-        [ moduleNameOf (modulePath m)+        [ moduleNameOf ((.path) m)         | (m, _, _) <- dispositions,-          any (`T.isSuffixOf` moduleNameOf (modulePath m)) [".Harness", ".ProcessHarness", ".WorkflowFacts"]+          any (`T.isSuffixOf` moduleNameOf ((.path) m)) [".Harness", ".ProcessHarness", ".WorkflowFacts"]         ]     harnessLine = case harnesses of       [] -> "harness:  (none emitted)"       _ -> "harness:  run `cabal test <your-component>` over " <> T.unwords harnesses     dependencyLine =       "dependency plan: consumer packages "-        <> renderBracketed (consumerPackages (wsrConsumerPlan report))+        <> renderBracketed ((.packages) ((.consumerPlan) report))         <> ", consumer modules "-        <> renderBracketed (consumerModules (wsrConsumerPlan report))-    previousManifestNote = case wsrPreviousManifest report of+        <> renderBracketed ((.modules) ((.consumerPlan) report))+    previousManifestNote = case (.previousManifest) report of       Just previous -> ["note: the previous workspace record was written from manifest " <> previous]       Nothing -> []-    migrationSection = maybe [] renderMigrationReport (wsrMigration report)-    sidecarMoveSection = case wsrSidecarMoves report of+    migrationSection = maybe [] renderMigrationReport ((.migration) report)+    sidecarMoveSection = case (.sidecarMoves) report of       [] -> []       moves ->         ["sidecar migration: applied (" <> tshow (length moves) <> " move(s))"]           <> map (("  " <>) . renderSidecarMove) moves-    nameMoveSection = case wsrNameMoves report of+    nameMoveSection = case (.nameMoves) report of       [] -> []       moves ->         ["name migration: applied (" <> tshow (length moves) <> " source move(s))"]           <> [ "  "-                 <> T.pack (moveOldPath move)+                 <> T.pack ((.oldPath) move)                  <> " -> "-                 <> T.pack (moveNewPath move)+                 <> T.pack ((.newPath) move)                  <> "  backup="-                 <> T.pack (moveBackupPath move)+                 <> T.pack ((.backupPath) move)              | move <- moves              ]-    constraintSection = case wsrConstraintPlan report of+    constraintSection = case (.constraintPlan) report of       [] -> []       constraints -> "constraint plan:" : map ("  " <>) constraints-    newHolesSection = case wsrNewHoles report of+    newHolesSection = case (.newHoles) report of       [] -> []       obligations ->         ["newly required holes since last scaffold: " <> tshow (length obligations)]           <> concatMap obligationLines obligations     obligationLines hole =-      [ "  " <> holeModule hole,-        "    " <> holeSignature hole <> " (" <> obligationKindLabel (holeKind hole) <> ")"+      [ "  " <> (.moduleName) hole,+        "    " <> (.signature) hole <> " (" <> obligationKindLabel ((.kind) hole) <> ")"       ]     queryContractSection =       [ "query contract history: baseline unavailable in the previous ledger; no legacy `()` API was inferred"-      | wsrQueryContractBaselineUnavailable report+      | (.queryContractBaselineUnavailable) report       ]-        <> case wsrQueryContractDrift report of+        <> case (.queryContractDrift) 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)+        "    previous: " <> maybe "(absent)" renderQueryIdentity ((.previous) drift),+        "    current:  " <> maybe "(absent)" renderQueryIdentity ((.current) drift)       ]       where-        (readModel, position) = qcdKey drift+        (readModel, position) = (.key) drift     renderQueryIdentity identity =-      qciTypeExpression identity+      (.typeExpression) identity         <> " mapped=["-        <> T.intercalate ", " (qciMappedDependencies identity)+        <> T.intercalate ", " ((.mappedDependencies) identity)         <> "]"     queryPositionLabel QueryInputConsumer = "input"     queryPositionLabel QueryResultConsumer = "result"-    queryContractMigrationSection = case wsrQueryContractMigrations report of+    queryContractMigrationSection = case (.queryContractMigrations) 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),+      [ "  " <> (.owner) migration,+        "    edit " <> T.pack ((.path) migration),         "    remove the local QueryInput/QueryResult type aliases",-        "    add " <> qcmRequiredImport migration+        "    add " <> (.requiredImport) migration       ]-    mappingDriftSection = case wsrMappingDrift report of+    mappingDriftSection = case (.mappingDrift) report of       [] -> []       drifts ->         ["mapping drift: " <> tshow (length drifts) <> " declaration(s) changed since the previous scaffold:"]           <> concatMap driftLines drifts     driftLines drift =-      [ "  " <> driftSpecName drift,-        "    previous: " <> maybe "(absent)" renderMappingIdentity (driftPrevious drift),-        "    current:  " <> maybe "(absent)" renderMappingIdentity (driftCurrent drift)+      [ "  " <> (.specName) drift,+        "    previous: " <> maybe "(absent)" renderMappingIdentity ((.previous) drift),+        "    current:  " <> maybe "(absent)" renderMappingIdentity ((.current) drift)       ]-    sourceLanguageDriftSection = case wsrSourceLanguageDrift report of+    sourceLanguageDriftSection = case (.sourceLanguageDrift) report of       [] -> []       drifts ->         ["source-language drift: " <> tshow (length drifts) <> " member(s) changed provenance (generated module bytes are semantic and unaffected):"]           <> [ "  "-                 <> T.pack (wsldPath drift)+                 <> T.pack ((.path) drift)                  <> "  "-                 <> workspaceSourceLanguageLabel (wsldPrevious drift)+                 <> workspaceSourceLanguageLabel ((.previous) drift)                  <> " -> "-                 <> workspaceSourceLanguageLabel (wsldCurrent drift)+                 <> workspaceSourceLanguageLabel ((.current) drift)              | drift <- drifts              ]     behaviorDriftSection =-      renderBehaviorRows "new behavior obligations" (wsrAddedBehavior report)-        <> renderBehaviorRows "removed behavior obligations (consumer rows become stale)" (wsrRemovedBehavior report)+      renderBehaviorRows "new behavior obligations" ((.addedBehavior) report)+        <> renderBehaviorRows "removed behavior obligations (consumer rows become stale)" ((.removedBehavior) report)     renderBehaviorRows _ [] = []     renderBehaviorRows label rows =       [label <> ": " <> tshow (length rows)] <> concatMap behaviorLines rows     behaviorLines row =       [ "  "-          <> behaviorRecordAggregate row+          <> (.aggregate) row           <> ":"-          <> behaviorRecordSource row+          <> (.source) row           <> " -- "-          <> behaviorRecordCommand row+          <> (.command) row           <> "  "-          <> unBehaviorKey (behaviorRecordKey row)-          <> maybe "" (("  owner=" <>) . T.pack) (behaviorRecordOwner row),-        "    Pending (BehaviorKey " <> tshow (unBehaviorKey (behaviorRecordKey row)) <> ")"+          <> (.unBehaviorKey) ((.key) row)+          <> maybe "" (("  owner=" <>) . T.pack) ((.owner) row),+        "    Pending (BehaviorKey " <> tshow ((.unBehaviorKey) ((.key) row)) <> ")"       ]-    obsoleteOutputSection = case wsrObsoleteOutputHooks report of+    obsoleteOutputSection = case (.obsoleteOutputHooks) report of       [] -> []       hooks ->         ["obsolete identity-copy output hooks (if still present, they are unused and may be removed):"]           <> ["  " <> aggregate <> ".Holes." <> hook | (aggregate, hook) <- hooks]-    ownershipSection = case wsrOwnershipMoves report of+    ownershipSection = case (.ownershipMoves) report of       [] -> []       moves ->         ["ownership moves: " <> tshow (length moves) <> " module(s) changed owning member (content unaffected):"]-          <> [ "  " <> T.pack (omPath move) <> "  " <> ownerName (omPrevious move) <> " -> " <> ownerName (omCurrent move)+          <> [ "  " <> T.pack ((.path) move) <> "  " <> ownerName ((.previous) move) <> " -> " <> ownerName ((.current) move)              | move <- moves              ]     ownerName = maybe "(context-level)" T.pack-    staleSection = case wsrStale report of+    staleSection = case (.stale) report of       [] -> []       stale ->         [ "stale: "             <> tshow (length stale)             <> " file(s) from a previous scaffold of workspace "-            <> wsrService report+            <> (.service) report             <> " are no longer produced by this workspace:"         ]           <> map staleLine stale           <> ["note: keiro-dsl never deletes files."]-    staleLine stale = case (staleKind stale, staleGeneratedEvidence stale) of+    staleLine stale = case ((.kind) stale, (.generatedEvidence) stale) of       (Generated, Just ExactGeneratedBannerPresent) ->-        "  generated " <> T.pack (stalePath stale) <> "  (exact generated banner present; verify unchanged bytes before deleting)"+        "  generated " <> T.pack ((.path) stale) <> "  (exact generated banner present; verify unchanged bytes before deleting)"       (Generated, _) ->-        "  generated " <> T.pack (stalePath stale) <> "  (exact generated banner missing; preserve and review)"-      (HoleStub, _) -> "  hole      " <> T.pack (stalePath stale) <> "  (hand-owned — preserve and review)"+        "  generated " <> T.pack ((.path) stale) <> "  (exact generated banner missing; preserve and review)"+      (HoleStub, _) -> "  hole      " <> T.pack ((.path) stale) <> "  (hand-owned — preserve and review)"  workspaceSourceLanguageLabel :: SourceLanguage -> Text workspaceSourceLanguageLabel sourceLanguage =

test/Keiro/Dsl/ConformanceBaseline.hs view

@@ -99,68 +99,68 @@ conformanceBaselineSpec = describe "conformance baseline" $ do   it "uses the registered stable and authoring languages plus explicit compatibility rows" $ do     baseline <- readBaseline-    baselineSchema baseline `shouldBe` "keiro-dsl/conformance-baseline/2"-    baselineStableLanguageVersion baseline+    (.baselineSchema) baseline `shouldBe` "keiro-dsl/conformance-baseline/2"+    (.baselineStableLanguageVersion) baseline       `shouldBe` languageVersionNumber currentStableLanguageVersion-    baselineAuthoringLanguageVersion baseline+    (.baselineAuthoringLanguageVersion) baseline       `shouldBe` languageVersionNumber currentAuthoringLanguageVersion     paths <- fixturePaths     observations <- forM paths $ \path -> (path,) <$> observeSource path-    baselinePrimaryLanguageVersions baseline `shouldContain` [languageVersionNumber currentStableLanguageVersion]-    baselinePrimaryLanguageVersions baseline `shouldContain` [languageVersionNumber currentAuthoringLanguageVersion]-    let primaryVersions = baselinePrimaryLanguageVersions baseline+    (.baselinePrimaryLanguageVersions) baseline `shouldContain` [languageVersionNumber currentStableLanguageVersion]+    (.baselinePrimaryLanguageVersions) baseline `shouldContain` [languageVersionNumber currentAuthoringLanguageVersion]+    let primaryVersions = (.baselinePrimaryLanguageVersions) baseline         nonStablePaths =           sort             [ path             | (path, observation) <- observations,-              sourceForm observation /= "declared"-                || maybe True (`notElem` primaryVersions) (sourceEffectiveVersion observation)+              (.sourceForm) observation /= "declared"+                || maybe True (`notElem` primaryVersions) ((.sourceEffectiveVersion) observation)             ]-        exceptionPaths = sort (map exceptionPath (baselineFixtureExceptions baseline))+        exceptionPaths = sort (map (.exceptionPath) ((.baselineFixtureExceptions) baseline))     (nonStablePaths \\ exceptionPaths)       `shouldBe` ([] :: [FilePath])     (exceptionPaths \\ nonStablePaths)       `shouldBe` ([] :: [FilePath])-    forM_ (baselineFixtureExceptions baseline) $ \exception -> do-      observation <- observeSource (exceptionPath exception)-      sourceForm observation `shouldBe` exceptionSourceForm exception-      sourceEffectiveVersion observation `shouldBe` exceptionEffectiveVersion exception-      exceptionRole exception+    forM_ ((.baselineFixtureExceptions) baseline) $ \exception -> do+      observation <- observeSource ((.exceptionPath) exception)+      (.sourceForm) observation `shouldBe` (.exceptionSourceForm) exception+      (.sourceEffectiveVersion) observation `shouldBe` (.exceptionEffectiveVersion) exception+      (.exceptionRole) exception         `shouldBe` "compatibility-proof"-      exceptionReason exception `shouldSatisfy` (not . T.null . T.strip)+      (.exceptionReason) exception `shouldSatisfy` (not . T.null . T.strip)    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-        manifestComponents = sort (map suiteComponent (baselineCompiledSuites baseline))+        manifestComponents = sort (map (.suiteComponent) ((.baselineCompiledSuites) baseline))     (cabalComponents \\ manifestComponents)       `shouldBe` ([] :: [Text])     (manifestComponents \\ cabalComponents)       `shouldBe` ([] :: [Text])-    forM_ (baselineCompiledSuites baseline) $ \suite -> do-      suiteRole suite+    forM_ ((.baselineCompiledSuites) baseline) $ \suite -> do+      (.suiteRole) suite         `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)+      (.suiteReason) suite `shouldSatisfy` (not . T.null . T.strip)+      directory <- resolveRepoDirectory ("keiro-dsl" </> (.suiteDirectory) suite)       doesDirectoryExist directory `shouldReturn` True-      case suiteLanguageVersion suite of+      case (.suiteLanguageVersion) suite of         Just primaryVersion -> do-          unless (suiteGeneration suite `elem` ["workspace", "skeletons"]) $ 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 primaryVersion+            (.sourceForm) observation `shouldBe` "declared"+            (.sourceResult) observation `shouldBe` "accept"+            (.sourceEffectiveVersion) observation `shouldBe` Just primaryVersion           banners <- generatedBannerLines directory           unless (not (null banners)) $-            expectationFailure (T.unpack (suiteComponent suite <> " has no generated banners"))+            expectationFailure (T.unpack ((.suiteComponent) suite <> " has no generated banners"))           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 primaryBanners)) $-            expectationFailure (T.unpack (suiteComponent suite <> " has no " <> T.pack (show primaryVersion) <> " generated banners"))+            expectationFailure (T.unpack ((.suiteComponent) suite <> " has no " <> T.pack (show primaryVersion) <> " generated banners"))           forM_ banners $ \(path, banner) ->             unless (expectedVersion `T.isInfixOf` banner || isVersionIndependentAuxiliary banner) $               expectationFailure (T.unpack (decorate path banner <> " (expected " <> expectedVersion <> ")"))@@ -178,7 +178,7 @@           unless (comparedActualPaths == comparedExpectedPaths) $             expectationFailure               ( T.unpack-                  ( suiteComponent suite+                  ( (.suiteComponent) suite                       <> " generated module inventory differs\nexpected: "                       <> T.pack (show comparedExpectedPaths)                       <> "\n but got: "@@ -188,23 +188,23 @@         Nothing -> pure ()  validateSuiteLanguageOwnership :: ConformanceBaseline -> CompiledSuite -> IO ()-validateSuiteLanguageOwnership baseline suite = case (suiteRole suite, suiteLanguageVersion suite) of+validateSuiteLanguageOwnership baseline suite = case ((.suiteRole) suite, (.suiteLanguageVersion) suite) of   ("stable-primary", Just rawVersion) -> do-    rawVersion `shouldBe` baselineStableLanguageVersion baseline+    rawVersion `shouldBe` (.baselineStableLanguageVersion) baseline     definition <- requireRegisteredDefinition suite rawVersion-    definitionSupport definition `shouldBe` Stable-    definitionMaturity definition `shouldBe` PublishedLanguage+    (.support) definition `shouldBe` Stable+    (.maturity) definition `shouldBe` PublishedLanguage   ("published-compatibility", Just rawVersion) -> do-    rawVersion `shouldNotBe` baselineStableLanguageVersion baseline+    rawVersion `shouldNotBe` (.baselineStableLanguageVersion) baseline     definition <- requireRegisteredDefinition suite rawVersion-    definitionSupport definition `shouldBe` CompatibilityOnly-    definitionMaturity definition `shouldBe` PublishedLanguage+    (.support) definition `shouldBe` CompatibilityOnly+    (.maturity) definition `shouldBe` PublishedLanguage   ("compatibility-proof", Nothing) -> pure ()   ("version-independent", Nothing) -> pure ()   (role, version) ->     expectationFailure       ( T.unpack-          ( suiteComponent suite+          ( (.suiteComponent) suite               <> " has invalid language ownership for role "               <> role               <> ": "@@ -219,7 +219,7 @@     Nothing -> do       expectationFailure         ( T.unpack-            ( suiteComponent suite+            ( (.suiteComponent) suite                 <> " owns unregistered language "                 <> T.pack (show rawVersion)             )@@ -227,7 +227,7 @@       fail "unregistered conformance language owner"  expectedStableGeneratedPaths :: CompiledSuite -> IO [FilePath]-expectedStableGeneratedPaths suite = case suiteGeneration suite of+expectedStableGeneratedPaths suite = case (.suiteGeneration) suite of   "source" -> do     source <- requiredSuiteSource suite     generatedPathsForSource source@@ -235,10 +235,10 @@     source <- requiredSuiteSource suite     sourceText <- readRepoText source     (service, sourceIndex) <- parseCheckedDocument source sourceText-    modules <- case planIndexedServiceScaffoldWithRuntimePackage (Just (RuntimePackageName "conformance-runtime")) sourceIndex (defaultContext (specContext (checkedSpec service))) service of+    scaffoldModules <- case planIndexedServiceScaffoldWithRuntimePackage (Just (RuntimePackageName "conformance-runtime")) sourceIndex (defaultContext ((checkedSpec service).context)) service of       Left refusals -> expectationFailure (show refusals) >> fail "stable configured source scaffold refusal"       Right value -> pure value-    pure (generatedPaths modules)+    pure (generatedPaths scaffoldModules)   "workspace" -> do     source <- requiredSuiteSource suite     resolved <- resolveRepoFile ("keiro-dsl" </> source)@@ -249,24 +249,25 @@     plan <- case planWorkspaceScaffold "goldens" (workspaceContext workspace) workspace of       Left refusals -> expectationFailure (show refusals) >> fail "stable workspace scaffold refusal"       Right value -> pure value-    pure (generatedPaths (map fst (wpModules plan)))+    pure (generatedPaths (map fst ((.modules) plan)))   "skeletons" -> fmap (sort . nub . concat) . forM skeletonModuleRoots $ \(skeletonKind, root) -> do     source <- case skeletonFor skeletonKind of       Left problem -> expectationFailure (T.unpack problem) >> fail "invalid stable skeleton"       Right value -> pure value     service <- parseCheckedSource ("new:" <> T.unpack skeletonKind) source-    let scaffoldContext = (defaultContext (specContext (checkedSpec service))) {moduleRoot = root}+    let baseContext = defaultContext (checkedSpec service).context+        scaffoldContext = Context {name = baseContext.name, moduleRoot = root, placement = baseContext.placement}     pure (generatedPaths (scaffoldServiceModules scaffoldContext service))-  other -> expectationFailure (T.unpack (suiteComponent suite <> " has invalid stable generation mode " <> other)) >> fail "invalid stable generation mode"+  other -> expectationFailure (T.unpack ((.suiteComponent) suite <> " has invalid stable generation mode " <> other)) >> fail "invalid stable generation mode"  generatedPathsForSource :: FilePath -> IO [FilePath] generatedPathsForSource path = do   source <- readRepoText path   (service, sourceIndex) <- parseCheckedDocument path source-  modules <- case planIndexedServiceScaffold sourceIndex (defaultContext (specContext (checkedSpec service))) service of+  scaffoldModules <- case planIndexedServiceScaffold sourceIndex (defaultContext ((checkedSpec service).context)) service of     Left refusals -> expectationFailure (show refusals) >> fail "stable source scaffold refusal"     Right value -> pure value-  pure (generatedPaths modules)+  pure (generatedPaths scaffoldModules)  parseCheckedSource :: FilePath -> Text -> IO CheckedService parseCheckedSource path source = case parseSource path source of@@ -276,23 +277,23 @@ 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} ->+  Right ParsedSourceDocument {parsedSource = parsed, sourceIndex = sourceIndex} ->     pure (checkedSource parsed, sourceIndex)  generatedPaths :: [ScaffoldModule] -> [FilePath]-generatedPaths = sort . map modulePath . filter ((== Generated) . kind)+generatedPaths = sort . map (.path) . filter ((== Generated) . (.kind))  requiredSuiteSource :: CompiledSuite -> IO FilePath-requiredSuiteSource suite = case suiteSource suite of-  Nothing -> expectationFailure (T.unpack (suiteComponent suite <> " has no source")) >> fail "missing stable source"+requiredSuiteSource suite = case (.suiteSource) suite of+  Nothing -> expectationFailure (T.unpack ((.suiteComponent) suite <> " has no source")) >> fail "missing stable source"   Just source -> pure source  workspaceContext :: WorkspaceSpec -> Context workspaceContext workspace =   Context-    { contextName = wsContext workspace,-      moduleRoot = maybe "" id (wsModuleRoot workspace),-      placement = maybe GeneratedPrefix id (wsLayout workspace)+    { name = workspace.context,+      moduleRoot = maybe "" id ((.moduleRoot) workspace),+      placement = maybe GeneratedPrefix id ((.layout) workspace)     }  skeletonModuleRoots :: [(Text, Text)]

test/Keiro/Dsl/FrontendCompatibility.hs view

@@ -65,13 +65,13 @@ instance ToJSON SourceExpectation where   toJSON row =     object-      [ "path" .= sourcePath row,-        "sourceForm" .= sourceForm row,-        "declaredVersion" .= sourceDeclaredVersion row,-        "effectiveVersion" .= sourceEffectiveVersion row,-        "result" .= sourceResult row,-        "failureClass" .= sourceFailureClass row,-        "diagnosticCode" .= sourceDiagnosticCode row+      [ "path" .= (.sourcePath) row,+        "sourceForm" .= (.sourceForm) row,+        "declaredVersion" .= (.sourceDeclaredVersion) row,+        "effectiveVersion" .= (.sourceEffectiveVersion) row,+        "result" .= (.sourceResult) row,+        "failureClass" .= (.sourceFailureClass) row,+        "diagnosticCode" .= (.sourceDiagnosticCode) row       ]  data WorkspaceExpectation = WorkspaceExpectation@@ -93,10 +93,10 @@ instance ToJSON WorkspaceExpectation where   toJSON row =     object-      [ "path" .= workspacePath row,-        "result" .= workspaceResult row,-        "failureClass" .= workspaceFailureClass row,-        "diagnosticCode" .= workspaceDiagnosticCode row+      [ "path" .= (.workspacePath) row,+        "result" .= (.workspaceResult) row,+        "failureClass" .= (.workspaceFailureClass) row,+        "diagnosticCode" .= (.workspaceDiagnosticCode) row       ]  data CompatibilityManifest = CompatibilityManifest@@ -120,47 +120,47 @@ instance ToJSON CompatibilityManifest where   toJSON manifest =     object-      [ "schema" .= manifestSchema manifest,-        "release" .= manifestRelease manifest,-        "entryPoints" .= manifestEntryPoints manifest,-        "sources" .= manifestSources manifest,-        "workspaces" .= manifestWorkspaces manifest+      [ "schema" .= (.manifestSchema) manifest,+        "release" .= (.manifestRelease) manifest,+        "entryPoints" .= (.manifestEntryPoints) manifest,+        "sources" .= (.manifestSources) manifest,+        "workspaces" .= (.manifestWorkspaces) manifest       ]  frontendCompatibilitySpec :: SpecWith () frontendCompatibilitySpec = describe "frontend 0.7 compatibility" $ do   it "decodes the released manifest and classifies every checked-in frontend fixture" $ do     manifest <- readManifest-    manifestSchema manifest `shouldBe` "keiro-dsl/frontend-compatibility/1"-    manifestRelease manifest `shouldBe` "0.7.0.0"-    manifestEntryPoints manifest `shouldBe` releasedFrontendEntryPoints+    (.manifestSchema) manifest `shouldBe` "keiro-dsl/frontend-compatibility/1"+    (.manifestRelease) manifest `shouldBe` "0.7.0.0"+    (.manifestEntryPoints) manifest `shouldBe` releasedFrontendEntryPoints     sources <- sourceFixturePaths     workspaces <- workspaceFixturePaths-    map sourcePath (manifestSources manifest) `shouldBe` sources-    map workspacePath (manifestWorkspaces manifest) `shouldBe` workspaces+    map (.sourcePath) ((.manifestSources) manifest) `shouldBe` sources+    map (.workspacePath) ((.manifestWorkspaces) manifest) `shouldBe` workspaces    it "preserves every source outcome, released contract, and accepted canonical round trip" $ do     manifest <- readManifest-    forM_ (manifestSources manifest) $ \expected -> do-      actual <- observeSource (sourcePath expected)+    forM_ ((.manifestSources) manifest) $ \expected -> do+      actual <- observeSource ((.sourcePath) expected)       actual `shouldBe` expected       whenAccepted expected $ do-        source <- readRepoText (sourcePath expected)-        case parseSource (sourcePath expected) source of+        source <- readRepoText ((.sourcePath) expected)+        case parseSource ((.sourcePath) expected) source of           Left failure -> expectationFailure (show failure)-          Right parsed -> case parseSource (sourcePath expected) (renderSource parsed) of+          Right parsed -> case parseSource ((.sourcePath) expected) (renderSource parsed) of             Left failure -> expectationFailure (show failure)             Right reparsed -> do-              parsedSpec reparsed `shouldBe` parsedSpec parsed-              effectiveLanguageVersion (parsedSourceLanguage reparsed)-                `shouldBe` effectiveLanguageVersion (parsedSourceLanguage parsed)-              sourceFormText (parsedSourceLanguage reparsed)-                `shouldBe` sourceFormText (parsedSourceLanguage parsed)+              (.spec) reparsed `shouldBe` (.spec) parsed+              effectiveLanguageVersion ((.sourceLanguage) reparsed)+                `shouldBe` effectiveLanguageVersion ((.sourceLanguage) parsed)+              sourceFormText ((.sourceLanguage) reparsed)+                `shouldBe` sourceFormText ((.sourceLanguage) parsed)    it "preserves every workspace composition outcome and member-attribution code" $ do     manifest <- readManifest-    forM_ (manifestWorkspaces manifest) $ \expected ->-      observeWorkspace (workspacePath expected) `shouldReturn` expected+    forM_ ((.manifestWorkspaces) manifest) $ \expected ->+      observeWorkspace ((.workspacePath) expected) `shouldReturn` expected    it "keeps direct parsing and representative one-member workspaces semantically identical" $ do     let examples =@@ -173,7 +173,7 @@       Left failure -> expectationFailure (show failure)       Right parsed -> do         let workspace = oneMemberParsedWorkspace path parsed-        wsMergedSpec workspace `shouldBe` parsedSpec parsed+        (.mergedSpec) workspace `shouldBe` (.spec) parsed         checkWorkspace workspace `shouldBe` []    it "renders curated source, grammar, semantic, and workspace failures byte-for-byte" $@@ -187,7 +187,7 @@  whenAccepted :: SourceExpectation -> IO () -> IO () whenAccepted row action-  | sourceResult row == "accept" = action+  | (.sourceResult) row == "accept" = action   | otherwise = pure ()  observeSource :: FilePath -> IO SourceExpectation@@ -209,16 +209,16 @@       base         "reject"         (Just "source-language")-        (Just (sourceLanguageErrorCodeText (sourceLanguageErrorCode diagnostic)))-        (languageVersionNumber <$> sourceLanguageDeclaredVersion diagnostic)+        (Just (sourceLanguageErrorCodeText ((.errorCode) diagnostic)))+        (languageVersionNumber <$> (.declaredVersion) diagnostic)     Left (BodyGrammarFailure _) ->       base "reject" (Just "body-grammar") Nothing (supportedHeaderVersion headerVersion)     Right parsed ->-      let sourceLanguage = parsedSourceLanguage parsed-          effective = Just (languageVersionNumber (effectiveLanguageVersion sourceLanguage))-          errors = filter ((== Error) . severity) (validateService (checkedSource parsed))+      let parsedLanguage = parsed.sourceLanguage+          effective = Just (languageVersionNumber (effectiveLanguageVersion parsedLanguage))+          errors = filter ((== Error) . (.severity)) (validateService (checkedSource parsed))        in case errors of-            diagnostic : _ -> base "reject" (Just "semantic") (Just (T.pack (show (code diagnostic)))) effective+            diagnostic : _ -> base "reject" (Just "semantic") (Just (T.pack (show ((.code) diagnostic)))) effective             [] -> base "accept" Nothing Nothing effective  observeWorkspace :: FilePath -> IO WorkspaceExpectation@@ -229,9 +229,9 @@     Left (WorkspaceManifestUnreadable _) -> rejected "manifest-unreadable" Nothing     Left (WorkspaceManifestUnparseable _) -> rejected "manifest-grammar" Nothing     Left (WorkspaceRefused diagnostics) ->-      rejected "composition" (Just (T.pack (show (wdCode (NE.head diagnostics)))))-    Right workspace -> case filter ((== Error) . wdSeverity) (checkWorkspace workspace) of-      diagnostic : _ -> rejected "semantic" (Just (T.pack (show (wdCode diagnostic))))+      rejected "composition" (Just (T.pack (show ((.code) (NE.head diagnostics)))))+    Right workspace -> case filter ((== Error) . (.severity)) (checkWorkspace workspace) of+      diagnostic : _ -> rejected "semantic" (Just (T.pack (show ((.code) diagnostic))))       [] -> WorkspaceExpectation path "accept" Nothing Nothing   where     rejected failureClass diagnostic = WorkspaceExpectation path "reject" (Just failureClass) diagnostic@@ -362,7 +362,7 @@ renderSemantic :: FilePath -> Text -> IO Text renderSemantic path source = pure $ case parseSource path source of   Left failure -> error ("semantic diagnostic source failed to parse: " <> show failure)-  Right parsed -> case filter ((== Error) . severity) (validateService (checkedSource parsed)) of+  Right parsed -> case filter ((== Error) . (.severity)) (validateService (checkedSource parsed)) of     diagnostic : _ -> renderDiagnostic path diagnostic <> "\n"     [] -> error ("semantic diagnostic source unexpectedly validated: " <> path)

test/Keiro/Dsl/FrontendProfiles.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE NoFieldSelectors #-}- module Keiro.Dsl.FrontendProfiles (frontendProfilesSpec) where  import Control.Monad (forM_)@@ -35,16 +33,16 @@                      [GeneratedIdDomainTypeIdV7, NominalEqualityV2, ContractIdDomainTypeIdV7, StrictSpecSurfaceValidation],                      [GeneratedIdDomainTypeIdV7, NominalEqualityV2, ContractIdDomainTypeIdV7, StrictSpecSurfaceValidation, ProjectionCatalogRuntime, TypedDomainCommandOutcomes, SeparatedProjectionQueryPolicy]                    ]-      map (runtimeProfileFoldSegments . definitionRuntimeSemanticsProfile) (NE.toList languageRegistry)+      map (runtimeProfileFoldSegments . (.runtimeSemanticsProfile)) (NE.toList languageRegistry)         `shouldBe` [ [],                      [],                      ["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)+      map (.support) (NE.toList languageRegistry)         `shouldBe` [CompatibilityOnly, CompatibilityOnly, CompatibilityOnly, CompatibilityOnly, Stable]-      map definitionMaturity (NE.toList languageRegistry)+      map (.maturity) (NE.toList languageRegistry)         `shouldBe` [PublishedLanguage, PublishedLanguage, PublishedLanguage, PublishedLanguage, PublishedLanguage]       currentStableLanguageVersion `shouldBe` version 5       currentAuthoringLanguageVersion `shouldBe` version 5@@ -54,18 +52,18 @@       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]+      [definition.version | definition <- NE.toList languageRegistry, (.support) definition == Stable]         `shouldBe` [currentStableLanguageVersion]-      [definitionVersion definition | definition <- NE.toList languageRegistry, definitionSupport definition == Candidate]+      [definition.version | definition <- NE.toList languageRegistry, (.support) definition == Candidate]         `shouldBe` []-      definitionVersion (NE.last languageRegistry) `shouldBe` currentAuthoringLanguageVersion-      definitionPredecessor (NE.last languageRegistry) `shouldBe` Just (version 4)+      (NE.last languageRegistry).version `shouldBe` currentAuthoringLanguageVersion+      (.predecessor) (NE.last languageRegistry) `shouldBe` Just (version 4)       forM_ (adjacent (NE.toList languageRegistry)) $ \(predecessor, successor) ->         forM_ allRuntimeCapabilities $ \capability ->-          runtimeProfileHasCapability (definitionRuntimeSemanticsProfile predecessor) capability+          runtimeProfileHasCapability ((.runtimeSemanticsProfile) predecessor) capability             `shouldSatisfy` \wasSupported ->               not wasSupported-                || runtimeProfileHasCapability (definitionRuntimeSemanticsProfile successor) capability+                || runtimeProfileHasCapability ((.runtimeSemanticsProfile) successor) capability       forM_ allFeatures $ \feature -> do         let minimumVersion = case feature of               ProjectionCatalogSyntax -> version 5@@ -363,7 +361,7 @@ definitionCapabilities definition =   [ capability   | capability <- allRuntimeCapabilities,-    runtimeProfileHasCapability (definitionRuntimeSemanticsProfile definition) capability+    runtimeProfileHasCapability ((.runtimeSemanticsProfile) definition) capability   ]  adjacent :: [a] -> [(a, a)]@@ -377,9 +375,9 @@  definitionRow :: LanguageDefinition -> (Integer, Maybe Integer, Text, Text) definitionRow definition =-  ( fromIntegral (languageVersionNumber (definitionVersion definition)),-    fromIntegral . languageVersionNumber <$> definitionPredecessor definition,-    syntaxProfileIdentifier (definitionSyntaxProfile definition),+  ( fromIntegral (languageVersionNumber definition.version),+    fromIntegral . languageVersionNumber <$> (.predecessor) definition,+    syntaxProfileIdentifier ((.syntaxProfile) definition),     definitionRuntimeSemantics definition   )

test/Keiro/Dsl/FrontendPublicApiProbe.hs view

@@ -8,8 +8,8 @@  import Data.Text (Text) 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.Grammar (Name, Node, Placement, Spec (..))+import Keiro.Dsl.LanguageVersion (ParseFailure, ParsedSource (..), SourceLanguage, SourceLanguageDiagnostic (..), SourceLanguageErrorCode) import Keiro.Dsl.Parser (ParseError, parseSource, parseSourceDocument, parseSpec, parseSpecText) import Keiro.Dsl.PrettyPrint (renderSource, renderSpec) import Keiro.Dsl.Source (SourceSpan)@@ -47,25 +47,25 @@ renderSpecProbe = renderSpec  parsedSourceLanguageProbe :: ParsedSource -> SourceLanguage-parsedSourceLanguageProbe = parsedSourceLanguage+parsedSourceLanguageProbe parsed = parsed.sourceLanguage  parsedSpecProbe :: ParsedSource -> Spec-parsedSpecProbe = parsedSpec+parsedSpecProbe parsed = parsed.spec  sourceLanguageErrorCodeProbe :: SourceLanguageDiagnostic -> SourceLanguageErrorCode-sourceLanguageErrorCodeProbe = sourceLanguageErrorCode+sourceLanguageErrorCodeProbe diagnostic = diagnostic.errorCode  specContextProbe :: Spec -> Name-specContextProbe = specContext+specContextProbe specification = specification.context  specModuleRootProbe :: Spec -> Maybe Text-specModuleRootProbe = specModuleRoot+specModuleRootProbe specification = specification.moduleRoot  specLayoutProbe :: Spec -> Maybe Placement-specLayoutProbe = specLayout+specLayoutProbe specification = specification.layout  specNodesProbe :: Spec -> [Node]-specNodesProbe = specNodes+specNodesProbe specification = specification.nodes  -- | Referencing every assignment keeps @-Wall@ useful and makes the module a -- real compile probe instead of passive documentation.

test/Keiro/Dsl/FrontendSurface.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE NoFieldSelectors #-}- module Keiro.Dsl.FrontendSurface (frontendSurfaceSpec) where  import Control.Monad (forM_)@@ -159,15 +157,15 @@       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+      let ParsedSourceDocument {parsedSource, sourceIndex} = document+      parseSource "semantic-source-index.keiro" source `shouldBe` Right parsedSource+      length (semanticSourceEntries sourceIndex) `shouldBe` 7+      case lookupSourceSpan (AggregateStateSubject "Journey" "Closed") sourceIndex 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+      case lookupSourceSpan (AggregateTransitionSubject "Journey" (TransitionOrdinal 1)) sourceIndex of         Just (ExactSourcePosition, SourceSpan {start = SourcePoint {line, column}}) ->           (line, column) `shouldBe` (14, 3)         other -> expectationFailure ("expected exact replay-only transition location, got " <> show other)@@ -188,11 +186,11 @@       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+      let ParsedSourceDocument {parsedSource} = document+      parsedSource `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)+      parseSpec "parser-parity.keiro" richParitySource `shouldBe` Right lowered.spec+      parseSpecText richParitySource `shouldBe` Right lowered.spec      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"]@@ -201,8 +199,8 @@         SurfaceSource {spec = Located {value = SurfaceSpec {items}}} ->           map topItemKind items `shouldBe` ["id", "enum", "id"]       lowered <- lowerRight surface-      map idName (specIds (parsedSpec lowered)) `shouldBe` ["FirstId", "SecondId"]-      map enumName (specEnums (parsedSpec lowered)) `shouldBe` ["Mode"]+      map (.name) lowered.spec.ids `shouldBe` ["FirstId", "SecondId"]+      map (.name) lowered.spec.enums `shouldBe` ["Mode"]      it "refuses surface evidence attributed to another source" $ do       surface <- parseSurfaceRight "owned.keiro" "context owned\n"@@ -220,11 +218,11 @@      it "lowers every accepted 0.7 fixture to the compatibility result" $ do       manifest <- readCompatibilityManifest-      forM_ [row | row <- manifestSources manifest, sourceResult row == "accept"] $ \row -> do-        source <- readRepoText (sourcePath row)-        surface <- parseSurfaceRight (sourcePath row) source+      forM_ [row | row <- manifest.manifestSources, row.sourceResult == "accept"] $ \row -> do+        source <- readRepoText row.sourcePath+        surface <- parseSurfaceRight row.sourcePath source         lowered <- lowerRight surface-        parseSource (sourcePath row) source `shouldBe` Right lowered+        parseSource row.sourcePath source `shouldBe` Right lowered    describe "parser module boundaries" $ do     it "keeps the public parser facade free of Megaparsec and grammar productions" $ do@@ -438,7 +436,7 @@  isFailure :: SourceIndexFailureCode -> Either SourceIndexFailure value -> Bool isFailure expected = \case-  Left SourceIndexFailure {failureCode} -> failureCode == expected+  Left SourceIndexFailure {code} -> code == expected   Right _ -> False  isFacadeImport :: Text -> Bool

test/Main.hs view

@@ -10,13926 +10,15037 @@ import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap import Data.Aeson.Types (parseEither)-import Data.Either (isLeft, isRight)-import Data.Foldable (toList)-import Data.KindID qualified as KindID-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"--consumerNominalFor :: Name -> NominalOwnership-consumerNominalFor name =-  ConsumerNominal-    ConsumerNominalBinding-      { consumerNominalHaskell = HaskellSource "domain" "Domain.Types" name,-        consumerNominalBinding = QualifiedValueName "Domain.Bindings.binding",-        consumerNominalBindingVersion = BindingVersion "1",-        consumerNominalCanonical = CanonicalTypeId ("domain." <> name <> ".v1"),-        consumerNominalFixtures = QualifiedValueName "Domain.Bindings.fixtures",-        consumerNominalInitial = Just (QualifiedValueName "Domain.Bindings.initialValue")-      }--genId :: Gen IdDecl-genId = IdDecl <$> genName <*> genWire <*> pure Nothing <*> pure noLoc--genEnum :: Gen EnumDecl-genEnum = EnumDecl <$> genName <*> smallList ((,) <$> genName <*> genWire) <*> pure Nothing <*> pure noLoc--genRule :: Gen RuleDecl-genRule =-  RuleDecl-    <$> genName-    <*> genName-    <*> genName-    <*> nonEmptyList ((,) <$> genName <*> genExpr)-    <*> pure noLoc--genMappedDecls :: Gen [MappedDecl]-genMappedDecls = do-  count <- choose (0, 4 :: Int)-  let names = take count ["MappedA", "MappedB", "MappedC", "MappedD"]-  traverse (genMappedDecl names) names--genMappedDecl :: [Name] -> Name -> Gen MappedDecl-genMappedDecl names name =-  oneof-    [ MappedStructural name-        <$> genMaybe genHaskellSource-        <*> genMaybe genAdversarialText-        <*> genMaybe genAdversarialText-        <*> genMaybe genAdversarialText-        <*> genMaybe genAdversarialText-        <*> genMaybe genAdversarialText-        <*> genMappedShape names-        <*> pure noLoc,-      MappedOpaque name-        <$> genMaybe genHaskellSource-        <*> genMaybe genAdversarialText-        <*> genMaybe genAdversarialText-        <*> genMaybe genAdversarialText-        <*> genMaybe genAdversarialText-        <*> pure noLoc-    ]--genHaskellSource :: Gen HaskellSource-genHaskellSource =-  HaskellSource-    <$> genWire-    <*> genModuleRoot-    <*> genName--genMappedShape :: [Name] -> Gen MappedShape-genMappedShape names =-  oneof-    [ ShapeRecord-        <$> genName-        <*> elements [RejectUnknown, IgnoreUnknown]-        <*> smallList (genWireField names),-      ShapeEnum <$> smallList (WireEnum <$> genName <*> genAdversarialText <*> pure noLoc),-      ShapeUnion-        <$> (TaggedObject <$> genAdversarialText <*> genAdversarialText <*> elements [RejectUnknown, IgnoreUnknown])-        <*> smallList (WireArm <$> genName <*> genAdversarialText <*> genMaybe (genTypeExpr names) <*> pure noLoc)-    ]--genWireField :: [Name] -> Gen WireField-genWireField names =-  WireField-    <$> genName-    <*> genAdversarialText-    <*> genTypeExpr names-    <*> elements [PRequired, POptional]-    <*> genMaybe genOnMissing-    <*> pure noLoc--genTypeExpr :: [Name] -> Gen TypeExpr-genTypeExpr names = sized (go . min 3)-  where-    go 0 = base-    go depth =-      frequency-        [ (4, base),-          (1, TOptional <$> go (depth - 1)),-          (1, TList <$> go (depth - 1)),-          (1, TMap <$> go (depth - 1))-        ]-    -- This generator renders through the unversioned/version-1 grammar. Keep-    -- successor-only Integer coverage in the dedicated version-2 properties.-    base = elements ([TText, TInt, TBool, TNatural, TTime, TJson] ++ map TRef names)--genOnMissing :: Gen OnMissing-genOnMissing =-  oneof-    [ pure OmNull,-      OmText <$> genAdversarialText,-      OmInt <$> choose (-10, 10),-      OmBool <$> arbitrary,-      pure OmEmptyList,-      pure OmEmptyMap,-      OmCtor <$> genName-    ]--genSpec :: Gen Spec-genSpec = do-  contextName <- genWire-  moduleRoot <- genMaybe genModuleRoot-  layout <- genMaybe (elements [GeneratedPrefix, CollocatedLeaf])-  ids <- smallList genId-  enums <- smallList genEnum-  rules <- smallList genRule-  mapped <- genMappedDecls-  nodes <- smallList genNode-  pure (Spec contextName moduleRoot layout ids enums rules [] mapped nodes)-  where-    genNode =-      oneof-        [ NAggregate <$> genAggregate,-          NProcess <$> genProcess,-          NRouter <$> genRouter,-          NContract <$> genContract,-          NIntake <$> genIntake,-          NEmit <$> genEmit,-          NPublisher <$> genPublisher,-          NWorkqueue <$> genWorkqueue,-          NPgmqDispatch <$> genPgmqDispatch,-          NReadModel <$> genReadModel,-          NWorkflow <$> genWorkflow,-          NOperation <$> genOperation-        ]---- | A dotted PascalCase module prefix, e.g. @Acme@ or @Acme.Services@.-genModuleRoot :: Gen T.Text-genModuleRoot = do-  n <- choose (1, 3 :: Int)-  segs <- vectorOf n (elements ["Acme", "Services", "Hospital", "Domain", "Core"])-  pure (T.intercalate "." segs)--assertGeneratedHaskellContract :: T.Text -> T.Text -> Expectation-assertGeneratedHaskellContract sourceName manifest =-  take 10 (T.lines manifest)-    `shouldBe` [ "-- keiro-dsl build manifest for " <> sourceName,-                 "-- Paste the complete fragment below into the consuming Cabal stanza.",-                 "-- The generated layer is overwritten on every scaffold; hole modules are",-                 "-- create-if-absent (filled by hand).",-                 "",-                 "default-language: GHC2024",-                 "default-extensions:",-                 "    OverloadedStrings",-                 "",-                 "other-modules:"-               ]+import Data.ByteString qualified as BS+import Data.Either (isLeft, isRight)+import Data.Foldable (toList)+import Data.KindID qualified as KindID+import Data.List (find, isInfixOf, 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.Encoding qualified as TextEncoding+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.GeneratedHaskellLanguage (RewriteState (..), modernizeGeneratedHaskellSourceWithState)+import Keiro.Dsl.Goldens (GoldenEvidence (..), GoldenPayload (..), emitGoldenPayloads, goldenRelativePath, goldensForDiff)+import Keiro.Dsl.Grammar+import Keiro.Dsl.Grammar qualified as 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 (..), GeneratedHaskellEditionImpact (..), GeneratedHaskellEditionUse (..), HoleUseForm (..), MappingDrift (..), QueryContractMigration (..), Refusal (..), ScaffoldReport (..), SourceLanguageDrift (..), StaleGeneratedEvidence (..), StaleModule (..), WriteDisposition (..), auditGeneratedHaskell, checkIndexedServiceDiagnostics, executeScaffold, executeScaffoldWithLanguage, executeServiceScaffold, executeServiceScaffoldWithRuntimePackage, executeServiceScaffoldWithRuntimePackageAndMigrations, executeServiceScaffoldWithRuntimePackageAndNameMigrations, planIndexedServiceScaffold, planIndexedServiceScaffoldWithRuntimePackage, planningRefusalDiagnostics, renderRefusals, renderScaffoldReport, renderSemanticImpactReport, scaffoldModules, scaffoldServiceModules)+import Keiro.Dsl.SemanticContract+import Keiro.Dsl.SemanticImpact+import Keiro.Dsl.SemanticImpact qualified as 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.Workspace qualified as 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.WorkspaceRecord qualified as 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, withCurrentDirectory)+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 = parsed.spec+      case [field | NWorkqueue workqueue <- (.nodes) spec, field <- (.payload) workqueue] of+        [field] -> do+          (.valueType) field `shouldBe` TypedQueueExpression (TList (TOptional (TRef "ArtifactInfo")))+          unLoc ((.loc) field) `shouldSatisfy` (> 0)+        fields -> expectationFailure ("unexpected mapped queue fields: " <> show fields)+      case [types | NReadModel readModel <- (.nodes) 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 (aggregateWithProjection (Just projection) aggregate)+            NReadModel readModel@ReadModelNode {name = "ArtifactLookup"} ->+              NReadModel (readModelWithGroupAndObservedTargets (Just "artifact_group") ["artifact_target"] readModel)+            other -> other+          owner name sourceKind feed groupName targetNames replayPolicy =+            NProjectionOwner+              ProjectionOwnerNode+                { name = name,+                  sources = [sourceKind],+                  delivery = case feed of RmInline -> DeliveryInline; RmSubscription -> DeliverySubscription,+                  group = groupName,+                  targets = targetNames,+                  order = 1,+                  subscription = if feed == RmSubscription then Just (name <> "-subscription") else Nothing,+                  dedup = if feed == RmSubscription then Just (name <> "-dedup") else Nothing,+                  checkpointOnMissing = if feed == RmSubscription then [CheckpointFromBeginning] else [],+                  replay = replayPolicy,+                  loc = noLoc+                }+          target name = NProjectionTarget (ProjectionTargetNode name "public" name TargetClear [] noLoc)+          groupNode name targetName = NRebuildGroup (RebuildGroupNode name [targetName] [targetName] noLoc)+          disjointReadModel =+            NReadModel+              ReadModelNode+                { name = "DisjointLookup",+                  table = "disjoint_lookup",+                  schema = "public",+                  columns = [],+                  version = 1,+                  shape = "fixture",+                  freshness = FreshnessImmediate,+                  supply = LegacyReadModelSupply Eventual Nothing RmSubscription (Just "disjoint-lookup"),+                  group = Just "disjoint_group",+                  observedTargets = ["disjoint_target"],+                  backingTarget = Nothing,+                  queryTypes = Nothing,+                  loc = noLoc+                }+          spec =+            specWithNodes+              ( map withInlineProjection base.nodes+                  <> [ 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+                     ]+              )+              base+      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 ((.unsupportedProjectionSources) 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 <- (.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")+                   ]+      (.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 (candidate.context)) 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,+              (.facet) (kindOfChange change) == "mapped-projection"+            ]+      map (.node) projectionChanges `shouldBe` ["Catalog", "artifactProjection", "liveProjection"]+      map (.subject) projectionChanges+        `shouldBe` [ "aggregate-projection:Catalog:artifact_view inherits ArtifactLocation",+                     "catalog-projection:artifactProjection:Catalog inherits ArtifactLocation",+                     "catalog-projection:liveProjection:Catalog inherits ArtifactLocation"+                   ]+      map (.paths) projectionChanges+        `shouldBe` replicate 3 ["Catalog event ArtifactObserved .artifact : ArtifactInfo .location : ArtifactLocation"]+      projectionChanges `shouldSatisfy` all ((== VAdvisory) . (.consumerBuild) . (.vector))+      map (.detail) projectionChanges+        `shouldSatisfy` any (T.isInfixOf "group=artifact_group, targets=[artifact_target], read-models=[ArtifactLookup], replayable=yes")+      [kindOfChange change | change <- diffSpecs commandOnly commandOnlyChanged, (.facet) (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 <- (.nodes) ((.spec) parsed)] of+        [workqueue] -> do+          let modules = scaffoldWorkqueueForService (defaultContext (parsed.spec.context)) (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 <- (.nodes) ((.spec) parsed)] of+        [readModel] -> do+          let ctx = defaultContext (parsed.spec.context)+              modules = scaffoldReadModelForService ctx (checkedSource parsed) readModel+              contract = generatedTextEndingIn "QueryContract.hs" modules+              generatedReadModel = generatedTextEndingIn "ReadModel.hs" modules+              holes = T.intercalate "\n" [(.text) 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 ((.spec) parsed)+        `shouldBe` Right+          [ QueryContractIdentity+              { readModel = "ArtifactLookup",+                position = QueryInputConsumer,+                typeExpression = "ArtifactInfo",+                mappedDependencies = ["ArtifactInfo", "ArtifactKind", "ArtifactLocation"]+              },+            QueryContractIdentity+              { readModel = "ArtifactLookup",+                position = QueryResultConsumer,+                typeExpression = "Optional ArtifactLocation",+                mappedDependencies = ["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 (spec.context)+        modules <- case planTestServiceScaffold ctx service of+          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"+          Right values -> pure values+        readModel <- case [value | NReadModel value <- (.nodes) 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 (value.path)] of+              [value] -> value+              values -> error ("expected one query hole, got " <> show (map (.path) values))+            legacyHole = case [value | value <- scaffoldReadModel ctx readModel, (.kind) value == HoleStub] of+              [value] -> value+              values -> error ("expected one legacy query hole, got " <> show (map (.path) values))+            holePath = out </> typedHole.path+            run = executeServiceScaffold out False "mapped-query.keiro" ((.sourceLanguage) parsed) ctx service modules+        createDirectoryIfMissing True (takeDirectory holePath)+        TIO.writeFile holePath ((.text) legacyHole)+        TIO.writeFile+          (out </> recordFileName (spec.context))+          ( renderRecord+              ScaffoldRecord+                { specPath = "mapped-query.keiro",+                  moduleRoot = "",+                  layout = "prefixed",+                  sourceLanguage = (.sourceLanguage) parsed,+                  languageContract = checkedLanguageContract service,+                  namingEdition = IdiomaticNamingV2,+                  moduleRoles = [],+                  files = [],+                  mappings = [],+                  idDomains = [],+                  nominalEqualities = [],+                  bindingObligations = [],+                  behaviorRequirements = [],+                  projectionCatalogFacts = [],+                  queryContractBaseline = False,+                  queryContracts = [],+                  routerSelections = [],+                  semanticImpact = Nothing+                }+          )+        first <- run >>= either (\refusals -> expectationFailure (show refusals) >> fail "unreachable") pure+        (.queryContractBaselineUnavailable) first `shouldBe` True+        (.queryContractMigrations) first+          `shouldBe` [ QueryContractMigration+                         { owner = "ArtifactLookup",+                           path = typedHole.path,+                           requiredImport = "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 ((.recordPath) first)+        case parseRecord currentLedger of+          Just record -> do+            (.queryContractBaseline) record `shouldBe` True+            length ((.queryContracts) 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 ((.text) typedHole)+        second <- run >>= either (\refusals -> expectationFailure (show refusals) >> fail "unreachable") pure+        (.queryContractMigrations) second `shouldBe` []+        [disposition | (value, disposition) <- (.dispositions) second, value.path == typedHole.path]+          `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" ((.sourceLanguage) changedParsed) ctx changedService changedModules+            >>= either (\refusals -> expectationFailure (show refusals) >> fail "unreachable") pure+        (.queryContractDrift) third+          `shouldSatisfy` \case+            [QueryContractDrift {key = ("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" ((.sourceLanguage) withoutQueryParsed) ctx withoutQueryService withoutQueryModules+            >>= either (\refusals -> expectationFailure (show refusals) >> fail "unreachable") pure+        length ((.queryContractDrift) fourth) `shouldBe` 2+        removedLedger <- TIO.readFile ((.recordPath) fourth)+        case parseRecord removedLedger of+          Just record -> do+            (.queryContractBaseline) record `shouldBe` True+            (.queryContracts) 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) <- (.modules) plan,+                "QueryContract.hs" `T.isSuffixOf` T.pack ((.path) scaffoldModule)+              ]+        case contractRows of+          [(contract, MemberOwned owner)] -> do+            owner `shouldBe` "readmodel.keiro"+            (.text) contract `shouldSatisfy` T.isInfixOf "type AccountSummaryQueryInput = AccountLookup"+            (.text) 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+        (.queryContractMigrations) report `shouldBe` []+        recordText <- TIO.readFile ((.recordPath) report)+        case parseWorkspaceRecord recordText of+          Just record -> do+            (.queryContractBaseline) record `shouldBe` True+            length ((.queryContracts) 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) ((.declarationConsequences) 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+      (.workqueuePayloads) ((.summary) queueCoverage)+        `shouldBe` Coverage.CoverageCounts 2 2 0 1+      (.readModelQueryInputs) ((.summary) queryCoverage)+        `shouldBe` Coverage.CoverageCounts 1 1 0 0+      (.readModelQueryResults) ((.summary) queryCoverage)+        `shouldBe` Coverage.CoverageCounts 1 1 0 0+      (.projectionTypedConsumers) ((.summary) projectionCoverage)+        `shouldBe` Coverage.CoverageCounts 3 0 3 0+      map (.consumer) [root | root <- (.roots) queryCoverage, (.surface) root `elem` [Coverage.ReadModelQueryInput, Coverage.ReadModelQueryResult]]+        `shouldBe` ["read-model-query:account_summary:input", "read-model-query:account_summary:result"]+      map (.surface) ((.unsupportedSurfaces) 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 {name = "order_summary_writer"} ->+              NProjectionOwner (projectionOwnerWithReplay (ProjectionLiveOnly "candidate is intentionally live-only") owner)+            other -> other+          moveObserver node = case node of+            NReadModel readModel@ReadModelNode {name = "catalogAudit"} ->+              NReadModel (readModelWithObservedTargets ["order_summary"] readModel)+            other -> other+          liveOnly = specWithNodes (map makeLiveOnly projectionSpec.nodes) projectionSpec+          observerMoved = specWithNodes (map moveObserver projectionSpec.nodes) projectionSpec+          liveDeltas = CheckedDiff.mappedSemanticImpact projectionSpec liveOnly+          observerDeltas = CheckedDiff.mappedSemanticImpact projectionSpec observerMoved+      map (.declaration) liveDeltas `shouldBe` [MappedKey "OrderPayload", MappedKey "SharedReference"]+      map (.currentConsequences) liveDeltas+        `shouldSatisfy` all (maybe False (not . any (\case MappedProjectionRebuild (CatalogProjectionConsumer "order_summary_writer" "Orders") _ -> True; _ -> False) . Set.toList))+      map (.declaration) observerDeltas `shouldBe` [MappedKey "OrderPayload", MappedKey "SharedReference"]+      map (.currentEvidence) observerDeltas+        `shouldSatisfy` any (maybe False (any (maybe False (T.isInfixOf "catalogAudit") . (.operation)) . 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 = semanticImpactSnapshotWithoutEvidence snapshot+          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+      (.deltas) report `shouldSatisfy` \case+        [delta] -> (.previousEvidence) delta == Nothing && (.currentEvidence) 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 (workqueueWithPayload [if field.name == "job" then wqFieldWithValueType (TypedQueueExpression (TRef "JobMetadata")) field else field | field <- queue.payload] queue)+            other -> other+          queueChanged = specWithNodes (map changeQueue queueSpec.nodes) queueSpec+          changeQuery node = case node of+            NReadModel readModel@ReadModelNode {queryTypes = Just queryPair} ->+              NReadModel (readModelWithQueryTypes (Just (ReadModelQueryTypes (TRef "TenantKey") queryPair.result queryPair.inputLoc queryPair.resultLoc)) readModel)+            other -> other+          queryChanged = specWithNodes (map changeQuery querySpec.nodes) querySpec+          findKind predicate changes = case [kindOfChange change | change <- changes, predicate (kindOfChange change)] of+            value : _ -> value+            [] -> error "expected mapped compatibility finding"+          queueKind = findKind ((== WqPayloadFieldChanged) . (.code)) (diffSpecs queueSpec queueChanged)+          queryKind = findKind ((== ReadModelQueryInputChanged) . (.code)) (diffSpecs querySpec queryChanged)+          eventKind = findKind ((== "mapped-event") . (.facet)) [change | mutation <- mappedWireMutations aggregateSpec, change <- diffSpecs aggregateSpec ((.mmCandidate) mutation)]+          snapshotKind = findKind ((== "mapped-register") . (.facet)) [change | mutation <- mappedWireMutations aggregateSpec, change <- diffSpecs aggregateSpec ((.mmCandidate) mutation)]+          projectionChanged = mapMappedDeclaration "OrderPayload" changeProjectionMappedWire projectionSpec+          projectionKind = findKind ((== "mapped-projection") . (.facet)) (diffSpecs projectionSpec projectionChanged)+      (.mappedConsequences) queueKind+        `shouldBe` Set.fromList [MappedConsumerBuild (WorkqueueConsumer "mapped_jobs"), MappedWorkqueueHistory "mapped_jobs"]+      (.privateHistoryRead) (queueKind.vector) `shouldBe` VNotApplicable+      (.consumerBuild) (queueKind.vector) `shouldBe` VBreaking+      (.mappedConsequences) queryKind+        `shouldBe` Set.fromList [MappedConsumerBuild (ReadModelQueryConsumer "account_summary" MappedQueryInput), MappedQueryApi "account_summary" MappedQueryInput]+      (.snapshotHydration) (queryKind.vector) `shouldBe` VNotApplicable+      (.mappedConsequences) eventKind `shouldSatisfy` Set.member (MappedPrivateEventHistory "Alpha")+      (.mappedConsequences) snapshotKind `shouldSatisfy` Set.member (MappedSnapshotHydration "Alpha")+      (.mappedConsequences) projectionKind `shouldSatisfy` Set.member (MappedProjectionHandlerReview (CatalogProjectionConsumer "order_summary_writer" "Orders"))+      (.mappedConsequences) 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 ((.mergedSpec) workspace)+      Aeson.decode (Aeson.encode standaloneSnapshot) `shouldBe` Just standaloneSnapshot+      (.consumers) orderPayload+        `shouldBe` Set.fromList+          [ AggregateConsumer "Orders",+            DerivedProjectionConsumer (CatalogProjectionConsumer "order_summary_writer" "Orders")+          ]+      Set.map (.rootKind) ((.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+      (.workqueuePayloads) ((.summary) coverage) `shouldBe` Coverage.CoverageCounts 4 1 3 1+      (.readModelQueryInputs) ((.summary) coverage) `shouldBe` Coverage.CoverageCounts 1 0 1 0+      (.readModelQueryResults) ((.summary) coverage) `shouldBe` Coverage.CoverageCounts 1 0 1 0+      (.projectionTypedConsumers) ((.summary) coverage) `shouldBe` Coverage.CoverageCounts 3 0 3 0+      map (.surface) ((.unsupportedSurfaces) 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+              [ (.mappedConsequences) (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 (spec.context)+          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 ((.modules) grownBaselinePlan)) (map fst ((.modules) 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 exact check report JSON bytes and retains semantic assertions" $ 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` ""+        reportBytes <- BS.readFile reportPath+        assertMatchesByteGolden "test/fixtures/check-report/legacy-min-language.golden.json" reportBytes+        report <- decodeJsonValue reportPath+        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 = (.contractVersion) <$> 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 =+            specWithNodes+              [ NAggregate (transform aggregate)+              | NAggregate aggregate <- baseSpec.nodes+              ]+              baseSpec+          replaceFirstTransition transform aggregate =+            aggregateWithTransitions+              (case aggregate.transitions of transition : rest -> transform transition : rest; [] -> [])+              aggregate+          guardSpec = withAggregate (replaceFirstTransition (transitionWithGuard (Just (EAtom (AName "missingGuardRoot")))))+          outputSpec = withAggregate (replaceFirstTransition (transitionWithEmits ["MissingEvent"]))+          typeGraphSpec = specWithMapped recursiveMapped.mapped baseSpec+          nominalSpec = specWithNominalScalars brokenNominal.nominalScalars baseSpec+          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 (guardSpec.context)) 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 <- (.nodes) 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 ((.key) 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"+        code source = case parseSource "source.keiro" source of+          Left (SourceLanguageFailure diagnostic) -> Just ((.errorCode) 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+      (.spec) legacySource `shouldBe` (.spec) declaredSource+      (.sourceLanguage) legacySource `shouldBe` LegacyUnversioned+      declaredVersionOf ((.sourceLanguage) declaredSource) `shouldBe` languageVersion 1+      effectiveLanguageVersion ((.sourceLanguage) legacySource)+        `shouldBe` effectiveLanguageVersion ((.sourceLanguage) 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 (v1Spec.context)+          aggregates spec = [aggregate | NAggregate aggregate <- (.nodes) spec]+      v1Spec `shouldBe` v2Spec+      Just ((.contractLanguageVersion) (checkedLanguageContract v1Service)) `shouldBe` languageVersion 1+      Just ((.contractLanguageVersion) (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 ((.contractLanguageVersion) (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 (.code) (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 ((.spec) declaredSource)++    it "classifies invalid, unsupported, duplicate, and misplaced preambles" $ do+      code "language keiro-dsl 0\ncontext hospital-capacity\n" `shouldBe` Just InvalidLanguageVersion+      code "language keiro-dsl nope\ncontext hospital-capacity\n" `shouldBe` Just InvalidLanguageVersion+      code "language keiro-dsl -1\ncontext hospital-capacity\n" `shouldBe` Just InvalidLanguageVersion+      code "language keiro-dsl 999999\ncontext hospital-capacity\n" `shouldBe` Just UnsupportedLanguageVersion+      code "language keiro-dsl 1\nlanguage keiro-dsl 1\ncontext hospital-capacity\n" `shouldBe` Just DuplicateLanguagePreamble+      code "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 ((.spec) 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+                (.errorCode) diagnostic `shouldBe` expectedCode+                unLoc ((.loc) 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+          (.errorCode) 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 ((.ids) ((.spec) parsed)) `shouldBe` 1+      length ((.enums) ((.spec) parsed)) `shouldBe` 1+      length ((.nominalScalars) ((.spec) 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"+      code ("language keiro-dsl 1\n" <> body) `shouldBe` Just LanguageFeatureRequiresVersion+      code 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 (.nodes) ((.spec) parsed) of+        [NAggregate aggregate, NContract contract] -> do+          case (.fields) =<< (.commands) aggregate of+            aliased : haskellField : asField : _ -> do+              ((.name) aliased, (.selector) aliased, (.wireKey) aliased)+                `shouldBe` ("type", Just "payloadType", Just "type")+              map (.name) [haskellField, asField] `shouldBe` ["haskell", "as"]+            fields -> expectationFailure ("unexpected aggregate alias fields: " <> show fields)+          case (.fields) =<< (.events) contract of+            [field] ->+              ((.name) field, (.selector) field, (.wireKey) field, (.loc) 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)+      code 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+                (.errorCode) diagnostic `shouldBe` LanguageFeatureRequiresVersion+                unLoc ((.loc) 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 = (.spec) legacySource+          newSpec = (.spec) declaredSource+          changes = diffSources legacySource declaredSource+          vectors = [kind.vector | 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 ((workspaceChangeKind change).context) SourceLanguageDeclarationChanged+            `shouldBe` (RemedyNoSemanticAction :| [])+        _ -> expectationFailure "expected one source-language change"+      let legacyGeneratedSurface spec =+            [ ((.path) scaffoldModule, (.text) scaffoldModule, (.kind) scaffoldModule)+            | scaffoldModule <- scaffoldModules (defaultContext (spec.context)) spec+            ]+          legacyFoldFingerprint spec aggregate = aggregateFoldFingerprintForService (legacyCheckedService spec) aggregate+      legacyGeneratedSurface oldSpec `shouldBe` legacyGeneratedSurface newSpec+      [legacyFoldFingerprint oldSpec aggregate | NAggregate aggregate <- (.nodes) oldSpec]+        `shouldBe` [legacyFoldFingerprint newSpec aggregate | NAggregate aggregate <- (.nodes) 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" $+      withTempDirectory "keiro-dsl-language-diff" $ \repository -> do+        source <- readTestText "test/fixtures/language-v1.keiro"+        TIO.writeFile (repository </> "language.keiro") source+        let git arguments = readProcessWithExitCode "git" ("-C" : repository : arguments) ""+        forM_+          [ ["init", "--quiet"],+            ["add", "language.keiro"],+            ["-c", "user.name=keiro-dsl-test", "-c", "user.email=keiro-dsl-test@example.invalid", "commit", "--quiet", "-m", "test: capture language contract baseline"]+          ]+          $ \arguments -> do+            (gitCode, gitOut, gitErr) <- git arguments+            unless (gitCode == ExitSuccess) (expectationFailure (gitOut <> gitErr))+        (diffCode, _, diffErr) <- withCurrentDirectory repository (runKeiroDsl ["diff", "language.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+          diagnostic.code `shouldBe` WorkspaceMemberParseFailed+          (.errorCode) <$> (.sourceLanguageCause) 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 (.members) workspace of+        firstMember : remaining -> do+          let changedMember =+                WorkspaceMember+                  { path = firstMember.path,+                    spec = firstMember.spec,+                    sourceLanguage = LegacyUnversioned,+                    sourceIndex = firstMember.sourceIndex,+                    lineBase = firstMember.lineBase,+                    lineCount = firstMember.lineCount+                  }+              changedWorkspace = workspaceWithMembers (changedMember : remaining) workspace+              changes = diffWorkspaces workspace changedWorkspace+          map (changeCode . (.change)) changes `shouldBe` [SourceLanguageDeclarationChanged]+          map (fmap (.file) . (.declarationSite)) changes `shouldBe` [Just ((.path) firstMember)]+          map (.change) 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 <- (.nodes) ((.spec) parsed)] of+        [aggregate] -> do+          fmap (\types -> ((.rejectionType) types, (.noOpType) types)) ((.domainOutcomeTypes) aggregate)+            `shouldBe` Just ("ReservationRejection", "ReservationNoOp")+          map (fmap outcomeKind . (.outcome)) ((.transitions) 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) -> (.errorCode) 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 <- (.nodes) ((.spec) parsed)] of+        [value] -> pure value+        values -> expectationFailure ("unexpected outcome aggregates: " <> show values) >> fail "unreachable"+      let scaffoldContext = defaultContext (parsed.spec.context)+          modules = scaffoldAggregateForService scaffoldContext (checkedSource parsed) aggregate+          modulesAgain = scaffoldAggregateForService scaffoldContext (checkedSource parsed) aggregate+          eventStream = case [(.text) value | value <- modules, "/EventStream.hs" `T.isSuffixOf` T.pack ((.path) value)] of+            [value] -> value+            values -> error ("unexpected outcome event-stream modules: " <> show values)+          behaviorContract = case [(.text) value | value <- modules, "/BehaviorContract.hs" `T.isSuffixOf` T.pack ((.path) value)] of+            [value] -> value+            values -> error ("unexpected outcome behavior-contract modules: " <> show values)+      map (.text) modulesAgain `shouldBe` map (.text) 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 <- (.nodes) ((.spec) oldParsed)] of+        [aggregate] -> pure aggregate+        aggregates -> expectationFailure ("unexpected old outcome aggregates: " <> show aggregates) >> fail "unreachable"+      newAggregate <- case [aggregate | NAggregate aggregate <- (.nodes) ((.spec) newParsed)] of+        [aggregate] -> pure aggregate+        aggregates -> expectationFailure ("unexpected new outcome aggregates: " <> show aggregates) >> fail "unreachable"+      let changes = diffSources oldParsed newParsed+          oldBehavior = Behavior.deriveAggregateBehaviorRequirements ((.spec) oldParsed) oldAggregate+          newBehavior = Behavior.deriveAggregateBehaviorRequirements ((.spec) newParsed) newAggregate+          changeKind change = case change of+            Additive value -> value+            Advisory value -> value+            Breaking value -> value+      map ((.code) . changeKind) changes `shouldContain` [DomainTransitionOutcomeChanged]+      map ((.code) . 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 -> (.spec) rendered `shouldBe` (.spec) 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 ((checkedSpec serviceA).context)+          modulesA = scaffoldServiceModules ctx serviceA+          modulesB = scaffoldServiceModules ctx serviceB+          generatedBytes modules = sort [((.path) moduleValue, (.text) 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 ((.code) . 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 (spec.context)) 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 -> (.spec) rendered `shouldBe` (.spec) parsed++      let spec = parsed.spec+          targets = [target | NProjectionTarget target <- (.nodes) spec]+          groups = [groupNode | NRebuildGroup groupNode <- (.nodes) spec]+          externalReads = [externalRead | NExternalRead externalRead <- (.nodes) spec]+          owners = [owner | NProjectionOwner owner <- (.nodes) spec]+      map (.name) targets `shouldBe` ["order_summary", "audit_log", "order_totals", "shipment_summary"]+      map (.name) groups `shouldBe` ["reporting", "shipping"]+      map (\externalRead -> ((.name) externalRead, (.version) externalRead, (.queryModel) externalRead)) externalReads+        `shouldBe` [("order_totals_reader", 1, "order_totals_lookup")]+      map (.name) owners `shouldBe` ["order_summary_writer", "shipment_writer", "audit_writer"]+      map (.checkpointOnMissing) 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 ((checkedSpec service).context)) 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 ((.code) . kindOfChange) (diffServices baseline changed)+          foldIdentities service =+            [ ((.name) aggregate, aggregateFoldFingerprintForService service aggregate)+            | NAggregate aggregate <- (.nodes) (checkedSpec service)+            ]+          sourceIdentities service =+            [ ((.name) aggregate, ProjectionImpact.projectionAggregateSourceFingerprintForService service ((.name) aggregate))+            | NAggregate aggregate <- (.nodes) (checkedSpec service)+            ]+          catalogAudit service = case [readModel | NReadModel readModel <- (.nodes) (checkedSpec service), (.name) 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 (.queryModel) supplies+        `shouldBe` ["catalog_administration", "catalog_validation"]+      map (.projectionOwner) supplies+        `shouldBe` ["catalog_writer", "catalog_writer"]+      map (NE.toList . (.observedTargets)) 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"+          ]+      (.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 ((.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 (.source) ((.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 (spec.context)) service+          facade = generatedTextEndingIn "Generated/CatalogDemo/ProjectionCatalog.hs" modules+          holes = case [(.text) m | m <- modules, (.kind) m == HoleStub, "ProjectionCatalog/ProjectionCatalogHoles.hs" `T.isSuffixOf` T.pack ((.path) 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 ((.code) . 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 (spec.context)+            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" ((.sourceLanguage) parsed) ctx service modules+        first `shouldSatisfy` isSuccessfulScaffold+        let path = out </> onlyPathEndingIn holeSuffix modules+            reviewedBody = "module CatalogDemo.ProjectionCatalog.ProjectionCatalogHoles where\nreviewed = True\n"+        TIO.writeFile path reviewedBody+        second <- executeServiceScaffold out False "projection-catalog.keiro" ((.sourceLanguage) parsed) ctx service modules+        second `shouldSatisfy` isSuccessfulScaffold+        TIO.readFile path `shouldReturn` reviewedBody+        case second of+          Left _ -> fail "unreachable"+          Right report ->+            do+              (.dispositions) 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 ((.code) . 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 ((.code) . 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, (.code) (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])))+          (.persistedIdentity) (finding.vector) `shouldBe` VCompatible+          (.consumerBuild) (finding.vector) `shouldBe` VBreaking+          (.rollout) (finding.vector) `shouldBe` Set.singleton RolloutStopTheWorld+          (.detail) 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"+      (.contractLanguageVersion) 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"+      (.contractLanguageVersion) 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 <- (.nodes) (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 (spec.context)) service+          generatedText suffix = case [(.text) value | value <- modules, T.pack suffix `T.isSuffixOf` T.pack ((.path) 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, (.mappedName) obligation == "OrderId", (.kind) obligation == BindingValue]+      map (.idDomainContract) orderIdBindings `shouldBe` [Just "keiro-dsl/id-domain/typeid-v7/1"]+      renderBindingObligations (spec.context) 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 (finding.vector) `shouldBe` VCompatible+        verdictFor OldBinaryReadNewEvents (finding.vector) `shouldBe` VCompatible+        verdictFor SnapshotHydration (finding.vector) `shouldBe` VAdvisory+        verdictFor PublicConsumer (finding.vector) `shouldBe` VBreaking+        verdictFor PersistedIdentity (finding.vector) `shouldBe` VCompatible+        verdictFor ConsumerBuild (finding.vector) `shouldBe` VAdvisory+        (.detail) finding `shouldSatisfy` T.isInfixOf "historical event replay retains its legacy decoder"+        remediationFor (finding.context) ((.code) finding)+          `shouldBe` RemedyDeploymentOrder RolloutProducerLast :| [RemedyStateCodecBump, RemedyRecompileConsumers, RemedyRunConformance]+      [(.detail) 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 (spec.context)+            modules = scaffoldServiceModules ctx service+            attempt = out </> "Attempt.hs"+            ghcOutput = out </> ".ghc"+        result <- executeServiceScaffold out False "id-domain-migration-v3.keiro" ((.sourceLanguage) parsed) ctx service modules+        result `shouldSatisfy` isRight+        recordContents <- TIO.readFile (out </> recordFileName (spec.context))+        record <- case parseRecord recordContents of+          Nothing -> expectationFailure "generated ID-domain scaffold record did not parse" >> fail "unreachable"+          Just value -> pure value+        (.idDomains) record `shouldBe` idDomainIdentitiesForService service+        (.nominalEqualities) 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\""+              ]+          )+        keiroCorePackageId <- activeCabalPackageId "keiro-core"+        (exitCode, standardOutput, standardError) <-+          readProcessWithExitCode+            "cabal"+            [ "exec",+              "--enable-tests",+              "--",+              "ghc",+              "-XGHC2024",+              "-XOverloadedStrings",+              "-fno-code",+              "-fforce-recomp",+              "-package-id",+              keiroCorePackageId,+              "-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 ((.path) . fst) ((.modules) plan)+      length (filter (== "Generated/WorkspaceNominalProof/Nominals.hs") paths) `shouldBe` 1+      length (filter (== "Generated/WorkspaceNominalProof/Nominals/Internal.hs") paths) `shouldBe` 1+      forM_ [(.text) value | (value, _) <- (.modules) plan, "/Domain.hs" `T.isSuffixOf` T.pack ((.path) 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 ((.service) workspace))+        record <- case parseWorkspaceRecord recordContents of+          Nothing -> expectationFailure "version-3 workspace record did not parse" >> fail "unreachable"+          Just value -> pure value+        (.idDomains) record `shouldBe` idDomainIdentitiesForService (plan.checkedService)+        (.nominalEqualities) 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 (spec.context)) service+          moduleAt path = case [value | value <- modules, value.path == path] of+            [value] -> pure value+            values -> expectationFailure ("expected one module at " <> path <> ", got " <> show (map (.path) 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"+      (.text) publicNominals `shouldSatisfy` T.isInfixOf "parseRequestId"+      (.text) publicNominals `shouldSatisfy` T.isInfixOf "instance ExactFieldProjection RequestIdEqualityProjection"+      (.text) publicNominals `shouldSatisfy` T.isInfixOf "idDomainTextPattern (typeIdV7Domain \"req\")"+      (.text) publicNominals `shouldSatisfy` (not . T.isInfixOf "unsafeRequestIdFromLegacyText")+      (.text) publicNominals `shouldSatisfy` (not . T.isInfixOf "newtype RequestId")+      (.text) internalNominals `shouldSatisfy` T.isInfixOf "newtype RequestId = RequestId Text"+      (.text) internalNominals `shouldSatisfy` T.isInfixOf "unsafeRequestIdFromLegacyText"+      (.text) domainModule `shouldSatisfy` (not . T.isInfixOf "RequestId (..)")+      (.text) codecModule `shouldSatisfy` T.isInfixOf "unsafeRequestIdFromLegacyText <$>"+      (.text) 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 ((.spec) parsed) `shouldBe` []+      parseSource "round-trip.keiro" (renderSource parsed) `shouldBe` Right parsed+      case [aggregate | NAggregate aggregate <- (.nodes) ((.spec) parsed)] of+        [aggregate] -> case (.transitions) aggregate of+          transition : holeTransition : [] -> do+            (.implementation) transition `shouldBe` GeneratedImplementation+            (.implementation) holeTransition `shouldBe` HoleImplementation+            let environment = expressionEnvironment ((.spec) parsed) aggregate transition+            case lookup "reserved" ((.writes) transition) >>= either (const Nothing) Just . resolveWriteExpr environment "reserved" of+              Just resolved -> do+                (.valueType) resolved `shouldBe` AggregateNatural+                show ((.node) resolved) `shouldContain` "TotalNaturalArithmetic"+              Nothing -> expectationFailure "reserved write did not resolve"+            let service = checkedSource parsed+                modules = scaffoldServiceModules (defaultContext (parsed.spec.context)) 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 (.path) modules `shouldSatisfy` all (not . T.isSuffixOf "Expressions.hs" . T.pack)+            map (.path) 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 (spec.context)) spec+          moduleAt suffix = case [(.text) value | value <- modules, T.pack suffix `T.isSuffixOf` T.pack ((.path) 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 (spec.context)) 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 (spec.context)) 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 <- (.nodes) ((.spec) original)],+             [aggregate | NAggregate aggregate <- (.nodes) ((.spec) changed)]+           ) of+        ([originalAggregate], [changedAggregate]) -> do+          let service = checkedSource original+              changedService = checkedSource changed+              prefixed = defaultContext (original.spec.context)+              collocated = prefixed {moduleRoot = "Acme", placement = CollocatedLeaf}+              prefixedModules = scaffoldServiceModules prefixed service+              collocatedModules = scaffoldServiceModules collocated service+              originalSurface = aggregateFoldSurfaceForService service originalAggregate+              originalFingerprint = aggregateFoldFingerprintForService service originalAggregate+          map (.path) prefixedModules `shouldNotBe` map (.path) collocatedModules+          sum (map (T.length . (.text)) prefixedModules) `shouldSatisfy` (> 0)+          sum (map (T.length . (.text)) 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 <- (.nodes) spec] of+        [aggregate] -> case (.transitions) 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 ((.spec) 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 <- (.nodes) spec] of+        [value] -> pure value+        _ -> expectationFailure "expected one Hole aggregate" >> fail "unreachable"+      let modules = scaffoldAggregate (defaultContext (spec.context)) spec aggregate+          transducer = generatedTextEndingIn "Transducer.hs" modules+          holes = holeTextEndingIn "Holes.hs" modules+      errorCodes spec `shouldBe` []+      map (.path) 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) -> (.errorCode) 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/" <> (.path) generatedModule)+        normalizeGenerated committed `shouldBe` normalizeGenerated ((.text) generatedModule)++  describe "behavior obligations" $ do+    describe "record migration byte contracts" $ do+      it "joins every source-stable behavior origin to one exact source position and freezes behavior-obligations JSON 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 {parsedSource = parsedSource, sourceIndex = 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 (.key) entries `shouldBe` map (.key) requirements+        entries `shouldSatisfy` all ((== "test/fixtures/behavior-complete.keiro") . (.file))+        entries `shouldSatisfy` all ((>= 1) . (.line))+        entries `shouldSatisfy` all ((>= 1) . (.column))+        let exactRequirements = BehaviorSource.attachBehaviorSourceLocations entries requirements+            exactJson =+              Behavior.encodeBehaviorObligationsJson+                (Behavior.BehaviorObligationsReport "test/fixtures/behavior-complete.keiro" Nothing exactRequirements)+            exactText =+              Behavior.renderBehaviorObligationsText+                (Behavior.BehaviorObligationsReport "test/fixtures/behavior-complete.keiro" Nothing exactRequirements)+            exactBytes = TextEncoding.encodeUtf8 exactJson+        assertMatchesByteGolden "test/fixtures/record-migration/behavior-obligations.exact.json.golden" exactBytes+        case Aeson.eitherDecodeStrict' exactBytes of+          Left failure -> expectationFailure ("behavior-obligations JSON did not decode: " <> failure)+          Right value -> do+            jsonField "schema" value `shouldBe` Just (Aeson.String "keiro-dsl/behavior-obligations/1")+            case jsonField "requirements" value of+              Just (Aeson.Array encodedRequirements) -> length encodedRequirements `shouldBe` length requirements+              other -> expectationFailure ("expected behavior requirements array, got " <> show other)+        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]"+        [(.origin) requirement | requirement <- requirements, (.kind) requirement == Behavior.RequiredRejection]+          `shouldSatisfy` all (\case Behavior.RejectionRequirementOrigin "Journey" _ -> True; _ -> False)++      it "freezes representative single-file scaffold ledger bytes and parses the golden" $ do+        (singleRecord, _) <- representativeRecordMigrationContracts+        let rendered = renderRecord singleRecord+            renderedBytes = TextEncoding.encodeUtf8 rendered+        assertMatchesByteGolden "test/fixtures/record-migration/single-file-scaffold-record.ledger.golden" renderedBytes+        golden <- readTestText "test/fixtures/record-migration/single-file-scaffold-record.ledger.golden"+        parseRecord golden `shouldBe` Just singleRecord++      it "freezes representative workspace scaffold ledger bytes and parses the golden" $ do+        (_, workspaceRecord) <- representativeRecordMigrationContracts+        let rendered = renderWorkspaceRecord workspaceRecord+            renderedBytes = TextEncoding.encodeUtf8 rendered+        assertMatchesByteGolden "test/fixtures/record-migration/workspace-scaffold-record.ledger.golden" renderedBytes+        golden <- readTestText "test/fixtures/record-migration/workspace-scaffold-record.ledger.golden"+        parseWorkspaceRecord golden `shouldBe` Just workspaceRecord++    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 (.code) 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 {parsedSource = parsedSource, sourceIndex = sourceIndex} = document+          service = checkedSource parsedSource+          ctx = defaultContext ((checkedSpec service).context)+      modules <- either (\refusals -> expectationFailure (show refusals) >> fail "unreachable") pure (planIndexedServiceScaffold sourceIndex ctx service)+      let sourceMaps = [(.text) value | value <- modules, T.isSuffixOf "/BehaviorSourceMap.hs" (T.pack ((.path) value))]+          contracts = [(.text) value | value <- modules, T.isSuffixOf "/BehaviorContract.hs" (T.pack ((.path) value))]+          witnesses = [(.text) value | value <- modules, T.isSuffixOf "/BehaviorHoles.hs" (T.pack ((.path) 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) . (.code))+        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 (.path) modules `shouldSatisfy` all (not . T.isSuffixOf "BehaviorSourceMap.hs" . T.pack)+      map (.path) 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 <- (.nodes) spec] of+        [value] -> pure value+        _ -> expectationFailure "expected one transition-layout aggregate" >> fail "unreachable"+      let ctx = defaultContext (spec.context)+          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, (.kind) requirement == Behavior.LiveTransition] `shouldBe` 5+      length [() | requirement <- requirements, (.kind) requirement == Behavior.RequiredRejection] `shouldBe` 11+      length [() | requirement <- requirements, (.kind) requirement == Behavior.ReplayTransition] `shouldBe` 3+      [(.source) requirement | requirement <- requirements, (.kind) requirement == Behavior.RequiredRejection]+        `shouldContain` ["Active", "Closed"]+      length [() | requirement <- requirements, (.guardCoverage) requirement == Behavior.GuardTotal] `shouldBe` 3+      length [() | requirement <- requirements, (.guardCoverage) 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 = (.spec) 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 (.key)) (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 <- (.nodes) spec] of+        [value] -> pure value+        _ -> expectationFailure "expected one behavior-complete aggregate" >> fail "unreachable"+      let ctx = defaultContext (spec.context)+          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 [(.text) value | value <- modules, T.isSuffixOf "BehaviorHoles.hs" (T.pack ((.path) value))] of+            [value] -> value+            values -> error ("expected one BehaviorHoles module, got " <> show (length values))+          ordinaryHoles = [value | value <- modules, T.isSuffixOf "/Holes.hs" (T.pack ((.path) value)), not (T.isSuffixOf "BehaviorHoles.hs" (T.pack ((.path) 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 == requirement.requirementCommandName"+      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\" .= behaviorFailure.failureSubject"+      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 (duplicate.context)) 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+              { specPath = "behavior-complete.keiro",+                moduleRoot = "",+                layout = "prefixed",+                sourceLanguage = DeclaredLanguage version noLoc,+                languageContract = effectiveLanguageContract (DeclaredLanguage version noLoc),+                namingEdition = IdiomaticNamingV1,+                moduleRoles = [],+                files = [],+                mappings = [],+                idDomains = [],+                nominalEqualities = [],+                bindingObligations = [],+                behaviorRequirements = rows,+                projectionCatalogFacts = [],+                queryContractBaseline = True,+                queryContracts = [],+                routerSelections = [],+                semanticImpact = 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 ((.mergedSpec) workspace))+      let ownedRequirements =+            map+              (Behavior.attributeBehaviorOwner (fmap fst . nodeOwner ((.ownership) workspace) "aggregate"))+              workspaceRequirements+          ownedRows = Behavior.behaviorRecordRows ownedRequirements+          workspaceRecord =+            WorkspaceRecord+              { service = (.service) workspace,+                manifest = "service.keiro-workspace",+                context = workspace.context,+                moduleRoot = "",+                layout = "prefixed",+                members = map (.path) ((.members) workspace),+                sourceLanguages = [WorkspaceSourceLanguageRow ((.path) member) ((.sourceLanguage) member) | member <- (.members) workspace],+                languageContract = (.languageContract) workspace,+                namingEdition = IdiomaticNamingV1,+                modules = [],+                mappings = [],+                idDomains = [],+                nominalEqualities = [],+                bindingObligations = [],+                requirements = ownedRows,+                projectionCatalogFacts = [],+                queryContractBaseline = True,+                queryContracts = [],+                routerSelections = [],+                adopted = [],+                semanticImpact = Nothing+              }+      map (.owner) 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 (.category) obligations `shouldSatisfy` all (`elem` ["nominal-id", "nominal-enum", "nominal-scalar"])+      length [() | obligation <- obligations, (.equalityContract) obligation /= Nothing] `shouldBe` 2+      renderBindingObligations (spec.context) obligations `shouldSatisfy` T.isInfixOf "equality-contract:"+      let signatures = map (.signature) 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 (.canonicalType) obligations `shouldSatisfy` all (/= Nothing)+      let rendered = renderBindingObligations (spec.context) 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) -> (.errorCode) 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 (spec.context)+          modules = scaffoldModules ctx spec+          moduleAt path = case [value | value <- modules, value.path == path] of+            [value] -> pure value+            values -> expectationFailure ("expected one module at " <> path <> ", got " <> show (map (.path) 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 (.path) modules `shouldNotContain` ["NominalScalars/NominalLedger/Holes.hs"]+      (.text) domainModule `shouldSatisfy` T.isInfixOf "import NominalConformance.Domain (AccountNumber, FeatureFlag, ObservedAt, OrderId, OrderStatus, RiskScore, SequenceNumber)"+      (.text) domainModule `shouldSatisfy` T.isInfixOf "orderId :: !OrderId"+      (.text) domainModule `shouldSatisfy` (not . T.isInfixOf "NominalConformance.Domain.OrderId")+      (.text) domainModule `shouldSatisfy` (not . T.isInfixOf "newtype OrderId")+      (.text) domainModule `shouldSatisfy` (not . T.isInfixOf "data OrderStatus =")+      (.text) codecModule `shouldSatisfy` T.isInfixOf "KindID.parseText @\"ord\""+      (.text) codecModule `shouldSatisfy` T.isInfixOf "KindID.toText (nominalToRepresentation"+      (.text) codecModule `shouldSatisfy` T.isInfixOf "nominalFromRepresentation"+      forM_ ["coerce", "unsafe", "read ", "error "] $ \forbidden ->+        (.text) codecModule `shouldSatisfy` (not . T.isInfixOf forbidden)+      (.text) enumModule `shouldSatisfy` T.isInfixOf "data OrderStatusRepresentation = Draft | Submitted"+      (.text) enumModule `shouldSatisfy` (not . T.isInfixOf "NominalConformance")+      (.text) projectionModule `shouldSatisfy` T.isInfixOf "type FieldOwner AccountNumberNominalProjection = AccountNumber"+      (.text) projectionModule `shouldSatisfy` T.isInfixOf "projectFieldValue _ = nominalToRepresentation Bindings.accountNumberBinding"+      (.text) projectionModule `shouldSatisfy` T.isInfixOf "instance ExactFieldProjection OrderIdEqualityProjection"+      (.text) projectionModule `shouldSatisfy` T.isInfixOf "textProjectionDomain orderIdEqualityPattern"+      (.text) projectionModule `shouldSatisfy` T.isInfixOf "instance ExactFieldProjection OrderStatusEqualityProjection"+      (.text) projectionModule `shouldSatisfy` T.isInfixOf "finiteProjectionDomain (\"draft\" :| [\"submitted\"])"+      (.kind) bindingModule `shouldBe` HoleStub+      (.text) bindingModule `shouldSatisfy` T.isInfixOf "import NominalConformance.Domain (AccountNumber, FeatureFlag, ObservedAt, OrderId, OrderStatus, RiskScore, SequenceNumber)"+      (.text) bindingModule `shouldSatisfy` T.isInfixOf "orderIdBinding :: NominalBinding OrderId (KindID \"ord\")"+      (.text) 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+              { specPath = "nominal-scalars.keiro",+                moduleRoot = "",+                layout = "prefixed",+                sourceLanguage = LegacyUnversioned,+                languageContract = effectiveLanguageContract LegacyUnversioned,+                namingEdition = IdiomaticNamingV1,+                moduleRoles = [],+                files = [],+                mappings = (.mappings) plan,+                idDomains = [],+                nominalEqualities = nominalEqualityIdentities spec,+                bindingObligations = [],+                behaviorRequirements = [],+                projectionCatalogFacts = [],+                queryContractBaseline = True,+                queryContracts = [],+                routerSelections = [],+                semanticImpact = Nothing+              }+          encoded = renderRecord record+          workspaceRecord =+            (sampleWorkspaceRecord workspace)+              { WorkspaceRecord.mappings = plan.mappings+              }+          workspaceEncoded = renderWorkspaceRecord workspaceRecord+      (.packages) plan `shouldBe` ["nominal-conformance"]+      length [() | NominalMapping {} <- (.mappings) 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+              ( aggregateWithRegs+                  [ if register.name == "orderId"+                      then regDeclWithInitial (RegInitBare "placeholder") register+                      else register+                  | register <- aggregate.regs+                  ]+                  aggregate+              )+          useGeneratedIdInitial node = node+          unbound =+            specWithIdsAndNodes+              [idDeclWithBinding Nothing declaration | declaration <- current.ids]+              (map useGeneratedIdInitial current.nodes)+              current+          adoption = diffSpecs unbound current+          decoderFindings = [kindOfChange change | change <- adoption, changeCode change == NominalIdDecoderTightened]+      map (.subject) decoderFindings `shouldContain` ["NominalLedger event NominalsRecorded .orderId"]+      decoderFindings `shouldSatisfy` all ((== VAdvisory) . verdictFor PrivateHistoryRead . (.vector))+      let bumped =+            specWithIds+              [ idDeclWithBinding (fmap (nominalBindingWithVersion (Just "2")) declaration.binding) declaration+              | declaration <- current.ids+              ]+              current+          bindingChanges = diffSpecs current bumped+      map changeCode bindingChanges `shouldContain` [NominalBindingChanged]+      replayImpactSpecs current bumped `shouldSatisfy` \case+        ReplayImpact.ReplayAffected impacts ->+          maybe False (\impact -> Set.member "NominalsRecorded" ((.eventTypes) impact) && (.includeSnapshotStreams) impact) (Map.lookup "NominalLedger" impacts)+        ReplayImpact.ReplayNeutral -> False+      case [aggregate | NAggregate aggregate <- (.nodes) 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")]+      (.coverageGaps) 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 (spec.context)+          planned = codecComparisonModule ctx spec "ArtifactInfo"+          ordinary = scaffoldModules ctx spec+      case planned of+        Left err -> expectationFailure (T.unpack err)+        Right comparisonModule -> do+          (.path) comparisonModule+            `shouldBe` "Generated/StructuralConformance/Structural/CodecCompare/ArtifactInfo.hs"+          (.text) comparisonModule `shouldSatisfy` T.isInfixOf codecComparisonBanner+          (.text) comparisonModule `shouldSatisfy` T.isInfixOf "Generated.StructuralConformance.ArtifactCatalog.Codec qualified as GeneratedCodec"+          (.text) comparisonModule `shouldSatisfy` T.isInfixOf "branchSchema = BranchRecord"+          map (.path) ordinary `shouldNotContain` [(.path) comparisonModule]+    it "refuses opaque selections rather than upgrading their claim" $ do+      spec <- specOf "test/fixtures/structural-conformance.keiro"+      codecComparisonModule (defaultContext (spec.context)) 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+      (.privateEventPayloads) ((.summary) report)+        `shouldBe` Coverage.CoverageCounts 2 1 1 0+      (.snapshotRegisters) ((.summary) report)+        `shouldBe` Coverage.CoverageCounts 2 1 1 0+      map (.mappedType) ((.opaqueBoundaries) report)+        `shouldBe` ["VendorGeometry"]+      map (.encoding) ((.snapshotBoundaries) report)+        `shouldBe` ["consumer-json-cache", "consumer-json-cache"]+      map (.invalidation) ((.snapshotBoundaries) report)+        `shouldBe` ["tracked-by-mapped-wire-fingerprint", "tracked-by-mapped-wire-fingerprint"]+      map (.code) ((.findings) report)+        `shouldBe` [CoverageOpaqueSurface]+      map (.severity) ((.findings) 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+      (.workqueuePayloads) ((.summary) report)+        `shouldBe` Coverage.CoverageCounts 1 1 0 1+      map (.path) [root | root <- (.roots) report, (.surface) root == Coverage.WorkqueuePayload]+        `shouldBe` ["workqueue ArtifactJobs payload .jobData : ArtifactInfo [] optional"]+      map (.path) [boundary | boundary <- (.jsonBoundaries) report, (.surface) boundary == Coverage.WorkqueuePayload]+        `shouldContain` ["workqueue ArtifactJobs payload .jobData : ArtifactInfo [] optional .extra"]+      map (.surface) ((.unsupportedSurfaces) 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+      (.workqueuePayloads) ((.summary) report)+        `shouldBe` Coverage.CoverageCounts 0 0 0 1+      map (.path) [boundary | boundary <- (.jsonBoundaries) report, (.surface) 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+      (.jsonBoundaries) ((.privateEventPayloads) ((.summary) report))+        `shouldBe` 1+      map (.path) ((.jsonBoundaries) 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)+      (.opaqueRoots) ((.privateEventPayloads) ((.summary) clear)) `shouldBe` 0+      (.opaqueBoundaries) clear `shouldBe` []+      (.findings) clear `shouldBe` []+      opaque <- shouldResolveCoverage "structural-conformance.keiro" original+      Coverage.coverageSucceeded opaque `shouldBe` True+      let gated = Coverage.failOnOpaque opaque+      Coverage.coverageSucceeded gated `shouldBe` False+      map (.code) ((.findings) gated)+        `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueGateExceeded]+      map (.severity) ((.findings) 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 (.opaqueBoundaryDelta) ((.delta) report) `shouldBe` Just 1+      fmap (map (.mappedType) . (.addedOpaqueBoundaries)) ((.delta) report)+        `shouldBe` Just ["VendorGeometry"]+      map (.code) ((.findings) report)+        `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueBoundaryAdded]+      Coverage.coverageSucceeded report `shouldBe` True+      let gated = Coverage.failOnOpaqueIncrease report+      Coverage.coverageSucceeded gated `shouldBe` False+      map (.code) ((.findings) 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 ((.nodes) s)+                roundTrip = parseSpec "<gen>" (renderSpec s) === Right s+             in cover 5 (not (null ((.mapped) 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 (.nodes) spec of+          [NAggregate first, NEmit _, NAggregate second, NPgmqDispatch _] -> do+            concatMap (.emits) ((.transitions) first) `shouldBe` ["Changed"]+            (.states) 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 ((.mapped) 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} <- (.mapped) spec, field <- recordFields]+          arms = [arm | MappedStructural {msShape = ShapeUnion _ unionArms} <- (.mapped) spec, arm <- unionArms]+      [value | field <- fields, Just value <- [(.onMissing) field]]+        `shouldBe` [OmCtor "Guide", OmNull, OmInt 0, OmBool False, OmEmptyList, OmEmptyMap]+      [(.valueType) field | field <- fields, (.haskell) field == "labels"]+        `shouldBe` [TList (TOptional TText)]+      [(.ctor) arm | arm <- arms, (.payload) 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 (.representation) 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 (.representation) 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 (spec.context)) spec aggregate+          generated =+            [ (.text) generatedModule+            | generatedModule <- modules,+              (.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 (spec.context)) 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, (.kind) generatedModule == Generated] $ \generatedModule -> do+        committed <- readTestText ("test/conformance-aggregate-scalars/" <> (.path) generatedModule)+        normalizeGenerated committed `shouldBe` normalizeGenerated ((.text) 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 (spec.context)) spec+               in counterexample+                    (show diagnostics <> "\n" <> show (scaffoldRefusals spec))+                    ( null diagnostics+                        && null (scaffoldRefusals spec)+                        && all (not . T.null . (.text)) 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 =+            [ ((.code) diagnostic, (.line) (NE.head ((.locations) diagnostic)), (.message) diagnostic)+            | diagnostic <- checkWorkspace composed,+              (.severity) 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 ((.declarations) graph) `shouldBe` 4+      Map.lookup (MappedKey "ArtifactInfo") ((.reachability) 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") ((.declarations) graph) of+        Just (ResolvedStructural _ (RRecord _ _ fields)) ->+          Set.fromList (concatMap (foldTypeExpr expressionTags . (.valueType)) 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"])])+              { ids = [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 (wireFieldWithHaskell "renamedKey") base)+      wireRenameGraph <- shouldResolveTypeGraph (mapArtifactField (wireFieldWithKey "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") ((.declarationConsumers) 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 (.kind) (aggregateMappedRoots impact "Alpha")+        `shouldBe` [MappedCommandFieldRoot, MappedCommandFieldRoot, MappedEventFieldRoot, MappedRegisterRoot]+      map (.kind) (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+              { mapped = reverse ((.mapped) spec),+                nodes = reverse ((.nodes) 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+              { mappedConsumers =+                  Map.adjust (Set.delete (AggregateConsumer "Beta")) shared ((.mappedConsumers) snapshot)+              }+      case diffSemanticImpact snapshot changed of+        [delta] -> do+          (.declaration) delta `shouldBe` shared+          (.previousConsumers) delta `shouldBe` Set.fromList [AggregateConsumer "Alpha", AggregateConsumer "Beta"]+          (.currentConsumers) delta `shouldBe` Set.singleton (AggregateConsumer "Alpha")+          (.serviceConformance) delta `shouldBe` True+        deltas -> expectationFailure ("expected one semantic-impact delta, got " <> show deltas)+      case mappedImpactForDeclarations [MappedKey "NestedPayload"] snapshot snapshot of+        [delta] -> do+          (.declaration) delta `shouldBe` MappedKey "NestedPayload"+          (.previousConsumers) delta `shouldBe` Set.singleton (AggregateConsumer "Alpha")+          (.currentConsumers) delta `shouldBe` Set.singleton (AggregateConsumer "Alpha")+          (.previousEvidence) delta `shouldSatisfy` maybe False (not . Set.null)+          (.currentConsequences) 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+              { specPath = "semantic-impact.keiro",+                moduleRoot = "",+                layout = "prefixed",+                sourceLanguage = LegacyUnversioned,+                languageContract = effectiveLanguageContract LegacyUnversioned,+                namingEdition = IdiomaticNamingV1,+                moduleRoles = [],+                files = [],+                mappings = [],+                idDomains = [],+                nominalEqualities = [],+                bindingObligations = [],+                behaviorRequirements = [],+                projectionCatalogFacts = [],+                queryContractBaseline = True,+                queryContracts = either (const []) id (queryContractIdentities spec),+                routerSelections = [],+                semanticImpact = 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 =+            SemanticImpactSnapshot+              { mappedConsumers = snapshot.mappedConsumers,+                mappedEvidence = snapshot.mappedEvidence,+                mappedConsequences = snapshot.mappedConsequences,+                serviceInventory = snapshot.serviceInventory,+                declarationIdentities = Map.adjust (const "") (MappedKey "CommandPayload") snapshot.declarationIdentities+              }+      length semanticRows `shouldBe` 1+      parseRecord encoded `shouldBe` Just singleRecord+      (.semanticImpact) <$> 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) {WorkspaceRecord.semanticImpact = 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 <- (.nodes) spec, row <- e.map] of+          [row] -> do+            (.value) row `shouldBe` "a\" => Wat \"b"+            (.event) 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))))+      [wire.schemaVersion | NAggregate aggregate <- (.nodes) spec, Just wire <- [(.wire) 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)),+              (.code) diagnostic == GeneratedOccurrenceReserved+            ]+          workspaceLocations =+            [ ((.file) location, (.line) location)+            | diagnostic <- workspaceDiagnostics,+              location <- NE.toList ((.locations) 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 (spec.context)+          modules = scaffoldServiceModules ctx service+      concatMap auditGeneratedHaskell modules `shouldBe` []+    it "rejects underscore module and declaration mutations but ignores literals and comments" $ do+      let mutated =+            ScaffoldModule+              { path = "Generated/IncidentPaging/Service_oncall/Mutation.hs",+                text =+                  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+              { path = "Generated/Repeated.hs",+                text =+                  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+              { path = "Generated/IncidentPaging/ServiceOncall/ReadModel.hs",+                text = "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+              { role = moduleRole currentModule,+                kind = Generated,+                oldModule = "Generated.IncidentPaging.Service_oncall.ReadModel",+                newModule = "Generated.IncidentPaging.ServiceOncall.ReadModel",+                oldPath = "Generated/IncidentPaging/Service_oncall/ReadModel.hs",+                newPath = "Generated/IncidentPaging/ServiceOncall/ReadModel.hs",+                backupPath = ".keiro-dsl-name-migrations/legacy-v1-to-idiomatic-v1/Generated/IncidentPaging/Service_oncall/ReadModel.hs",+                contentDigest = Nothing,+                transformedDigest = 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 "requires both flags when a legacy ledger needs only sidecar renames" $ do+      withTempDirectory "keiro-dsl-sidecar-only-name-migration" $ \out -> do+        spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+        let service = legacyCheckedService spec+            ctx = defaultContext (spec.context)+        modules <- case planTestServiceScaffold ctx service of+          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"+          Right planned -> pure planned+        initial <- executeServiceScaffoldWithRuntimePackageAndMigrations Nothing False False out False "incident-paging.keiro" LegacyUnversioned ctx service modules+        case initial of+          Left refusals -> expectationFailure (show refusals)+          Right _ -> pure ()+        let recordPath = out </> recordFileName (spec.context)+            fragmentPath = out </> contextCabalFragmentFileName (spec.context)+        currentRecord <-+          TIO.readFile recordPath >>= \contents ->+            maybe (expectationFailure "fresh scaffold record did not parse" >> fail "unreachable") pure (parseRecord contents)+        TIO.writeFile recordPath (renderRecord (scaffoldRecordWithEdition LegacyNamingV1 currentRecord))+        renameFile recordPath (out </> legacyContextRecordFileName (spec.context))+        renameFile fragmentPath (out </> legacyContextManifestFileName (spec.context))+        nameOnly <- executeServiceScaffoldWithRuntimePackageAndMigrations Nothing True False out False "incident-paging.keiro" LegacyUnversioned ctx service modules+        nameOnly `shouldSatisfy` \case+          Left [NameMigrationRequired [], GeneratedHaskellEditionRequired impact, SidecarMovesAlreadyApplied sidecars] ->+            (.fromEdition) impact == LegacyNamingV1 && length sidecars == 2+          _ -> False++      withTempDirectory "keiro-dsl-workspace-sidecar-only-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 service = (.service) workspace+            recordPath = out </> workspaceRecordFileName service+            fragmentPath = out </> workspaceManifestFileName service+        currentRecord <-+          TIO.readFile recordPath >>= \contents ->+            maybe (expectationFailure "fresh workspace record did not parse" >> fail "unreachable") pure (parseWorkspaceRecord contents)+        TIO.writeFile recordPath (renderWorkspaceRecord (workspaceRecordWithEditionAndModules LegacyNamingV1 currentRecord.modules currentRecord))+        renameFile recordPath (out </> legacyWorkspaceRecordFileName service)+        renameFile fragmentPath (out </> legacyWorkspaceManifestFileName service)+        nameOnly <- executeWorkspaceScaffoldWithMigrations out False True False plan+        nameOnly `shouldSatisfy` \case+          Left [NameMigrationRequired [], GeneratedHaskellEditionRequired impact, SidecarMovesAlreadyApplied sidecars] ->+            (.fromEdition) impact == LegacyNamingV1 && length sidecars == 2+          _ -> False+    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 (spec.context)+        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 ((.path) scaffoldModule)) ["ServiceOncall/ReadModel.hs", "ServiceOncall/ReadModelHoles.hs"]+              ]+            legacyPath = T.unpack . T.replace "ServiceOncall" "Service_oncall" . T.pack+            reverseModules =+              Map.fromList+                [ (moduleNameFromPath ((.path) scaffoldModule), moduleNameFromPath (legacyPath ((.path) scaffoldModule)))+                | scaffoldModule <- selected+                ]+        forM_ selected $ \scaffoldModule -> do+          legacyText <- case rewriteHaskellModuleReferences reverseModules ((.text) scaffoldModule) of+            Left err -> expectationFailure (show err) >> fail "unreachable"+            Right source -> pure source+          let oldPath = out </> legacyPath ((.path) 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+                { specPath = "incident-paging.keiro",+                  moduleRoot = "",+                  layout = "prefixed",+                  sourceLanguage = LegacyUnversioned,+                  languageContract = effectiveLanguageContract LegacyUnversioned,+                  namingEdition = LegacyNamingV1,+                  moduleRoles = [],+                  files = [((.kind) scaffoldModule, legacyPath ((.path) scaffoldModule)) | scaffoldModule <- selected],+                  mappings = [],+                  idDomains = [],+                  nominalEqualities = [],+                  bindingObligations = [],+                  behaviorRequirements = [],+                  projectionCatalogFacts = [],+                  queryContractBaseline = False,+                  queryContracts = [],+                  routerSelections = [],+                  semanticImpact = Nothing+                }+            recordPath = out </> recordFileName (spec.context)+        TIO.writeFile recordPath (renderRecord legacyRecord)+        let currentFragment = out </> contextCabalFragmentFileName (spec.context)+            legacyRecordPath = out </> legacyContextRecordFileName (spec.context)+            legacyFragmentPath = out </> legacyContextManifestFileName (spec.context)+        TIO.writeFile currentFragment "legacy cabal fragment\n"+        renameFile recordPath legacyRecordPath+        renameFile currentFragment legacyFragmentPath+        beforeMigration <- treeSnapshot out+        refused <- executeServiceScaffoldWithRuntimePackageAndNameMigrations Nothing False out False "incident-paging.keiro" LegacyUnversioned ctx service modules+        refused `shouldSatisfy` \case+          Left [SidecarMigrationRequired sidecars, GeneratedHaskellEditionRequired impact] ->+            length sidecars == 2 && (.fromEdition) impact == LegacyNamingV1+          _ -> False+        renderRefusals (either id (const []) refused)+          `shouldSatisfy` any (T.isInfixOf "needs both --apply-name-migrations and --apply-generated-haskell-edition")+        treeSnapshot out `shouldReturn` beforeMigration++        nameOnly <- executeServiceScaffoldWithRuntimePackageAndMigrations Nothing True False out False "incident-paging.keiro" LegacyUnversioned ctx service modules+        nameOnly `shouldSatisfy` \case+          Left [NameMigrationRequired moves, GeneratedHaskellEditionRequired impact, SidecarMovesAlreadyApplied sidecars] ->+            length moves == 2+              && all ((/= Nothing) . (.contentDigest)) moves+              && all ((/= Nothing) . (.transformedDigest)) moves+              && (.fromEdition) impact == LegacyNamingV1+              && length sidecars == 2+          _ -> False+        applied <- executeServiceScaffoldWithRuntimePackageAndMigrations Nothing True 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 ((.nameMoves) report) `shouldBe` 2+        let editionBackupRoot = out </> ".keiro-dsl-generated-haskell-migrations/legacy-v1-to-idiomatic-v2"+        doesFileExist (editionBackupRoot </> recordFileName (spec.context)) `shouldReturn` True+        doesFileExist (editionBackupRoot </> contextCabalFragmentFileName (spec.context)) `shouldReturn` True+        remediation <- TIO.readFile (editionBackupRoot </> "remediation-report.txt")+        remediation `shouldSatisfy` T.isInfixOf "source-moves: 2"+        remediation `shouldSatisfy` T.isInfixOf "Service_oncall/ReadModel.hs -> Generated/IncidentPaging/ServiceOncall/ReadModel.hs"+        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 <- executeServiceScaffoldWithRuntimePackageAndMigrations Nothing True True out False "incident-paging.keiro" LegacyUnversioned ctx service modules+        case rerun of+          Left refusals -> expectationFailure (show refusals)+          Right rerunReport -> (.nameMoves) 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 </> (.path) scaffoldModule+              preparedPath = newPath <> ".keiro-dsl-name-migration-prepared"+          bytes <- TIO.readFile newPath+          renameFile newPath preparedPath+          pure (preparedPath, bytes)+        -- This is specifically the name-move crash state. Keep the ledger at+        -- the current presentation edition so the independent edition-backup+        -- conflict gate does not mask the prepared-source digest check.+        TIO.writeFile recordPath (renderRecord (scaffoldRecordWithEdition IdiomaticNamingV2 legacyRecord))+        case preparedSnapshots of+          (firstPrepared, firstBytes) : _ -> TIO.writeFile firstPrepared (firstBytes <> "\ncorrupt")+          [] -> expectationFailure "expected prepared migration sources"+        conflicted <- executeServiceScaffoldWithRuntimePackageAndMigrations Nothing True 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 <- executeServiceScaffoldWithRuntimePackageAndMigrations Nothing True True out False "incident-paging.keiro" LegacyUnversioned ctx service modules+        case resumed of+          Left refusals -> expectationFailure (show refusals)+          Right resumedReport -> length ((.nameMoves) 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 ((.service) workspace)+        currentRecord <-+          TIO.readFile recordPath >>= \contents ->+            maybe (expectationFailure "fresh workspace record did not parse" >> fail "unreachable") pure (parseWorkspaceRecord contents)+        let selectedRows = [row | row <- (.modules) currentRecord, "ProjectActivity" `T.isInfixOf` T.pack ((.path) row)]+            legacyPath = T.unpack . T.replace "ProjectActivity" "Project_activity" . T.pack+            reverseModules =+              Map.fromList+                [ (moduleNameFromPath ((.path) row), moduleNameFromPath (legacyPath ((.path) row)))+                | row <- selectedRows+                ]+        selectedRows `shouldSatisfy` (not . null)+        forM_ selectedRows $ \row -> do+          currentSource <- TIO.readFile (out </> (.path) row)+          legacySource <- case rewriteHaskellModuleReferences reverseModules currentSource of+            Left err -> expectationFailure (show err) >> fail "unreachable"+            Right source -> pure source+          writeFileWithParents (out </> legacyPath ((.path) row)) legacySource+          removeFile (out </> (.path) row)+        let legacyRecord =+              workspaceRecordWithEditionAndModules+                LegacyNamingV1+                [ if row `elem` selectedRows then workspaceModuleRowWithPath (legacyPath row.path) row else row+                | row <- currentRecord.modules+                ]+                currentRecord+            ownersBefore = Map.fromList [((.role) row, (.owner) row) | row <- selectedRows]+        TIO.writeFile recordPath (renderWorkspaceRecord legacyRecord)+        let currentFragment = out </> workspaceManifestFileName ((.service) workspace)+            legacyRecordPath = out </> legacyWorkspaceRecordFileName ((.service) workspace)+            legacyFragmentPath = out </> legacyWorkspaceManifestFileName ((.service) workspace)+        renameFile recordPath legacyRecordPath+        renameFile currentFragment legacyFragmentPath+        beforeMigration <- treeSnapshot out+        refused <- executeWorkspaceScaffoldWithNameMigrations out False False plan+        refused `shouldSatisfy` \case+          Left [SidecarMigrationRequired sidecars, GeneratedHaskellEditionRequired impact] ->+            length sidecars == 2 && (.fromEdition) impact == LegacyNamingV1+          _ -> False+        treeSnapshot out `shouldReturn` beforeMigration+        nameOnly <- executeWorkspaceScaffoldWithMigrations out False True False plan+        nameOnly `shouldSatisfy` \case+          Left [NameMigrationRequired moves, GeneratedHaskellEditionRequired impact, SidecarMovesAlreadyApplied sidecars] ->+            length moves == length selectedRows+              && (.fromEdition) impact == LegacyNamingV1+              && length sidecars == 2+          _ -> False+        applied <- executeWorkspaceScaffoldWithMigrations out False True True plan+        report <- case applied of+          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"+          Right value -> pure value+        length ((.nameMoves) report) `shouldBe` length selectedRows+        let editionBackupRoot = out </> ".keiro-dsl-generated-haskell-migrations/legacy-v1-to-idiomatic-v2"+        doesFileExist (editionBackupRoot </> workspaceRecordFileName ((.service) workspace)) `shouldReturn` True+        doesFileExist (editionBackupRoot </> workspaceManifestFileName ((.service) workspace)) `shouldReturn` True+        remediation <- TIO.readFile (editionBackupRoot </> "remediation-report.txt")+        remediation `shouldSatisfy` T.isInfixOf ("source-moves: " <> T.pack (show (length selectedRows)))+        migratedRecord <-+          TIO.readFile recordPath >>= \contents ->+            maybe (expectationFailure "migrated workspace record did not parse" >> fail "unreachable") pure (parseWorkspaceRecord contents)+        (.namingEdition) migratedRecord `shouldBe` IdiomaticNamingV2+        let migratedRows = [row | row <- (.modules) migratedRecord, (.role) row `Map.member` ownersBefore]+        Map.fromList [((.role) row, (.owner) row) | row <- migratedRows] `shouldBe` ownersBefore+        map (.path) migratedRows `shouldSatisfy` all (not . T.isInfixOf "Project_activity" . T.pack)+        forM_ selectedRows $ \row -> do+          doesFileExist (out </> legacyPath ((.path) row)) `shouldReturn` False+          doesFileExist (out </> (.path) row) `shouldReturn` True+          doesFileExist (out </> ".keiro-dsl-name-migrations/legacy-v1-to-idiomatic-v1" </> legacyPath ((.path) row)) `shouldReturn` True++  describe "generated Haskell edition migration" $ do+    it "refuses without mutation and adopts idiomatic-v2 with durable backups while preserving Hole bytes" $+      withTempDirectory "keiro-dsl-generated-haskell-edition" $ \out -> do+        parsed <- parsedSourceOf "test/fixtures/behavior-complete.keiro"+        let service = checkedSource parsed+            spec = checkedSpec service+            ctx = defaultContext (spec.context)+            sourceLanguage = (.sourceLanguage) parsed+        modules <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planTestServiceScaffold ctx service)+        let runAt applyEdition =+              executeServiceScaffoldWithRuntimePackageAndMigrations+                Nothing+                False+                applyEdition+                out+                False+                "behavior-complete.keiro"+                sourceLanguage+                ctx+                service+                modules+        _ <- runAt False >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        let recordPath = out </> recordFileName (spec.context)+            backupRoot = out </> ".keiro-dsl-generated-haskell-migrations/legacy-v1-to-idiomatic-v2"+        currentRecord <-+          TIO.readFile recordPath >>= \contents ->+            maybe (expectationFailure "fresh scaffold record did not parse" >> fail "unreachable") pure (parseRecord contents)+        let legacyRecord = scaffoldRecordWithEdition LegacyNamingV1 currentRecord+            behaviorHole =+              head+                [ out </> (.path) scaffoldModule+                | scaffoldModule <- modules,+                  (.kind) scaffoldModule == HoleStub,+                  "BehaviorHoles.hs" `T.isSuffixOf` T.pack ((.path) scaffoldModule)+                ]+        TIO.writeFile recordPath (renderRecord legacyRecord)+        originalHole <- TIO.readFile behaviorHole+        let legacyHole =+              originalHole+                <> T.unlines+                  [ "",+                    "editionMigrationPrefix f = failureCode f",+                    "editionMigrationQualified f = BC.failureCode f",+                    "editionMigrationDot f = f.failureCode",+                    "editionMigrationField f = f {failureCode = \"x\"}",+                    "editionMigrationOperator fs = failureCode <$> fs",+                    "-- failureCode f",+                    "editionMigrationCurrent f = f.code"+                  ]+        TIO.writeFile behaviorHole legacyHole+        beforeRefusal <- treeSnapshot out+        refused <- runAt False+        refused `shouldSatisfy` \case+          Left [GeneratedHaskellEditionRequired impact] ->+            (.fromEdition) impact == LegacyNamingV1+              && not (null ((.generatedPaths) impact))+              && length ((.sidecarPaths) impact) == 2+              && Set.fromList [((.current) use, (.form) use) | use <- (.handOwnedUses) impact]+                == Set.fromList+                  [ ("failureCode", PrefixApplication),+                    ("failureCode", QualifiedApplication),+                    ("failureCode", RecordDotRenamed),+                    ("failureCode", RecordFieldBinding),+                    ("failureCode", OperatorOperand)+                  ]+          _ -> False+        renderRefusals (either id (const []) refused)+          `shouldSatisfy` \lines' ->+            any (T.isInfixOf "--apply-generated-haskell-edition") lines'+              && any (T.isInfixOf "legacy-v1 -> idiomatic-v2") lines'+        treeSnapshot out `shouldReturn` beforeRefusal++        _ <- runAt True >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        TIO.readFile behaviorHole `shouldReturn` legacyHole+        backupRecord <- TIO.readFile (backupRoot </> recordFileName (spec.context))+        backupRecord `shouldSatisfy` T.isInfixOf "naming-edition legacy-v1"+        adoptedRecord <- TIO.readFile recordPath+        adoptedRecord `shouldSatisfy` T.isInfixOf "naming-edition idiomatic-v2"+        remediation <- TIO.readFile (backupRoot </> "remediation-report.txt")+        remediation `shouldSatisfy` T.isInfixOf "failureCode (PrefixApplication) -> record.code"+        remediation `shouldSatisfy` T.isInfixOf "attributable uses only"++        backedUpFiles <- treeSnapshot backupRoot+        forM_ backedUpFiles $ \(path, contents) ->+          unless (path == "remediation-report.txt") (writeFileWithParents (out </> path) contents)+        TIO.writeFile behaviorHole originalHole+        _ <- runAt True >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        refreshedRemediation <- TIO.readFile (backupRoot </> "remediation-report.txt")+        refreshedRemediation `shouldSatisfy` T.isInfixOf "hand-owned-selector-uses: 0"+        rerun <- runAt False+        case rerun of+          Left failures -> expectationFailure (show failures)+          Right _ -> pure ()+    it "uses the same refusal and backup protocol for a workspace ledger" $+      withTempDirectory "keiro-dsl-workspace-generated-haskell-edition" $ \out -> do+        workspace <- shouldComposeWorkspace canonicalWorkspacePath+        plan <- shouldPlanWorkspaceSpec workspace+        _ <- executeWorkspaceScaffold out False plan >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        let recordPath = out </> workspaceRecordFileName ((.service) workspace)+            backupRecord =+              out+                </> ".keiro-dsl-generated-haskell-migrations/legacy-v1-to-idiomatic-v2"+                </> workspaceRecordFileName ((.service) workspace)+        currentRecord <- TIO.readFile recordPath+        TIO.writeFile recordPath (T.unlines (filter (not . T.isPrefixOf "naming-edition ") (T.lines currentRecord)))+        beforeRefusal <- treeSnapshot out+        refused <- executeWorkspaceScaffoldWithMigrations out False False False plan+        refused `shouldSatisfy` \case+          Left [GeneratedHaskellEditionRequired impact] ->+            (.fromEdition) impact == LegacyNamingV1 && not (null ((.generatedPaths) impact))+          _ -> False+        treeSnapshot out `shouldReturn` beforeRefusal+        _ <- executeWorkspaceScaffoldWithMigrations out False False True plan >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        backedUp <- TIO.readFile backupRecord+        backedUp `shouldSatisfy` (not . T.isInfixOf "naming-edition ")+        adopted <- TIO.readFile recordPath+        adopted `shouldSatisfy` T.isInfixOf "naming-edition idiomatic-v2"+    it "refuses an unreadable single-spec ledger without changing the tree" $+      withTempDirectory "keiro-dsl-unreadable-ledger" $ \out -> do+        parsed <- parsedSourceOf "test/fixtures/behavior-complete.keiro"+        let service = checkedSource parsed+            spec = checkedSpec service+            ctx = defaultContext (spec.context)+            sourceLanguage = (.sourceLanguage) parsed+        modules <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planTestServiceScaffold ctx service)+        let run =+              executeServiceScaffoldWithRuntimePackageAndMigrations+                Nothing+                False+                False+                out+                False+                "behavior-complete.keiro"+                sourceLanguage+                ctx+                service+                modules+            recordPath = out </> recordFileName (spec.context)+        _ <- run >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        TIO.appendFile recordPath "spec: duplicate.keiro\n"+        before <- treeSnapshot out+        run `shouldReturn` Left [LedgerUnreadable recordPath]+        treeSnapshot out `shouldReturn` before+    it "refuses an unreadable workspace ledger without changing the tree" $+      withTempDirectory "keiro-dsl-workspace-unreadable-ledger" $ \out -> do+        workspace <- shouldComposeWorkspace canonicalWorkspacePath+        plan <- shouldPlanWorkspaceSpec workspace+        _ <- executeWorkspaceScaffold out False plan >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        let recordPath = out </> workspaceRecordFileName ((.service) workspace)+        TIO.appendFile recordPath "service: duplicate\n"+        before <- treeSnapshot out+        executeWorkspaceScaffoldWithMigrations out False False False plan+          `shouldReturn` Left [LedgerUnreadable recordPath]+        treeSnapshot out `shouldReturn` before+    it "refuses a tampered edition backup without changing the tree" $+      withTempDirectory "keiro-dsl-tampered-edition-backup" $ \out -> do+        parsed <- parsedSourceOf "test/fixtures/behavior-complete.keiro"+        let service = checkedSource parsed+            spec = checkedSpec service+            ctx = defaultContext (spec.context)+            sourceLanguage = (.sourceLanguage) parsed+        modules <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planTestServiceScaffold ctx service)+        let runAt applyEdition =+              executeServiceScaffoldWithRuntimePackageAndMigrations Nothing False applyEdition out False "behavior-complete.keiro" sourceLanguage ctx service modules+            recordPath = out </> recordFileName (spec.context)+            backupRoot = out </> ".keiro-dsl-generated-haskell-migrations/idiomatic-v1-to-idiomatic-v2"+        _ <- runAt False >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        currentRecord <- TIO.readFile recordPath >>= maybe (fail "fresh record did not parse") pure . parseRecord+        TIO.writeFile recordPath (renderRecord (scaffoldRecordWithEdition IdiomaticNamingV1 currentRecord))+        _ <- runAt True >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        backedUpFiles <- treeSnapshot backupRoot+        forM_ backedUpFiles $ \(path, contents) ->+          unless (path == "remediation-report.txt") (writeFileWithParents (out </> path) contents)+        let generatedBackup =+              head [path | (path, _) <- backedUpFiles, takeExtension path == ".hs"]+        TIO.appendFile (backupRoot </> generatedBackup) "\n-- tampered\n"+        beforeRefusal <- treeSnapshot out+        refused <- runAt True+        refused `shouldSatisfy` \case+          Left [GeneratedHaskellEditionRefusal [reason]] -> T.pack generatedBackup `T.isInfixOf` reason+          _ -> False+        treeSnapshot out `shouldReturn` beforeRefusal+    it "detects an interrupted apply while the ledger is pre-current and recovers after restoring backups" $+      withTempDirectory "keiro-dsl-interrupted-edition-apply" $ \out -> do+        parsed <- parsedSourceOf "test/fixtures/behavior-complete.keiro"+        let service = checkedSource parsed+            spec = checkedSpec service+            ctx = defaultContext (spec.context)+            sourceLanguage = (.sourceLanguage) parsed+        modules <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure (planTestServiceScaffold ctx service)+        let runAt applyEdition =+              executeServiceScaffoldWithRuntimePackageAndMigrations Nothing False applyEdition out False "behavior-complete.keiro" sourceLanguage ctx service modules+            recordRelative = recordFileName (spec.context)+            recordPath = out </> recordRelative+            backupRoot = out </> ".keiro-dsl-generated-haskell-migrations/idiomatic-v1-to-idiomatic-v2"+        _ <- runAt False >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        currentRecord <- TIO.readFile recordPath >>= maybe (fail "fresh record did not parse") pure . parseRecord+        TIO.writeFile recordPath (renderRecord (scaffoldRecordWithEdition IdiomaticNamingV1 currentRecord))+        forM_ [out </> path | (Generated, path) <- (.files) currentRecord] $ \path ->+          TIO.appendFile path "\n-- pre-adoption edition bytes\n"+        initialRefusal <- runAt False+        generatedCount <- case initialRefusal of+          Left [GeneratedHaskellEditionRequired impact] -> pure (length ((.generatedPaths) impact))+          other -> expectationFailure (show other) >> fail "unreachable"+        _ <- runAt True >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        cleanApply <- treeSnapshot out+        -- Conflict detection is active only while the ledger records a+        -- pre-current edition; restoring just that ledger models interruption.+        TIO.readFile (backupRoot </> recordRelative) >>= TIO.writeFile recordPath+        interrupted <- runAt True+        interrupted `shouldSatisfy` \case+          Left [GeneratedHaskellEditionRefusal reasons] ->+            length reasons == generatedCount && all (T.isInfixOf "edition backup conflict") reasons+          _ -> False+        backedUpFiles <- treeSnapshot backupRoot+        forM_ backedUpFiles $ \(path, contents) ->+          unless (path == "remediation-report.txt") (writeFileWithParents (out </> path) contents)+        _ <- runAt True >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        treeSnapshot out `shouldReturn` cleanApply+    it "drives the built CLI through refusal, apply, and idempotent rerun" $+      withTempDirectory "keiro-dsl-edition-cli" $ \out -> do+        let fixture = "test/fixtures/behavior-complete.keiro"+        (initialCode, _, _) <- runKeiroDsl ["scaffold", fixture, "--out", out]+        initialCode `shouldBe` ExitSuccess+        spec <- specOf fixture+        let recordPath = out </> recordFileName (spec.context)+        currentRecord <- TIO.readFile recordPath+        TIO.writeFile recordPath (T.replace "naming-edition idiomatic-v2" "naming-edition idiomatic-v1" currentRecord)+        beforeRefusal <- treeSnapshot out+        (refusalCode, _, refusalError) <- runKeiroDsl ["scaffold", fixture, "--out", out]+        refusalCode `shouldBe` ExitFailure 1+        refusalError `shouldSatisfy` isInfixOf "generated Haskell edition migration required: idiomatic-v1 -> idiomatic-v2"+        treeSnapshot out `shouldReturn` beforeRefusal+        (applyCode, _, _) <- runKeiroDsl ["scaffold", fixture, "--out", out, "--apply-generated-haskell-edition"]+        applyCode `shouldBe` ExitSuccess+        afterApply <- treeSnapshot out+        (rerunCode, _, _) <- runKeiroDsl ["scaffold", fixture, "--out", out, "--apply-generated-haskell-edition"]+        rerunCode `shouldBe` ExitSuccess+        treeSnapshot out `shouldReturn` afterApply++  describe "generated Haskell presentation rewrite" $ do+    it "keeps Template Haskell quotes and promoted ticks in Code" $ do+      modernizeGeneratedHaskellSourceWithState "x = ''Foo\ny = sourceFile r\n"+        `shouldBe` ("x = ''Foo\ny = file r\n", Code)+      modernizeGeneratedHaskellSourceWithState "x = '[]\ny = sourceFile r\n"+        `shouldBe` ("x = '[]\ny = file r\n", Code)+      modernizeGeneratedHaskellSourceWithState "x = a --> sourceFile r\n"+        `shouldBe` ("x = a --> file r\n", Code)+    it "finishes every tracked Generated module in Code" $ do+      testTree <- treeSnapshot "test"+      let generatedSources = [(path, source) | (path, source) <- testTree, "/Generated/" `isInfixOf` ("/" <> path)]+      generatedSources `shouldSatisfy` (not . null)+      forM_ generatedSources $ \(path, source) -> do+        let (_, finalState) = modernizeGeneratedHaskellSourceWithState source+        unless (finalState == Code) (expectationFailure (path <> " ended in " <> show finalState))++  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 (spec.context)+            sourceLanguage = (.sourceLanguage) 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 (spec.context)+            currentFragment = contextCabalFragmentFileName (spec.context)+            oldLedger = legacyContextRecordFileName (spec.context)+            oldFragment = legacyContextManifestFileName (spec.context)+        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) . (.moveDisposition)) 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 (.moveDisposition) ((.sidecarMoves) applied) `shouldBe` [RenameSidecar, RenameSidecar]+        (.stale) applied `shouldBe` (.stale) baseline+        (.previousSpecPath) 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+        (.sidecarMoves) 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]] -> (.moveDisposition) move == RetireLegacySidecar+          _ -> False+        retired <- runAt migrated True "reservation-reduced.keiro" reduced >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        map (.moveDisposition) ((.sidecarMoves) 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 (workqueueWithPayloadName "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 (.change) (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+          (.subject) (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 = specWithNodes [node | node@NWorkqueue {} <- base.nodes] base+          renamed = mapWorkqueue (workqueueWithName "reservation_jobs") queueOnly+          findings = generatedHaskellNameFindings (diffSpecs queueOnly renamed)+      case findings of+        [finding] -> do+          assertGeneratedHaskellNameFinding finding+          (.facet) (kindOfChange finding) `shouldBe` "workqueue-module"+        values -> expectationFailure ("expected one module-name finding, got " <> show (length values))+      map ((.code) . 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 = specWithNodes [node | node@NWorkqueue {} <- base.nodes] base+          recased = mapWorkqueue (workqueueWithName "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+          spec.context `shouldBe` "hospital-capacity"+          length ((.ids) spec) `shouldBe` 3+          length ((.enums) spec) `shouldBe` 3+          length ((.rules) spec) `shouldBe` 1+          case (.nodes) spec of+            [NAggregate a] -> do+              (.name) a `shouldBe` "Reservation"+              length ((.states) a) `shouldBe` 6+              length ((.commands) a) `shouldBe` 2+              length ((.events) a) `shouldBe` 2+              length ((.transitions) a) `shouldBe` 2+              map (.terminal) ((.states) 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 <- (.nodes) spec] of+        aggregate : _ -> do+          let emptyAggregate = aggregateWithCommandsEventsTransitions [] [] [] aggregate+              emptySpec = specWithNodes [NAggregate emptyAggregate] spec+              expectedLine = unLoc ((.loc) 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 (emptySpec.context)) 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 <- (.nodes) spec] of+        contract : _ -> do+          let emptyContract = contractNodeWithEvents [] contract+              emptySpec = specWithNodes [NContract emptyContract] spec+              expectedLine = unLoc ((.loc) 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 (emptySpec.context)) 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 (publisherWithOrdering "banana") emitSpec+          unknownBackoff =+            mapPublisher+              (\publisher -> publisherWithBackoff (backoffWithKind "banana" publisher.backoff) publisher)+              emitSpec+          incompleteBackoff =+            mapPublisher+              (publisherWithBackoff (BackoffSpec "exponential" "2s" Nothing Nothing))+              emitSpec+          unknownDedupe = mapIntake (intakeWithDedupePolicy "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 (contractWithSchemaVersion 0) emitSpec+          zeroAttempts = mapPublisher (publisherWithMaxAttempts 0) emitSpec+          zeroDecode = mapIntake (\intake -> intakeWithDecode (decodeWithBodySchemaVersion 0 intake.decode) intake) intakeSpec+          zeroReadModel = modifyReadModel "transferDecision" (readModelWithVersion 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 -> aggregateWithCommands (updateFirst (\command -> commandWithFields (duplicateFirst command.fields) command) aggregate.commands) aggregate)+              reservation+          duplicateState = modifyAggregate "Reservation" (\aggregate -> aggregateWithStates (duplicateFirst aggregate.states) aggregate) reservation+          duplicateTransition =+            modifyAggregate+              "Reservation"+              (\aggregate -> aggregateWithTransitions (aggregate.transitions <> take 1 (reverse aggregate.transitions)) aggregate)+              reservation+          duplicateContractField =+            mapContract+              (\contract -> contractNodeWithEvents (updateFirst (\event -> contractEventWithFields (duplicateFirst event.fields) event) contract.events) contract)+              integration+          duplicateContractEvent = mapContract (\contract -> contractNodeWithEvents (duplicateFirst contract.events) contract) integration+          duplicateTopicAlias = mapContract (\contract -> contractWithTopics (duplicateFirst contract.topics) 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 -> aggregateWithRegs (duplicateFirst aggregate.regs) aggregate) reservation+          duplicateNominal = specWithIds (duplicateFirst reservation.ids) reservation+          duplicateMap = mapEmit (\emitNode -> emitNodeWithMap (duplicateFirst emitNode.map) emitNode) integration+          shadowDiscriminator =+            mapContract+              ( \contract ->+                  contractNodeWithEvents+                    ( updateFirst+                        (\event -> contractEventWithFields (updateFirst (contractFieldWithName contract.discriminator) event.fields) event)+                        contract.events+                    )+                    contract+              )+              integration+          guardedSibling =+            modifyAggregate+              "Reservation"+              ( \aggregate ->+                  aggregateWithTransitions+                    (aggregate.transitions <> [transitionWithGuard (Just (EAtom (ABool True))) transition | transition <- take 1 (reverse aggregate.transitions)])+                    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 (workflowWithStable "") workflowSpec+          duplicateIdentity =+            specWithNodes+              ( processSpec.nodes+                  <> [NRouter (routerWithName "surge-demo" router) | NRouter router <- routerSpec.nodes]+              )+              processSpec+          invalidTopic = mapContract (\contract -> contractWithTopics [(alias, "bad topic") | (alias, _) <- contract.topics] contract) integration+          emptyTopic = mapContract (\contract -> contractWithTopics [(alias, "") | (alias, _) <- contract.topics] contract) integration+          invalidReadModel = modifyReadModel "transferDecision" (readModelWithTable "Bad-Table") workflowSpec+          duplicateColumn = modifyReadModel "transferDecision" (\readModel -> readModelWithColumns (duplicateFirst readModel.columns) 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 -> intakeWithBinds (updateFirst (bindRowWithField "ghost") intake.binds) intake)+              intakeSpec+          acceptedEventBind =+            mapIntake+              (\intake -> intakeWithBinds (updateFirst (bindRowWithField "region") intake.binds) intake)+              intakeSpec+          unresolvedDedupe = mapIntake (intakeWithDedupeKey "ghost") intakeSpec+          unknownEnvelope = mapIntake (\intake -> intakeWithDecode (decodeWithEnvelope "banana policy" intake.decode) intake) intakeSpec+          mismatchedSchema = mapIntake (\intake -> intakeWithDecode (decodeWithBodySchemaVersion 2 intake.decode) intake) intakeSpec+          unresolvedAlias =+            mapContract+              (\contract -> contractNodeWithEvents (updateFirst (contractEventWithTopic "ghost") contract.events) contract)+              intakeSpec+          unsupportedWire =+            modifyAggregate+              "Reservation"+              (\aggregate -> aggregateWithWire (fmap (wireSpecWithKind "banana") aggregate.wire) 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 -> workqueueWithPayload [if field.name == "hospitalId" then wqFieldWithValueType (LegacyQueueScalar (QueueOther "numeric")) field else field | field <- queue.payload] queue)+              queueSpec+          queueDelay = mapWorkqueue (workqueueWithDelay huge) queueSpec+          queueRetry = mapWorkqueue (\queue -> workqueueWithDisposition (updateFirst (wqDispRowWithAction (IRetry huge)) queue.disposition) queue) queueSpec+          intakeRetry = mapIntake (\intake -> intakeWithDisposition (updateFirst (dispositionRowWithAction (IRetry huge)) intake.disposition) intake) intakeSpec+          publisherBackoff = mapPublisher (\publisher -> publisherWithBackoff (backoffWithWindow huge publisher.backoff) publisher) emitSpec+          publisherMaximum =+            mapPublisher+              (\publisher -> publisherWithBackoff (BackoffSpec "exponential" publisher.backoff.window (Just huge) (Just "2")) publisher)+              emitSpec+          processFireAt =+            modifyProcess+              "HospitalSurge"+              (\process -> processWithTimer (timerWithFireAt (fireAtWithWindow huge process.timer.fireAt) process.timer) process)+              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 -> intakeWithDecode (decodeWithBodyStrict False intake.decode) intake) intakeSpec+          unknownHeader =+            mapIntake+              (\intake -> intakeWithBinds (updateFirst (bindRowWithSource (SrcHeader "x-custom")) intake.binds) intake)+              intakeSpec+          retryOnAppended =+            modifyProcess+              "HospitalSurge"+              ( \process ->+                  processWithHandle+                    ( handleWithDispatch+                        ( updateFirst+                            (\d -> dispatchNodeWithDisposition (dispatchDispositionWithOnAppended DRetry d.disposition) d)+                            process.handle.dispatch+                        )+                        process.handle+                    )+                    process+              )+              processSpec+          firedNotMine =+            modifyProcess+              "HospitalSurge"+              ( \process ->+                  let timer = process.timer+                      fire = timer.fire+                   in processWithTimer+                        ( timerWithFire+                            (fireNodeWithDisposition (fireDispositionWithNotMine OFired fire.disposition) fire)+                            timer+                        )+                        process+              )+              processSpec+          routerRetryOnAppended =+            mapRouter+              ( \router ->+                  routerWithDispatch+                    (routerDispatchWithDisposition (dispatchDispositionWithOnAppended DRetry router.dispatch.disposition) router.dispatch)+                    router+              )+              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 -> processWithTimer (timerWithDecodeUnknown "Abandoned" process.timer) process)+              processSpec+          blankDeadLetter =+            modifyProcess+              "HospitalSurge"+              (\process -> processWithTimer (timerWithDeadLetter "   " process.timer) process)+              processSpec+          phantomDedupeKey =+            mapPgmqDispatch (pgmqDispatchWithDedupKey "ghostKey") dispatchSpec+          uppercaseFanout =+            mapPgmqDispatch (pgmqDispatchWithFanoutBody "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 -> processWithTimer (timerWithDecodeUnknown status p.timer) p) 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 -> aggregateWithProjection (fmap (projectionSpecWithKey "ghost") aggregate.projection) aggregate) reservation+          outboxField = mapPublisher (publisherWithOutboxField "ghost") emitSpec+          timerIds =+            modifyProcess+              "HospitalSurge"+              ( \process ->+                  let timer = process.timer+                      fire = timer.fire+                   in processWithTimer+                        ( timerWithIdAndFire+                            (idExprWithField "ghostTimerKey" timer.id)+                            (fireNodeWithFiredEventId (idExprWithField "ghostEventKey" fire.firedEventId) fire)+                            timer+                        )+                        process+              )+              processSpec+          sourceKey = mapDispatch (pgmqDispatchWithSourceKey "ghost") dispatchSpec+          subscriptionIdentity = modifyReadModel "transfer_decisions" (\readModel -> readModelWithSupply (setLegacySubscription (Just "bad subscription") readModel.supply) readModel) readModelSpec+          scopeIdentity = modifyReadModel "transfer_decisions" (\readModel -> readModelWithSupply (setLegacyScope (Just (RmCategory "bad-category")) readModel.supply) 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 = router.dispatch+                      disposition = dispatch.disposition+                   in routerWithDispatch+                        (routerDispatchWithDisposition (dispatchDispositionWithOnDuplicate DAckOk disposition) dispatch)+                        router+              )+              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 = aggregateWithTransitions (updateFirst update aggregate.transitions) aggregate+          undeclaredEvent = modifyAggregate "Reservation" (updateFirstTransition (transitionWithEmits ["GhostEvent"])) reservation+          undeclaredState = modifyAggregate "Reservation" (updateFirstTransition (transitionWithGoto "GhostState")) reservation+          terminalOutgoing = modifyAggregate "Reservation" (updateFirstTransition (transitionWithSource "Expired")) reservation+          deprecatedEmitted = modifyAggregate "Reservation" (\aggregate -> aggregateWithEvents (updateFirst (eventWithDeprecated True) aggregate.events) aggregate) reservation+          wireVersionMismatch = modifyAggregate "Reservation" (\aggregate -> aggregateWithWire (fmap (wireSpecWithSchemaVersion 2) aggregate.wire) aggregate) reservation+          decodeRetry =+            mapIntake+              ( \intake ->+                  intakeWithDisposition+                    [ if row.outcome == "decodeFailed" then dispositionRowWithAction (IRetry "5s") row else row+                    | row <- intake.disposition+                    ]+                    intake+              )+              intakeSpec+          unresolvedPublisher = mapPublisher (publisherWithEmit "ghost") emitSpec+          unresolvedIntake = mapIntake (intakeWithContract "ghost") intakeSpec+          unboundedQueue = mapWorkqueue (workqueueWithMaxRetries 0) queueSpec+          unresolvedEnqueue = mapDispatch (pgmqDispatchWithEnqueueTo "ghost") queueSpec+          unresolvedWorkflow =+            mapOperation+              ( \operation -> case (.shape) operation of+                  RunOp _ input outcome -> operationWithShape (RunOp "GhostWorkflow" input outcome) operation+                  _ -> 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 = parsed.spec+          codes = [(.code) diagnostic | diagnostic <- validateSpec spec, (.severity) diagnostic == Error]+      mapM_+        (\expected -> codes `shouldContain` [expected])+        [ DuplicateEnumCtor,+          DuplicateEnumWire,+          DuplicateIdPrefix,+          DuplicateCommandName,+          DuplicateEventName+        ]+      case [node | node@NAggregate {} <- (.nodes) spec] of+        aggregateNode : _ ->+          [(.code) diagnostic | diagnostic <- validateSpec (specWithNodes (spec.nodes <> [aggregateNode]) spec), (.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 ->+                  [(.guard) t | NAggregate a <- (.nodes) spec, t <- (.transitions) 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 <- (.nodes) spec, e <- (.events) a, (.name) e == "TransferReservationCreated"] of+          (e : _) -> do+            (.version) e `shouldBe` 2+            (.upcastFrom) 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+      [(.retiring) event | NAggregate aggregate <- (.nodes) spec, event <- (.events) aggregate, (.name) 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 <- (.nodes) spec] of+        [aggregate] -> (.snapshot) 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 <- (.nodes) snapshot], [aggregate | NAggregate aggregate <- (.nodes) ordinary]) of+        ([_], [_]) -> do+          let snapshotModules = scaffoldServiceModules (defaultContext (snapshot.context)) snapshotService+              ordinaryModules = scaffoldServiceModules (defaultContext (ordinary.context)) 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 <- (.nodes) spec] of+          (p : _) -> do+            p.id `shouldBe` "HospitalSurge"+            (.name) p `shouldBe` "hospital-surge"+            (.rejected) p `shouldBe` PolHalt+            (.poison) p `shouldBe` PolHalt+            (.category) ((.saga) p) `shouldBe` "hospitalSurge"+            (.name) ((.timer) p) `shouldBe` "surgeFollowUp"+            (.onReject) ((.disposition) ((.fire) ((.timer) p))) `shouldBe` OFired+            (.onAmbiguous) ((.disposition) ((.fire) ((.timer) p))) `shouldBe` ORetry+            (.maxAttempts) ((.timer) 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 -> processWithSaga (sagaRefWithCategory categoryName process.saga) process) 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 -> processWithCorrelate (correlateDeclWithField "ghost" process.correlate) process)+              spec+          badDispatchKey =+            modifyProcess+              "HospitalSurge"+              ( \process ->+                  let handle = process.handle+                   in processWithHandle (handleWithDispatch (updateFirst (dispatchNodeWithKey "input.ghost") handle.dispatch) handle) process+              )+              spec+          badBinding =+            modifyProcess+              "HospitalSurge"+              ( \process ->+                  let handle = process.handle+                      advance = handle.advance+                   in processWithHandle+                        (handleWithAdvance (advanceNodeWithFields (updateFirst (fieldBindingWithValue (Just "ghost.value")) advance.advFields) advance) handle)+                        process+              )+              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 <- (.nodes) spec] of+        [router] -> case RouterSelection.checkRouterSelection (checkedLanguageContract service) graph spec router of+          Left diagnostics -> expectationFailure (show diagnostics)+          Right selection -> do+            (.identity) selection `shouldBe` "hospital-transfer-selection"+            (.version) selection `shouldBe` 1+            (.limit) selection `shouldBe` 64+            (.useSites) selection `shouldSatisfy` (not . null)+            T.length ((.fingerprint) selection) `shouldBe` 64+            (.fingerprint) 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 (spec.context)) service+          routerModule = generatedTextEndingIn "HospitalTransferRouter/Router.hs" modules+          routerHarness = generatedTextEndingIn "HospitalTransferRouter/RouterHarness.hs" modules+      [(.path) generatedModule | generatedModule <- modules, "HospitalTransferRouter/Router.hs" `T.isSuffixOf` T.pack ((.path) generatedModule)]+        `shouldBe` ["Generated/TransferRouting/HospitalTransferRouter/Router.hs"]+      [(.path) hole | hole <- modules, "HospitalTransferRouter/RouterHoles.hs" `T.isSuffixOf` T.pack ((.path) 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+                        { input = ((.input) router) {valueType = Nothing, fields = [Field "transferNeedId" Nothing, Field "region" Nothing]},+                          resolve = ResolveDecl ResolveHole ["hospitalId"] ((.loc) ((.resolve) router))+                        }+                  )+                  (checkedSpec baseline)+              )+              baseline+          classifyCoordination old new = [(impact.reason, (.severity) impact) | impact <- coordinationImpact old new []]+      case routerSelectionSnapshots baseline of+        [snapshot] -> do+          (.verification) snapshot `shouldBe` DeclarativeVerified+          (.identity) snapshot `shouldBe` Just "hospital-transfer-selection"+          (.version) snapshot `shouldBe` Just 1+          fmap T.length ((.fingerprint) 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") . (.declaration)) 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 . (.currentConsumers))+      map (.reason) 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 <- (.nodes) spec] of+          [router] -> do+            router.id `shouldBe` "PagingRouter"+            (.name) router `shouldBe` "jitsurei-paging"+            (.field) ((.key) router) `shouldBe` "incidentId"+            (.source) ((.resolve) router) `shouldBe` ResolveReadModel "service_oncall"+            (.row) ((.resolve) router) `shouldBe` ["responderId"]+            (.command) ((.dispatch) router) `shouldBe` "SendPage"+            (.rejected) router `shouldBe` PolDeadLetter+            (.poison) 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 (routerWithTarget "Pge") spec `shouldContain` [RouterUnresolvedRef]+      routerErrorCodes (\router -> routerWithKey (correlateDeclWithField "incidntId" router.key) router) spec `shouldContain` [RouterKeyFieldUnknown]+      routerErrorCodes (\router -> routerWithDispatch (routerDispatchWithCommand "SendPag" router.dispatch) router) spec `shouldContain` [RouterCommandUnknown]+      routerErrorCodes+        ( \router ->+            let dispatch = router.dispatch+             in routerWithDispatch (routerDispatchWithFields [FieldBinding "responderId" (Just "resolved.responder")] dispatch) router+        )+        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 = router.dispatch+                disposition = dispatch.disposition+             in routerWithRejectedAndDispatch+                  PolHalt+                  (routerDispatchWithDisposition (dispatchDispositionWithOnFailed (DDeadLetter "page rejected") disposition) dispatch)+                  router+        )+        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 -> routerWithResolve (resolveDeclWithRow ["ghostColumn"] router.resolve) router)+              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 =+            specWithNodes+              [ case node of+                  NProcess process ->+                    let timer = process.timer+                        fire = timer.fire+                        disposition = fire.disposition+                     in NProcess+                          ( processWithTimer+                              (timerWithFire (fireNodeWithDisposition (fireDispositionWithOnAmbiguous OFired disposition) fire) timer)+                              process+                          )+                  _ -> node+              | node <- spec.nodes+              ]+              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 <- (.nodes) spec] of+        [router] -> do+          let ctx = defaultContext (spec.context)+              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], [moduleName]) -> do+              (.text) generatedModule `shouldSatisfy` T.isInfixOf "pagingRouterWorkerOptions"+              (.text) generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedDeadLetter"+              (.text) moduleName `shouldSatisfy` T.isInfixOf "UNION of resolved target identities"+              (.text) moduleName `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 <- (.nodes) spec] of+        [router] -> do+          let ctx = defaultContext (spec.context)+              generatedFor choice = [(.text) m | m <- scaffoldRouter ctx (routerWithPoison choice router), (.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 [(.text) m | m <- scaffoldRouter ctx (routerWithRejected PolSkip router), (.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 <- (.nodes) spec] of+        [router] -> case harnessRouter (defaultContext (spec.context)) router of+          [facts] -> do+            (.text) facts `shouldSatisfy` T.isInfixOf "(\"rejectedPolicy\", \"deadLetter\")"+            (.text) 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+          (.text) generatedModule `shouldSatisfy` T.isInfixOf "max-attempts = 5"+          (.text) generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeProcessWorkerOptions"+          (.text) generatedModule `shouldSatisfy` T.isInfixOf "import Generated.HospitalCapacity.Surge.EventStream (SurgeEventStreamDef)"+          (.text) generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeCategory :: Stream.StreamCategory SurgeEventStreamDef"+          (.text) generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeCategory = Stream.categoryUnsafe \"hospitalSurge\""+          (.text) generatedModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate"+          (.text) generatedModule `shouldSatisfy` T.isInfixOf "StreamName -> EventId -> CommandError -> Eff es Bool"+          (.text) generatedModule `shouldSatisfy` T.isInfixOf "Left (CommandAmbiguous _)"+          case holes of+            [moduleName] -> (.text) moduleName `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 (.text) a `shouldBe` map (.text) 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 (spec.context)+          modules = concat [scaffoldAggregate ctx spec aggregate | NAggregate aggregate <- (.nodes) 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 <- (.nodes) spec] of+          (c : _) -> do+            (.name) c `shouldBe` "emergency"+            (.discriminator) c `shouldBe` "messageType"+            map fst ((.topics) c) `shouldBe` ["incidentEvents", "hospitalEvents"]+            map (.name) ((.events) 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 (spec.context)+      contract <- case [value | NContract value <- (.nodes) 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 ((.text) typedModule) `shouldBe` normalizeGenerated committed+      (.text) legacyModule `shouldSatisfy` T.isInfixOf "incidentId :: !Text"+      (.text) legacyModule `shouldSatisfy` (not . T.isInfixOf "KindID")+      (.text) typedModule `shouldSatisfy` T.isInfixOf "incidentId :: !(KindID \"inc\")"+      (.text) typedModule `shouldSatisfy` T.isInfixOf "KindID.toText payload.incidentId"+      (.text) typedModule `shouldSatisfy` T.isInfixOf "explicitParseField (parseKindIdV7Value @\"inc\") o \"incidentId\""+      (.text) typedModule `shouldSatisfy` T.isInfixOf "  , incidentEventsTopic"+      (.text) typedModule `shouldSatisfy` T.isInfixOf "  , hospitalEventsTopic"+      (.text) 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 (spec.context)+          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" ((.sourceLanguage) parsed) ctx service modules+        result `shouldSatisfy` isRight+        contents <- TIO.readFile (out </> recordFileName (spec.context))+        record <- maybe (expectationFailure "typed contract scaffold record did not parse" >> fail "unreachable") pure (parseRecord contents)+        (.idDomains) 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) <- workspacePlan.modules, (.path) 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 (workspace.service))+        record <- maybe (expectationFailure "typed contract workspace record did not parse" >> fail "unreachable") pure (parseWorkspaceRecord contents)+        (.idDomains) record `shouldBe` identities+        [((.path) row, (.owner) row) | row <- record.modules, (.path) 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 <- (.nodes) spec], [intake | NIntake intake <- (.nodes) ordinary]) of+        ([intake], [defaultIntake]) -> do+          (.persist) intake `shouldBe` InkPersistDedupeOnly+          (.persist) defaultIntake `shouldBe` InkPersistFull+          renderSpec spec `shouldSatisfy` T.isInfixOf "persist = dedupe-only"+          renderSpec ordinary `shouldNotSatisfy` T.isInfixOf "persist ="+          let inbox = generatedTextEndingIn "Inbox.hs" (scaffoldIntake (defaultContext (spec.context)) 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 (spec.context)) spec+        (.inertNodes) 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 <- (.nodes) spec] of+        workqueue : _ -> do+          let modules = scaffoldWorkqueue (defaultContext (spec.context)) 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 <- (.nodes) spec] of+        [subscriptionModel, inlineModel] -> do+          (.name) subscriptionModel `shouldBe` "transfer_decisions"+          (.columns) 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"+          (.name) 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 <- (.nodes) spec, Just projection <- [(.projection) aggregate]] of+        [projection] -> (.consistency) 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 <- (.nodes) 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 (spec.context) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions"+          subscriptionNameFor (spec.context) 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 (spec.context)+          readModels = [readModel | NReadModel readModel <- (.nodes) spec]+          modules = concatMap (scaffoldReadModel ctx) readModels+          transfer = generatedTextEndingIn "TransferDecisions/ReadModel.hs" modules+          inline = generatedTextEndingIn "Subscriptions/ReadModel.hs" modules+          transferHoles = [(.text) m | m <- modules, "TransferDecisions/ReadModelHoles.hs" `T.isSuffixOf` T.pack ((.path) 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 <- (.nodes) spec] of+        [aggregate] -> do+          let modules = scaffoldAggregate (defaultContext (spec.context)) spec aggregate+              holes = [(.text) 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 <- (.nodes) spec] of+        (subscriptionModel : _) -> do+          let modules = harnessReadModel (defaultContext (spec.context)) spec subscriptionModel+              harnessText = generatedTextEndingIn "ReadModelHarness.hs" modules+          length modules `shouldBe` 1+          firewallBreaches modules `shouldBe` []+          harnessText `shouldNotSatisfy` 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 <- (.nodes) spec] of+        [workflow] -> do+          let modules = harnessWorkflow (defaultContext (spec.context)) 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 ((.events) aggregate, (.transitions) aggregate) of+        (event : _, transition : _) -> do+          let newEvent = eventWithNameAndLoc "ReservationReviewed" noLoc event+              newTransition =+                transition+                  { emits = ["ReservationReviewed"],+                    loc = noLoc+                  }+              new =+                modifyAggregate+                  "Reservation"+                  ( \candidate ->+                      candidate+                        { events = (.events) candidate <> [newEvent],+                          transitions = (.transitions) 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+                    { transitions =+                        [ transition {guard = Nothing}+                        | transition <- (.transitions) 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 ((.transitions) aggregate, (.events) aggregate) of+        (prototype : _, firstEvent : secondEvent : _) -> do+          let sibling guardExpression eventName =+                prototype+                  { guard = guardExpression,+                    emits = [eventName],+                    loc = noLoc+                  }+              commandOverride = EPath noLoc CommandRoot ["lifeCriticalOverride"]+              exact = sibling (Just (EAtom (ABool True))) ((.name) firstEvent)+              loosenedOld = sibling (Just commandOverride) ((.name) firstEvent)+              loosenedNew = sibling Nothing ((.name) firstEvent)+              changedOld = sibling (Just (ECmp OpEq commandOverride (ELiteral noLoc (LiteralBool False)))) ((.name) secondEvent)+              changedNew = sibling (Just (ECmp OpEq commandOverride (ELiteral noLoc (LiteralBool True)))) ((.name) firstEvent)+              oldSiblings = [exact, loosenedOld, changedOld]+              newSiblings = [exact, loosenedNew, changedNew]+              withTransitions transitions =+                modifyAggregate+                  ((.name) aggregate)+                  (\candidate -> candidate {transitions = 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 ->+          (.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 (spec.context)) spec of+        [assembly] -> do+          (.path) assembly `shouldBe` "Generated/SurgeDemo/ReplayAudit.hs"+          (.text) assembly `shouldSatisfy` T.isInfixOf "Hospital.hospitalEventStream"+          (.text) assembly `shouldSatisfy` T.isInfixOf "Surge.surgeEventStream"+          T.count "      AuditTarget" ((.text) 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 (.declaration) 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 {mapped = reverse ((.mapped) old), nodes = reverse ((.nodes) 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 (.declaration) added `shouldBe` [expectedB]+      map (.previousConsumers) added `shouldBe` [Set.empty]+      map (.currentConsumers) added `shouldBe` [Set.empty]+      map (.serviceConformance) added `shouldBe` [True]+      map (.declaration) removed `shouldBe` [expectedB]+      map (.previousConsumers) removed `shouldBe` [Set.empty]+      map (.currentConsumers) removed `shouldBe` [Set.empty]+      map (.serviceConformance) removed `shouldBe` [True]++      old <- specOf "test/fixtures/semantic-impact.keiro"+      let changed = mapMappedStructural "UnusedPayload" changeMappedCanonical old+          unusedImpact = CheckedDiff.mappedSemanticImpact old changed+      map (.declaration) unusedImpact `shouldBe` [MappedKey "UnusedPayload"]+      map (.previousConsumers) unusedImpact `shouldBe` [Set.empty]+      map (.currentConsumers) unusedImpact `shouldBe` [Set.empty]+      map (.serviceConformance) 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 ((kindOfChange change).vector)+            `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,+              (.code) kind == EnumCtorAdded,+              verdictFor OldBinaryReadNewEvents (kind.vector) == VBreaking+            ]+      eventEnumFindings `shouldSatisfy` all (not . gatedBreaking defaultGate)+      eventEnumFindings `shouldSatisfy` all (gatedBreaking (gateWith [OldBinaryReadNewEvents]))+      forM_ changes $ \change ->+        remediationFor ((kindOfChange change).context) ((.code) (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 ((.code) . kindOfChange) changes `shouldContain` [expectedCode]+        forM_ changes $ \change ->+          remediationFor ((kindOfChange change).context) ((.code) (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, (.code) (kindOfChange change) == MappedFieldAddedNoDefault]+      [(.facet) kind | Breaking kind <- noDefault] `shouldContain` ["mapped-event"]+      [(.facet) 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, (.code) kind == MappedFieldAddedWithDefault, (.facet) kind == "mapped-event"]+      eventDefaults `shouldSatisfy` any ((== VBreaking) . verdictFor OldBinaryReadNewEvents . (.vector))+      armAdded <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-armadd.keiro"+      [change | change <- armAdded, isBreaking change] `shouldBe` []+      [kind | Advisory kind <- armAdded, (.code) kind == MappedArmAdded, (.facet) kind == "mapped-event"]+        `shouldSatisfy` any ((== VBreaking) . verdictFor OldBinaryReadNewEvents . (.vector))+    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" (wireFieldWithKey "artifact_key_v2") base+          queueFindings =+            [ kind+            | change <- diffSpecs base candidate,+              let kind = kindOfChange change,+              (.facet) kind == "mapped-workqueue"+            ]+      queueFindings `shouldSatisfy` (not . null)+      forM_ queueFindings $ \kind -> do+        verdictFor PrivateHistoryRead (kind.vector) `shouldBe` VNotApplicable+        verdictFor OldBinaryReadNewEvents (kind.vector) `shouldBe` VNotApplicable+        verdictFor SnapshotHydration (kind.vector) `shouldBe` VNotApplicable+        verdictFor ConsumerBuild (kind.vector) `shouldBe` VBreaking+        (.rollout) (kind.vector) `shouldBe` Set.fromList [RolloutWorkersFirst, RolloutDrainRequired]+        (.mappedPersistedImpact) kind+          `shouldBe` Just (MappedPersistedImpact (WorkqueueHistory "ArtifactJobs") VBreaking)+        (.detail) kind `shouldSatisfy` T.isInfixOf "schema-version-1 history"+        remediationFor (kind.context) ((.code) 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 =+            [ (.subject) kind+            | change <- changes,+              let kind = kindOfChange change,+              (.code) 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" (wireFieldWithValueType TInt) base, MappedFieldTypeChanged),+              (mapArtifactNamedField "key" (wireFieldWithPresenceAndDefault POptional (Just (OmText ""))) base, MappedPresenceChanged),+              (mapArtifactNamedField "key" (wireFieldWithValueType (TOptional TText)) base, MappedNullabilityChanged),+              (mapArtifactNamedField "description" (wireFieldWithOnMissing Nothing) base, MappedDefaultRemoved),+              (mapArtifactNamedField "count" (wireFieldWithOnMissing (Just (OmInt 1))) base, MappedDefaultChanged),+              (mapMappedStructural "ArtifactInfo" renameMappedRecordConstructor base, MappedRecordConstructorChanged),+              (mapMappedStructural "ArtifactInfo" changeMappedCanonical base, MappedCanonicalTypeChanged)+            ]+      forM_ mutationCodes $ \(candidate, expectedCode) ->+        map ((.code) . 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 ((.code) . kindOfChange) (diffSpecs onlyA withB) `shouldContain` [MappedDeclAdded]+      map ((.code) . kindOfChange) (diffSpecs withB onlyA) `shouldContain` [MappedDeclRemoved]+      diffSpecs base (mapArtifactNamedField "key" (wireFieldWithHaskell "renamedKey") base)+        `shouldSatisfy` \case+          [Advisory change] -> (.code) 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),+                (.code) (kindOfChange change) == (.mmCode) mutation+              ]+            actualSubjects = Set.fromList (map ((.subject) . 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+      [(.code) 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") . (.subject))+    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"+      [(.code) 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"+      [(.code) 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"+      [(.code) 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, (.code) finding == GeneratedHaskellNameChanged]+          wireFindings = [finding | Breaking finding <- wireChanges, (.code) finding == EvtFieldWireKeyChanged]+      selectorChanges `shouldSatisfy` all (not . isBreaking)+      map (.facet) selectorFindings `shouldContain` ["command-field-selector", "event-field-selector"]+      map (verdictFor ConsumerBuild . (.vector)) selectorFindings `shouldSatisfy` all (== VAdvisory)+      resolvedFold (ReplayImpact.replayImpactServices base selectorAlias) `shouldBe` ReplayNeutral+      case wireFindings of+        [finding] -> do+          (.subject) finding `shouldBe` "Observed.region"+          verdictFor PrivateHistoryRead (finding.vector) `shouldBe` VBreaking+          verdictFor OldBinaryReadNewEvents (finding.vector) `shouldBe` VBreaking+          (.detail) 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") . (.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, (.code) finding == GeneratedHaskellNameChanged]+      [(.code) finding | Additive finding <- changes] `shouldContain` [VersionBumped]+      map (.facet) selectorFindings `shouldBe` ["event-field-selector"]+      map (verdictFor ConsumerBuild . (.vector)) 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] ->+          (.code) finding == GeneratedHaskellNameChanged+            && (.facet) finding == "contract-field-selector"+            && verdictFor ConsumerBuild (finding.vector) == VAdvisory+        _ -> False+      case [finding | Breaking finding <- wireChanges, (.code) finding == ContractFieldChanged] of+        [finding] -> do+          verdictFor PublicConsumer (finding.vector) `shouldBe` VBreaking+          (.rollout) (finding.vector) `shouldBe` Set.singleton RolloutProducerLast+          (.detail) 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+      [(.code) finding | Breaking finding <- changes]+        `shouldContain` [EvtFieldAddedWithoutBump, EvtFieldRemovedSameVersion]+      [finding | Advisory finding <- changes, (.code) finding == GeneratedHaskellNameChanged]+        `shouldBe` []+    it "uses EvtVersionDecreased for a version decrease" $ do+      cs <- diffFixtures "test/fixtures/reservation-v2.keiro" "test/fixtures/reservation.keiro"+      [(.code) 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"+      [(.code) 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"+      [(.code) 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"+      [(.code) 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"+      [(.code) 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, (.code) k == EnumCtorAdded]+      [(.subject) k | k <- enumFindings] `shouldContain` ["BlackTag"]+      [verdictFor SnapshotHydration (k.vector) | 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"+      [(.code) 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+      [(.code) 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+      [(.code) k | Advisory k <- deprecated] `shouldContain` [DeprecatedEventReplayHazard]+      restored <- diffFixtures "test/fixtures/reservation-deprecated.keiro" "test/fixtures/reservation.keiro"+      any isAdvisory restored `shouldBe` True+      [(.code) 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+      [(.code) k | Advisory k <- cs] `shouldContain` [EventRetirementInProgress]+      [(.code) 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+      [(.code) 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 =+            specWithNodes+              [ case node of+                  NAggregate aggregate ->+                    NAggregate+                      aggregate+                        { events =+                            [ event+                            | event <- (.events) aggregate,+                              (.name) event /= "TransferReservationConfirmed"+                            ],+                          transitions =+                            [ transition {emits = filter (/= "TransferReservationConfirmed") ((.emits) transition)}+                            | transition <- (.transitions) aggregate+                            ]+                        }+                  _ -> node+              | node <- old.nodes+              ]+              old+          removals = [change | change@(Breaking kind) <- diffSpecs old new, (.code) kind == EvtRemovedNotDeprecated]+      removals `shouldSatisfy` (not . null)+      [(.detail) 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, (.code) k == AggGuardTightened]+      map (.subject) advisories `shouldBe` ["Unrequested -- RequestTransferReservation"]+      advisoryDetail <- case advisories of+        [k] -> pure ((.detail) k)+        other -> expectationFailure ("expected one advisory, got " <> show other) >> pure ""+      advisoryDetail `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" advisoryDetail)+          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, (.code) 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, (.code) k == AggGuardTightened] `shouldBe` []+    it "classifies a removed contract event as ContractEventRemoved" $ do+      cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventdrop.keiro"+      [(.code) 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"+      [(.code) k | Breaking k <- changed] `shouldContain` [ContractFieldChanged]+      added <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldadd.keiro"+      [(.code) k | Breaking k <- added] `shouldContain` [ContractFieldChanged]+    it "freezes the contract TypeID diff report byte contract 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, (.code) kind == ContractTypeIdDomainChanged]+      assertMatchesGolden "test/fixtures/contract-typeid-domain.diff.golden" textGolden+      assertMatchesByteGolden "test/fixtures/contract-typeid-domain.diff.json.golden" (TextEncoding.encodeUtf8 jsonGolden)+      case findings of+        [finding] -> do+          verdictFor PublicConsumer (finding.vector) `shouldBe` VBreaking+          verdictFor ConsumerBuild (finding.vector) `shouldBe` VBreaking+          [verdictFor surface (finding.vector) | surface <- [PrivateHistoryRead, OldBinaryReadNewEvents, SnapshotHydration, PersistedIdentity]]+            `shouldBe` replicate 4 VNotApplicable+          (.rollout) (finding.vector) `shouldBe` Set.fromList [RolloutDrainRequired, RolloutProducerFirst]+          deriveLabel (Set.singleton PublicConsumer) (finding.vector) `shouldBe` LabelBreaking+          deriveLabel (Set.singleton ConsumerBuild) (finding.vector) `shouldBe` LabelBreaking+          remediationFor (finding.context) ((.code) 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 }, (.code) kind == ContractTypeIdDomainChanged] `shouldBe` []+      [kind | change <- diffServices v4 v4, let { kind = kindOfChange change }, (.code) kind == ContractTypeIdDomainChanged] `shouldBe` []+      let edited = diffServices v3 v4Edited+      map ((.code) . kindOfChange) edited `shouldContain` [ContractFieldChanged]+      [kind | change <- edited, let { kind = kindOfChange change }, (.code) 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+      [(.code) 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"+      [(.code) 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"+      [(.code) k | Breaking k <- topic] `shouldContain` [ContractTopicChanged]+      discriminatorChanges <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-discriminator.keiro"+      [(.code) k | Breaking k <- discriminatorChanges] `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+      [(.subject) 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"+      [(.code) k | Breaking k <- wire] `shouldContain` [WqPayloadFieldChanged]+      fieldTypeChange <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-fieldtype.keiro"+      [(.code) k | Breaking k <- fieldTypeChange] `shouldContain` [WqPayloadFieldChanged]+      required <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-reqfield.keiro"+      [(.code) 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"+      [(.code) k | Breaking k <- cs] `shouldContain` [WqPayloadFieldChanged]+      [(.subject) k | Breaking k <- cs] `shouldContain` ["note"]+      [(.detail) k | Breaking k <- cs, (.subject) 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"+      [(.code) k | Breaking k <- cs] `shouldContain` [WqOrderingChanged]+      [(.detail) k | Breaking k <- cs, (.code) 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"+      [(.code) k | Breaking k <- cs] `shouldContain` [WqProvisionChanged]+      [(.detail) k | Breaking k <- cs, (.code) 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"+      [(.code) k | Breaking k <- cs] `shouldContain` [WqGroupKeyChanged]+      [(.detail) k | Breaking k <- cs, (.code) 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"+      [(.code) 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"+      [(.code) k | Breaking k <- input] `shouldContain` [WorkflowShapeChanged]+      output <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-output.keiro"+      [(.code) 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"+      [(.code) k | Breaking k <- relabeled] `shouldContain` [WorkflowBodyChanged]+      appended <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-stepadd.keiro"+      [(.code) k | Breaking k <- appended] `shouldContain` [WorkflowBodyChanged]+      [(.detail) k | Breaking k <- appended, (.code) 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+      [(.subject) k | Additive k <- cs, (.facet) k == "workflow-patch"] `shouldContain` ["fraud-check-v2"]+      [(.subject) k | Additive k <- cs, (.facet) 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"+      [(.code) k | Breaking k <- cs] `shouldContain` [WorkflowPatchRemoved]+      [(.detail) k | Breaking k <- cs, (.code) 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+      [(.facet) k | Additive k <- appended] `shouldContain` ["workflow-continue-as-new"]+      changed <- diffFixtures "test/fixtures/workflow-continue.keiro" "test/fixtures/workflow-continue-seed-v2.keiro"+      [(.code) k | Breaking k <- changed] `shouldContain` [WorkflowContinueSeedChanged]+      [(.detail) k | Breaking k <- changed, (.code) 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"+      [(.code) 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"+      [(.code) 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"+      [(.code) 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"+      [(.code) k | Breaking k <- policy] `shouldContain` [DedupeIdentityChanged]+      key <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-dedupekey.keiro"+      [(.code) 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+      [(.code) k | Advisory k <- cs] `shouldContain` [DecodePostureChanged]+      [(.code) 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"+      [(.code) k | Breaking k <- processName] `shouldContain` [DerivedIdentityChanged]+      timerId <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-timerid.keiro"+      [(.code) k | Breaking k <- timerId] `shouldContain` [DerivedIdentityChanged]+      base <- specOf "test/fixtures/hospital-surge.keiro"+      let categoryChange = diffSpecs base (modifyProcess "HospitalSurge" (\process -> processWithSaga (sagaRefWithCategory "hospitalSurgeV2" process.saga) process) base)+      [(.code) 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" (routerWithName "paging-v2") base)+          keyDerivation = diffSpecs base (modifyRouter "PagingRouter" (\router -> routerWithKey (correlateDeclWithVia "otherIdText" router.key) router) base)+          target = diffSpecs base (modifyRouter "PagingRouter" (routerWithTarget "OtherPage") base)+      [(.code) k | Breaking k <- stableName] `shouldContain` [RouterStableNameChanged]+      [(.code) k | Breaking k <- keyDerivation] `shouldContain` [DerivedIdentityChanged]+      [(.code) 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+      [(.code) 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+      [(.code) 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+      [(.code) 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+      [(.code) 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+      [(.code) k | Advisory k <- mapping] `shouldContain` [EmitMappingChanged]+      derive <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-derive.keiro"+      [(.code) 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"+      [(.code) k | Breaking k <- outbox] `shouldContain` [DerivedIdentityChanged]+      ordering <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-ordering.keiro"+      any isBreaking ordering `shouldBe` False+      [(.code) 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"+      [(.code) 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"+      [(.code) k | Breaking k <- dedupe] `shouldContain` [DedupeIdentityChanged]+      retarget <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-retarget.keiro"+      any isBreaking retarget `shouldBe` False+      [(.code) 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+      [(.code) 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" (readModelWithVersion 2) base+          changedShape = modifyReadModel "transfer_decisions" changeReadModelShape base+          bumpedShape = modifyReadModel "transfer_decisions" (readModelWithVersion 2 . changeReadModelShape) base+          decreased = diffSpecs versionTwo base+          unversioned = diffSpecs base changedShape+          bumped = diffSpecs base bumpedShape+      [(.code) k | Breaking k <- decreased] `shouldContain` [ReadModelVersionDecreased]+      [(.code) k | Breaking k <- unversioned] `shouldContain` [ReadModelShapeChangedWithoutBump]+      any isBreaking bumped `shouldBe` False+      [(.facet) 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 ->+                  readModelWithQueryTypes (fmap update readModel.queryTypes) readModel+              )+              base+          inputChanged = changeQuery (\queryPair -> readModelQueryTypesWithInput (TList queryPair.input) queryPair)+          resultChanged = changeQuery (readModelQueryTypesWithResult (TRef "ArtifactInfo"))+          assertBuildOnly expectedCode changes = case [kind | Advisory kind <- changes, (.code) kind == expectedCode] of+            [kind] -> do+              (.consumerBuild) (kind.vector) `shouldBe` VBreaking+              (.privateHistoryRead) (kind.vector) `shouldBe` VCompatible+              (.oldBinaryReadNewEvents) (kind.vector) `shouldBe` VCompatible+              (.snapshotHydration) (kind.vector) `shouldBe` VNotApplicable+              (.publicConsumer) (kind.vector) `shouldBe` VNotApplicable+              (.persistedIdentity) (kind.vector) `shouldBe` VNotApplicable+              (.mappedPersistedImpact) kind `shouldBe` Nothing+              remediationFor (kind.context) ((.code) kind)+                `shouldBe` RemedyRecompileConsumers :| [RemedyRunConformance]+            values -> expectationFailure ("expected one query build finding, got " <> show values)+          onlyReadModel spec = case [readModel | NReadModel readModel <- (.nodes) spec, (.name) 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 (inputChanged.context) (onlyReadModel inputChanged)+        `shouldBe` registryNameFor (base.context) (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" (readModelWithTable "transfer_decisions_v2") base+          subscriptionChanged = modifyReadModel "transfer_decisions" (\readModel -> readModelWithSupply (setLegacySubscription (Just "transfer-decisions-v2") readModel.supply) readModel) base+          renamed = modifyReadModel "transfer_decisions" (readModelWithName "reservation_decisions") base+          removed = removeReadModel "transfer_decisions" base+      mapM_+        (\changes -> [(.code) 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 {supply = setLegacyFeed RmInline ((.supply) readModel)}) base+          consistencyWeakened = modifyReadModel "transfer_decisions" (\readModel -> readModel {supply = setLegacyConsistency Eventual ((.supply) readModel), freshness = FreshnessImmediate}) base+          entireLog = modifyReadModel "transfer_decisions" (\readModel -> readModel {supply = setLegacyScope (Just RmEntireLog) ((.supply) readModel), freshness = FreshnessWaitForHead RmEntireLog}) base+      [(.code) k | Breaking k <- diffSpecs base feedChanged] `shouldContain` [ReadModelFeedChanged]+      [(.code) k | Breaking k <- diffSpecs base consistencyWeakened] `shouldContain` [ReadModelConsistencyWeakened]+      [(.code) 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 {supply = setLegacyConsistency Eventual ((.supply) readModel), freshness = FreshnessImmediate}) strong+          changes = diffSpecs eventual strong+      any isBreaking changes `shouldBe` False+      [(.facet) 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+      [(.code) k | Breaking k <- changes] `shouldContain` [QueryFreshnessChanged]+      [(.facet) k | Breaking k <- changes] `shouldContain` ["query-freshness"]+      [(.facet) k | Additive k <- changes] `shouldNotContain` ["read-model-scope"]+      [(.detail) k | Breaking k <- changes, (.code) 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 ((.facet) . 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+      [(.code) k | Additive k <- strengthenedChanges] `shouldContain` [CompatibilityStrengthened]+      [(.facet) 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+      [(.code) k | Additive k <- widenedChanges] `shouldContain` [CompatibilityStrengthened]+      [(.facet) k | Additive k <- widenedChanges] `shouldContain` ["query-freshness"]+      categoryChanged <- checkedServiceFromText "readmodel-migration-scope-category-changed.keiro" (toLanguage5 "  freshness = wait-for-head category \"other\"\n" source)+      [(.code) 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+      [(.code) 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)+      [(.code) 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 ((.facet) . 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 = contextWithModuleRoot "Acme" (defaultContext "hospital-capacity")+      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+          (.moduleRoot) spec `shouldBe` Just "Acme.Services"+          (.layout) 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+          (.moduleRoot) spec `shouldBe` Nothing+          (.layout) 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 (spec.context)) spec+          paths = map (.path) 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 (spec.context)) spec+          skeletons = [moduleValue | moduleValue <- modules, (.kind) moduleValue == HoleStub, (.path) moduleValue == "Example/Artifact/KeiroBindings.hs"]+          shape = generatedTextEndingIn "Structural/Shape/ArtifactInfo.hs" modules+      case skeletons of+        [skeleton] -> do+          (.text) skeleton `shouldSatisfy` T.isInfixOf "artifactInfoBinding :: StructuralBinding"+          (.text) skeleton `shouldSatisfy` T.isInfixOf "artifactKindBinding :: StructuralBinding"+          (.text) skeleton `shouldSatisfy` T.isInfixOf "artifactLocationBinding :: StructuralBinding"+          (.text) skeleton `shouldSatisfy` T.isInfixOf "HOLE: fill ArtifactInfo bindingToShape.key"+        _ -> expectationFailure ("expected exactly one shared binding skeleton, got " <> show (map (.path) 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 (spec.context)+            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"+        (.dispositions) second+          `shouldSatisfy` any (\(moduleValue, disposition) -> (.path) 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 (spec.context)+            ghcOutput = out </> ".ghc"+            domainSource = out </> "Conformance/Structural/Domain.hs"+        _ <- executePlannedScaffold out "structural-conformance.keiro" ctx spec+        readTestText "test/conformance-structural/Conformance/Structural/Domain.hs"+          >>= writeFileWithParents domainSource+        createDirectoryIfMissing True ghcOutput+        keiroCorePackageId <- activeCabalPackageId "keiro-core"+        (exitCode, standardOutput, standardError) <-+          readProcessWithExitCode+            "cabal"+            [ "exec",+              "--enable-tests",+              "--",+              "ghc",+              "-XGHC2024",+              "-XOverloadedStrings",+              "-fno-code",+              "-fforce-recomp",+              "-package-id",+              keiroCorePackageId,+              "-outputdir",+              ghcOutput,+              "-i" <> out,+              "-itest/conformance-structural",+              out </> "Conformance/Structural/Bindings.hs"+            ]+            ""+        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 (spec.context)) 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 (spec.context)) 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 = [spec.witness | spec <- specs, (.pointer) spec == "/key"]+          collidedWitnesses = [spec.witness | spec <- specs, (.pointer) 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 (spec.context)) 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 (spec.context)) 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 (spec.context)) 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 (spec.context)+        first <- executePlannedScaffold out "consumer-types.keiro" ctx spec+        length first.consumerPlan.mappings `shouldBe` 4+        recordText <- TIO.readFile (out </> recordFileName (spec.context))+        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 (.mappings) (parseRecord recordText) `shouldSatisfy` maybe False ((== 4) . length)+        fmap (.bindingObligations) (parseRecord recordText) `shouldSatisfy` maybe False ((== length bindingRows) . length)+        let bumped = spec {mapped = map bumpArtifactBindingVersion ((.mapped) spec)}+        second <- executePlannedScaffold out "consumer-types.keiro" ctx bumped+        (.mappingDrift) second+          `shouldSatisfy` any (\drift -> (.specName) drift == "ArtifactInfo" && (.previous) drift /= (.current) 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 (spec.context)+        _ <- executePlannedScaffold out "consumer-types.keiro" ctx spec+        let extended = spec {mapped = map addArtifactSummaryField ((.mapped) spec)}+        second <- executePlannedScaffold out "consumer-types.keiro" ctx extended+        (.newHoles) second+          `shouldBe` [ BindingHole+                         { mappedName = "ArtifactInfo",+                           moduleName = "Example.Artifact.KeiroBindings",+                           symbol = "artifactInfoBinding",+                           kind = BindingValue,+                           path = Just "summary",+                           signature = "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 (spec.context)) spec+        recordText <- TIO.readFile ((.recordPath) 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 (old.context)+            currentOut = root </> "current"+            legacyOut = root </> "legacy"+            assertAlphaOnly report = do+              map (.declaration) ((.deltas) (report.semanticImpact))+                `shouldBe` [MappedKey "AlphaPayload"]+              map (.previousConsumers) ((.deltas) (report.semanticImpact))+                `shouldBe` [Set.singleton (AggregateConsumer "Alpha")]+              map (.currentConsumers) ((.deltas) (report.semanticImpact))+                `shouldBe` [Set.singleton (AggregateConsumer "Alpha")]+              let semanticLines = renderSemanticImpactReport (report.semanticImpact)+              semanticLines `shouldSatisfy` any (T.isInfixOf "current aggregate consumers:  Alpha")+              semanticLines `shouldSatisfy` all (not . T.isInfixOf "Beta")+              map (.category) ((.generatedArtifactImpact) report)+                `shouldContain` [ServiceStructuralConformanceArtifact]+              map (.path) ((.generatedArtifactImpact) 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 ((.recordPath) firstLegacy)+        TIO.writeFile+          ((.recordPath) firstLegacy)+          (T.unlines (filter (not . T.isPrefixOf "semantic-impact ") (T.lines legacyText)))+        legacy <- executePlannedScaffold legacyOut "semantic-impact.keiro" ctx legacyNew+        let legacyLines = renderSemanticImpactReport (legacy.semanticImpact)+        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 ((.recordPath) legacy)+        (parseRecord currentLedger >>= (.semanticImpact)) `shouldSatisfy` maybe False (const True)+        third <- executePlannedScaffold legacyOut "semantic-impact.keiro" ctx legacyNew+        (.declarations) (third.semanticImpact) `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 (spec.context)) 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 {mapped = map moveArtifactBindingIntoGenerated ((.mapped) spec)}+      case planTestScaffold (defaultContext (cyclic.context)) 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 (missing.context)) missing `shouldSatisfy` isFoldSurfaceRefusal+      spec <- specOf "test/fixtures/consumer-types.keiro"+      let commandOnly = removeMappedRegisterRequirements spec+      planTestScaffold (defaultContext (commandOnly.context)) 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 ->+              (.kind) obligation == BindingValue+                && (.symbol) obligation == "artifactInfoBinding"+                && (.bindingVersion) obligation == Just "1"+          )+      obligations+        `shouldSatisfy` any+          ( \obligation ->+              (.kind) obligation == InitialValue+                && (.symbol) obligation == "emptyArtifactInfo"+                && any (T.isInfixOf "Catalog register currentArtifact") ((.useSites) obligation)+          )+      let rendered = renderBindingObligations (spec.context) 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 (spec.context) 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 (spec.context)+          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 (spec.context)) 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+                  { mapped = [declaration | declaration@MappedOpaque {} <- (.mapped) spec],+                    nodes = []+                  }+              )+              service+          structural = generatedTextEndingIn "StructuralConformance.hs" (scaffoldServiceModules (defaultContext (spec.context)) 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 ((checkedSpec service).context)+      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" ((.text) facade) `shouldBe` 1+          T.count "StructuralConformance.structuralConformanceAssertions" ((.text) facade) `shouldBe` 1+          (.text) facade `shouldSatisfy` T.isInfixOf "\"structural/\" <> fact"+          (.text) 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 ((.mergedSpec) workspace)+          changedMember member = workspaceMemberWithSpec (addAlphaPayloadOptionalField member.spec) member+          changedWorkspace = workspaceWithMembersAndMergedSpec (map changedMember workspace.members) changedSpec workspace+          ctx = workspaceContext workspace+          plan value = planWorkspaceScaffold "goldens" ctx value+          moduleBytes owner planValue =+            Map.fromList+              [ ((.path) moduleValue, ((.text) moduleValue, (.kind) moduleValue, provenance))+              | (moduleValue, provenance) <- (.modules) planValue,+                ("/" <> owner <> "/") `T.isInfixOf` T.pack ((.path) moduleValue)+              ]+          moduleWith suffix planValue = generatedTextEndingIn suffix (map fst ((.modules) 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 ((.modules) baselinePlan)+            changedModules = map fst ((.modules) 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,+                  (.path) generatedModule `Set.member` expectedPaths+                ]+            impact = CheckedDiff.mappedSemanticImpact ((.mergedSpec) workspace) ((.mergedSpec) changedWorkspace)+            renderedImpact = T.unlines (renderSemanticImpact impact)+            encodedReport = LazyText.toStrict (LazyTextEncoding.decodeUtf8 (Aeson.encode (diffReportWithSemanticImpact defaultGate (diffSpecs ((.mergedSpec) workspace) ((.mergedSpec) changedWorkspace)) impact)))+        (.changedPaths) delta `shouldBe` expectedPaths+        (.addedPaths) delta `shouldBe` Set.empty+        (.removedPaths) delta `shouldBe` Set.empty+        assertAllowedGeneratedDelta allowedRoles baselineModules changedModules delta+        map (.declaration) impact `shouldBe` [MappedKey "AlphaPayload"]+        map (.previousConsumers) impact `shouldBe` [Set.singleton (AggregateConsumer "Alpha")]+        map (.currentConsumers) 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+        (.declarations) (report.semanticImpact) `shouldBe` [MappedKey "AlphaPayload"]+        map (.path) ((.generatedArtifactImpact) report) `shouldBe` Set.toAscList expectedPaths+        map (.category) ((.generatedArtifactImpact) report)+          `shouldSatisfy` \categories ->+            AggregateGeneratedArtifact `elem` categories+              && ServiceStructuralConformanceArtifact `elem` categories+        map (.category) ((.generatedArtifactImpact) report)+          `shouldNotContain` [BehaviorSourceMapArtifact]+        ledger <- TIO.readFile ((.recordPath) report)+        case parseWorkspaceRecord ledger of+          Just record -> record.semanticImpact `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 ((.modules) baseline)) (map fst ((.modules) 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 ((.modules) baseline)+            nestedModules = map fst ((.modules) nested)+            fixtureModules = map fst ((.modules) fixtureChanged)+            nestedDelta = generatedTreeDelta baselineModules nestedModules+            fixtureDelta = generatedTreeDelta baselineModules fixtureModules+            betaPaths = Set.fromList [(.path) value | value <- baselineModules, "/Beta/" `T.isInfixOf` T.pack ((.path) value)]+            structural = generatedTextEndingIn "StructuralConformance.hs" baselineModules+            alphaHarness = generatedTextEndingIn "Alpha/Harness.hs" baselineModules+            betaHarness = generatedTextEndingIn "Beta/Harness.hs" baselineModules+            snapshot = semanticImpactSnapshotForSpec ((.mergedSpec) workspace)+        (.changedPaths) nestedDelta `shouldSatisfy` Set.null . Set.intersection betaPaths+        (.changedPaths) fixtureDelta `shouldSatisfy` Set.null . Set.intersection betaPaths+        map (.declaration) (CheckedDiff.mappedSemanticImpact ((.mergedSpec) workspace) (addNestedPayloadOptionalField ((.mergedSpec) workspace)))+          `shouldBe` [MappedKey "AlphaPayload", MappedKey "NestedPayload"]+        mappedDeclarationConsumers (semanticImpactForSpec ((.mergedSpec) workspace)) (MappedKey "SharedPayload")+          `shouldBe` [AggregateConsumer "Alpha", AggregateConsumer "Beta"]+        mappedDeclarationConsumers (semanticImpactForSpec ((.mergedSpec) workspace)) (MappedKey "UnusedPayload")+          `shouldBe` []+        (.serviceInventory) 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 path = root </> "domain/alpha.keiro"+          original <- TIO.readFile path+          TIO.writeFile path (mutateSource original)+          moved <- loadTempWorkspace root+          report <- executePlannedWorkspaceScaffold out moved+          let overwritten = [value.path | (value, _, Overwritten) <- (.dispositions) report]+              sourceMapPath path = T.isSuffixOf "/BehaviorSourceMap.hs" (T.pack path)+          overwritten `shouldSatisfy` \case+            [path] -> sourceMapPath path+            _ -> False+          (.declarations) (report.semanticImpact) `shouldBe` []+          map (.category) ((.generatedArtifactImpact) 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 <> ":" <> (.path) 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", "TemplateHaskell"]+      generatedExtensionsEndingIn "ScalarAccount/Transducer.hs" scalar+        `shouldBe` ["BlockArguments", "OverloadedLabels", "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 ((.path) generatedModule)+            ]+      structuralShapeExtensions `shouldSatisfy` all null+      generatedExtensionsEndingIn "Projection.hs" reservation `shouldBe` []+      generatedExtensionsEndingIn "ReplayAudit.hs" reservation `shouldBe` []+      generatedExtensionsEndingIn "Contract.hs" contract `shouldBe` []+      generatedExtensionsEndingIn "Inbox.hs" intake `shouldBe` []+      generatedExtensionsEndingIn "Queue.hs" queue `shouldBe` []+      generatedExtensionsEndingIn "ReadModel.hs" readModel `shouldBe` []++    it "conditions label and derivation extensions on emitted syntax while record defaults stay manifest-owned" $ 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 ((checkedSpec mappedGuardService).context)) 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` []+      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 <- (.nodes) spec],+                generatedModule <- scaffoldContract (defaultContext (spec.context)) contractNode+              ]+      contractExtensions disjoint `shouldBe` []+      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 . (.path)) 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 ((checkedSpec service).context)+      case serviceHarnessModule ctx service of+        Left duplicates -> expectationFailure ("unexpected duplicate fact keys: " <> show duplicates)+        Right facade -> do+          committed <- readTestText ("test/conformance-newsurface/" <> (.path) facade)+          normalizeGenerated committed `shouldBe` normalizeGenerated ((.text) facade)+          moduleNameOf ((.path) facade) `shouldBe` "Generated.TransferRouting.Conformance"+          (.text) facade `shouldSatisfy` T.isInfixOf ".harnessAssertions"+          (.text) facade `shouldSatisfy` T.isInfixOf ".readModelFactResults"+          (.text) facade `shouldSatisfy` T.isInfixOf "aggregate/Hospital/"+          (.text) facade `shouldSatisfy` T.isInfixOf "readmodel/hospital_load/"+          (.text) facade `shouldSatisfy` T.isInfixOf "qualified as Hospital"+          (.text) facade `shouldSatisfy` T.isInfixOf "qualified as HospitalLoad"+          (.text) facade `shouldNotSatisfy` T.isInfixOf "qualified as Harness"+          (.text) 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 . (.nodes) . 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 (specWithNodes factNodes baseSpec) processService+          ctx = defaultContext (baseSpec.context)+      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+          (.text) facade `shouldSatisfy` T.isInfixOf ".processHarnessValues"+          (.text) facade `shouldSatisfy` T.isInfixOf ".routerHarnessValues"+          (.text) facade `shouldSatisfy` T.isInfixOf ".workflowFactValues"+    it "uses the shared context-level placement policy" $ do+      service <- checkedServiceOf "test/fixtures/contract-v4.keiro"+      let ctx = Context {name = "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+          (.text) facade `shouldSatisfy` T.isInfixOf "runServiceConformanceChecks = pure []"+          (.text) 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 ((checkedSpec service).context)+          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 ((.path) 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 =+            [ ((.text) moduleValue, provenance)+            | (moduleValue, provenance) <- (.modules) workspacePlan,+              ".Conformance" `T.isSuffixOf` moduleNameOf ((.path) 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 {} <- (.nodes) spec]+          duplicated = checkedServiceWithSpec (specWithNodes (processes <> processes) spec) service+      serviceHarnessModule (defaultContext (spec.context)) 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)+      (.packageName) plan `shouldBe` "keiro-hospital-surge-conformance"+      length [file | file <- (.files) plan, takeExtension ((.path) file) == ".cabal"] `shouldBe` 1+      cabalFile <- case [file | file <- (.files) plan, takeExtension ((.path) file) == ".cabal"] of+        [file] -> pure file+        files -> expectationFailure ("expected one Cabal file, got " <> show (map (.path) files)) >> fail "unreachable"+      let cabalText = (.text) 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 <- (.files) plan, (.path) file == conformanceRecordFileName] of+        [file] -> pure file+        files -> expectationFailure ("expected one package record, got " <> show (map (.path) files)) >> fail "unreachable"+      let recordText = (.text) recordFile+      parseConformancePackageRecord recordText+        `shouldBe` Just+          ConformancePackageRecord+            { schema = 1,+              serviceKey = (.serviceKey) plan,+              runtimePackage = runtimePackage,+              facadeModule = facade,+              files = [((.kind) file, (.path) file) | file <- (.files) 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+              { schema = 1,+                serviceKey = StandaloneConformanceService "hospital-surge",+                runtimePackage = RuntimePackageName "hospital-runtime",+                facadeModule = "Generated.HospitalSurge.Conformance",+                files = [(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 (spec.context)+            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" ((.sourceLanguage) parsed) ctx service modules+        firstReport <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure first+        firstPackage <- maybe (expectationFailure "expected conformance package report" >> fail "unreachable") pure ((.conformancePackage) firstReport)+        let packageRoot = out </> conformancePackageDirectory (StandaloneConformanceService ((.name) ctx))+            expectationsPath = packageRoot </> "src/KeiroConformance/Expectations.hs"+            accepted = "module KeiroConformance.Expectations where\n-- accepted by the application\n"+        map snd ((.dispositions) firstPackage) `shouldContain` [ConformanceCreated]+        TIO.writeFile expectationsPath accepted+        second <- executeServiceScaffoldWithRuntimePackage (Just runtimePackage) out True "hospital-surge.keiro" ((.sourceLanguage) parsed) ctx service modules+        secondReport <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure second+        secondPackage <- maybe (expectationFailure "expected conformance package report" >> fail "unreachable") pure ((.conformancePackage) secondReport)+        TIO.readFile expectationsPath `shouldReturn` accepted+        [ disposition+          | (file, disposition) <- (.dispositions) secondPackage,+            (.kind) file == Generated+          ]+          `shouldSatisfy` all (== ConformanceUnchanged)+        [ disposition+          | (file, disposition) <- (.dispositions) secondPackage,+            (.kind) 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 (spec.context)+            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"+                ((.sourceLanguage) 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 ((.name) ctx))+          sourceModules <-+            either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure $+              planTestServiceScaffoldWithRuntimePackage (Just sourceRuntime) ctx service+          _ <-+            executeServiceScaffoldWithRuntimePackageAndNameMigrations+              (Just sourceRuntime)+              False+              source+              False+              "hospital-surge.keiro"+              ((.sourceLanguage) 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 " <> (.name) ctx,+                       "runtime-package " <> (.unRuntimePackageName) ((.runtimePackage) record),+                       "facade-module " <> (.facadeModule) record+                     ]+                  <> [ "file "+                         <> (case fileKind of Generated -> "generated"; HoleStub -> "create-once")+                         <> " "+                         <> T.pack path+                     | (fileKind, path) <- (.files) record+                     ]+            )+        refused <- run False+        refused `shouldSatisfy` \case+          Left [SidecarMigrationRequired [move]] ->+            (.moveDisposition) move == ConvertLegacyConformanceLedger+          _ -> False++        applied <- run True >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        map (.moveDisposition) ((.sidecarMoves) 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 (spec.context)+            runtimePackage = RuntimePackageName "hospital-runtime"+            packageRoot = out </> conformancePackageDirectory (StandaloneConformanceService ((.name) ctx))+            currentPath = packageRoot </> conformanceLedgerFileName+            legacyPath = packageRoot </> legacyConformanceRecordFileName+            backupPath = out </> ".keiro-dsl-name-migrations/sidecar-v1" </> conformancePackageDirectory (StandaloneConformanceService ((.name) 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"+                ((.sourceLanguage) 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 =+              conformanceRecordWithFiles+                [ (fileKind, if path == conformanceLedgerFileName then legacyConformanceRecordFileName else path)+                | (fileKind, path) <- record.files+                ]+                record+            legacyContents =+              T.unlines $+                [line | line <- T.lines currentContents, isGeneratedBannerLine line]+                  <> [ "schema 1",+                       "service-key " <> renderLegacyKey ((.serviceKey) legacyRecord),+                       "runtime-package " <> (.unRuntimePackageName) legacyRecord.runtimePackage,+                       "facade-module " <> (.facadeModule) legacyRecord+                     ]+                  <> ["file " <> renderLegacyKind fileKind <> " " <> T.pack path | (fileKind, path) <- (.files) legacyRecord]+        renameFile currentPath legacyPath+        TIO.writeFile legacyPath legacyContents+        migrationTreeBefore <- treeSnapshot out+        refused <- run False+        refused `shouldSatisfy` \case+          Left [SidecarMigrationRequired [move]] -> (.moveDisposition) move == ConvertLegacyConformanceLedger+          _ -> False+        treeSnapshot out `shouldReturn` migrationTreeBefore+        applied <- run True >>= either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure+        map (.moveDisposition) ((.sidecarMoves) applied) `shouldBe` [ConvertLegacyConformanceLedger]+        doesFileExist legacyPath `shouldReturn` False+        TIO.readFile backupPath `shouldReturn` legacyContents+        migrated <- TIO.readFile currentPath+        (.serviceKey) <$> parseConformancePackageRecord migrated+          `shouldBe` Just (StandaloneConformanceService ((.name) ctx))++        TIO.writeFile+          currentPath+          ( T.replace+              ("service-key standalone " <> (.name) 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 (spec.context)+            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" ((.sourceLanguage) parsed) ctx service modules+          >>= either (\failure -> expectationFailure (show failure)) (const (pure ()))+        facade <- case [moduleValue | moduleValue <- modules, ".Conformance" `T.isSuffixOf` moduleNameOf ((.path) moduleValue)] of+          [moduleValue] -> pure moduleValue+          values -> expectationFailure ("expected one facade, got " <> show (map (.path) values)) >> fail "unreachable"+        let facadePath = out </> (.path) facade+            serviceKey = (.name) 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" ((.sourceLanguage) 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 {} <- (.nodes) (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+        (.serviceKey) <$> 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"+            path = 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 path+          >>= TIO.writeFile path . 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"+        localSourcePackages <-+          filterM+            doesDirectoryExist+            [ repositoryRoot </> "keiro",+              repositoryRoot </> "keiro-core"+            ]+        -- Compiling this generated package is a repository integration proof:+        -- it deliberately builds against the sibling keiro and keiro-core+        -- source packages. The package-owned scaffold and immutable-+        -- Expectations assertions above remain active in an unpacked sdist.+        unless (null localSourcePackages) $ do+          let packageRoots = localSourcePackages <> [copied </> "runtime", packageRoot]+          TIO.writeFile+            projectPath+            ( T.unlines $+                ["packages:"]+                  <> map (("  " <>) . T.pack) packageRoots+                  <> [ "",+                       "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 {path = "Gen/Foo.hs", text = "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 {path = "Foo/Holes.hs", text = "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 {path = "Gen/Q.hs", text = "quality = split facility", kind = Generated, origin = "test"}+          dirty = ScaffoldModule {path = "Gen/L.hs", text = "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 ((checkedSpec service).context)+      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 ((.text) 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, _) <- (.modules) workspacePlan, (.kind) moduleValue == Generated] $ \moduleValue ->+        filter isGeneratedBannerLine (T.lines ((.text) 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 (spec.context)+        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 </> target.path+                stamped = generatedBannerFor (effectiveLanguageContract LegacyUnversioned) ((.origin) target)+                legacyText = T.replace stamped generatedBanner ((.text) 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` (.text) 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 <- (.nodes) spec] of+        aggregate : _ -> do+          let caseVariant =+                specWithNodes+                  [ NAggregate aggregate,+                    NAggregate (aggregateWithName (T.toUpper aggregate.name) aggregate)+                  ]+                  spec+              diagnostics =+                checkTestServiceDiagnostics+                  Nothing+                  (defaultContext (caseVariant.context))+                  (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 ((.loc) 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 <- (.nodes) spec] of+        contract : _ -> do+          let defective =+                mapPublisher+                  (publisherWithBackoff (BackoffSpec "exponential" "2s" Nothing Nothing))+                  (specWithNodes (NContract contract : spec.nodes) spec)+              ctx = defaultContext (defective.context)+              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 {mapped = map moveArtifactBindingIntoGenerated ((.mapped) spec)}+      checkTestServiceDiagnostics Nothing (defaultContext (cyclic.context)) (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 <- (.nodes) spec] of+        aggregate : _ -> do+          let duplicate = specWithNodes [NAggregate aggregate, NAggregate aggregate] spec+              caseVariant = specWithNodes [NAggregate aggregate, NAggregate (aggregateWithName (T.toUpper aggregate.name) aggregate)] spec+          planTestScaffold (defaultContext (spec.context)) duplicate `shouldSatisfy` hasPathCollisionWithTwoOrigins+          planTestScaffold (defaultContext (spec.context)) 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 (spec.context)+        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 </> (.path) 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` (.text) 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 (spec.context)) spec+        let renamed = specWithNodes (map renameCounter spec.nodes) spec+        second <- executePlannedScaffold out "counter.keiro" (defaultContext (renamed.context)) renamed+        let oldDomain = onlyPathEndingIn "Counter/Domain.hs" (map fst ((.dispositions) first))+            oldHoles = onlyPathEndingIn "Counter/Holes.hs" (map fst ((.dispositions) first))+        (.stale) 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 (spec.context)) spec+        let oldDomain = onlyPathEndingIn "Counter/Domain.hs" (map fst ((.dispositions) first))+            renamed = specWithNodes (map renameCounter spec.nodes) spec+        TIO.writeFile (out </> oldDomain) "-- generated by something else\n"+        second <- executePlannedScaffold out "counter.keiro" (defaultContext (renamed.context)) renamed+        (.stale) 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 (spec.context)+            rootedCtx = contextWithModuleRoot "Acme" initialCtx+        first <- executePlannedScaffold out "counter.keiro" initialCtx spec+        second <- executePlannedScaffold out "moved-counter.keiro" rootedCtx spec+        (.stale) second+          `shouldMatchList` [ StaleModule ((.kind) m) ((.path) m) (if (.kind) m == Generated then Just ExactGeneratedBannerPresent else Nothing)+                            | (m, _) <- (.dispositions) first+                            ]+        forM_ ((.stale) second) $ \stale -> doesFileExist (out </> (.path) 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 (spec.context)+            collocatedCtx = initialCtx {placement = CollocatedLeaf}+        first <- executePlannedScaffold out "counter.keiro" initialCtx spec+        second <- executePlannedScaffold out "counter.keiro" collocatedCtx spec+        let oldGenerated = [StaleModule Generated ((.path) m) (Just ExactGeneratedBannerPresent) | (m, _) <- (.dispositions) first, (.kind) m == Generated]+        (.stale) second `shouldSatisfy` all (`elem` oldGenerated)+        length ((.stale) 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 (spec.context)+        report <- executePlannedScaffold out "counter.keiro" ctx spec+        (.stale) report `shouldBe` []+        renderScaffoldReport report `shouldSatisfy` all (not . T.isPrefixOf "stale:")+        contents <- TIO.readFile (out </> recordFileName (spec.context))+        requirements <- either (\errors -> expectationFailure (show errors) >> pure []) pure (Behavior.deriveBehaviorRequirements spec)+        let expected =+              ScaffoldRecord+                { specPath = "counter.keiro",+                  moduleRoot = "",+                  layout = "prefixed",+                  sourceLanguage = LegacyUnversioned,+                  languageContract = effectiveLanguageContract LegacyUnversioned,+                  namingEdition = IdiomaticNamingV2,+                  moduleRoles = [ScaffoldModuleRoleRow (moduleRole m) ((.kind) m) ((.path) m) | (m, _) <- (.dispositions) report],+                  files = [((.kind) m, (.path) m) | (m, _) <- (.dispositions) report],+                  mappings = [],+                  idDomains = [],+                  nominalEqualities = [],+                  bindingObligations = [],+                  behaviorRequirements = Behavior.behaviorRecordRows requirements,+                  projectionCatalogFacts = [],+                  queryContractBaseline = False,+                  queryContracts = either (const []) id (queryContractIdentities spec),+                  routerSelections = [],+                  semanticImpact = 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 (spec.context)+        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+                (.sourceLanguageDrift) report+                  `shouldBe` Just (SourceLanguageDrift LegacyUnversioned declared)+                contents <- TIO.readFile ((.recordPath) report)+                (.sourceLanguage) <$> 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 <- (.nodes) spec] of+        process : _ -> do+          let timer = timerNodeWithPayload [FieldBinding "kind" (Just "\"follow-up\\\"")] process.timer+              modules = scaffoldProcess (defaultContext (spec.context)) process {timer = 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 (spec.context)) spec =<< [aggregate | NAggregate aggregate <- (.nodes) 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 <- (.nodes) exponential] of+        publisher : _ -> do+          let generated = generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (exponential.context)) 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 <- (.nodes) constant] of+        publisher : _ -> generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (constant.context)) 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 <- (.nodes) queueSpec] of+        workqueue : _ -> do+          let policy = generatedTextEndingIn "QueuePolicy.hs" (scaffoldWorkqueue (defaultContext (queueSpec.context)) 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 <- (.nodes) statusSpec] of+        aggregate : _ -> do+          let ctx = defaultContext (statusSpec.context)+              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 {parsedSource = parsedSource, sourceIndex = sourceIndex} = document+          service = checkedSource parsedSource+          spec = checkedSpec service+          ctx = defaultContext (spec.context)+          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 . (.modules)) (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+          (.json) golden `shouldSatisfy` T.isInfixOf "\"family\":\"sample\""+          (.json) golden `shouldSatisfy` T.isInfixOf "\"type\":\"sample\""+          (.json) golden `shouldSatisfy` T.isInfixOf "\"region_code\":\"sample\""+          (.json) golden `shouldSatisfy` (not . T.isInfixOf "payloadType")+          (.json) 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 ((checkedSpec service).context)) 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"+          (.json) golden+            `shouldBe` "{\"commandId\":\"cmd_01hzy3v7q2e8kaw2m5x0d41n9c\",\"divertStatus\":\"open\",\"hospitalId\":\"hosp_01hzy3v7q2e8kaw2m5x0d41n9c\",\"kind\":\"TransferReservationCreated\",\"lifeCriticalOverride\":true,\"patientAcuity\":\"red\",\"reservationId\":\"rsv_01hzy3v7q2e8kaw2m5x0d41n9c\"}\n"+          (.evidence) golden `shouldBe` SynthesizedWeakStandIn+          let aggregate = onlyAggregate newSpec+              modules =+                harnessForWithGoldens+                  [golden]+                  (defaultContext (newSpec.context))+                  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+          (.evidence) golden `shouldBe` SynthesizedWeakStandIn+          (.json) golden `shouldSatisfy` T.isInfixOf "\"artifact\":{"+          (.json) golden `shouldSatisfy` T.isInfixOf "\"location\":{\"contents\":\"sample\",\"tag\":\"local_file\"}"+          (.json) golden `shouldSatisfy` T.isInfixOf "\"labels\":[\"sample\"]"+          (.json) golden `shouldSatisfy` T.isInfixOf "\"revision\":1"+          (.json) 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` (.json) 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 = parsed.spec+      case [aggregate | NAggregate aggregate <- (.nodes) spec] of+        [_] -> do+          let modules = scaffoldServiceModules (defaultContext (spec.context)) (checkedSource parsed)+              codec = generatedTextEndingIn "Codec.hs" modules+              holes = case [(.text) m | m <- modules, "/Holes.hs" `T.isSuffixOf` T.pack ((.path) 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 . (.path)) 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 (.text) a `shouldBe` map (.text) 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 -> ((.path) m, (.kind) m, (.text) m)) retiring+        `shouldBe` map (\m -> ((.path) m, (.kind) m, (.text) 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/" <> (.path) m)+        normalizeGenerated committed `shouldBe` normalizeGenerated ((.text) m)+    it "scaffolds the register-free OrderStream smoke target without error" $ do+      mods <- scaffoldFixture "test/fixtures/order.keiro"+      -- Stable and.aggregate.modules.context 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 <- (.nodes) spec] of+        aggregate : _ -> do+          let ctx = defaultContext (spec.context)+              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 (.text) 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 (.text) 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+        (.service) manifest `shouldBe` "demo-project"+        (.runtimePackage) manifest `shouldBe` Nothing+        (.moduleRoot) manifest `shouldBe` Just "Demo.Modules.Project"+        (.layout) manifest `shouldBe` Just CollocatedLeaf+        map (.path) (NE.toList ((.members) 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"+              ]+        (.runtimePackage) 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+        (.service) workspace `shouldBe` "demo-project"+        workspace.context `shouldBe` "demo-project"+        (.moduleRoot) workspace `shouldBe` Just "Demo.Modules.Project"+        (.layout) workspace `shouldBe` Just CollocatedLeaf+        map (.path) ((.members) 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 ownershipIndex = workspace.ownership+        fmap fst (declarationOwner ownershipIndex "id" "ProjectId")+          `shouldBe` Just "domain/shared.keiro"+        fmap fst (declarationOwner ownershipIndex "enum" "ProjectPhase")+          `shouldBe` Just "domain/shared.keiro"+        fmap fst (declarationOwner ownershipIndex "rule" "phaseIsTerminal")+          `shouldBe` Just "domain/shared.keiro"+        fmap fst (declarationOwner ownershipIndex "mapped" "ProjectSummary")+          `shouldBe` Just "domain/shared.keiro"+        fmap fst (nodeOwner ownershipIndex "aggregate" "Project")+          `shouldBe` Just "domain/project.keiro"+        fmap fst (nodeOwner ownershipIndex "aggregate" "ProjectArtifact")+          `shouldBe` Just "domain/project-artifact.keiro"+        fmap fst (nodeOwner ownershipIndex "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 = [((.path) m, (.lineBase) m, (.lineCount) m) | m <- (.members) 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+        workspaceWithManifestPath canonical.manifestPath reordered `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))+                  ((.sourceIndex) workspace)+              betaBase workspace = (.lineBase) <$> find ((== "b.keiro") . (.path)) ((.members) 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 {parsedSource} = document+              compatibility = oneMemberParsedWorkspace "b.keiro" parsedSource+          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) . (.severity))+    describe "composition refusals" $ do+      let refusesWith path expectedCode expectedFiles = do+            diagnostics <- shouldRefuseWorkspace path+            map (.code) (NE.toList diagnostics) `shouldContain` [expectedCode]+            let cited =+                  [ (.file) location+                  | diagnostic <- NE.toList diagnostics,+                    (.code) diagnostic == expectedCode,+                    location <- NE.toList ((.locations) 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, (.severity) d == Error]+        map (.code) errors `shouldContain` [GuardAtomOutOfScope]+        [(.file) location | d <- errors, location <- NE.toList ((.locations) 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 ((.mergedSpec) oldAdded) ((.mergedSpec) 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 ((.mergedSpec) oldRemoved) ((.mergedSpec) 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 ((.mergedSpec) oldRenamed) ((.mergedSpec) 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 . (.change)) changes+          mappedChanges = filter ((== MappedFieldTypeChanged) . changeCode . (.change)) changes+          citedFiles workspaceChanges =+            [ (.file) site+            | change <- workspaceChanges,+              (_, Just site) <- (.useSites) change+            ]+      enumChanges `shouldSatisfy` (not . null)+      mappedChanges `shouldSatisfy` (not . null)+      let enumWireChanges =+            [ underlyingChange+            | workspaceChange <- enumChanges,+              let underlyingChange = workspaceChange.change,+              OldBinaryReadNewEvents `elem` breakingSurfaces underlyingChange+            ]+      enumWireChanges `shouldSatisfy` (not . null)+      enumWireChanges `shouldSatisfy` all (not . gatedBreaking defaultGate)+      enumWireChanges `shouldSatisfy` all (gatedBreaking (gateWith [OldBinaryReadNewEvents]))+      map (fmap (.file) . (.declarationSite)) (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+              { identity = (.service) new,+                manifest = "service.keiro-workspace",+                since = "HEAD",+                membersOld = map (.path) ((.members) old),+                membersNew = map (.path) ((.members) new),+                adoptionBaseline = 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 ((.mergedSpec) old) ((.mergedSpec) 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 . (.change)) changes `shouldBe` [OwnershipMoved]+      forM_ changes $ \workspaceMove -> do+        let move = (.change) workspaceMove+        move `shouldSatisfy` isAdvisory+        move `shouldSatisfy` (not . gatedBreaking defaultGate)+        move `shouldSatisfy` (not . gatedBreaking (gateWith [minBound .. maxBound]))+        deriveLabel defaultGate ((workspaceChangeKind move).vector) `shouldBe` LabelAdvisory+        remediationFor ((workspaceChangeKind move).context) 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 ownershipIndex = old.ownership+          renamed =+            workspaceWithOwnership+              (OwnershipIndex ownershipIndex.declarations (Map.adjust (\(_, loc) -> ("domain/shipping.keiro", loc)) ("aggregate", "Shipment") ownershipIndex.nodes))+              old+          moves = filter ((== OwnershipMoved) . changeCode . (.change)) (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 ownershipIndex = edited.ownership+          movedAndEdited =+            workspaceWithOwnership+              (OwnershipIndex ownershipIndex.declarations (Map.adjust (\(_, loc) -> ("domain/order.keiro", loc)) ("aggregate", "Shipment") ownershipIndex.nodes))+              edited+          codes = map (changeCode . (.change)) (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 =+            workspaceWithContextAndMergedSpec newContext (specWithContext newContext old.mergedSpec) old+          changes = diffWorkspaces old renamed+          codes = map (changeCode . (.change)) changes+      codes `shouldContain` [WorkspaceAuthorityChanged]+      codes `shouldContain` [DerivedIdentityChanged]+      map (.change) changes `shouldSatisfy` any (gatedBreaking defaultGate)++    it "keeps service, module-root, and layout authority advisories non-blocking" $ do+      old <- shouldComposeWorkspace canonicalWorkspacePath+      let changed = workspaceWithAuthority "demo-project-renamed" (Just "Demo.Modules.Renamed") (Just GeneratedPrefix) old+          authority = filter ((== WorkspaceAuthorityChanged) . changeCode . (.change)) (diffWorkspaces old changed)+      length authority `shouldBe` 3+      forM_ (map (.change) authority) $ \change -> do+        deriveLabel defaultGate ((workspaceChangeKind change).vector) `shouldBe` LabelAdvisory+        change `shouldSatisfy` (not . gatedBreaking (gateWith [minBound .. maxBound]))+        remediationFor ((workspaceChangeKind change).context) 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 <- (.modules) record, (.owner) 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 (plan.modules)+            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+          (.text) audit `shouldSatisfy` T.isInfixOf "Project.projectEventStream"+          (.text) 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 = plan.context+            modules = map fst (plan.modules)+            nominalModules = [m | m <- modules, (.path) m == T.unpack (T.replace "." "/" (generatedNominalModule ctx) <> ".hs")]+            internalNominalModules = [m | m <- modules, (.path) 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 (.path) found)) >> fail "unreachable"+        ownerModule <- case nominalModules of+          [m] -> pure m+          found -> expectationFailure ("expected one generated nominal owner, got " <> show (map (.path) found)) >> fail "unreachable"+        internalOwnerModule <- case internalNominalModules of+          [m] -> pure m+          found -> expectationFailure ("expected one generated internal nominal owner, got " <> show (map (.path) found)) >> fail "unreachable"+        let nominalText = (.text) ownerModule+            internalNominalText = (.text) 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+          (.text) domain `shouldSatisfy` (not . T.isInfixOf "newtype ProjectId")+          (.text) domain `shouldSatisfy` (not . T.isInfixOf "data ProjectPhase")+          (.text) domain `shouldSatisfy` T.isInfixOf (generatedNominalModule ctx <> " (ProjectId, parseProjectId, ProjectPhase (..))")+          (.text) 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 ((.sourceIndex) ((.workspace) plan)) ctx (plan.checkedService) of+          Left refusals -> expectationFailure (show refusals) >> fail "unreachable"+          Right values -> pure values+        let withoutOrigin m = ((.path) m, (.text) m, (.kind) m)+        map withoutOrigin singleFileModules `shouldBe` map withoutOrigin modules+        owners <- case planNominalGeneration ctx ((.mergedSpec) ((.workspace) plan)) of+          Left errors -> expectationFailure (show errors) >> fail "unreachable"+          Right values -> pure values+        map ((.name) . (.declaration)) owners+          `shouldBe` ["ProjectId", "ProjectPhase", "WorkspaceVisibility"]+        case [owner | owner <- owners, (.name) ((.declaration) owner) == "ProjectId"] of+          [owner] -> do+            (.moduleName) owner `shouldBe` generatedNominalModule ctx+            Set.fromList [NominalUseSite "Project" RegisterUse, NominalUseSite "ProjectArtifact" EventFieldUse]+              `shouldSatisfy` (`Set.isSubsetOf` (.useSites) 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 (.path) ((.members) ((.workspace) plan))+            ownerOf suffix =+              case [provenance | (m, provenance) <- (.modules) 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) ((.modules) 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 ((.modules) plan) `shouldSatisfy` all (not . isSuffixOfPath "/Holes.hs")+        forM_ compiledPaths $ \path ->+          case [m | (m, _) <- (.modules) plan, m.path == path] of+            [generated] -> do+              committed <- readTestText ("test/conformance-workspace-nominals/" <> path)+              normalizeGenerated committed `shouldBe` normalizeGenerated ((.text) generated)+            found -> expectationFailure ("expected one generated module at " <> path <> ", got " <> show (map (.path) 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 {parsedSource = parsedSource, sourceIndex = sourceIndex} = document+              service = checkedSource parsedSource+              spec = checkedSpec service+              ctx = defaultContext (spec.context)+              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 ((.modules) 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+                  workspaceSourceMap.path `shouldBe` singleSourceMap.path+                  (.text) workspaceSourceMap+                    `shouldBe` T.replace (T.pack path) (T.pack (takeFileName path)) ((.text) singleSourceMap)+                found -> expectationFailure ("expected one source map per planning path, got " <> show (map (.path) (fst found), map (.path) (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 {parsedSource = parsedSource} = document+            spec = checkedSpec (checkedSource parsedSource)+        case planWorkspaceScaffold "goldens" (defaultContext (spec.context)) workspace of+          Left refusals -> expectationFailure ("reservation should plan: " <> show refusals)+          Right plan -> do+            (.modules) plan `shouldSatisfy` (not . null)+            map snd ((.modules) plan)+              `shouldSatisfy` all (`elem` [ContextLevel, MemberOwned "reservation.keiro"])+            map snd ((.modules) plan)+              `shouldSatisfy` elem (MemberOwned "reservation.keiro")+      it "computes obligations from the complete merged graph, spanning members" $ do+        workspace <- shouldComposeWorkspace canonicalWorkspacePath+        case bindingObligations ((.mergedSpec) workspace) of+          Left graphErrors -> expectationFailure ("merged graph did not resolve: " <> show graphErrors)+          Right obligations ->+            case [o | o <- obligations, (.mappedName) o == "ProjectSummary", (.kind) o == BindingValue] of+              [obligation] -> do+                (.useSites) obligation+                  `shouldSatisfy` any (T.isInfixOf "Project register summary")+                (.useSites) 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+          (.recordPath) report+            `shouldBe` out </> workspaceLedgerFileName "demo-project"+          (.buildManifestPath) report+            `shouldBe` out </> workspaceCabalFragmentFileName "demo-project"+          doesFileExist (out </> recordFileName "demo-project") `shouldReturn` False+          doesFileExist (out </> contextCabalFragmentFileName "demo-project") `shouldReturn` False+          contents <- TIO.readFile ((.recordPath) report)+          buildManifest <- TIO.readFile ((.buildManifestPath) report)+          assertGeneratedHaskellContract "service.keiro-workspace" buildManifest+          case parseWorkspaceRecord contents of+            Nothing -> expectationFailure ("workspace record did not parse:\n" <> T.unpack contents)+            Just record -> do+              (.service) record `shouldBe` "demo-project"+              (.manifest) record `shouldBe` "service.keiro-workspace"+              (.queryContractBaseline) record `shouldBe` False+              contents `shouldNotSatisfy` T.isInfixOf "query-contract-baseline"+              (.members) 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.+              [(.path) row | row <- (.modules) record, (.owner) 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+              [ (.owner) row+                | row <- (.modules) record,+                  "Project/Generated/Domain.hs" `T.isSuffixOf` T.pack ((.path) 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 = workspace.service+              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) . (.moveDisposition)) moves+            _ -> False+          treeSnapshot out `shouldReturn` migrationTreeBefore+          applied <- executeWorkspaceScaffoldWithNameMigrations out False True plan+          report <- either (\failure -> expectationFailure (show failure) >> fail "unreachable") pure applied+          map (.moveDisposition) ((.sidecarMoves) report) `shouldBe` [RenameSidecar, RenameSidecar]+          (.stale) 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 -> (.sidecarMoves) 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 ((.dispositions) second)+            `shouldSatisfy` all (`elem` [Unchanged, Skipped])+          (.stale) second `shouldBe` []+          (.ownershipMoves) second `shouldBe` []+          (.mappingDrift) second `shouldBe` []+          (.newHoles) second `shouldBe` []+          -- The first run had to write; the claim is not vacuous.+          map thd3 ((.dispositions) 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 =+                [(.path) generatedModule | (generatedModule, _, Overwritten) <- (.dispositions) second]+          overwrittenPaths `shouldSatisfy` \case+            [path] -> T.isSuffixOf "/BehaviorSourceMap.hs" (T.pack path)+            _ -> False+          (.declarations) (second.semanticImpact) `shouldBe` []+          map (.category) ((.generatedArtifactImpact) 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 =+                [ (.path) m+                | (m, provenance, _) <- (.dispositions) 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 (.path) ((.stale) 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+          (.stale) second+            `shouldSatisfy` all+              ( \stale -> case (.kind) stale of+                  Generated -> (.generatedEvidence) stale == Just ExactGeneratedBannerPresent+                  HoleStub -> (.generatedEvidence) 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+          (.stale) second `shouldBe` []+          let moves = (.ownershipMoves) second+          moves `shouldSatisfy` (not . null)+          moves+            `shouldSatisfy` all+              ( \move ->+                  (.previous) move == Just "domain/project-artifact.keiro"+                    && (.current) move == Just "domain/project.keiro"+              )+          map (.path) moves+            `shouldSatisfy` any (T.isInfixOf "ProjectArtifact" . T.pack)+          -- Behavior contracts contain only semantic identity. Moving a+          -- declaration rewrites the one source.map.context, while the ledger+          -- independently records module ownership moves.+          map thd3 ((.dispositions) second)+            `shouldSatisfy` all (`elem` [Unchanged, Skipped, Overwritten])+          let overwrittenPaths =+                [(.path) generatedModule | (generatedModule, _, Overwritten) <- (.dispositions) 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, _) <- (.modules) plan, (.kind) m == Generated]+          case generated of+            [] -> expectationFailure "workspace fixture has no Generated module"+            target : _ -> do+              let path = out </> target.path+              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` (.text) 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 [(.path) m | (m, _) <- (.modules) 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+          path <- 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 </> path) "-- hand-owned 0.6 implementation\n"++          report <- executePlannedWorkspaceScaffold out workspace+          (.stale) report `shouldBe` []+          [disposition | (m, _, disposition) <- (.dispositions) report, m.path == domainPath]+            `shouldBe` [Overwritten]+          [disposition | (m, _, disposition) <- (.dispositions) report, m.path == 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 </> path) `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-specs.context+          -- 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+          (.stale) legacyB `shouldSatisfy` (not . null)+          legacyBefore <- TIO.readFile (out </> recordFileName "adoption-demo")++          report <- executePlannedWorkspaceScaffold out workspace+          (.stale) report `shouldBe` []+          case (.migration) report of+            Nothing -> expectationFailure "expected the first workspace run to adopt"+            Just migration -> do+              let generatedOf run = sort [(.path) m | (m, _) <- (.dispositions) run, (.kind) m == Generated]+                  claimedBy evidence = sort [entry.path | entry <- migration.claimed, entry.evidence == 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)+              (.likelyStale) migration `shouldBe` []+              (.legacyRecord) migration+                `shouldBe` Just (recordFileName "adoption-demo", "domain/b.keiro")+              -- Provenance is persisted, not merely printed.+              recorded <- parseWorkspaceRecord <$> TIO.readFile ((.recordPath) report)+              fmap (sort . map (.path) . (.adopted)) recorded+                `shouldBe` Just (sort (map (.path) ((.claimed) migration)))+              fmap (sort . nubOrd . map (.evidence) . (.adopted)) 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+            (.migration) 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 (.migration) report of+            Nothing -> expectationFailure "expected legacy-name context history to be adopted"+            Just migration -> (.legacyRecord) 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 [(.path) m | (m, _) <- (.modules) plan, (.kind) m == HoleStub] of+            [] -> expectationFailure "adoption fixture emits no hole module"+            path : _ -> do+              writeFileWithParents (out </> path) "-- hand filled\n"+              writeFileWithParents (out </> "Notes.hs") "module Notes where\n"+              report <- executePlannedWorkspaceScaffold out workspace+              case (.migration) report of+                Nothing -> expectationFailure "expected a report for a directory holding hand-written files"+                Just migration -> do+                  (.legacyRecord) migration `shouldBe` Nothing+                  (.claimed) migration `shouldBe` []+                  (.unclaimed) migration `shouldBe` sort [path, "Notes.hs"]+              TIO.readFile (out </> path) `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 [(.path) m | (m, _) <- (.modules) 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+          (.migration) 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+          (.migration) second `shouldBe` Nothing+          (.stale) second `shouldBe` []+          map thd3 ((.dispositions) 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+    { historicalCodecIdentity = "example.historical",+      historicalCodecVersion = "legacy-v1",+      canonicalType = CanonicalTypeId "example.Artifact.v1",+      bindingSymbol = QualifiedValueName "Example.Bindings.artifactBinding",+      bindingVersion = BindingVersion "1",+      wireFingerprint = "deadbeef"+    }++syntheticGenerated :: FilePath -> T.Text -> ScaffoldModule+syntheticGenerated path contents =+  ScaffoldModule {path = path, text = 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 changedLineCount 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+    changedLineCount path = case (Map.lookup path previousByPath, Map.lookup path currentByPath) of+      (Just old, Just new) -> differingLineCount ((.text) old) ((.text) new)+      (Just old, Nothing) -> length (T.lines ((.text) old))+      (Nothing, Just new) -> length (T.lines ((.text) new))+      (Nothing, Nothing) -> 0+    generatedByPath modules = Map.fromList [((.path) 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 [((.path) 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 [(.text) m | m <- modules, (.kind) m == Generated, suffix `T.isSuffixOf` T.pack ((.path) 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 ((.path) generatedModule)] of+  [generatedModule] -> generatedLocalExtensions generatedModule+  matches -> error ("expected one generated module ending in " <> T.unpack suffix <> ", got " <> show (map (.path) matches))++generatedLocalExtensions :: ScaffoldModule -> [T.Text]+generatedLocalExtensions generatedModule =+  [ extension+  | line <- takeWhile (T.isPrefixOf languagePrefix) (T.lines ((.text) 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 [(.text) m | m <- modules, (.kind) m == HoleStub, suffix `T.isSuffixOf` T.pack ((.path) m), not ("BehaviorHoles.hs" `T.isSuffixOf` T.pack ((.path) m))] of+  contents : _ -> contents+  [] -> ""++onlyAggregate :: Spec -> Aggregate+onlyAggregate spec = case [aggregate | NAggregate aggregate <- (.nodes) 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+    ( aggregateWithNameAndRegs+        "Widget"+        [regDeclWithValueType (if reg.valueType == TRef "CounterVertex" then TRef "WidgetVertex" else reg.valueType) reg | reg <- aggregate.regs]+        aggregate+    )+renameCounter node = node++onlyPathEndingIn :: FilePath -> [ScaffoldModule] -> FilePath+onlyPathEndingIn suffix modules = case [(.path) m | m <- modules, T.pack suffix `T.isSuffixOf` T.pack ((.path) 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+          { source = "S",+            command = "C",+            implementation = LegacyHoleImplementation,+            guard = Just e,+            writes = [],+            emits = [],+            outcome = Nothing,+            outcomeDuplicateLocs = [],+            goto = "S",+            mode = TmLive,+            loc = 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) . (.code) . kindOfChange)++assertGeneratedHaskellNameFinding :: Change -> Expectation+assertGeneratedHaskellNameFinding change = do+  change `shouldSatisfy` isAdvisory+  let kind = kindOfChange change+      compatibility = kind.vector+      nonBuildVerdicts =+        [ verdictFor surface compatibility+        | surface <- [PrivateHistoryRead, OldBinaryReadNewEvents, SnapshotHydration, PublicConsumer, PersistedIdentity]+        ]+  nonBuildVerdicts `shouldBe` replicate 5 VCompatible+  verdictFor ConsumerBuild compatibility `shouldBe` VAdvisory+  (.rollout) compatibility `shouldBe` Set.empty+  renderFinding change `shouldSatisfy` T.isInfixOf "consumer-build=advisory"+  remediationFor (kind.context) ((.code) 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 =+  specWithNodes+    [ case node of+        NAggregate aggregate | aggregate.name == target -> NAggregate (update aggregate)+        _ -> node+    | node <- spec.nodes+    ]+    spec++modifyReadModel :: Name -> (ReadModelNode -> ReadModelNode) -> Spec -> Spec+modifyReadModel target update spec =+  specWithNodes+    [ case node of+        NReadModel readModel | readModel.name == target -> NReadModel (update readModel)+        _ -> node+    | node <- spec.nodes+    ]+    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 =+  specWithNodes [case node of { NContract contract -> NContract (update contract); _ -> node } | node <- spec.nodes] spec++mapIntake :: (IntakeNode -> IntakeNode) -> Spec -> Spec+mapIntake update spec =+  specWithNodes [case node of { NIntake intake -> NIntake (update intake); _ -> node } | node <- spec.nodes] spec++mapPgmqDispatch :: (PgmqDispatchNode -> PgmqDispatchNode) -> Spec -> Spec+mapPgmqDispatch update spec =+  specWithNodes [case node of { NPgmqDispatch dispatch -> NPgmqDispatch (update dispatch); _ -> node } | node <- spec.nodes] spec++mapRouter :: (RouterNode -> RouterNode) -> Spec -> Spec+mapRouter update spec =+  specWithNodes [case node of { NRouter router -> NRouter (update router); _ -> node } | node <- spec.nodes] spec++mapEmit :: (EmitNode -> EmitNode) -> Spec -> Spec+mapEmit update spec =+  specWithNodes [case node of { NEmit emitNode -> NEmit (update emitNode); _ -> node } | node <- spec.nodes] spec++mapWorkflow :: (WorkflowNode -> WorkflowNode) -> Spec -> Spec+mapWorkflow update spec =+  specWithNodes [case node of { NWorkflow workflow -> NWorkflow (update workflow); _ -> node } | node <- spec.nodes] spec++mapWorkqueue :: (WorkqueueNode -> WorkqueueNode) -> Spec -> Spec+mapWorkqueue update spec =+  specWithNodes [case node of { NWorkqueue queue -> NWorkqueue (update queue); _ -> node } | node <- spec.nodes] spec++mapDispatch :: (PgmqDispatchNode -> PgmqDispatchNode) -> Spec -> Spec+mapDispatch update spec =+  mapPgmqDispatch update spec++mapOperation :: (OperationNode -> OperationNode) -> Spec -> Spec+mapOperation update spec =+  specWithNodes [case node of { NOperation operation -> NOperation (update operation); _ -> node } | node <- spec.nodes] spec++mapPublisher :: (PublisherNode -> PublisherNode) -> Spec -> Spec+mapPublisher update spec =+  specWithNodes [case node of { NPublisher publisher -> NPublisher (update publisher); _ -> node } | node <- spec.nodes] 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 =+  specWithNodes [node | node <- spec.nodes, not (isTarget node)] spec+  where+    isTarget (NReadModel readModel) = (.name) readModel == target+    isTarget _ = False++modifyRouter :: Name -> (RouterNode -> RouterNode) -> Spec -> Spec+modifyRouter target update spec =+  specWithNodes+    [ case node of+        NRouter router | router.id == target -> NRouter (update router)+        _ -> node+    | node <- spec.nodes+    ]+    spec++routerErrorCodes :: (RouterNode -> RouterNode) -> Spec -> [DiagnosticCode]+routerErrorCodes update = errorCodes . modifyRouter "PagingRouter" update++modifyProcess :: Name -> (ProcessNode -> ProcessNode) -> Spec -> Spec+modifyProcess target update spec =+  specWithNodes+    [ case node of+        NProcess process | process.id == target -> NProcess (update process)+        _ -> node+    | node <- spec.nodes+    ]+    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+    { columns = (.columns) readModel <> [RmColumn "reviewed_by" "text" False],+      shape = "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+      (.contractLanguageVersion) (checkedLanguageContract service) `shouldBe` currentAuthoringLanguageVersion+      effectiveLanguageSupport (checkedLanguageContract service) `shouldBe` Stable+      [(.code) diagnostic | diagnostic <- validateService service, (.severity) diagnostic == Error]+        `shouldBe` ([] :: [DiagnosticCode])+      scaffoldServiceModules (defaultContext ((checkedSpec service).context)) 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 (spec.context)) 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+                     { haskell = "summary",+                       key = "summary",+                       valueType = TText,+                       presence = PRequired,+                       onMissing = Nothing,+                       loc = 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 name spec = spec {mapped = map addField ((.mapped) spec)}+  where+    addField declaration@MappedStructural {msName = declarationName, msShape = ShapeRecord constructor unknownFields fields}+      | declarationName == target =+          declaration+            { msShape =+                ShapeRecord+                  constructor+                  unknownFields+                  ( fields+                      <> [ WireField+                             { haskell = name,+                               key = name,+                               valueType = TOptional TText,+                               presence = POptional,+                               onMissing = Just OmNull,+                               loc = Loc 0+                             }+                         ]+                  )+            }+    addField declaration = declaration++changeAlphaPayloadFixtureSymbol :: Spec -> Spec+changeAlphaPayloadFixtureSymbol spec = spec {mapped = map changeFixture ((.mapped) 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 =+  workspaceWithMembersAndMergedSpec+    [workspaceMemberWithSpec (transform member.spec) member | member <- workspace.members]+    (transform workspace.mergedSpec)+    workspace++expectGenericCompileFailure :: FilePath -> String -> Expectation+expectGenericCompileFailure fixture expectedDiagnostic =+  withTempDirectory ("keiro-dsl-generic-" <> fixture) $ \fixtureDir -> do+    let fixtureSource = fixtureDir </> "Fixture.hs"+        domainSource = fixtureDir </> "Domain.hs"+        shapeSource = fixtureDir </> "Shape.hs"+        recordModule moduleName fields =+          T.unlines+            [ "{-# LANGUAGE DeriveGeneric #-}",+              "module " <> moduleName <> " (Item (..)) where",+              "import Data.Text (Text)",+              "import GHC.Generics (Generic)",+              "data Item = Exact {" <> fields <> "}",+              "  deriving stock (Generic)"+            ]+        (domainFields, shapeFields) = case fixture of+          "renamed-field" -> ("contentHash :: Text", "contentDigest :: Text")+          "reordered-field" -> ("first :: Text, second :: Int", "second :: Int, first :: Text")+          "arity-mismatch" -> ("first :: Text", "first :: Text, second :: Int")+          "incompatible-type" -> ("content :: Text", "content :: Int")+          other -> error ("unknown generic compile-fail fixture: " <> other)+    TIO.writeFile domainSource (recordModule "Domain" domainFields)+    TIO.writeFile shapeSource (recordModule "Shape" shapeFields)+    TIO.writeFile+      fixtureSource+      ( T.unlines+          [ "module Fixture where",+            "import Domain qualified",+            "import Keiro.Codec.Structural (StructuralBinding)",+            "import Keiro.Codec.Structural.Generic (genericStructuralBinding)",+            "import Shape qualified",+            "binding :: StructuralBinding Domain.Item Shape.Item",+            "binding = genericStructuralBinding"+          ]+      )+    keiroCorePackageId <- activeCabalPackageId "keiro-core"+    (exitCode, standardOutput, standardError) <-+      readProcessWithExitCode+        "cabal"+        [ "exec",+          "--enable-tests",+          "--",+          "ghc",+          "-XGHC2024",+          "-fno-code",+          "-fforce-recomp",+          "-package-id",+          keiroCorePackageId,+          "-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` takeFileName fixtureSource++activeCabalPackageId :: String -> IO String+activeCabalPackageId packageName = do+  planPaths <- filterM doesFileExist ["dist-newstyle/cache/plan.json", "../dist-newstyle/cache/plan.json"]+  planPath <- case planPaths of+    candidate : _ -> pure candidate+    [] -> expectationFailure "could not find Cabal's dist-newstyle/cache/plan.json" >> fail "unreachable"+  decodedPlan <- Aeson.eitherDecodeFileStrict' planPath :: IO (Either String Value)+  let packageIds = case decodedPlan of+        Right (Aeson.Object plan) -> case KeyMap.lookup "install-plan" plan of+          Just (Aeson.Array entries) ->+            [ T.unpack packageId+            | Aeson.Object entry <- toList entries,+              KeyMap.lookup "pkg-name" entry == Just (Aeson.String (T.pack packageName)),+              KeyMap.lookup "component-name" entry == Just (Aeson.String "lib"),+              Just (Aeson.String packageId) <- [KeyMap.lookup "id" entry]+            ]+          _ -> []+        _ -> []+  case packageIds of+    [packageId] -> pure packageId+    resolvedPackageIds ->+      expectationFailure+        ( "could not resolve one active Cabal package ID for "+            <> packageName+            <> ": "+            <> show resolvedPackageIds+            <> either (\decodeError -> " (plan decode failed: " <> decodeError <> ")") (const "") decodedPlan+        )+        >> fail "unreachable"++moveArtifactBindingIntoGenerated :: MappedDecl -> MappedDecl+moveArtifactBindingIntoGenerated declaration@MappedStructural {msName = "ArtifactInfo"} =+  declaration {msBinding = Just "Generated.ConsumerDemo.Bindings.artifactInfoBinding"}+moveArtifactBindingIntoGenerated declaration = declaration++removeMappedRegisterRequirements :: Spec -> Spec+removeMappedRegisterRequirements spec =+  spec+    { mapped = map removeInitial ((.mapped) spec),+      nodes = map removeRegisters ((.nodes) spec)+    }+  where+    removeInitial declaration@MappedStructural {} = declaration {msInitial = Nothing}+    removeInitial declaration@MappedOpaque {} = declaration {moInitial = Nothing}+    removeRegisters (NAggregate aggregate) =+      NAggregate+        aggregate+          { regs = [],+            transitions = [transition {writes = []} | transition <- (.transitions) 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) = (.code) kind+changeCode (Advisory kind) = (.code) kind+changeCode (Breaking kind) = (.code) kind++breakingSurfaces :: Change -> [CompatibilitySurface]+breakingSurfaces change =+  [ surface+  | surface <- [minBound .. maxBound],+    verdictFor surface (kind.vector) == 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 (workspaceWithManifestPath path workspace)++-- | The 'Context' a workspace scaffolds under, with no CLI overrides: the+-- members' unanimous name.context, the manifest's module-root and layout+-- authority, and the built-in defaults where the manifest is silent.+workspaceContext :: WorkspaceSpec -> Context+workspaceContext workspace =+  Context+    { name = workspace.context,+      moduleRoot = maybe "" id ((.moduleRoot) workspace),+      placement = maybe GeneratedPrefix id ((.layout) 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 ((.path) 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+    { service = (.service) workspace,+      manifest = "service.keiro-workspace",+      context = workspace.context,+      moduleRoot = maybe "" id ((.moduleRoot) workspace),+      layout = "collocated",+      members = map (.path) ((.members) workspace),+      sourceLanguages =+        [ WorkspaceSourceLanguageRow ((.path) member) ((.sourceLanguage) member)+        | member <- (.members) workspace+        ],+      languageContract = (.languageContract) workspace,+      namingEdition = IdiomaticNamingV1,+      modules =+        [ 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+        ],+      mappings = (.mappings) (consumerPlan ((.mergedSpec) workspace)),+      idDomains = [],+      nominalEqualities = nominalEqualityIdentities ((.mergedSpec) workspace),+      bindingObligations = either (const []) id (bindingHoles ((.mergedSpec) workspace)),+      requirements = [],+      projectionCatalogFacts = [],+      queryContractBaseline = True,+      queryContracts = either (const []) id (queryContractIdentities ((.mergedSpec) workspace)),+      routerSelections = [],+      adopted =+        [ AdoptedRow "claimed/One.hs" "record" (Just "keiro-dsl-ledger.context.demo-project.txt") (Just "project.keiro"),+          AdoptedRow "claimed/Two.hs" "banner" Nothing Nothing+        ],+      semanticImpact = Just (semanticImpactSnapshotForSpec ((.mergedSpec) workspace))+    }++-- | Representative byte contracts for the two line-oriented scaffold ledgers.+-- The behavior rows and semantic snapshot come from one checked source fixture;+-- the query row is deliberately explicit so the golden scopes that serialized+-- contract even though the behavior fixture itself has no read model.+representativeRecordMigrationContracts :: IO (ScaffoldRecord, WorkspaceRecord)+representativeRecordMigrationContracts = do+  parsed <- parsedSourceOf "test/fixtures/behavior-complete.keiro"+  let service = checkedSource parsed+      spec = checkedSpec service+      sourceLanguageForm = (.sourceLanguage) parsed+      queryIdentity =+        QueryContractIdentity+          { readModel = "BehaviorSummary",+            position = QueryInputConsumer,+            typeExpression = "RequestId",+            mappedDependencies = ["RequestId"]+          }+  requirements <-+    either+      (\errors -> expectationFailure (show errors) >> fail "unreachable")+      pure+      (Behavior.deriveBehaviorRequirements spec)+  let behaviorRows = Behavior.behaviorRecordRows requirements+      impact = Just (semanticImpactSnapshotForSpec spec)+      singleRecord =+        ScaffoldRecord+          { specPath = "behavior-complete.keiro",+            moduleRoot = "",+            layout = "prefixed",+            sourceLanguage = sourceLanguageForm,+            languageContract = checkedLanguageContract service,+            namingEdition = IdiomaticNamingV2,+            moduleRoles = [],+            files = [],+            mappings = [],+            idDomains = [],+            nominalEqualities = [],+            bindingObligations = [],+            behaviorRequirements = behaviorRows,+            projectionCatalogFacts = [],+            queryContractBaseline = True,+            queryContracts = [queryIdentity],+            routerSelections = [],+            semanticImpact = impact+          }+      workspaceRecord =+        WorkspaceRecord+          { service = "behavior-contract-fixture",+            manifest = "service.keiro-workspace",+            context = spec.context,+            moduleRoot = "",+            layout = "prefixed",+            members = ["behavior-complete.keiro"],+            sourceLanguages = [WorkspaceSourceLanguageRow "behavior-complete.keiro" sourceLanguageForm],+            languageContract = checkedLanguageContract service,+            namingEdition = IdiomaticNamingV1,+            modules = [],+            mappings = [],+            idDomains = [],+            nominalEqualities = [],+            bindingObligations = [],+            requirements = behaviorRows,+            projectionCatalogFacts = [],+            queryContractBaseline = True,+            queryContracts = [queryIdentity],+            routerSelections = [],+            adopted = [],+            semanticImpact = impact+          }+  pure (singleRecord, workspaceRecord)++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 ((.declarationEvidence) impact),+      consumers = Map.findWithDefault Set.empty key ((.declarationConsumers) impact),+      consequences = Map.findWithDefault Set.empty key ((.declarationConsequences) 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 <- (.nodes) merged, (.name) aggregate == "Project"] of+  [] -> error "canonical workspace fixture has no Project aggregate"+  aggregate : _ ->+    let shouted = aggregateWithName (T.toUpper aggregate.name) aggregate+        ownershipIndex = workspace.ownership+        mergedWithVariant = specWithNodes (merged.nodes <> [NAggregate shouted]) merged+        ownershipWithVariant =+          OwnershipIndex+            { declarations = ownershipIndex.declarations,+              nodes = Map.insert ("aggregate", shouted.name) ("domain/project-artifact.keiro", Loc 1) ownershipIndex.nodes+            }+     in workspaceWithMergedSpecAndOwnership mergedWithVariant ownershipWithVariant workspace+  where+    merged = (.mergedSpec) 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)]++scaffoldRecordWithEdition :: GeneratedHaskellNamingEdition -> ScaffoldRecord -> ScaffoldRecord+scaffoldRecordWithEdition edition record = case record of+  ScaffoldRecord+    recordSpecPath+    recordModuleRoot+    recordLayout+    recordSourceLanguage+    recordLanguageContract+    _recordNamingEdition+    recordModuleRoles+    recordFiles+    recordMappings+    recordIdDomains+    recordNominalEqualities+    recordBindingObligations+    recordBehaviorRequirements+    recordProjectionCatalogFacts+    recordQueryContractBaseline+    recordQueryContracts+    recordRouterSelections+    recordSemanticImpact ->+      ScaffoldRecord+        recordSpecPath+        recordModuleRoot+        recordLayout+        recordSourceLanguage+        recordLanguageContract+        edition+        recordModuleRoles+        recordFiles+        recordMappings+        recordIdDomains+        recordNominalEqualities+        recordBindingObligations+        recordBehaviorRequirements+        recordProjectionCatalogFacts+        recordQueryContractBaseline+        recordQueryContracts+        recordRouterSelections+        recordSemanticImpact++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+      { service = service,+        serviceLoc = Loc 1,+        runtimePackage = runtimePackage,+        runtimePackageLoc = Loc 2,+        moduleRoot = moduleRoot,+        moduleRootLoc = Loc 2,+        layout = layout,+        layoutLoc = Loc 3,+        members = 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=" <> (.name) aggregate,+            "fingerprint=" <> aggregateFoldFingerprintForService service aggregate,+            "surface-begin"+          ]+            <> T.lines (aggregateFoldSurfaceForService service aggregate)+            <> ["surface-end"]+        )+    | NAggregate aggregate <- (.nodes) (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 ((checkedSpec service).context)) service)++legacyScaffoldProcessFixture :: FilePath -> IO [ScaffoldModule]+legacyScaffoldProcessFixture path = do+  spec <- specOf path+  pure $ concat [scaffoldProcess (ctx spec) process | NProcess process <- (.nodes) spec]+  where+    ctx spec = defaultContext (spec.context)++-- | 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/" <> (.path) m+  committed <- readTestText committedPath+  normalizeGenerated committed `shouldBe` normalizeGenerated ((.text) 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++-- | Assert an exact serialized contract, including its final-newline policy.+assertMatchesByteGolden :: FilePath -> BS.ByteString -> IO ()+assertMatchesByteGolden path actual = do+  resolved <- resolveTestPath path+  update <- lookupEnv "KEIRO_DSL_UPDATE_GOLDENS"+  if update == Just "1"+    then BS.writeFile resolved actual+    else BS.readFile resolved >>= (`shouldBe` actual)++-- | 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 -> wireArmWithTag (arm.tag <> "-changed") arm : remaining+          )+    }+changeProjectionMappedWire declaration = declaration++projectionEventWithoutGeometry :: Spec -> Spec+projectionEventWithoutGeometry candidate =+  specWithNodes (map stripGeometry candidate.nodes) candidate+  where+    stripGeometry (NAggregate aggregate) =+      let artifactFields =+            [ field+            | command <- (.commands) aggregate,+              (.name) command == "ObserveArtifact",+              field <- (.fields) command,+              (.name) field == "artifact"+            ]+       in NAggregate+            aggregate+              { regs = filter ((/= "currentGeometry") . (.name)) ((.regs) aggregate),+                events = map (explicitArtifactEvent artifactFields) ((.events) aggregate),+                transitions = map stripGeometryWrite ((.transitions) aggregate)+              }+    stripGeometry node = node+    explicitArtifactEvent artifactFields event@Event {body = EventFromCommand commandName}+      | commandName == "ObserveArtifact" =+          eventWithBody (EventFields artifactFields) event+    explicitArtifactEvent _ event = event+    stripGeometryWrite transition = transition {writes = filter ((/= "currentGeometry") . fst) ((.writes) 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 (parsed.spec)+  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 (parsed.spec)+  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+    { mapped = filter (not . isVendorGeometry) ((.mapped) spec),+      nodes = map stripNode ((.nodes) spec)+    }+  where+    isVendorGeometry MappedOpaque {moName = "VendorGeometry"} = True+    isVendorGeometry _ = False+    stripNode (NAggregate aggregate) =+      NAggregate+        aggregate+          { regs = filter ((/= TRef "VendorGeometry") . (.valueType)) ((.regs) aggregate),+            commands = map stripCommand ((.commands) aggregate),+            events = map stripEvent ((.events) aggregate)+          }+    stripNode node = node+    stripCommand command = commandWithFields (filter ((/= Just (TRef "VendorGeometry")) . (.valueType)) command.fields) command+    stripEvent event = eventWithBody (case event.body of EventFields fields -> EventFields (filter ((/= Just (TRef "VendorGeometry")) . (.valueType)) fields); body -> body) event++withMetadataJson :: Spec -> Spec+withMetadataJson spec = spec {mapped = map updateDeclaration ((.mapped) spec)}+  where+    updateDeclaration declaration@MappedStructural {msName = "ArtifactMetadata", msShape = ShapeRecord constructor unknownFields fields} =+      declaration+        { msShape =+            ShapeRecord+              constructor+              unknownFields+              [if field.haskell == "note" then wireFieldWithValueType TJson field 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+        { haskell = "field" <> T.pack (show index),+          key = "field" <> T.pack (show index),+          valueType = valueType,+          presence = PRequired,+          onMissing = Nothing,+          loc = noLoc+        }+    | (index, valueType) <- zip [(1 :: Int) ..] types+    ]++mapArtifactField :: (WireField -> WireField) -> Spec -> Spec+mapArtifactField = mapArtifactNamedField "key"++mapArtifactNamedField :: Name -> (WireField -> WireField) -> Spec -> Spec+mapArtifactNamedField target transform spec = spec {mapped = map updateDeclaration ((.mapped) spec)}+  where+    updateDeclaration declaration@MappedStructural {msName = "ArtifactInfo", msShape = ShapeRecord constructor unknownFields fields} =+      declaration+        { msShape =+            ShapeRecord+              constructor+              unknownFields+              [if (.haskell) field == target then transform field else field | field <- fields]+        }+    updateDeclaration declaration = declaration++mapMappedStructural :: Name -> (MappedDecl -> MappedDecl) -> Spec -> Spec+mapMappedStructural target transform spec =+  spec+    { mapped =+        [ case declaration of+            MappedStructural {msName = name}+              | name == target -> transform declaration+            _ -> declaration+        | declaration <- (.mapped) 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 ..] ((.mapped) 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 (wireFieldWithKey (field.key <> "__mutated") field))+                  (mutateRecordField declarationIndex fieldIndex (\value -> wireFieldWithKey (value.key <> "__mutated") value) spec),+                mutation+                  graph+                  declarationName+                  MappedPresenceChanged+                  (fieldSubject field)+                  (mutateRecordField declarationIndex fieldIndex (\value -> wireFieldWithPresence (flipPresence value.presence) value) spec)+              ]+                <> [ mutation+                       graph+                       declarationName+                       defaultCode+                       (fieldSubject field)+                       (mutateRecordField declarationIndex fieldIndex (wireFieldWithOnMissing changedDefault) spec)+                   | oldDefault <- maybeToListTest ((.onMissing) field),+                     let (changedDefault, defaultCode) = mutateDefault oldDefault+                   ]+            | (fieldIndex, field) <- zip [0 :: Int ..] fields+            ]+        ShapeEnum entries ->+          [ mutation+              graph+              declarationName+              MappedEnumSpellingChanged+              (enumSubject (wireEnumWithTag (entry.tag <> "__mutated") entry))+              (mutateEnumEntry declarationIndex entryIndex (\value -> wireEnumWithTag (value.tag <> "__mutated") value) spec)+          | (entryIndex, entry) <- zip [0 :: Int ..] entries+          ]+        ShapeUnion _ arms ->+          [ mutation+              graph+              declarationName+              MappedArmTagChanged+              (armSubject (wireArmWithTag (arm.tag <> "__mutated") arm))+              (mutateUnionArm declarationIndex armIndex (\value -> wireArmWithTag (value.tag <> "__mutated") value) 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 " <> (.haskell) field <> "[\"" <> (.key) field <> "\"]"++enumSubject :: WireEnum -> T.Text+enumSubject entry = ".enum " <> (.ctor) entry <> "[\"" <> (.tag) entry <> "\"]"++armSubject :: WireArm -> T.Text+armSubject arm = ".arm " <> (.ctor) arm <> "[\"" <> (.tag) 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 {mapped = updateAt declarationIndex transform ((.mapped) 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+    { mapped =+        [ if mappedDeclarationName declaration == target then transform declaration else declaration+        | declaration <- (.mapped) 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+          { name = "Contract",+            schemaVersion = 1,+            discriminator = "kind",+            topics = [("events", value)],+            events = [],+            loc = noLoc+          },+      NEmit+        EmitNode+          { name = "Emit",+            contract = "Contract",+            topic = "events",+            source = "source",+            key = "key",+            discriminant = "status",+            map = [EmitMapRow value "Event" noLoc],+            skip = True,+            messageId = DeriveSpec Nothing,+            idempotencyKey = DeriveSpec Nothing,+            loc = noLoc+          },+      NProcess (processWithLiteral value)+    ]++processWithLiteral :: T.Text -> ProcessNode+processWithLiteral value =+  ProcessNode+    { id = "Process",+      name = "process",+      input = InputDecl "Input" [] Nothing noLoc,+      correlate = CorrelateDecl "key" "idText",+      saga = SagaRef "Saga" "saga",+      target = "Target",+      projections = [],+      handle =+        HandleNode+          { on = "Input",+            advance = AdvanceNode "Advance" [FieldBinding "literal" (Just ("\"" <> value <> "\""))],+            dispatch = [],+            schedule = "timer"+          },+      rejected = PolHalt,+      poison = PolHalt,+      timer =+        TimerNode+          { name = "timer",+            id = IdExpr UuidV5Id "timer:" "correlationId",+            fireAt = FireAtExpr "observedAt" "5m",+            payload = [],+            fire =+              FireNode+                { target = "Target",+                  key = "correlationId",+                  command = "Fire",+                  fields = [],+                  firedEventId = IdExpr UuidV5Id "fired:" "correlationId",+                  disposition = FireDisposition OFired OFired ORetry ORetry ORetry+                },+            decodeUnknown = "Cancelled",+            maxAttempts = 5,+            deadLetter = "exhausted",+            loc = noLoc+          },+      loc = 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+      { name = name,+        body = eventBody,+        version = version,+        upcastFrom = upcast,+        retiring = retiring,+        deprecated = deprecated,+        loc = 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"++consumerNominalFor :: Name -> NominalOwnership+consumerNominalFor name =+  ConsumerNominal+    ConsumerNominalBinding+      { haskell = HaskellSource "domain" "Domain.Types" name,+        binding = QualifiedValueName "Domain.Bindings.binding",+        bindingVersion = BindingVersion "1",+        canonical = CanonicalTypeId ("domain." <> name <> ".v1"),+        fixtures = QualifiedValueName "Domain.Bindings.fixtures",+        initial = Just (QualifiedValueName "Domain.Bindings.initialValue")+      }++genId :: Gen IdDecl+genId = IdDecl <$> genName <*> genWire <*> pure Nothing <*> pure noLoc++genEnum :: Gen EnumDecl+genEnum = EnumDecl <$> genName <*> smallList ((,) <$> genName <*> genWire) <*> pure Nothing <*> pure noLoc++genRule :: Gen RuleDecl+genRule =+  RuleDecl+    <$> genName+    <*> genName+    <*> genName+    <*> nonEmptyList ((,) <$> genName <*> genExpr)+    <*> pure noLoc++genMappedDecls :: Gen [MappedDecl]+genMappedDecls = do+  count <- choose (0, 4 :: Int)+  let names = take count ["MappedA", "MappedB", "MappedC", "MappedD"]+  traverse (genMappedDecl names) names++genMappedDecl :: [Name] -> Name -> Gen MappedDecl+genMappedDecl names name =+  oneof+    [ MappedStructural name+        <$> genMaybe genHaskellSource+        <*> genMaybe genAdversarialText+        <*> genMaybe genAdversarialText+        <*> genMaybe genAdversarialText+        <*> genMaybe genAdversarialText+        <*> genMaybe genAdversarialText+        <*> genMappedShape names+        <*> pure noLoc,+      MappedOpaque name+        <$> genMaybe genHaskellSource+        <*> genMaybe genAdversarialText+        <*> genMaybe genAdversarialText+        <*> genMaybe genAdversarialText+        <*> genMaybe genAdversarialText+        <*> pure noLoc+    ]++genHaskellSource :: Gen HaskellSource+genHaskellSource =+  HaskellSource+    <$> genWire+    <*> genModuleRoot+    <*> genName++genMappedShape :: [Name] -> Gen MappedShape+genMappedShape names =+  oneof+    [ ShapeRecord+        <$> genName+        <*> elements [RejectUnknown, IgnoreUnknown]+        <*> smallList (genWireField names),+      ShapeEnum <$> smallList (WireEnum <$> genName <*> genAdversarialText <*> pure noLoc),+      ShapeUnion+        <$> (TaggedObject <$> genAdversarialText <*> genAdversarialText <*> elements [RejectUnknown, IgnoreUnknown])+        <*> smallList (WireArm <$> genName <*> genAdversarialText <*> genMaybe (genTypeExpr names) <*> pure noLoc)+    ]++genWireField :: [Name] -> Gen WireField+genWireField names =+  WireField+    <$> genName+    <*> genAdversarialText+    <*> genTypeExpr names+    <*> elements [PRequired, POptional]+    <*> genMaybe genOnMissing+    <*> pure noLoc++genTypeExpr :: [Name] -> Gen TypeExpr+genTypeExpr names = sized (go . min 3)+  where+    go 0 = base+    go depth =+      frequency+        [ (4, base),+          (1, TOptional <$> go (depth - 1)),+          (1, TList <$> go (depth - 1)),+          (1, TMap <$> go (depth - 1))+        ]+    -- This generator renders through the unversioned/version-1 grammar. Keep+    -- successor-only Integer coverage in the dedicated version-2 properties.+    base = elements ([TText, TInt, TBool, TNatural, TTime, TJson] ++ map TRef names)++genOnMissing :: Gen OnMissing+genOnMissing =+  oneof+    [ pure OmNull,+      OmText <$> genAdversarialText,+      OmInt <$> choose (-10, 10),+      OmBool <$> arbitrary,+      pure OmEmptyList,+      pure OmEmptyMap,+      OmCtor <$> genName+    ]++genSpec :: Gen Spec+genSpec = do+  name <- genWire+  moduleRoot <- genMaybe genModuleRoot+  layout <- genMaybe (elements [GeneratedPrefix, CollocatedLeaf])+  ids <- smallList genId+  enums <- smallList genEnum+  rules <- smallList genRule+  mapped <- genMappedDecls+  nodes <- smallList genNode+  pure (Spec name moduleRoot layout ids enums rules [] mapped nodes)+  where+    genNode =+      oneof+        [ NAggregate <$> genAggregate,+          NProcess <$> genProcess,+          NRouter <$> genRouter,+          NContract <$> genContract,+          NIntake <$> genIntake,+          NEmit <$> genEmit,+          NPublisher <$> genPublisher,+          NWorkqueue <$> genWorkqueue,+          NPgmqDispatch <$> genPgmqDispatch,+          NReadModel <$> genReadModel,+          NWorkflow <$> genWorkflow,+          NOperation <$> genOperation+        ]++-- | A dotted PascalCase module prefix, e.g. @Acme@ or @Acme.Services@.+genModuleRoot :: Gen T.Text+genModuleRoot = do+  n <- choose (1, 3 :: Int)+  segs <- vectorOf n (elements ["Acme", "Services", "Hospital", "Domain", "Core"])+  pure (T.intercalate "." segs)++assertGeneratedHaskellContract :: T.Text -> T.Text -> Expectation+assertGeneratedHaskellContract sourceName manifest =+  take 13 (T.lines manifest)+    `shouldBe` [ "-- keiro-dsl build manifest for " <> sourceName,+                 "-- Paste the complete fragment below into the consuming Cabal stanza.",+                 "-- The generated layer is overwritten on every scaffold; hole modules are",+                 "-- create-if-absent (filled by hand).",+                 "",+                 "default-language: GHC2024",+                 "default-extensions:",+                 "    DuplicateRecordFields",+                 "    NoFieldSelectors",+                 "    OverloadedRecordDot",+                 "    OverloadedStrings",+                 "",+                 "other-modules:"+               ]++workspaceWithMembers :: [WorkspaceMember] -> WorkspaceSpec -> WorkspaceSpec+workspaceWithMembers members workspace =+  WorkspaceSpec+    { service = workspace.service,+      manifestPath = workspace.manifestPath,+      languageContract = workspace.languageContract,+      context = workspace.context,+      runtimePackage = workspace.runtimePackage,+      moduleRoot = workspace.moduleRoot,+      layout = workspace.layout,+      members = members,+      mergedSpec = workspace.mergedSpec,+      sourceIndex = workspace.sourceIndex,+      lineMap = workspace.lineMap,+      ownership = workspace.ownership+    }++specWithNodes :: [Node] -> Spec -> Spec+specWithNodes nodes (Spec contextName moduleRoot layout ids enums rules nominalScalars mapped _) =+  Spec contextName moduleRoot layout ids enums rules nominalScalars mapped nodes++specWithContext :: Name -> Spec -> Spec+specWithContext contextName (Spec _ moduleRoot layout ids enums rules nominalScalars mapped nodes) =+  Spec contextName moduleRoot layout ids enums rules nominalScalars mapped nodes++specWithMapped :: [MappedDecl] -> Spec -> Spec+specWithMapped mapped (Spec contextName moduleRoot layout ids enums rules nominalScalars _ nodes) =+  Spec contextName moduleRoot layout ids enums rules nominalScalars mapped nodes++specWithNominalScalars :: [NominalScalarDecl] -> Spec -> Spec+specWithNominalScalars nominalScalars (Spec contextName moduleRoot layout ids enums rules _ mapped nodes) =+  Spec contextName moduleRoot layout ids enums rules nominalScalars mapped nodes++specWithIds :: [IdDecl] -> Spec -> Spec+specWithIds ids (Spec contextName moduleRoot layout _ enums rules nominalScalars mapped nodes) =+  Spec contextName moduleRoot layout ids enums rules nominalScalars mapped nodes++specWithIdsAndNodes :: [IdDecl] -> [Node] -> Spec -> Spec+specWithIdsAndNodes ids nodes (Spec contextName moduleRoot layout _ enums rules nominalScalars mapped _) =+  Spec contextName moduleRoot layout ids enums rules nominalScalars mapped nodes++contractNodeWithEvents :: [ContractEvent] -> ContractNode -> ContractNode+contractNodeWithEvents events (ContractNode name schemaVersion discriminator topics _ loc) =+  ContractNode name schemaVersion discriminator topics events loc++commandWithFields :: [AggregateField] -> Command -> Command+commandWithFields fields (Command name _ loc) = Command name fields loc++contractEventWithFields :: [ContractField] -> ContractEvent -> ContractEvent+contractEventWithFields fields (ContractEvent name topic _) = ContractEvent name topic fields++contractEventWithTopic :: Name -> ContractEvent -> ContractEvent+contractEventWithTopic topic (ContractEvent name _ fields) = ContractEvent name topic fields++contractFieldWithName :: Name -> ContractField -> ContractField+contractFieldWithName name (ContractField _ selector wireKey valueType loc) =+  ContractField name selector wireKey valueType loc++bindRowWithField :: Name -> BindRow -> BindRow+bindRowWithField field (BindRow _ source required crossCheck) = BindRow field source required crossCheck++wireSpecWithKind :: T.Text -> WireSpec -> WireSpec+wireSpecWithKind kind (WireSpec _ fields schemaVersion) = WireSpec kind fields schemaVersion++wireSpecWithSchemaVersion :: Int -> WireSpec -> WireSpec+wireSpecWithSchemaVersion schemaVersion (WireSpec kind fields _) = WireSpec kind fields schemaVersion++wqDispRowWithAction :: InboxAction -> WqDispRow -> WqDispRow+wqDispRowWithAction action (WqDispRow outcome _ loc) = WqDispRow outcome action loc++dispositionRowWithAction :: InboxAction -> DispositionRow -> DispositionRow+dispositionRowWithAction action (DispositionRow outcome _ loc) = DispositionRow outcome action loc++bindRowWithSource :: WireSource -> BindRow -> BindRow+bindRowWithSource source (BindRow field _ required crossCheck) = BindRow field source required crossCheck++dispatchDispositionWithOnAppended :: Disp -> DispatchDisposition -> DispatchDisposition+dispatchDispositionWithOnAppended onAppended (DispatchDisposition _ onDuplicate onFailed) =+  DispatchDisposition onAppended onDuplicate onFailed++dispatchNodeWithDisposition :: DispatchDisposition -> DispatchNode -> DispatchNode+dispatchNodeWithDisposition disposition (DispatchNode target key command fields _ loc) =+  DispatchNode target key command fields disposition loc++dispatchNodeWithKey :: T.Text -> DispatchNode -> DispatchNode+dispatchNodeWithKey key (DispatchNode target _ command fields disposition loc) =+  DispatchNode target key command fields disposition loc++fieldBindingWithValue :: Maybe T.Text -> FieldBinding -> FieldBinding+fieldBindingWithValue value (FieldBinding name _) = FieldBinding name value++projectionSpecWithKey :: Name -> ProjectionSpec -> ProjectionSpec+projectionSpecWithKey key (ProjectionSpec table consistency _ statusMap loc) =+  ProjectionSpec table consistency key statusMap loc++eventWithNameAndLoc :: Name -> Loc -> Event -> Event+eventWithNameAndLoc name loc (Event _ body version upcastFrom retiring deprecated _) =+  Event name body version upcastFrom retiring deprecated loc++eventWithBody :: EventBody -> Event -> Event+eventWithBody body (Event name _ version upcastFrom retiring deprecated loc) =+  Event name body version upcastFrom retiring deprecated loc++contextWithModuleRoot :: T.Text -> Context -> Context+contextWithModuleRoot moduleRoot (Context name _ placement) = Context name moduleRoot placement++workspaceMemberWithSpec :: Spec -> WorkspaceMember -> WorkspaceMember+workspaceMemberWithSpec spec (WorkspaceMember path _ sourceLanguage sourceIndex lineBase lineCount) =+  WorkspaceMember path spec sourceLanguage sourceIndex lineBase lineCount++workspaceWithMembersAndMergedSpec :: [WorkspaceMember] -> Spec -> WorkspaceSpec -> WorkspaceSpec+workspaceWithMembersAndMergedSpec members mergedSpec workspace =+  WorkspaceSpec+    workspace.service+    workspace.manifestPath+    workspace.languageContract+    workspace.context+    workspace.runtimePackage+    workspace.moduleRoot+    workspace.layout+    members+    mergedSpec+    workspace.sourceIndex+    workspace.lineMap+    workspace.ownership++workspaceWithMergedSpecAndOwnership :: Spec -> OwnershipIndex -> WorkspaceSpec -> WorkspaceSpec+workspaceWithMergedSpecAndOwnership mergedSpec ownership workspace =+  WorkspaceSpec+    workspace.service+    workspace.manifestPath+    workspace.languageContract+    workspace.context+    workspace.runtimePackage+    workspace.moduleRoot+    workspace.layout+    workspace.members+    mergedSpec+    workspace.sourceIndex+    workspace.lineMap+    ownership++workspaceWithOwnership :: OwnershipIndex -> WorkspaceSpec -> WorkspaceSpec+workspaceWithOwnership ownership workspace =+  workspaceWithMergedSpecAndOwnership workspace.mergedSpec ownership workspace++workspaceWithAuthority :: T.Text -> Maybe T.Text -> Maybe Placement -> WorkspaceSpec -> WorkspaceSpec+workspaceWithAuthority service moduleRoot layout workspace =+  WorkspaceSpec+    service+    workspace.manifestPath+    workspace.languageContract+    workspace.context+    workspace.runtimePackage+    moduleRoot+    layout+    workspace.members+    workspace.mergedSpec+    workspace.sourceIndex+    workspace.lineMap+    workspace.ownership++workspaceWithContextAndMergedSpec :: Name -> Spec -> WorkspaceSpec -> WorkspaceSpec+workspaceWithContextAndMergedSpec contextName mergedSpec workspace =+  WorkspaceSpec+    workspace.service+    workspace.manifestPath+    workspace.languageContract+    contextName+    workspace.runtimePackage+    workspace.moduleRoot+    workspace.layout+    workspace.members+    mergedSpec+    workspace.sourceIndex+    workspace.lineMap+    workspace.ownership++workspaceWithManifestPath :: FilePath -> WorkspaceSpec -> WorkspaceSpec+workspaceWithManifestPath manifestPath workspace =+  WorkspaceSpec+    workspace.service+    manifestPath+    workspace.languageContract+    workspace.context+    workspace.runtimePackage+    workspace.moduleRoot+    workspace.layout+    workspace.members+    workspace.mergedSpec+    workspace.sourceIndex+    workspace.lineMap+    workspace.ownership++aggregateWithName :: Name -> Aggregate -> Aggregate+aggregateWithName name (Aggregate _ regs states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc) =+  Aggregate name regs states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc++aggregateWithProjection :: Maybe ProjectionSpec -> Aggregate -> Aggregate+aggregateWithProjection projection (Aggregate name regs states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire _ snapshot loc) =+  Aggregate name regs states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc++aggregateWithTransitions :: [Transition] -> Aggregate -> Aggregate+aggregateWithTransitions transitions (Aggregate name regs states commands events _ domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc) =+  Aggregate name regs states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc++aggregateWithRegs :: [RegDecl] -> Aggregate -> Aggregate+aggregateWithRegs regs (Aggregate name _ states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc) =+  Aggregate name regs states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc++aggregateWithNameAndRegs :: Name -> [RegDecl] -> Aggregate -> Aggregate+aggregateWithNameAndRegs name regs (Aggregate _ _ states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc) =+  Aggregate name regs states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc++aggregateWithCommands :: [Command] -> Aggregate -> Aggregate+aggregateWithCommands commands (Aggregate name regs states _ events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc) =+  Aggregate name regs states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc++aggregateWithStates :: [StateDecl] -> Aggregate -> Aggregate+aggregateWithStates states (Aggregate name regs _ commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc) =+  Aggregate name regs states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc++aggregateWithCommandsEventsTransitions :: [Command] -> [Event] -> [Transition] -> Aggregate -> Aggregate+aggregateWithCommandsEventsTransitions commands events transitions (Aggregate name regs states _ _ _ domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc) =+  Aggregate name regs states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc++aggregateWithWire :: Maybe WireSpec -> Aggregate -> Aggregate+aggregateWithWire wire (Aggregate name regs states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs _ projection snapshot loc) =+  Aggregate name regs states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc++regDeclWithInitial :: RegInitial -> RegDecl -> RegDecl+regDeclWithInitial initial (RegDecl name valueType _ loc) = RegDecl name valueType initial loc++regDeclWithValueType :: TypeExpr -> RegDecl -> RegDecl+regDeclWithValueType valueType (RegDecl name _ initial loc) = RegDecl name valueType initial loc++idDeclWithBinding :: Maybe NominalBindingDecl -> IdDecl -> IdDecl+idDeclWithBinding binding (IdDecl name prefix _ loc) = IdDecl name prefix binding loc++nominalBindingWithVersion :: Maybe T.Text -> NominalBindingDecl -> NominalBindingDecl+nominalBindingWithVersion bindingVersion (NominalBindingDecl haskell binding _ canonicalType fixtures initial loc) =+  NominalBindingDecl haskell binding bindingVersion canonicalType fixtures initial loc++transitionWithGuard :: Maybe Expr -> Transition -> Transition+transitionWithGuard guard (Transition source command implementation _ writes emits outcome outcomeDuplicateLocs goto mode loc) =+  Transition source command implementation guard writes emits outcome outcomeDuplicateLocs goto mode loc++transitionWithEmits :: [Name] -> Transition -> Transition+transitionWithEmits emits (Transition source command implementation guard writes _ outcome outcomeDuplicateLocs goto mode loc) =+  Transition source command implementation guard writes emits outcome outcomeDuplicateLocs goto mode loc++projectionOwnerWithReplay :: ProjectionReplayPolicy -> ProjectionOwnerNode -> ProjectionOwnerNode+projectionOwnerWithReplay replay (ProjectionOwnerNode name sources delivery group targets order subscription dedup checkpointOnMissing _ loc) =+  ProjectionOwnerNode name sources delivery group targets order subscription dedup checkpointOnMissing replay loc++readModelWithObservedTargets :: [Name] -> ReadModelNode -> ReadModelNode+readModelWithObservedTargets observedTargets (ReadModelNode name table schema columns version shape freshness supply group _ backingTarget queryTypes loc) =+  ReadModelNode name table schema columns version shape freshness supply group observedTargets backingTarget queryTypes loc++readModelWithGroupAndObservedTargets :: Maybe Name -> [Name] -> ReadModelNode -> ReadModelNode+readModelWithGroupAndObservedTargets group observedTargets (ReadModelNode name table schema columns version shape freshness supply _ _ backingTarget queryTypes loc) =+  ReadModelNode name table schema columns version shape freshness supply group observedTargets backingTarget queryTypes loc++readModelWithQueryTypes :: Maybe ReadModelQueryTypes -> ReadModelNode -> ReadModelNode+readModelWithQueryTypes queryTypes (ReadModelNode name table schema columns version shape freshness supply group observedTargets backingTarget _ loc) =+  ReadModelNode name table schema columns version shape freshness supply group observedTargets backingTarget queryTypes loc++workqueueWithPayload :: [WqField] -> WorkqueueNode -> WorkqueueNode+workqueueWithPayload payload (WorkqueueNode name logical physical dlq table ordering groupKey provision payloadName _ maxRetries delay dlqOn disposition loc) =+  WorkqueueNode name logical physical dlq table ordering groupKey provision payloadName payload maxRetries delay dlqOn disposition loc++workqueueWithName :: Name -> WorkqueueNode -> WorkqueueNode+workqueueWithName name (WorkqueueNode _ logical physical dlq table ordering groupKey provision payloadName payload maxRetries delay dlqOn disposition loc) =+  WorkqueueNode name logical physical dlq table ordering groupKey provision payloadName payload maxRetries delay dlqOn disposition loc++workqueueWithPayloadName :: Name -> WorkqueueNode -> WorkqueueNode+workqueueWithPayloadName payloadName (WorkqueueNode name logical physical dlq table ordering groupKey provision _ payload maxRetries delay dlqOn disposition loc) =+  WorkqueueNode name logical physical dlq table ordering groupKey provision payloadName payload maxRetries delay dlqOn disposition loc++workqueueWithDelay :: T.Text -> WorkqueueNode -> WorkqueueNode+workqueueWithDelay delay (WorkqueueNode name logical physical dlq table ordering groupKey provision payloadName payload maxRetries _ dlqOn disposition loc) =+  WorkqueueNode name logical physical dlq table ordering groupKey provision payloadName payload maxRetries delay dlqOn disposition loc++workqueueWithDisposition :: [WqDispRow] -> WorkqueueNode -> WorkqueueNode+workqueueWithDisposition disposition (WorkqueueNode name logical physical dlq table ordering groupKey provision payloadName payload maxRetries delay dlqOn _ loc) =+  WorkqueueNode name logical physical dlq table ordering groupKey provision payloadName payload maxRetries delay dlqOn disposition loc++wqFieldWithValueType :: QueuePayloadType -> WqField -> WqField+wqFieldWithValueType valueType (WqField name wire _ loc) = WqField name wire valueType loc++wireFieldWithHaskell :: Name -> WireField -> WireField+wireFieldWithHaskell haskell (WireField _ key valueType presence onMissing loc) =+  WireField haskell key valueType presence onMissing loc++wireFieldWithKey :: T.Text -> WireField -> WireField+wireFieldWithKey key (WireField haskell _ valueType presence onMissing loc) =+  WireField haskell key valueType presence onMissing loc++wireFieldWithValueType :: TypeExpr -> WireField -> WireField+wireFieldWithValueType valueType (WireField haskell key _ presence onMissing loc) =+  WireField haskell key valueType presence onMissing loc++wireFieldWithPresenceAndDefault :: Presence -> Maybe OnMissing -> WireField -> WireField+wireFieldWithPresenceAndDefault presence onMissing (WireField haskell key valueType _ _ loc) =+  WireField haskell key valueType presence onMissing loc++wireFieldWithOnMissing :: Maybe OnMissing -> WireField -> WireField+wireFieldWithOnMissing onMissing (WireField haskell key valueType presence _ loc) =+  WireField haskell key valueType presence onMissing loc++wireFieldWithPresence :: Presence -> WireField -> WireField+wireFieldWithPresence presence (WireField haskell key valueType _ onMissing loc) =+  WireField haskell key valueType presence onMissing loc++contractWithSchemaVersion :: Int -> ContractNode -> ContractNode+contractWithSchemaVersion schemaVersion (ContractNode name _ discriminator topics events loc) =+  ContractNode name schemaVersion discriminator topics events loc++contractWithTopics :: [(Name, T.Text)] -> ContractNode -> ContractNode+contractWithTopics topics (ContractNode name schemaVersion discriminator _ events loc) =+  ContractNode name schemaVersion discriminator topics events loc++publisherWithOrdering :: Name -> PublisherNode -> PublisherNode+publisherWithOrdering ordering (PublisherNode name emit _ maxAttempts backoff outboxField loc) =+  PublisherNode name emit ordering maxAttempts backoff outboxField loc++publisherWithBackoff :: BackoffSpec -> PublisherNode -> PublisherNode+publisherWithBackoff backoff (PublisherNode name emit ordering maxAttempts _ outboxField loc) =+  PublisherNode name emit ordering maxAttempts backoff outboxField loc++publisherWithMaxAttempts :: Int -> PublisherNode -> PublisherNode+publisherWithMaxAttempts maxAttempts (PublisherNode name emit ordering _ backoff outboxField loc) =+  PublisherNode name emit ordering maxAttempts backoff outboxField loc++publisherWithEmit :: Name -> PublisherNode -> PublisherNode+publisherWithEmit emit (PublisherNode name _ ordering maxAttempts backoff outboxField loc) =+  PublisherNode name emit ordering maxAttempts backoff outboxField loc++publisherWithOutboxField :: Name -> PublisherNode -> PublisherNode+publisherWithOutboxField outboxField (PublisherNode name emit ordering maxAttempts backoff _ loc) =+  PublisherNode name emit ordering maxAttempts backoff outboxField loc++backoffWithKind :: Name -> BackoffSpec -> BackoffSpec+backoffWithKind kind (BackoffSpec _ window maximumValue multiplier) = BackoffSpec kind window maximumValue multiplier++backoffWithWindow :: T.Text -> BackoffSpec -> BackoffSpec+backoffWithWindow window (BackoffSpec kind _ maximumValue multiplier) = BackoffSpec kind window maximumValue multiplier++intakeWithDedupePolicy :: Name -> IntakeNode -> IntakeNode+intakeWithDedupePolicy dedupePolicy (IntakeNode name contract topic accept binds dedupeKey _ persist decode disposition loc) =+  IntakeNode name contract topic accept binds dedupeKey dedupePolicy persist decode disposition loc++intakeWithDedupeKey :: Name -> IntakeNode -> IntakeNode+intakeWithDedupeKey dedupeKey (IntakeNode name contract topic accept binds _ dedupePolicy persist decode disposition loc) =+  IntakeNode name contract topic accept binds dedupeKey dedupePolicy persist decode disposition loc++intakeWithDecode :: DecodeSpec -> IntakeNode -> IntakeNode+intakeWithDecode decode (IntakeNode name contract topic accept binds dedupeKey dedupePolicy persist _ disposition loc) =+  IntakeNode name contract topic accept binds dedupeKey dedupePolicy persist decode disposition loc++intakeWithBinds :: [BindRow] -> IntakeNode -> IntakeNode+intakeWithBinds binds (IntakeNode name contract topic accept _ dedupeKey dedupePolicy persist decode disposition loc) =+  IntakeNode name contract topic accept binds dedupeKey dedupePolicy persist decode disposition loc++intakeWithDisposition :: [DispositionRow] -> IntakeNode -> IntakeNode+intakeWithDisposition disposition (IntakeNode name contract topic accept binds dedupeKey dedupePolicy persist decode _ loc) =+  IntakeNode name contract topic accept binds dedupeKey dedupePolicy persist decode disposition loc++intakeWithContract :: Name -> IntakeNode -> IntakeNode+intakeWithContract contract (IntakeNode name _ topic accept binds dedupeKey dedupePolicy persist decode disposition loc) =+  IntakeNode name contract topic accept binds dedupeKey dedupePolicy persist decode disposition loc++decodeWithEnvelope :: T.Text -> DecodeSpec -> DecodeSpec+decodeWithEnvelope envelope (DecodeSpec _ bodyStrict bodySchemaVersion) = DecodeSpec envelope bodyStrict bodySchemaVersion++decodeWithBodyStrict :: Bool -> DecodeSpec -> DecodeSpec+decodeWithBodyStrict bodyStrict (DecodeSpec envelope _ bodySchemaVersion) = DecodeSpec envelope bodyStrict bodySchemaVersion++decodeWithBodySchemaVersion :: Int -> DecodeSpec -> DecodeSpec+decodeWithBodySchemaVersion bodySchemaVersion (DecodeSpec envelope bodyStrict _) = DecodeSpec envelope bodyStrict bodySchemaVersion++emitNodeWithMap :: [EmitMapRow] -> EmitNode -> EmitNode+emitNodeWithMap mapping (EmitNode name contract topic source key discriminant _ skip messageId idempotencyKey loc) =+  EmitNode name contract topic source key discriminant mapping skip messageId idempotencyKey loc++workflowWithStable :: T.Text -> WorkflowNode -> WorkflowNode+workflowWithStable stable (WorkflowNode nodeId _ input inputFields output idField idVia body loc) =+  WorkflowNode nodeId stable input inputFields output idField idVia body loc++routerWithName :: T.Text -> RouterNode -> RouterNode+routerWithName name (RouterNode nodeId _ input key resolve target projections dispatch rejected poison loc) =+  RouterNode nodeId name input key resolve target projections dispatch rejected poison loc++readModelWithVersion :: Int -> ReadModelNode -> ReadModelNode+readModelWithVersion version (ReadModelNode name table schema columns _ shape freshness supply group observedTargets backingTarget queryTypes loc) =+  ReadModelNode name table schema columns version shape freshness supply group observedTargets backingTarget queryTypes loc++readModelWithName :: Name -> ReadModelNode -> ReadModelNode+readModelWithName name (ReadModelNode _ table schema columns version shape freshness supply group observedTargets backingTarget queryTypes loc) =+  ReadModelNode name table schema columns version shape freshness supply group observedTargets backingTarget queryTypes loc++readModelWithTable :: T.Text -> ReadModelNode -> ReadModelNode+readModelWithTable table (ReadModelNode name _ schema columns version shape freshness supply group observedTargets backingTarget queryTypes loc) =+  ReadModelNode name table schema columns version shape freshness supply group observedTargets backingTarget queryTypes loc++readModelWithColumns :: [RmColumn] -> ReadModelNode -> ReadModelNode+readModelWithColumns columns (ReadModelNode name table schema _ version shape freshness supply group observedTargets backingTarget queryTypes loc) =+  ReadModelNode name table schema columns version shape freshness supply group observedTargets backingTarget queryTypes loc++readModelQueryTypesWithInput :: TypeExpr -> ReadModelQueryTypes -> ReadModelQueryTypes+readModelQueryTypesWithInput input (ReadModelQueryTypes _ result inputLoc resultLoc) =+  ReadModelQueryTypes input result inputLoc resultLoc++readModelQueryTypesWithResult :: TypeExpr -> ReadModelQueryTypes -> ReadModelQueryTypes+readModelQueryTypesWithResult result (ReadModelQueryTypes input _ inputLoc resultLoc) =+  ReadModelQueryTypes input result inputLoc resultLoc++processWithTimer :: TimerNode -> ProcessNode -> ProcessNode+processWithTimer timer (ProcessNode nodeId name input correlate saga target projections handle rejected poison _ loc) =+  ProcessNode nodeId name input correlate saga target projections handle rejected poison timer loc++processWithHandle :: HandleNode -> ProcessNode -> ProcessNode+processWithHandle handle (ProcessNode nodeId name input correlate saga target projections _ rejected poison timer loc) =+  ProcessNode nodeId name input correlate saga target projections handle rejected poison timer loc++processWithSaga :: SagaRef -> ProcessNode -> ProcessNode+processWithSaga saga (ProcessNode nodeId name input correlate _ target projections handle rejected poison timer loc) =+  ProcessNode nodeId name input correlate saga target projections handle rejected poison timer loc++processWithCorrelate :: CorrelateDecl -> ProcessNode -> ProcessNode+processWithCorrelate correlate (ProcessNode nodeId name input _ saga target projections handle rejected poison timer loc) =+  ProcessNode nodeId name input correlate saga target projections handle rejected poison timer loc++sagaRefWithCategory :: T.Text -> SagaRef -> SagaRef+sagaRefWithCategory category (SagaRef agg _) = SagaRef agg category++correlateDeclWithField :: Name -> CorrelateDecl -> CorrelateDecl+correlateDeclWithField field (CorrelateDecl _ via) = CorrelateDecl field via++correlateDeclWithVia :: Name -> CorrelateDecl -> CorrelateDecl+correlateDeclWithVia via (CorrelateDecl field _) = CorrelateDecl field via++handleWithDispatch :: [DispatchNode] -> HandleNode -> HandleNode+handleWithDispatch dispatch (HandleNode on advance _ schedule) = HandleNode on advance dispatch schedule++handleWithAdvance :: AdvanceNode -> HandleNode -> HandleNode+handleWithAdvance advance (HandleNode on _ dispatch schedule) = HandleNode on advance dispatch schedule++advanceNodeWithFields :: [FieldBinding] -> AdvanceNode -> AdvanceNode+advanceNodeWithFields fields (AdvanceNode command _) = AdvanceNode command fields++timerWithFireAt :: FireAtExpr -> TimerNode -> TimerNode+timerWithFireAt fireAt (TimerNode name timerId _ payload fire decodeUnknown maxAttempts deadLetter loc) =+  TimerNode name timerId fireAt payload fire decodeUnknown maxAttempts deadLetter loc++timerWithFire :: FireNode -> TimerNode -> TimerNode+timerWithFire fire (TimerNode name timerId fireAt payload _ decodeUnknown maxAttempts deadLetter loc) =+  TimerNode name timerId fireAt payload fire decodeUnknown maxAttempts deadLetter loc++timerWithIdAndFire :: IdExpr -> FireNode -> TimerNode -> TimerNode+timerWithIdAndFire timerId fire (TimerNode name _ fireAt payload _ decodeUnknown maxAttempts deadLetter loc) =+  TimerNode name timerId fireAt payload fire decodeUnknown maxAttempts deadLetter loc++timerWithDecodeUnknown :: Name -> TimerNode -> TimerNode+timerWithDecodeUnknown decodeUnknown (TimerNode name timerId fireAt payload fire _ maxAttempts deadLetter loc) =+  TimerNode name timerId fireAt payload fire decodeUnknown maxAttempts deadLetter loc++timerWithDeadLetter :: T.Text -> TimerNode -> TimerNode+timerWithDeadLetter deadLetter (TimerNode name timerId fireAt payload fire decodeUnknown maxAttempts _ loc) =+  TimerNode name timerId fireAt payload fire decodeUnknown maxAttempts deadLetter loc++idExprWithField :: Name -> IdExpr -> IdExpr+idExprWithField field (IdExpr strategy prefix _) = IdExpr strategy prefix field++fireNodeWithDisposition :: FireDisposition -> FireNode -> FireNode+fireNodeWithDisposition disposition (FireNode target key command fields firedEventId _) =+  FireNode target key command fields firedEventId disposition++fireNodeWithFiredEventId :: IdExpr -> FireNode -> FireNode+fireNodeWithFiredEventId firedEventId (FireNode target key command fields _ disposition) =+  FireNode target key command fields firedEventId disposition++fireDispositionWithNotMine :: FireOutcome -> FireDisposition -> FireDisposition+fireDispositionWithNotMine notMine (FireDisposition onOk onReject onAmbiguous onError _) =+  FireDisposition onOk onReject onAmbiguous onError notMine++fireDispositionWithOnAmbiguous :: FireOutcome -> FireDisposition -> FireDisposition+fireDispositionWithOnAmbiguous onAmbiguous (FireDisposition onOk onReject _ onError notMine) =+  FireDisposition onOk onReject onAmbiguous onError notMine++routerWithDispatch :: RouterDispatchNode -> RouterNode -> RouterNode+routerWithDispatch dispatch (RouterNode nodeId name input key resolve target projections _ rejected poison loc) =+  RouterNode nodeId name input key resolve target projections dispatch rejected poison loc++routerWithTarget :: Name -> RouterNode -> RouterNode+routerWithTarget target (RouterNode nodeId name input key resolve _ projections dispatch rejected poison loc) =+  RouterNode nodeId name input key resolve target projections dispatch rejected poison loc++routerWithKey :: CorrelateDecl -> RouterNode -> RouterNode+routerWithKey key (RouterNode nodeId name input _ resolve target projections dispatch rejected poison loc) =+  RouterNode nodeId name input key resolve target projections dispatch rejected poison loc++routerWithResolve :: ResolveDecl -> RouterNode -> RouterNode+routerWithResolve resolve (RouterNode nodeId name input key _ target projections dispatch rejected poison loc) =+  RouterNode nodeId name input key resolve target projections dispatch rejected poison loc++routerWithPoison :: PolicyChoice -> RouterNode -> RouterNode+routerWithPoison poison (RouterNode nodeId name input key resolve target projections dispatch rejected _ loc) =+  RouterNode nodeId name input key resolve target projections dispatch rejected poison loc++routerWithRejected :: PolicyChoice -> RouterNode -> RouterNode+routerWithRejected rejected (RouterNode nodeId name input key resolve target projections dispatch _ poison loc) =+  RouterNode nodeId name input key resolve target projections dispatch rejected poison loc++routerWithRejectedAndDispatch :: PolicyChoice -> RouterDispatchNode -> RouterNode -> RouterNode+routerWithRejectedAndDispatch rejected dispatch (RouterNode nodeId name input key resolve target projections _ _ poison loc) =+  RouterNode nodeId name input key resolve target projections dispatch rejected poison loc++resolveDeclWithRow :: [Name] -> ResolveDecl -> ResolveDecl+resolveDeclWithRow row (ResolveDecl source _ loc) = ResolveDecl source row loc++routerDispatchWithDisposition :: DispatchDisposition -> RouterDispatchNode -> RouterDispatchNode+routerDispatchWithDisposition disposition (RouterDispatchNode command fields _ loc) =+  RouterDispatchNode command fields disposition loc++routerDispatchWithCommand :: Name -> RouterDispatchNode -> RouterDispatchNode+routerDispatchWithCommand command (RouterDispatchNode _ fields disposition loc) =+  RouterDispatchNode command fields disposition loc++routerDispatchWithFields :: [FieldBinding] -> RouterDispatchNode -> RouterDispatchNode+routerDispatchWithFields fields (RouterDispatchNode command _ disposition loc) =+  RouterDispatchNode command fields disposition loc++dispatchDispositionWithOnDuplicate :: Disp -> DispatchDisposition -> DispatchDisposition+dispatchDispositionWithOnDuplicate onDuplicate (DispatchDisposition onAppended _ onFailed) =+  DispatchDisposition onAppended onDuplicate onFailed++dispatchDispositionWithOnFailed :: Disp -> DispatchDisposition -> DispatchDisposition+dispatchDispositionWithOnFailed onFailed (DispatchDisposition onAppended onDuplicate _) =+  DispatchDisposition onAppended onDuplicate onFailed++fireAtWithWindow :: T.Text -> FireAtExpr -> FireAtExpr+fireAtWithWindow window (FireAtExpr field _) = FireAtExpr field window++transitionWithSource :: Name -> Transition -> Transition+transitionWithSource source (Transition _ command implementation guard writes emits outcome outcomeDuplicateLocs goto mode loc) =+  Transition source command implementation guard writes emits outcome outcomeDuplicateLocs goto mode loc++transitionWithGoto :: Name -> Transition -> Transition+transitionWithGoto goto (Transition source command implementation guard writes emits outcome outcomeDuplicateLocs _ mode loc) =+  Transition source command implementation guard writes emits outcome outcomeDuplicateLocs goto mode loc++eventWithDeprecated :: Bool -> Event -> Event+eventWithDeprecated deprecated (Event name body version upcastFrom retiring _ loc) =+  Event name body version upcastFrom retiring deprecated loc++aggregateWithEvents :: [Event] -> Aggregate -> Aggregate+aggregateWithEvents events (Aggregate name regs states commands _ transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc) =+  Aggregate name regs states commands events transitions domainOutcomeTypes domainOutcomeDuplicateLocs wire projection snapshot loc++workqueueWithMaxRetries :: Int -> WorkqueueNode -> WorkqueueNode+workqueueWithMaxRetries maxRetries (WorkqueueNode name logical physical dlq table ordering groupKey provision payloadName payload _ delay dlqOn disposition loc) =+  WorkqueueNode name logical physical dlq table ordering groupKey provision payloadName payload maxRetries delay dlqOn disposition loc++pgmqDispatchWithSourceKey :: Name -> PgmqDispatchNode -> PgmqDispatchNode+pgmqDispatchWithSourceKey sourceKey (PgmqDispatchNode name sourceReadModel _ fanoutBody dedupKey dedupReadModel dedupReadModelField dedupQueue dedupQueueField enqueueTo loc) =+  PgmqDispatchNode name sourceReadModel sourceKey fanoutBody dedupKey dedupReadModel dedupReadModelField dedupQueue dedupQueueField enqueueTo loc++pgmqDispatchWithFanoutBody :: Name -> PgmqDispatchNode -> PgmqDispatchNode+pgmqDispatchWithFanoutBody fanoutBody (PgmqDispatchNode name sourceReadModel sourceKey _ dedupKey dedupReadModel dedupReadModelField dedupQueue dedupQueueField enqueueTo loc) =+  PgmqDispatchNode name sourceReadModel sourceKey fanoutBody dedupKey dedupReadModel dedupReadModelField dedupQueue dedupQueueField enqueueTo loc++pgmqDispatchWithDedupKey :: Name -> PgmqDispatchNode -> PgmqDispatchNode+pgmqDispatchWithDedupKey dedupKey (PgmqDispatchNode name sourceReadModel sourceKey fanoutBody _ dedupReadModel dedupReadModelField dedupQueue dedupQueueField enqueueTo loc) =+  PgmqDispatchNode name sourceReadModel sourceKey fanoutBody dedupKey dedupReadModel dedupReadModelField dedupQueue dedupQueueField enqueueTo loc++pgmqDispatchWithEnqueueTo :: Name -> PgmqDispatchNode -> PgmqDispatchNode+pgmqDispatchWithEnqueueTo enqueueTo (PgmqDispatchNode name sourceReadModel sourceKey fanoutBody dedupKey dedupReadModel dedupReadModelField dedupQueue dedupQueueField _ loc) =+  PgmqDispatchNode name sourceReadModel sourceKey fanoutBody dedupKey dedupReadModel dedupReadModelField dedupQueue dedupQueueField enqueueTo loc++readModelWithSupply :: ReadModelSupply -> ReadModelNode -> ReadModelNode+readModelWithSupply supply (ReadModelNode name table schema columns version shape freshness _ group observedTargets backingTarget queryTypes loc) =+  ReadModelNode name table schema columns version shape freshness supply group observedTargets backingTarget queryTypes loc++operationWithShape :: OperationShape -> OperationNode -> OperationNode+operationWithShape shape (OperationNode name _ loc) = OperationNode name shape loc++semanticImpactSnapshotWithoutEvidence :: SemanticImpactSnapshot -> SemanticImpactSnapshot+semanticImpactSnapshotWithoutEvidence (SemanticImpactSnapshot mappedConsumers _ _ serviceInventory declarationIdentities) =+  SemanticImpactSnapshot mappedConsumers Nothing Nothing serviceInventory declarationIdentities++workspaceModuleRowWithPath :: FilePath -> WorkspaceModuleRow -> WorkspaceModuleRow+workspaceModuleRowWithPath path (WorkspaceModuleRow kind _ owner role) =+  WorkspaceModuleRow kind path owner role++workspaceRecordWithEditionAndModules :: GeneratedHaskellNamingEdition -> [WorkspaceModuleRow] -> WorkspaceRecord -> WorkspaceRecord+workspaceRecordWithEditionAndModules namingEdition modules (WorkspaceRecord service manifest contextName moduleRoot layout members sourceLanguages languageContract _ _ mappings idDomains nominalEqualities bindingObligations requirements projectionCatalogFacts queryContractBaseline queryContracts routerSelections adopted semanticImpact) =+  WorkspaceRecord service manifest contextName moduleRoot layout members sourceLanguages languageContract namingEdition modules mappings idDomains nominalEqualities bindingObligations requirements projectionCatalogFacts queryContractBaseline queryContracts routerSelections adopted semanticImpact++timerNodeWithPayload :: [FieldBinding] -> TimerNode -> TimerNode+timerNodeWithPayload payload (TimerNode name identity fireAt _ fire decodeUnknown maxAttempts deadLetter loc) =+  TimerNode name identity fireAt payload fire decodeUnknown maxAttempts deadLetter loc++wireArmWithTag :: T.Text -> WireArm -> WireArm+wireArmWithTag tag (WireArm ctor _ payload loc) = WireArm ctor tag payload loc++wireEnumWithTag :: T.Text -> WireEnum -> WireEnum+wireEnumWithTag tag (WireEnum ctor _ loc) = WireEnum ctor tag loc++conformanceRecordWithFiles :: [(ModuleKind, FilePath)] -> ConformancePackageRecord -> ConformancePackageRecord+conformanceRecordWithFiles files (ConformancePackageRecord schema serviceKey runtimePackage facadeModule _) =+  ConformancePackageRecord schema serviceKey runtimePackage facadeModule files

+ test/README.md view

@@ -0,0 +1,78 @@+# keiro-dsl conformance corpus++The directories named `conformance-*` are committed examples of public+`keiro-dsl scaffold` output. Together with their hand-owned fills and Cabal test+components, they prove that generated modules compile and that their runtime facts+hold.++## Regenerating the corpus++Run the driver from the repository development environment:++```console+nix develop -c cabal run -v0 keiro-dsl-corpus-regen -- regenerate+```++For a focused iteration, repeat `--only` with a repository-relative output+directory:++```console+nix develop -c cabal run -v0 keiro-dsl-corpus-regen -- regenerate \+  --only keiro-dsl/test/conformance-behavior-complete+```++The driver invokes the public CLI. It never passes the force-overwrite flag,+never overwrites create-once modules, and never commits. Review `git status` and+`git diff` after every run.++Ordinary single-spec and workspace invocations are derived from the committed+scaffold ledgers (`keiro-dsl-ledger.context.<context>.txt` and+`keiro-dsl-ledger.workspace.<service>.txt`).+`conformance-corpus-manifest.txt` stores only provenance the ledgers cannot+retain: workspace manifest locations, ordered stdin skeleton runs, extra+arguments, reviewed Cabal-inventory exemptions, and one legacy generated file+that predates the current ledger grammar. The driver rejects missing ledger+files, unrecorded generated files, dangling Cabal modules, and stale exemptions.++To verify the committed baseline without accepting drift, run:++```console+scripts/check-conformance-corpus.sh+```++The check refuses immediately when any corpus path is already dirty. From a+clean baseline it replays every invocation, verifies record/disk and Cabal/disk+consistency, and fails if regeneration changes a byte. The equivalent repository+recipe is `nix develop -c just conformance-corpus-policy`; it is also part of+`just verify`.++## Updating render goldens++Six renderer goldens are owned by `keiro-dsl-test`. Update them through the tests+that calculate the asserted values:++```console+nix develop -c cabal run -v0 keiro-dsl-corpus-regen -- update-goldens+```++Optional Cabal test arguments are passed through, for example+`--test-options=--match=fold`. Structural substring assertions continue to run in+accept mode, so an invalid renderer result is not accepted blindly. Review and+commit the resulting golden diff.++## Adding a conformance suite++1. Scaffold the fixture once with the public `keiro-dsl` CLI and fill its+   create-once modules.+2. Force-add the suite's scaffold ledger (`keiro-dsl-ledger.*.txt`) and its+   generated Cabal fragment (`keiro-dsl-cabal-fragment.*`). The global ignore+   rule remains correct for non-corpus consumer output.+3. Add a supplement row only when the history needs a workspace path, an ordered+   skeleton replay, extra scaffold arguments, or a reviewed generated-module+   exemption.+4. Add or extend the appropriate component in `keiro-dsl.cabal` and run its test.+5. Run focused regeneration and inspect the diff, then run the whole-corpus check+   from the committed baseline.++Do not hand-edit a generated module to make regeneration pass. Fix the generator,+fixture, ledger provenance, or Cabal inventory at its source.

+ test/aggregate-scalar-expression-mutation-test.sh view

@@ -0,0 +1,128 @@+#!/usr/bin/env bash+# Mutation sentinels for the authoritative inline scalar transducer.+set -euo pipefail++TRANSDUCER="keiro-dsl/test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Transducer.hs"+HOLES="keiro-dsl/test/conformance-scalar-expressions/AggregateScalarExpressions/ScalarAccount/Holes.hs"+FIXTURE="keiro-dsl/test/fixtures/aggregate-scalar-expressions-v2.keiro"+CONFORMANCE_ROOT="keiro-dsl/test/conformance-scalar-expressions"++BACKUP_DIR="$(mktemp -d "${TMPDIR:-/tmp}/keiro-scalar-mutation.XXXXXX")"+case "$BACKUP_DIR" in+  *keiro-scalar-mutation.*) ;;+  *) echo "FAIL: unexpected backup path: $BACKUP_DIR"; exit 1 ;;+esac++cp "$TRANSDUCER" "$BACKUP_DIR/Transducer.hs"+cp "$HOLES" "$BACKUP_DIR/Holes.hs"+cp "$FIXTURE" "$BACKUP_DIR/fixture.keiro"+cp -R "$CONFORMANCE_ROOT" "$BACKUP_DIR/conformance-root"++restore_all() {+  cp -R "$BACKUP_DIR/conformance-root/." "$CONFORMANCE_ROOT/"+  cp "$BACKUP_DIR/fixture.keiro" "$FIXTURE"+}++cleanup() {+  restore_all+  rm -rf "$BACKUP_DIR/conformance-root"+  rm -f "$BACKUP_DIR/Transducer.hs" "$BACKUP_DIR/Holes.hs" "$BACKUP_DIR/fixture.keiro" "$BACKUP_DIR/mutation.log"+  rmdir "$BACKUP_DIR"+}+trap cleanup EXIT++restore_file() {+  cp "$BACKUP_DIR/$1" "$2"+}++expect_red() {+  local label="$1"+  shift+  echo "== mutate: $label =="+  set +e+  "$@" >"$BACKUP_DIR/mutation.log" 2>&1+  mutation_status=$?+  set -e+  if [[ "$mutation_status" -eq 0 ]]; then+    sed -n '1,240p' "$BACKUP_DIR/mutation.log"+    echo "FAIL: mutation stayed green: $label"+    exit 1+  fi+  echo "PASS: mutation turned its owning check red: $label"+}++run_conformance() {+  cabal test keiro-dsl-conformance-aggregate-scalar-expressions --test-show-details=direct+}++echo "== baseline: scalar expression checks are green =="+run_conformance >/dev/null+cabal test keiro-dsl-test --test-option=--match --test-option='scalar expressions' >/dev/null++sed -i.sed-bak \+  's/d.requested .- B.reg @"capacity"/K.TApp2 (-) (d.requested) (B.reg @"capacity")/' \+  "$TRANSDUCER"+rm -f "$TRANSDUCER.sed-bak"+expect_red "Natural monus becomes partial subtraction" cabal test keiro-dsl-conformance-aggregate-scalar-expressions --test-show-details=direct+restore_file Transducer.hs "$TRANSDUCER"++sed -i.sed-bak \+  '/^        B.requireGuard \$/c\+        B.requireGuard K.PTop' \+  "$TRANSDUCER"+rm -f "$TRANSDUCER.sed-bak"+expect_red "generated guard is bypassed" cabal test keiro-dsl-conformance-aggregate-scalar-expressions --test-show-details=direct+cabal run -v0 keiro-dsl -- scaffold "$FIXTURE" --out keiro-dsl/test/conformance-scalar-expressions >/dev/null+run_conformance >/dev/null+cmp "$BACKUP_DIR/Transducer.hs" "$TRANSDUCER"+restore_file Transducer.hs "$TRANSDUCER"++sed -i.sed-bak \+  's/K.lit (2 :: Integer)/K.lit (3 :: Integer)/' \+  "$TRANSDUCER"+rm -f "$TRANSDUCER.sed-bak"+expect_red "generated write operand changes" cabal test keiro-dsl-conformance-aggregate-scalar-expressions --test-show-details=direct+restore_file Transducer.hs "$TRANSDUCER"++sed -i.sed-bak \+  '/^    implementation hole$/a\+    guard cmd.balance >= 0' \+  "$FIXTURE"+rm -f "$FIXTURE.sed-bak"+expect_red "Hole ownership coexists with a DSL guard" \+  cabal run -v0 keiro-dsl -- check "$FIXTURE"+restore_file fixture.keiro "$FIXTURE"++sed -i.sed-bak \+  '/^        B.emit wireClosedEvent (ClosedEventTermFields$/,/^          })$/c\+        B.noEmit' \+  "$TRANSDUCER"+rm -f "$TRANSDUCER.sed-bak"+expect_red "Hole transition violates its declared event envelope" cabal test keiro-dsl-conformance-aggregate-scalar-expressions --test-show-details=direct+restore_file Transducer.hs "$TRANSDUCER"++sed -i.sed-bak \+  's/B.goto ScalarAccountClosed/B.goto ScalarAccountReviewed/' \+  "$TRANSDUCER"+rm -f "$TRANSDUCER.sed-bak"+expect_red "Hole transition violates its declared target envelope" cabal test keiro-dsl-conformance-aggregate-scalar-expressions --test-show-details=direct+restore_file Transducer.hs "$TRANSDUCER"++sed -i.sed-bak \+  's/transition2ReviewedCloseHoleFoldVersion/omittedTransition2ReviewedCloseHoleFoldVersion/g' \+  "$HOLES"+rm -f "$HOLES.sed-bak"+expect_red "Hole fold version is omitted" cabal test keiro-dsl-conformance-aggregate-scalar-expressions --test-show-details=direct+restore_file Holes.hs "$HOLES"++sed -i.sed-bak \+  's/verifyTransition "transition2ReviewedClose" HoleOwned ScalarAccountReviewed 0/pure ("transition2ReviewedClose", HoleOwned, S.VerifiedSatisfiable)/' \+  "$TRANSDUCER"+rm -f "$TRANSDUCER.sed-bak"+expect_red "opaque Hole is falsely reported verified" cabal test keiro-dsl-conformance-aggregate-scalar-expressions --test-show-details=direct+restore_file Transducer.hs "$TRANSDUCER"++restore_all+run_conformance >/dev/null+git diff --check+echo "PASS: all scalar expression mutations were detected and exact files restored"

+ test/aggregate-scalars-mutation-test.sh view

@@ -0,0 +1,51 @@+#!/usr/bin/env bash+# Mutation test for the Time/Natural replay-safety boundary (plan 157).+set -euo pipefail++HOLES="keiro-dsl/test/conformance-aggregate-scalars/AggregateScalars/ScalarLedger/Holes.hs"+BACKUP="$(mktemp)"+cp "$HOLES" "$BACKUP"+restore() {+  cp "$BACKUP" "$HOLES"+  rm -f "$BACKUP"+}+trap restore EXIT++echo "== baseline: scalar conformance is green =="+if cabal test keiro-dsl-conformance-aggregate-scalars >/dev/null 2>&1; then+  echo "ok: baseline green"+else+  echo "FAIL: baseline scalar conformance is not green"+  exit 1+fi++echo "== mutate: replace the emitted Natural with an idempotent dishonest value =="+sed -i.sed-bak \+  '/import Keiki.Builder qualified as B/a\+import Keiki.Core qualified as K+' \+  "$HOLES"+rm -f "$HOLES.sed-bak"+sed -i.sed-bak \+  's/^    , revision = d.revision$/    , revision = K.lit 1/' \+  "$HOLES"+rm -f "$HOLES.sed-bak"++echo "== rebuild + run conformance (expect the revision replay-safety gate red) =="+if MUTATION_OUTPUT="$(cabal test keiro-dsl-conformance-aggregate-scalars --test-show-details=direct 2>&1)"; then+  echo "$MUTATION_OUTPUT"+  echo "FAIL: the dishonest Natural event value was not caught"+  exit 1+fi+echo "$MUTATION_OUTPUT"++if ! printf '%s\n' "$MUTATION_OUTPUT" | grep -Fq 'is not replay-safe'; then+  echo "FAIL: expected replay-safety validation to reject the dishonest Natural"+  exit 1+fi+if ! printf '%s\n' "$MUTATION_OUTPUT" | grep -Fq 'revision'; then+  echo "FAIL: replay-safety failure did not identify the Natural register"+  exit 1+fi++echo "PASS: scalar replay-safety validation caught dishonest Natural persistence"

+ test/behavior-complete-mutation-test.sh view

@@ -0,0 +1,171 @@+#!/usr/bin/env bash+# Falsification evidence for ExecPlans 159 and 191's complete behavior contract.+set -euo pipefail++WITNESSES="keiro-dsl/test/conformance-behavior-complete/BehaviorComplete/Journey/BehaviorHoles.hs"+LEGACY_HOLES="keiro-dsl/test/conformance-behavior-complete/BehaviorComplete/Journey/Holes.hs"+TRANSDUCER="keiro-dsl/test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Transducer.hs"+CODEC="keiro-dsl/test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Codec.hs"+SCAFFOLD_SOURCE="keiro-dsl/src/Keiro/Dsl/Scaffold.hs"+SPEC="keiro-dsl/test/fixtures/behavior-complete.keiro"+OUT="keiro-dsl/test/conformance-behavior-complete"+LEDGER="$OUT/keiro-dsl-ledger.context.behavior-complete.txt"++BACKUP_DIR="$(mktemp -d "${TMPDIR:-/tmp}/keiro-behavior-mutation.XXXXXX")"+case "$BACKUP_DIR" in+  *keiro-behavior-mutation.*) ;;+  *) echo "FAIL: unexpected backup path: $BACKUP_DIR"; exit 1 ;;+esac++cp "$WITNESSES" "$BACKUP_DIR/BehaviorHoles.hs"+cp "$LEGACY_HOLES" "$BACKUP_DIR/Holes.hs"+cp "$TRANSDUCER" "$BACKUP_DIR/Transducer.hs"+cp "$CODEC" "$BACKUP_DIR/Codec.hs"+cp "$SCAFFOLD_SOURCE" "$BACKUP_DIR/Scaffold.hs"+cp "$LEDGER" "$BACKUP_DIR/ledger.txt"++restore_all() {+  cp "$BACKUP_DIR/BehaviorHoles.hs" "$WITNESSES"+  cp "$BACKUP_DIR/Holes.hs" "$LEGACY_HOLES"+  cp "$BACKUP_DIR/Transducer.hs" "$TRANSDUCER"+  cp "$BACKUP_DIR/Codec.hs" "$CODEC"+  cp "$BACKUP_DIR/Scaffold.hs" "$SCAFFOLD_SOURCE"+  cp "$BACKUP_DIR/ledger.txt" "$LEDGER"+}++cleanup() {+  restore_all+  rm -f "$BACKUP_DIR/BehaviorHoles.hs" "$BACKUP_DIR/Holes.hs" "$BACKUP_DIR/Transducer.hs" "$BACKUP_DIR/Codec.hs" "$BACKUP_DIR/Scaffold.hs" "$BACKUP_DIR/ledger.txt" "$BACKUP_DIR/mutation.log"+  rmdir "$BACKUP_DIR"+}+trap cleanup EXIT++restore_file() {+  cp "$BACKUP_DIR/$1" "$2"+}++run_report() {+  cabal run -v0 keiro-dsl-behavior-complete-report -- --format=json+}++expect_red() {+  local label="$1"+  local expected="$2"+  local require_location="${3:-yes}"+  set +e+  run_report >"$BACKUP_DIR/mutation.log" 2>&1+  local status=$?+  set -e+  if [[ "$status" -eq 0 ]]; then+    sed -n '1,240p' "$BACKUP_DIR/mutation.log"+    echo "FAIL: mutation stayed green: $label"+    exit 1+  fi+  if ! grep -Fq "$expected" "$BACKUP_DIR/mutation.log"; then+    sed -n '1,240p' "$BACKUP_DIR/mutation.log"+    echo "FAIL: $label failed through an unexpected gate (wanted $expected)"+    exit 1+  fi+  if [[ "$require_location" == "yes" ]] && ! grep -Eq 'keiro-dsl/test/fixtures/behavior-complete\.keiro:[0-9]+:[0-9]+' "$BACKUP_DIR/mutation.log"; then+    sed -n '1,240p' "$BACKUP_DIR/mutation.log"+    echo "FAIL: $label did not report the current exact source position"+    exit 1+  fi+  echo "ok: $label -> $expected"+}++expect_focused_test_red() {+  local label="$1"+  set +e+  cabal test -v0 keiro-dsl-test --test-options='--match "generates direct fields(Command) output and separate create-once pending witnesses"' >"$BACKUP_DIR/mutation.log" 2>&1+  local status=$?+  set -e+  if [[ "$status" -eq 0 ]]; then+    sed -n '1,240p' "$BACKUP_DIR/mutation.log"+    echo "FAIL: mutation stayed green: $label"+    exit 1+  fi+  echo "ok: $label -> focused generated-source assertion"+}++echo "== baseline: all 19 obligations are filled and green =="+run_report >/dev/null++echo "== obsolete legacy hook is reported and cannot affect execution =="+SCAFFOLD_OUTPUT="$(cabal run -v0 keiro-dsl -- scaffold "$SPEC" --out "$OUT" 2>&1)"+grep -Fq "Journey.Holes.transition1EmptyStartOutput1Started" <<<"$SCAFFOLD_OUTPUT"+sed -i.sed-bak 's/requestId = d.requestId/requestId = error "obsolete identity hook executed"/' "$LEGACY_HOLES"+rm -f "$LEGACY_HOLES.sed-bak"+run_report >/dev/null+restore_file Holes.hs "$LEGACY_HOLES"++sed -i.sed-bak '/behavior-v1-43b8fc7fa48595dd/d' "$WITNESSES"+rm -f "$WITNESSES.sed-bak"+expect_red "remove a later-state witness" '"missing":["behavior-v1-43b8fc7fa48595dd"]' no+restore_file BehaviorHoles.hs "$WITNESSES"++sed -i.sed-bak 's/activeHistory = \[startedEvent 0\]/activeHistory = []/' "$WITNESSES"+rm -f "$WITNESSES.sed-bak"+expect_red "use a history reaching the wrong source" 'history-wrong-source'+restore_file BehaviorHoles.hs "$WITNESSES"++sed -i.sed-bak 's/behavior-v1-2f3ebf37a55781db/behavior-v1-swap-placeholder/; s/behavior-v1-db1a553baa3eda84/behavior-v1-2f3ebf37a55781db/; s/behavior-v1-swap-placeholder/behavior-v1-db1a553baa3eda84/' "$WITNESSES"+rm -f "$WITNESSES.sed-bak"+expect_red "swap same-target guarded sibling keys" 'edge-attribution'+restore_file BehaviorHoles.hs "$WITNESSES"++sed -i.sed-bak '/behavior-v1-83b0a46823e1a788/ s/(Rejects RejectNoMatchingEdge)/NoOp/' "$WITNESSES"+rm -f "$WITNESSES.sed-bak"+expect_red "change rejection to no-op" 'expectation-kind'+restore_file BehaviorHoles.hs "$WITNESSES"++sed -i.sed-bak '/behavior-v1-43b8fc7fa48595dd/ s/(startCommand 0)/(decideCommand 0)/' "$WITNESSES"+rm -f "$WITNESSES.sed-bak"+expect_red "use another rejecting command for a required cell" 'command-mismatch'+restore_file BehaviorHoles.hs "$WITNESSES"++perl -0pi -e 's/(B\.onCmd inCtorPing \$ \\_d -> B\.do\n)/$1        B.slot \@"lastAmount" =: K.lit 1\n/' "$TRANSDUCER"+expect_red "change a no-op register" 'noop-register-change'+restore_file Transducer.hs "$TRANSDUCER"++sed -i.sed-bak '/behavior-v1-db1a553baa3eda84/d' "$WITNESSES"+rm -f "$WITNESSES.sed-bak"+expect_red "omit one guard alternative" '"missing":["behavior-v1-db1a553baa3eda84"]' no+restore_file BehaviorHoles.hs "$WITNESSES"++perl -0pi -e 's/ReplayWitness \(key "behavior-v1-f0fbe3a3ba0b40e8"\) activeHistory \[retiredEvent 0, retirementAuditedEvent 0\]/live "behavior-v1-f0fbe3a3ba0b40e8" activeHistory (retireCommand 0) (Emits (retiredEvent 0 :| [retirementAuditedEvent 0]))/' "$WITNESSES"+expect_red "expect a replay-only edge to fire forward" 'witness-kind'+restore_file BehaviorHoles.hs "$WITNESSES"++sed -i.sed-bak '/behavior-v1-f0fbe3a3ba0b40e8/ s/retiredEvent 0, retirementAuditedEvent 0/retiredEvent 1, retirementAuditedEvent 1/' "$WITNESSES"+rm -f "$WITNESSES.sed-bak"+expect_red "let the live twin steal a replay witness" 'replay-edge-attribution'+restore_file BehaviorHoles.hs "$WITNESSES"++sed -i.sed-bak '/behavior-v1-08a2bda57424a16e/ s/startedEvent 1/startedEvent 0/' "$WITNESSES"+rm -f "$WITNESSES.sed-bak"+expect_red "let the live initial edge steal the initial replay witness" 'replay-edge-attribution'+restore_file BehaviorHoles.hs "$WITNESSES"++sed -i.sed-bak '/behavior-v1-f0fbe3a3ba0b40e8/ s/, retirementAuditedEvent 0//' "$WITNESSES"+rm -f "$WITNESSES.sed-bak"+expect_red "truncate a multi-event replay chunk" 'replay-chunk-failed'+restore_file BehaviorHoles.hs "$WITNESSES"++sed -i.sed-bak '/"Retired" ->/,/"RetirementAudited" ->/ s/<\$> o \.: "amount"/<$> ((+ 1) <$> o .: "amount")/' "$CODEC"+rm -f "$CODEC.sed-bak"+expect_red "make codec replay diverge" 'emitted-replay-failed'+restore_file Codec.hs "$CODEC"++perl -0pi -e 's/amount = d\.amount/amount = K.lit 999/' "$TRANSDUCER"+expect_red "mutate a generated identity selector" 'event-value-mismatch'+restore_file Transducer.hs "$TRANSDUCER"++perl -0pi -e 's/let edgeIndex = layoutOutgoingIndex entry/let edgeIndex = 0/' "$SCAFFOLD_SOURCE"+expect_focused_test_red "reset source-wide predicate edge indices"+restore_file Scaffold.hs "$SCAFFOLD_SOURCE"++restore_all+run_report >/dev/null+git diff --check+echo "PASS: all behavior mutations were caught and exact files restored"

+ test/conformance-aggregate-scalars/AggregateScalars/ScalarLedger/BehaviorHoles.hs view

@@ -0,0 +1,10 @@+-- Consumer-owned behavioral witnesses. Created once; never overwritten.+module AggregateScalars.ScalarLedger.BehaviorHoles (behaviorWitnesses) where++import Generated.AggregateScalars.ScalarLedger.BehaviorContract++behaviorWitnesses :: [BehaviorWitness]+behaviorWitnesses =+  [ Pending (BehaviorKey "behavior-v1-4e461a9ba9271054")+  , Pending (BehaviorKey "behavior-v1-d15e326edfa1a438")+  ]

test/conformance-aggregate-scalars/Generated/AggregateScalars/BehaviorSourceMap.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from context aggregate-scalars behavior source map; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from context aggregate-scalars behavior source map; do not edit. module Generated.AggregateScalars.BehaviorSourceMap   ( BehaviorSourceLocation (..)   , behaviorSourceLocation@@ -9,9 +9,9 @@ import Data.Text qualified as T  data BehaviorSourceLocation = BehaviorSourceLocation-  { sourceFile :: !FilePath-  , sourceLine :: !Int-  , sourceColumn :: !Int+  { file :: !FilePath+  , line :: !Int+  , column :: !Int   }   deriving stock (Eq, Ord, Show) @@ -23,7 +23,7 @@  renderBehaviorSourceLocation :: Text -> Text renderBehaviorSourceLocation key = case behaviorSourceLocation key of-  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Just location -> T.pack location.file <> ":" <> tshow location.line <> ":" <> tshow location.column   Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"  tshow :: Show value => value -> Text

test/conformance-aggregate-scalars/Generated/AggregateScalars/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from context aggregate-scalars replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.15.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/BehaviorContract.hs view

@@ -0,0 +1,350 @@+{-# LANGUAGE OverloadedLabels #-}+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit.+module Generated.AggregateScalars.ScalarLedger.BehaviorContract+  ( BehaviorKey (..)+  , unBehaviorKey+  , ObligationKind (..)+  , EvidenceLevel (..)+  , GuardCoverage (..)+  , BehaviorRequirement (..)+  , RejectionClass (..)+  , LiveExpectation (..)+  , BehaviorWitness (..)+  , BehaviorFailure (..)+  , BehaviorConformanceReport (..)+  , behaviorRequirements+  , behaviorCoverageReport+  , behaviorConformancePassed+  , behaviorConformancePassedWith+  , renderBehaviorConformanceText+  ) where++import Generated.AggregateScalars.ScalarLedger.Codec (encodeScalarLedgerEvent, parseScalarLedgerEvent, scalarLedgerCodec)+import Generated.AggregateScalars.ScalarLedger.Domain+import Generated.AggregateScalars.ScalarLedger.Transducer (scalarLedgerTransducer)+import Generated.AggregateScalars.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)++unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value++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+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !ScalarLedgerVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef ScalarLedgerVertex))+  , target :: !(Maybe ScalarLedgerVertex)+  , eventKinds :: ![Text]+  }+  deriving stock (Eq, Show)++data RejectionClass = RejectNoOutgoingEdges | RejectNoMatchingEdge+  deriving stock (Eq, Show)++data LiveExpectation+  = Emits (NonEmpty ScalarLedgerEvent)+  | Rejects RejectionClass+  | NoOp+  deriving stock (Eq, Show)++data BehaviorWitness+  = Pending BehaviorKey+  | LiveWitness+      { key :: BehaviorKey+      , history :: [ScalarLedgerEvent]+      , command :: ScalarLedgerCommand+      , expected :: LiveExpectation+      }+  | ReplayWitness+      { key :: BehaviorKey+      , historyPrefix :: [ScalarLedgerEvent]+      , observedChunk :: [ScalarLedgerEvent]+      }+  deriving stock (Eq, Show)++data BehaviorFailure = BehaviorFailure+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !Text+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorFailure where+  toJSON behaviorFailure = object+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail+    ]++data BehaviorConformanceReport = BehaviorConformanceReport+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![BehaviorKey]+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorConformanceReport where+  toJSON report = object+    [ "schema" .= ("keiro/behavior-conformance/1" :: Text)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified+    ]++behaviorRequirements :: [BehaviorRequirement]+behaviorRequirements =+  [ -- ScalarLedgerEmpty x Record: live transition+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-4e461a9ba9271054"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardUnknown+      , source = ScalarLedgerEmpty+      , commandName = "Record"+      , expectedEdge = (Just (K.EdgeRef ScalarLedgerEmpty 0))+      , target = Just ScalarLedgerRecorded+      , eventKinds = ["ScalarsRecorded"]+      }+  , -- ScalarLedgerRecorded x Record: required rejection+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-d15e326edfa1a438"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = ScalarLedgerRecorded+      , commandName = "Record"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []+      }+  ]++behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport+behaviorCoverageReport witnesses =+  BehaviorConformanceReport+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]+    }+ where+  requiredByKey = Map.fromList [(requirement.key, 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 report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)++renderBehaviorConformanceText :: BehaviorConformanceReport -> Text+renderBehaviorConformanceText report = T.unlines+  [ "behavior conformance: ScalarLedger"+  , "schema: keiro/behavior-conformance/1"+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]++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 -> [ScalarLedgerEvent] -> ScalarLedgerCommand -> LiveExpectation -> Either BehaviorFailure ()+runLive requirement history command expectation = do+  settled <- settleHistory requirement "history" history+  ensure requirement (K.replaySuccessState settled == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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 -> (ScalarLedgerVertex, K.RegFile ScalarLedgerRegs) -> ScalarLedgerCommand -> 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 scalarLedgerTransducer 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 -> (ScalarLedgerVertex, K.RegFile ScalarLedgerRegs) -> ScalarLedgerCommand -> 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 scalarLedgerTransducer 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 scalarLedgerTransducer 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 == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)+      decoded <- either (failure requirement "emitted-codec-decode") Right (decodeEvents actual)+      replayed <- case K.applyEventsDetailedEither scalarLedgerTransducer 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 ScalarLedgerRegs ScalarLedgerVertex ScalarLedgerEvent -> 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) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)++runReplay :: BehaviorRequirement -> [ScalarLedgerEvent] -> [ScalarLedgerEvent] -> Either BehaviorFailure ()+runReplay requirement prefix chunk = case requirement.kind of+  ReplayTransition -> do+    settled <- settleHistory requirement "history-prefix" prefix+    ensure requirement (K.replaySuccessState settled == requirement.source) "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 scalarLedgerTransducer (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) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)+    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 ScalarLedgerVertex] -> Either BehaviorFailure ()+checkSingleAttribution requirement expectedMode eventCount trace = case trace of+  [attribution] -> do+    ensure requirement (Just (K.replayAttributionEdge attribution) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)+    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 == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)+    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 -> [ScalarLedgerEvent] -> Either BehaviorFailure (K.ReplaySuccess ScalarLedgerRegs ScalarLedgerVertex)+settleHistory requirement label history = do+  decoded <- either (failure requirement (label <> "-codec-decode")) Right (decodeEvents history)+  case K.applyEventsDetailedEither scalarLedgerTransducer (ScalarLedgerEmpty, initialScalarLedgerRegs) decoded of+    Left replayFailure -> failure requirement (label <> "-replay-failed") (tshow replayFailure)+    Right replaySuccess -> Right replaySuccess++decodeEvents :: [ScalarLedgerEvent] -> Either Text [ScalarLedgerEvent]+decodeEvents = traverse (\event -> parseScalarLedgerEvent (Codec.eventType scalarLedgerCodec event) (encodeScalarLedgerEvent event))++commandKind :: ScalarLedgerCommand -> Text+commandKind command = case command of+  Record _ -> "Record"++eventKind :: ScalarLedgerEvent -> Text+eventKind event = case Codec.eventType scalarLedgerCodec event of Codec.EventType tag -> tag++regsEqual :: K.RegFile ScalarLedgerRegs -> K.RegFile ScalarLedgerRegs -> Bool+regsEqual left right = (left K.! #observedAt) == (right K.! #observedAt) && (left K.! #revision) == (right K.! #revision)++proofStrength :: BehaviorRequirement -> Bool+proofStrength requirement =+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]++behaviorWitnessKey :: BehaviorWitness -> BehaviorKey+behaviorWitnessKey witness = case witness of+  Pending key -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = 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+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")+        code+        detail+    )+ where+  kindPhrase = case requirement.kind 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-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/Codec.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit.+-- @generated by keiro-dsl 0.15.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,6 @@ {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit.+-- @generated by keiro-dsl 0.15.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,6 @@ {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate ScalarLedger; do not edit. module Generated.AggregateScalars.ScalarLedger.Transducer   ( scalarLedgerTransducer   , scalarLedgerFoldFingerprint

+ test/conformance-aggregate-scalars/keiro-dsl-cabal-fragment.context.aggregate-scalars.txt view

@@ -0,0 +1,32 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/aggregate-scalars.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    AggregateScalars.ScalarLedger.BehaviorHoles+    AggregateScalars.ScalarLedger.Holes+    Generated.AggregateScalars.BehaviorSourceMap+    Generated.AggregateScalars.ReplayAudit+    Generated.AggregateScalars.ScalarLedger.BehaviorContract+    Generated.AggregateScalars.ScalarLedger.Codec+    Generated.AggregateScalars.ScalarLedger.Domain+    Generated.AggregateScalars.ScalarLedger.EventStream+    Generated.AggregateScalars.ScalarLedger.Harness+    Generated.AggregateScalars.ScalarLedger.Projection+    Generated.AggregateScalars.ScalarLedger.Transducer++build-depends:+    , aeson+    , base+    , keiki+    , keiro+    , text+    , time

+ test/conformance-aggregate-scalars/keiro-dsl-ledger.context.aggregate-scalars.txt view

@@ -0,0 +1,32 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/aggregate-scalars.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":4,"effectiveLanguageVersion":4,"sourceForm":"declared"}+semantic-contract {"languageSupport":"compatibility-only","languageVersion":4,"runtimeSemantics":"keiro-dsl/runtime-semantics/3"}+naming-edition idiomatic-v2+module-role {"family":"BehaviorSourceMap","kind":"generated","ownerKind":"context","ownerName":"context aggregate-scalars behavior source map","path":"Generated/AggregateScalars/BehaviorSourceMap.hs"}+module-role {"family":"ReplayAudit","kind":"generated","ownerKind":"context","ownerName":"context aggregate-scalars replay-audit assembly","path":"Generated/AggregateScalars/ReplayAudit.hs"}+module-role {"family":"Domain","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate ScalarLedger (line 4)","path":"Generated/AggregateScalars/ScalarLedger/Domain.hs"}+module-role {"family":"Codec","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate ScalarLedger (line 4)","path":"Generated/AggregateScalars/ScalarLedger/Codec.hs"}+module-role {"family":"Transducer","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate ScalarLedger (line 4)","path":"Generated/AggregateScalars/ScalarLedger/Transducer.hs"}+module-role {"family":"BehaviorContract","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate ScalarLedger (line 4)","path":"Generated/AggregateScalars/ScalarLedger/BehaviorContract.hs"}+module-role {"family":"BehaviorHoles","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate behavior witnesses ScalarLedger (line 4)","path":"AggregateScalars/ScalarLedger/BehaviorHoles.hs"}+module-role {"family":"EventStream","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate ScalarLedger (line 4)","path":"Generated/AggregateScalars/ScalarLedger/EventStream.hs"}+module-role {"family":"Projection","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate ScalarLedger (line 4)","path":"Generated/AggregateScalars/ScalarLedger/Projection.hs"}+module-role {"family":"Holes","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate ScalarLedger (line 4)","path":"AggregateScalars/ScalarLedger/Holes.hs"}+module-role {"family":"Harness","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate ScalarLedger (line 4)","path":"Generated/AggregateScalars/ScalarLedger/Harness.hs"}+generated Generated/AggregateScalars/BehaviorSourceMap.hs+generated Generated/AggregateScalars/ReplayAudit.hs+generated Generated/AggregateScalars/ScalarLedger/Domain.hs+generated Generated/AggregateScalars/ScalarLedger/Codec.hs+generated Generated/AggregateScalars/ScalarLedger/Transducer.hs+generated Generated/AggregateScalars/ScalarLedger/BehaviorContract.hs+hole AggregateScalars/ScalarLedger/BehaviorHoles.hs+generated Generated/AggregateScalars/ScalarLedger/EventStream.hs+generated Generated/AggregateScalars/ScalarLedger/Projection.hs+hole AggregateScalars/ScalarLedger/Holes.hs+generated Generated/AggregateScalars/ScalarLedger/Harness.hs+behavior {"aggregate":"ScalarLedger","command":"Record","evidence":"generated-authoritative","key":"behavior-v1-4e461a9ba9271054","kind":"live-transition","outputs":[{"obligation":"event-output-v1/ScalarLedger/live/Empty/Record/cmd.observedAt >= reg.observedAt && cmd.revision >= reg.revision/observedAt:=cmd.observedAt;revision:=cmd.revision/ScalarsRecorded/Recorded/1/ScalarsRecorded","ownership":"hand-owned"}],"source":"Empty"}+behavior {"aggregate":"ScalarLedger","command":"Record","evidence":"generated-authoritative","key":"behavior-v1-d15e326edfa1a438","kind":"required-rejection","outputs":[],"source":"Recorded"}+semantic-impact {"declarations":[],"mappedSurfaceEvidenceVersion":1,"serviceInventory":[]}

+ test/conformance-baseline.json view

@@ -0,0 +1,63 @@+{+  "schema": "keiro-dsl/conformance-baseline/2",+  "stableLanguageVersion": 5,+  "authoringLanguageVersion": 5,+  "primaryLanguageVersions": [4, 5],+  "fixtureExceptions": [+    {"path": "test/fixtures/aggregate-collection-expressions-v2-rejects.keiro", "sourceForm": "declared", "effectiveVersion": 2, "role": "compatibility-proof", "reason": "version-2 grammar rejection vector"},+    {"path": "test/fixtures/aggregate-scalar-expressions-v1-rejects.keiro", "sourceForm": "declared", "effectiveVersion": 1, "role": "compatibility-proof", "reason": "version-1 predecessor feature rejection vector"},+    {"path": "test/fixtures/contract-v1-compat.keiro", "sourceForm": "declared", "effectiveVersion": 1, "role": "compatibility-proof", "reason": "version-1 permissive Text contract compatibility proof"},+    {"path": "test/fixtures/id-domain-migration-v3.keiro", "sourceForm": "declared", "effectiveVersion": 3, "role": "compatibility-proof", "reason": "version-3 historical replay admission boundary"},+    {"path": "test/fixtures/language-duplicate.keiro", "sourceForm": "declared", "effectiveVersion": null, "role": "compatibility-proof", "reason": "released source-selection compatibility vector"},+    {"path": "test/fixtures/language-identifier-v1.keiro", "sourceForm": "legacy-unversioned", "effectiveVersion": 1, "role": "compatibility-proof", "reason": "released source-selection compatibility vector"},+    {"path": "test/fixtures/language-identifier-v2.keiro", "sourceForm": "declared", "effectiveVersion": 2, "role": "compatibility-proof", "reason": "released source-selection compatibility vector"},+    {"path": "test/fixtures/language-legacy.keiro", "sourceForm": "legacy-unversioned", "effectiveVersion": 1, "role": "compatibility-proof", "reason": "released source-selection compatibility vector"},+    {"path": "test/fixtures/language-malformed.keiro", "sourceForm": "declared", "effectiveVersion": null, "role": "compatibility-proof", "reason": "released source-selection compatibility vector"},+    {"path": "test/fixtures/language-misplaced.keiro", "sourceForm": "legacy-unversioned", "effectiveVersion": null, "role": "compatibility-proof", "reason": "released source-selection compatibility vector"},+    {"path": "test/fixtures/language-v1.keiro", "sourceForm": "declared", "effectiveVersion": 1, "role": "compatibility-proof", "reason": "released source-selection compatibility vector"},+    {"path": "test/fixtures/language-zero.keiro", "sourceForm": "declared", "effectiveVersion": null, "role": "compatibility-proof", "reason": "released source-selection compatibility vector"},+    {"path": "test/fixtures/nominal-v1.keiro", "sourceForm": "declared", "effectiveVersion": 1, "role": "compatibility-proof", "reason": "version-1 nominal-syntax rejection vector"},+    {"path": "test/fixtures/outcome-identifier-legacy.keiro", "sourceForm": "legacy-unversioned", "effectiveVersion": 1, "role": "compatibility-proof", "reason": "released outcome-identifier compatibility proof"}+  ],+  "compiledSuites": [+    {"component": "keiro-dsl-conformance", "directory": "test/conformance", "source": "test/fixtures/reservation.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 canonical reservation aggregate proof"},+    {"component": "keiro-dsl-conformance-aggregate-scalars", "directory": "test/conformance-aggregate-scalars", "source": "test/fixtures/aggregate-scalars.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 aggregate scalar transition and field-identity selector/wire-key proof"},+    {"component": "keiro-dsl-conformance-aggregate-scalar-expressions", "directory": "test/conformance-scalar-expressions", "source": "test/fixtures/aggregate-scalar-expressions-v2.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 aggregate scalar expression proof"},+    {"component": "keiro-dsl-conformance-behavior-complete", "directory": "test/conformance-behavior-complete", "source": "test/fixtures/behavior-complete.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 complete behavior ownership proof"},+    {"component": "keiro-dsl-conformance-domain-outcomes", "directory": "test/conformance-domain-outcomes", "source": "test/fixtures/domain-command-outcomes.keiro", "generation": "source", "role": "stable-primary", "languageVersion": 5, "reason": "stable typed domain outcome handler and exact silent-reason proof"},+    {"component": "keiro-dsl-conformance-import-planning", "directory": "test/conformance-import-planning", "source": "test/fixtures/import-planning-collisions.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 consumer import collision and alias proof"},+    {"component": "keiro-dsl-conformance-nominal-scalars", "directory": "test/conformance-nominal-scalars", "source": "test/fixtures/nominal-scalars.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 nominal scalar codec proof"},+    {"component": "keiro-dsl-conformance-workspace-nominals", "directory": "test/conformance-workspace-nominals", "source": "test/fixtures/workspace-nominals/service.keiro-workspace", "generation": "workspace", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 workspace-owned nominal proof"},+    {"component": "keiro-dsl-conformance-structural", "directory": "test/conformance-structural", "source": "test/fixtures/structural-conformance.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 structural mapping proof"},+    {"component": "keiro-dsl-conformance-mapped-queue", "directory": "test/conformance-mapped-queue", "source": "test/fixtures/mapped-workqueue.keiro", "generation": "source", "role": "stable-primary", "languageVersion": 5, "reason": "stable mapped workqueue structural, opaque, required-nullable, and schema-version-1 envelope proof"},+    {"component": "keiro-dsl-conformance-mapped-readmodel", "directory": "test/conformance-mapped-readmodel", "source": "test/fixtures/mapped-readmodel.keiro", "generation": "source", "role": "stable-primary", "languageVersion": 5, "reason": "stable mapped read-model query contract, workspace provenance, and projection catalog proof"},+    {"component": "keiro-dsl-conformance-codec-compare", "directory": "test/conformance-codec-compare", "source": null, "generation": "none", "role": "version-independent", "reason": "codec comparison helper proof has no source-language fixture"},+    {"component": "keiro-dsl-conformance-replay", "directory": "test/conformance-replay", "source": "test/fixtures/replay-divergence.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 replay divergence proof"},+    {"component": "keiro-dsl-conformance-snapshot", "directory": "test/conformance-snapshot", "source": "test/fixtures/reservation-snapshot.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 snapshot compatibility proof"},+    {"component": "keiro-dsl-conformance-skeletons", "directory": "test/conformance-skeletons", "source": null, "generation": "none", "role": "compatibility-proof", "reason": "compiled released-language-4 skeleton corpus retained without unrelated banner rewrites"},+    {"component": "keiro-dsl-conformance-coldstart", "directory": "test/conformance-coldstart", "source": "test/fixtures/subscription.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 cold-start subscription proof"},+    {"component": "keiro-dsl-conformance-contract", "directory": "test/conformance-contract", "source": "test/fixtures/contract-v4.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 typed contract and field-identity selector/wire-key proof"},+    {"component": "keiro-dsl-conformance-contract-v1-compat", "directory": "test/conformance-contract-v1-compat", "source": "test/fixtures/contract-v1-compat.keiro", "generation": "none", "role": "compatibility-proof", "reason": "version-1 permissive Text contract compatibility proof"},+    {"component": "keiro-dsl-conformance-intake-runtime", "directory": "test/conformance-intake-runtime", "source": "test/fixtures/intake.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 intake runtime proof"},+    {"component": "keiro-dsl-conformance-intake-full", "directory": "test/conformance-intake-full", "source": "test/fixtures/intake.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 complete intake scaffold proof"},+    {"component": "keiro-dsl-conformance-publisher-runtime", "directory": "test/conformance-publisher-runtime", "source": "test/fixtures/emit.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 publisher runtime proof"},+    {"component": "keiro-dsl-conformance-queue", "directory": "test/conformance-queue", "source": "test/fixtures/reservation-work.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 workqueue scaffold proof"},+    {"component": "keiro-dsl-conformance-queue-runtime", "directory": "test/conformance-queue-runtime", "source": "test/fixtures/reservation-work.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 workqueue runtime proof"},+    {"component": "keiro-dsl-conformance-readmodel-runtime", "directory": "test/conformance-readmodel-runtime", "source": "test/fixtures/readmodel-runtime.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 read-model runtime proof"},+    {"component": "keiro-dsl-conformance-projection-catalog", "directory": "test/conformance-projection-catalog", "source": "test/fixtures/projection-catalog.keiro", "generation": "source", "role": "stable-primary", "languageVersion": 5, "reason": "stable Language 5 typed projection catalog and group-scoped rebuild facade proof"},+    {"component": "keiro-dsl-conformance-dispatch-full", "directory": "test/conformance-dispatch-full", "source": "test/fixtures/reservation-work.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 complete dispatch scaffold proof"},+    {"component": "keiro-dsl-conformance-workflow", "directory": "test/conformance-workflow", "source": "test/fixtures/workflow-evolution.keiro", "generation": "source", "role": "stable-primary", "languageVersion": 5, "reason": "stable Language 5 workflow scaffold proof"},+    {"component": "keiro-dsl-conformance-workflow-runtime", "directory": "test/conformance-workflow-runtime", "source": "test/fixtures/workflow-evolution.keiro", "generation": "source", "role": "stable-primary", "languageVersion": 5, "reason": "stable live workflow allocation and completion proof"},+    {"component": "keiro-dsl-conformance-process-full", "directory": "test/conformance-process-full", "source": "test/fixtures/surge-service.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 complete process scaffold proof"},+    {"component": "keiro-dsl-conformance-workflow-full", "directory": "test/conformance-workflow-full", "source": "test/fixtures/workflow-evolution.keiro", "generation": "source", "role": "stable-primary", "languageVersion": 5, "reason": "complete stable Language 5 workflow scaffold proof"},+    {"component": "keiro-dsl-conformance-process-runtime", "directory": "test/conformance-process-runtime", "source": "test/fixtures/hospital-surge.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 process runtime proof"},+    {"component": "keiro-dsl-conformance-router-runtime", "directory": "test/conformance-router-runtime", "source": "test/fixtures/incident-paging/incident-paging.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 router runtime proof"},+    {"component": "keiro-dsl-conformance-declarative-router", "directory": "test/conformance-declarative-router", "source": "test/fixtures/declarative-router/valid.keiro", "generation": "source", "role": "stable-primary", "languageVersion": 5, "reason": "stable checked declarative selection, normalization, redelivery, conflict, and PostgreSQL query proof"},+    {"component": "keiro-dsl-conformance-router", "directory": "test/conformance-router", "source": "test/fixtures/incident-paging/incident-paging.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 router scaffold proof"},+    {"component": "keiro-dsl-conformance-router-full", "directory": "test/conformance-router-full", "source": "test/fixtures/incident-paging/incident-paging.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 complete router scaffold proof"},+    {"component": "keiro-dsl-conformance-newsurface", "directory": "test/conformance-newsurface", "source": "test/fixtures/transfer-routing.keiro", "generation": "source-with-conformance-facade", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 surface integration and service-facade compilation proof"},+    {"component": "keiro-dsl-conformance-process", "directory": "test/conformance-process", "source": "test/fixtures/hospital-surge.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "published Language 4 process scaffold proof"},+    {"component": "keiro-dsl-conformance-v2", "directory": "test/conformance-v2", "source": "test/fixtures/reservation-v2.keiro", "generation": "source", "role": "published-compatibility", "languageVersion": 4, "reason": "historically named target proving the published Language 4 reservation fixture"},+    {"component": "keiro-dsl-conformance-id-domain-migration", "directory": "test/conformance-id-domain-migration", "source": "test/fixtures/id-domain-migration-v3.keiro", "generation": "none", "role": "compatibility-proof", "reason": "version-3 historical replay admission proof"}+  ]+}

test/conformance-behavior-complete/Generated/BehaviorComplete/BehaviorSourceMap.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from context behavior-complete behavior source map; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from context behavior-complete behavior source map; do not edit. module Generated.BehaviorComplete.BehaviorSourceMap   ( BehaviorSourceLocation (..)   , behaviorSourceLocation@@ -9,9 +9,9 @@ import Data.Text qualified as T  data BehaviorSourceLocation = BehaviorSourceLocation-  { sourceFile :: !FilePath-  , sourceLine :: !Int-  , sourceColumn :: !Int+  { file :: !FilePath+  , line :: !Int+  , column :: !Int   }   deriving stock (Eq, Ord, Show) @@ -40,7 +40,7 @@  renderBehaviorSourceLocation :: Text -> Text renderBehaviorSourceLocation key = case behaviorSourceLocation key of-  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Just location -> T.pack location.file <> ":" <> tshow location.line <> ":" <> tshow location.column   Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"  tshow :: Show value => value -> Text

test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/BehaviorContract.hs view

@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit. module Generated.BehaviorComplete.Journey.BehaviorContract   ( BehaviorKey (..)+  , unBehaviorKey   , ObligationKind (..)   , EvidenceLevel (..)   , GuardCoverage (..)@@ -35,6 +36,9 @@ newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }   deriving stock (Eq, Ord, Show) +unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value+ data ObligationKind = LiveTransition | RequiredRejection | ReplayTransition   deriving stock (Eq, Ord, Show) @@ -45,15 +49,15 @@   deriving stock (Eq, Ord, Show)  data BehaviorRequirement = BehaviorRequirement-  { requirementKey :: !BehaviorKey-  , requirementKind :: !ObligationKind-  , requirementEvidence :: !EvidenceLevel-  , requirementGuardCoverage :: !GuardCoverage-  , requirementSource :: !JourneyVertex-  , requirementCommandName :: !Text-  , requirementExpectedEdge :: !(Maybe (K.EdgeRef JourneyVertex))-  , requirementTarget :: !(Maybe JourneyVertex)-  , requirementEventKinds :: ![Text]+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !JourneyVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef JourneyVertex))+  , target :: !(Maybe JourneyVertex)+  , eventKinds :: ![Text]   }   deriving stock (Eq, Show) @@ -69,308 +73,308 @@ data BehaviorWitness   = Pending BehaviorKey   | LiveWitness-      { witnessKey :: BehaviorKey-      , witnessHistory :: [JourneyEvent]-      , witnessCommand :: JourneyCommand-      , witnessExpected :: LiveExpectation+      { key :: BehaviorKey+      , history :: [JourneyEvent]+      , command :: JourneyCommand+      , expected :: LiveExpectation       }   | ReplayWitness-      { witnessKey :: BehaviorKey-      , witnessHistoryPrefix :: [JourneyEvent]-      , witnessObservedChunk :: [JourneyEvent]+      { key :: BehaviorKey+      , historyPrefix :: [JourneyEvent]+      , observedChunk :: [JourneyEvent]       }   deriving stock (Eq, Show)  data BehaviorFailure = BehaviorFailure-  { failureKey :: !BehaviorKey-  , failureSubject :: !Text-  , failureCode :: !Text-  , failureDetail :: !Text+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !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+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail     ]  data BehaviorConformanceReport = BehaviorConformanceReport-  { reportRequired :: ![BehaviorKey]-  , reportFilled :: ![BehaviorKey]-  , reportPending :: ![BehaviorKey]-  , reportMissing :: ![BehaviorKey]-  , reportDuplicate :: ![BehaviorKey]-  , reportStale :: ![BehaviorKey]-  , reportFailed :: ![BehaviorFailure]-  , reportVerified :: ![BehaviorKey]-  , reportUnverified :: ![BehaviorKey]+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![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)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified     ]  behaviorRequirements :: [BehaviorRequirement] behaviorRequirements =   [ -- JourneyEmpty x LegacyStart: replay-only transition     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-0128e858fee6f2b3"-      , requirementKind = ReplayTransition-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = JourneyEmpty-      , requirementCommandName = "LegacyStart"-      , requirementExpectedEdge = (Just (K.EdgeRef JourneyEmpty 2))-      , requirementTarget = Just JourneyActive-      , requirementEventKinds = ["LegacyStarted"]+      { key = BehaviorKey "behavior-v1-0128e858fee6f2b3"+      , kind = ReplayTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = JourneyEmpty+      , commandName = "LegacyStart"+      , expectedEdge = (Just (K.EdgeRef JourneyEmpty 2))+      , target = Just JourneyActive+      , eventKinds = ["LegacyStarted"]       }   , -- JourneyEmpty x Start: replay-only transition     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-08a2bda57424a16e"-      , requirementKind = ReplayTransition-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = JourneyEmpty-      , requirementCommandName = "Start"-      , requirementExpectedEdge = (Just (K.EdgeRef JourneyEmpty 1))-      , requirementTarget = Just JourneyActive-      , requirementEventKinds = ["Started"]+      { key = BehaviorKey "behavior-v1-08a2bda57424a16e"+      , kind = ReplayTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = JourneyEmpty+      , commandName = "Start"+      , expectedEdge = (Just (K.EdgeRef JourneyEmpty 1))+      , target = Just JourneyActive+      , eventKinds = ["Started"]       }   , -- JourneyClosed x Ping: required rejection     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-2e1fd6b9580e1a3d"-      , requirementKind = RequiredRejection-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = JourneyClosed-      , requirementCommandName = "Ping"-      , requirementExpectedEdge = Nothing-      , requirementTarget = Nothing-      , requirementEventKinds = []+      { key = BehaviorKey "behavior-v1-2e1fd6b9580e1a3d"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = JourneyClosed+      , commandName = "Ping"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []       }   , -- JourneyActive x Decide: live transition     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-2f3ebf37a55781db"-      , requirementKind = LiveTransition-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardTotal-      , requirementSource = JourneyActive-      , requirementCommandName = "Decide"-      , requirementExpectedEdge = (Just (K.EdgeRef JourneyActive 0))-      , requirementTarget = Just JourneyActive-      , requirementEventKinds = ["DecisionRecorded"]+      { key = BehaviorKey "behavior-v1-2f3ebf37a55781db"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = JourneyActive+      , commandName = "Decide"+      , expectedEdge = (Just (K.EdgeRef JourneyActive 0))+      , target = Just JourneyActive+      , eventKinds = ["DecisionRecorded"]       }   , -- JourneyActive x Start: required rejection     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-43b8fc7fa48595dd"-      , requirementKind = RequiredRejection-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = JourneyActive-      , requirementCommandName = "Start"-      , requirementExpectedEdge = Nothing-      , requirementTarget = Nothing-      , requirementEventKinds = []+      { key = BehaviorKey "behavior-v1-43b8fc7fa48595dd"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = JourneyActive+      , commandName = "Start"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []       }   , -- JourneyActive x Retire: live transition     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-68e75665b789892c"-      , requirementKind = LiveTransition-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardUnknown-      , requirementSource = JourneyActive-      , requirementCommandName = "Retire"-      , requirementExpectedEdge = (Just (K.EdgeRef JourneyActive 3))-      , requirementTarget = Just JourneyClosed-      , requirementEventKinds = ["Retired", "RetirementAudited"]+      { key = BehaviorKey "behavior-v1-68e75665b789892c"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardUnknown+      , source = JourneyActive+      , commandName = "Retire"+      , expectedEdge = (Just (K.EdgeRef JourneyActive 3))+      , target = Just JourneyClosed+      , eventKinds = ["Retired", "RetirementAudited"]       }   , -- JourneyActive x LegacyStart: required rejection     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-76005937ded24bec"-      , requirementKind = RequiredRejection-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = JourneyActive-      , requirementCommandName = "LegacyStart"-      , requirementExpectedEdge = Nothing-      , requirementTarget = Nothing-      , requirementEventKinds = []+      { key = BehaviorKey "behavior-v1-76005937ded24bec"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = JourneyActive+      , commandName = "LegacyStart"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []       }   , -- JourneyClosed x Decide: required rejection     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-7ea811586a738ee5"-      , requirementKind = RequiredRejection-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = JourneyClosed-      , requirementCommandName = "Decide"-      , requirementExpectedEdge = Nothing-      , requirementTarget = Nothing-      , requirementEventKinds = []+      { key = BehaviorKey "behavior-v1-7ea811586a738ee5"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = JourneyClosed+      , commandName = "Decide"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []       }   , -- JourneyEmpty x Ping: required rejection     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-83b0a46823e1a788"-      , requirementKind = RequiredRejection-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = JourneyEmpty-      , requirementCommandName = "Ping"-      , requirementExpectedEdge = Nothing-      , requirementTarget = Nothing-      , requirementEventKinds = []+      { key = BehaviorKey "behavior-v1-83b0a46823e1a788"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = JourneyEmpty+      , commandName = "Ping"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []       }   , -- JourneyEmpty x LegacyStart: required rejection     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-8f79f2e40d8b3bd5"-      , requirementKind = RequiredRejection-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = JourneyEmpty-      , requirementCommandName = "LegacyStart"-      , requirementExpectedEdge = Nothing-      , requirementTarget = Nothing-      , requirementEventKinds = []+      { key = BehaviorKey "behavior-v1-8f79f2e40d8b3bd5"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = JourneyEmpty+      , commandName = "LegacyStart"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []       }   , -- JourneyEmpty x Retire: required rejection     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-926739ffb27d20e7"-      , requirementKind = RequiredRejection-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = JourneyEmpty-      , requirementCommandName = "Retire"-      , requirementExpectedEdge = Nothing-      , requirementTarget = Nothing-      , requirementEventKinds = []+      { key = BehaviorKey "behavior-v1-926739ffb27d20e7"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = JourneyEmpty+      , commandName = "Retire"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []       }   , -- JourneyClosed x LegacyStart: required rejection     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-9c61af3593764622"-      , requirementKind = RequiredRejection-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = JourneyClosed-      , requirementCommandName = "LegacyStart"-      , requirementExpectedEdge = Nothing-      , requirementTarget = Nothing-      , requirementEventKinds = []+      { key = BehaviorKey "behavior-v1-9c61af3593764622"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = JourneyClosed+      , commandName = "LegacyStart"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []       }   , -- JourneyEmpty x Decide: required rejection     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-ba7053f86d15e1b0"-      , requirementKind = RequiredRejection-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = JourneyEmpty-      , requirementCommandName = "Decide"-      , requirementExpectedEdge = Nothing-      , requirementTarget = Nothing-      , requirementEventKinds = []+      { key = BehaviorKey "behavior-v1-ba7053f86d15e1b0"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = JourneyEmpty+      , commandName = "Decide"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []       }   , -- JourneyClosed x Start: required rejection     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-be8b08a049ab4d8b"-      , requirementKind = RequiredRejection-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = JourneyClosed-      , requirementCommandName = "Start"-      , requirementExpectedEdge = Nothing-      , requirementTarget = Nothing-      , requirementEventKinds = []+      { key = BehaviorKey "behavior-v1-be8b08a049ab4d8b"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = JourneyClosed+      , commandName = "Start"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []       }   , -- JourneyEmpty x Start: live transition     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-d2fc3eca5c449e84"-      , requirementKind = LiveTransition-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardUnknown-      , requirementSource = JourneyEmpty-      , requirementCommandName = "Start"-      , requirementExpectedEdge = (Just (K.EdgeRef JourneyEmpty 0))-      , requirementTarget = Just JourneyActive-      , requirementEventKinds = ["Started"]+      { key = BehaviorKey "behavior-v1-d2fc3eca5c449e84"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardUnknown+      , source = JourneyEmpty+      , commandName = "Start"+      , expectedEdge = (Just (K.EdgeRef JourneyEmpty 0))+      , target = Just JourneyActive+      , eventKinds = ["Started"]       }   , -- JourneyActive x Decide: live transition     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-db1a553baa3eda84"-      , requirementKind = LiveTransition-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardTotal-      , requirementSource = JourneyActive-      , requirementCommandName = "Decide"-      , requirementExpectedEdge = (Just (K.EdgeRef JourneyActive 1))-      , requirementTarget = Just JourneyActive-      , requirementEventKinds = ["DecisionRecorded"]+      { key = BehaviorKey "behavior-v1-db1a553baa3eda84"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = JourneyActive+      , commandName = "Decide"+      , expectedEdge = (Just (K.EdgeRef JourneyActive 1))+      , target = Just JourneyActive+      , eventKinds = ["DecisionRecorded"]       }   , -- JourneyActive x Ping: live transition     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-ea258e9c47d66aac"-      , requirementKind = LiveTransition-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardTotal-      , requirementSource = JourneyActive-      , requirementCommandName = "Ping"-      , requirementExpectedEdge = (Just (K.EdgeRef JourneyActive 2))-      , requirementTarget = Just JourneyActive-      , requirementEventKinds = []+      { key = BehaviorKey "behavior-v1-ea258e9c47d66aac"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = JourneyActive+      , commandName = "Ping"+      , expectedEdge = (Just (K.EdgeRef JourneyActive 2))+      , target = Just JourneyActive+      , eventKinds = []       }   , -- JourneyActive x Retire: replay-only transition     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-f0fbe3a3ba0b40e8"-      , requirementKind = ReplayTransition-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = JourneyActive-      , requirementCommandName = "Retire"-      , requirementExpectedEdge = (Just (K.EdgeRef JourneyActive 4))-      , requirementTarget = Just JourneyClosed-      , requirementEventKinds = ["Retired", "RetirementAudited"]+      { key = BehaviorKey "behavior-v1-f0fbe3a3ba0b40e8"+      , kind = ReplayTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = JourneyActive+      , commandName = "Retire"+      , expectedEdge = (Just (K.EdgeRef JourneyActive 4))+      , target = Just JourneyClosed+      , eventKinds = ["Retired", "RetirementAudited"]       }   , -- JourneyClosed x Retire: required rejection     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-f9cae2bf4c0d0562"-      , requirementKind = RequiredRejection-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = JourneyClosed-      , requirementCommandName = "Retire"-      , requirementExpectedEdge = Nothing-      , requirementTarget = Nothing-      , requirementEventKinds = []+      { key = BehaviorKey "behavior-v1-f9cae2bf4c0d0562"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = JourneyClosed+      , commandName = "Retire"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []       }   ]  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)]+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]     }  where-  requiredByKey = Map.fromList [(requirementKey requirement, requirement) | requirement <- behaviorRequirements]+  requiredByKey = Map.fromList [(requirement.key, requirement) | requirement <- behaviorRequirements]   witnessGroups = Map.fromListWith (flip (<>)) [(behaviorWitnessKey witness, [witness]) | witness <- witnesses]   executions =     [ (requirement, runWitness requirement witness)@@ -385,27 +389,27 @@  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))+  null report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)  renderBehaviorConformanceText :: BehaviorConformanceReport -> Text renderBehaviorConformanceText report = T.unlines   [ "behavior conformance: Journey"   , "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]+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]  runWitness :: BehaviorRequirement -> BehaviorWitness -> Either BehaviorFailure () runWitness requirement witness = case witness of@@ -416,9 +420,9 @@ runLive :: BehaviorRequirement -> [JourneyEvent] -> JourneyCommand -> 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+  ensure requirement (K.replaySuccessState settled == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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@@ -450,7 +454,7 @@       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))+      ensure requirement (map eventKind actual == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)       decoded <- either (failure requirement "emitted-codec-decode") Right (decodeEvents actual)       replayed <- case K.applyEventsDetailedEither journeyTransducer seed decoded of         Left replayFailure -> failure requirement "emitted-replay-failed" (tshow replayFailure)@@ -462,30 +466,30 @@ checkAcceptedEnvelope :: BehaviorRequirement -> K.StepSuccess JourneyRegs JourneyVertex JourneyEvent -> 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))+  ensure requirement (Just (K.stepSuccessEdge success) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)  runReplay :: BehaviorRequirement -> [JourneyEvent] -> [JourneyEvent] -> Either BehaviorFailure ()-runReplay requirement prefix chunk = case requirementKind requirement of+runReplay requirement prefix chunk = case requirement.kind 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 (K.replaySuccessState settled == requirement.source) "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 journeyTransducer (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))+    ensure requirement (Just (K.replaySuccessState replayed) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)     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 JourneyVertex] -> 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 (Just (K.replayAttributionEdge attribution) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)     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.replayAttributionSource attribution == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)     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" @@ -515,14 +519,14 @@  proofStrength :: BehaviorRequirement -> Bool proofStrength requirement =-  requirementEvidence requirement == GeneratedAuthoritative-    && requirementGuardCoverage requirement `elem` [GuardTotal, GuardNotApplicable]+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]  behaviorWitnessKey :: BehaviorWitness -> BehaviorKey behaviorWitnessKey witness = case witness of   Pending key -> key-  LiveWitness { witnessKey = key } -> key-  ReplayWitness { witnessKey = key } -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = key } -> key  isPending :: BehaviorWitness -> Bool isPending Pending {} = True@@ -534,13 +538,13 @@ failure requirement code detail =   Left     ( BehaviorFailure-        (requirementKey requirement)-        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey requirement)) <> ")")+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")         code         detail     )  where-  kindPhrase = case requirementKind requirement of+  kindPhrase = case requirement.kind of     LiveTransition -> "live transition"     RequiredRejection -> "required rejection"     ReplayTransition -> "replay-only transition"

test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Codec.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit. module Generated.BehaviorComplete.Journey.Codec (     journeyCodec,     parseJourneyEvent,@@ -42,8 +41,8 @@ encodeStartPayloadShape :: ShapeStartPayload.StartPayloadShape -> Value encodeStartPayloadShape shape =   object-      [ "display_label" .= toJSON (ShapeStartPayload.label shape)-      , "optional_note" .= maybe Null (\item -> toJSON (item)) (ShapeStartPayload.note shape)+      [ "display_label" .= toJSON (shape.label)+      , "optional_note" .= maybe Null (\item -> toJSON (item)) (shape.note)       ]  parseStartPayloadShape :: Value -> Parser ShapeStartPayload.StartPayloadShape

test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Domain.hs view

@@ -1,7 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit.+-- @generated by keiro-dsl 0.15.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,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit. module Generated.BehaviorComplete.Journey.Harness (harnessAssertions) where  import Generated.BehaviorComplete.Journey.Domain

test/conformance-behavior-complete/Generated/BehaviorComplete/Journey/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit.+-- @generated by keiro-dsl 0.15.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,6 @@ {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from context behavior-complete generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from context behavior-complete generated nominal ID internals; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from context behavior-complete replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from mapped structural StartPayload; do not edit.+-- @generated by keiro-dsl 0.15.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

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from context behavior-complete structural conformance; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from context behavior-complete structural conformance; do not edit. module Generated.BehaviorComplete.StructuralConformance   ( structuralConformanceAssertions   ) where@@ -12,9 +12,9 @@ import Keiki.Shape (CanonicalTypeName (..)) import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape) import Generated.BehaviorComplete.StructuralProjections qualified as StructuralProjections+import Generated.BehaviorComplete.Structural.Shape.StartPayload (StartPayloadShape(label, note)) import BehaviorComplete.Bindings qualified as Bindings import BehaviorComplete.Domain (StartPayload)-import Generated.BehaviorComplete.Structural.Shape.StartPayload qualified as ShapeStartPayload  structuralConformanceAssertions :: [(String, Bool)] structuralConformanceAssertions =@@ -44,11 +44,11 @@     cases = fixtureCases Bindings.startPayloadCases  coverageStartPayload :: Bool-coverageStartPayload = any (isNothing . ShapeStartPayload.note) shapes && any (isJust . ShapeStartPayload.note) shapes+coverageStartPayload = any (isNothing . (.note)) shapes && any (isJust . (.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)))+  [ ("projection witness agreement: behavior-complete.StartPayload.v1/display_label", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.startPayloadDisplayLabelWitness (\referenceOwner -> (bindingToShape Bindings.startPayloadBinding referenceOwner).label) 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.14.0.0 (language keiro-dsl 4) from context behavior-complete mapped structural facade; do not edit.+-- @generated by keiro-dsl 0.15.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@@ -9,9 +9,9 @@ import Data.Text (Text) import Keiro.Codec.Structural (bindingToShape) import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)+import Generated.BehaviorComplete.Structural.Shape.StartPayload (StartPayloadShape(label)) import BehaviorComplete.Bindings qualified as Bindings import BehaviorComplete.Domain (StartPayload)-import Generated.BehaviorComplete.Structural.Shape.StartPayload qualified as ShapeStartPayload  data StartPayloadDisplayLabelProjection @@ -20,7 +20,7 @@   type FieldOwner StartPayloadDisplayLabelProjection = StartPayload   type FieldResult StartPayloadDisplayLabelProjection = Text   fieldShapeId _ = "behavior-complete.StartPayload.v1"-  projectFieldValue _ owner = ShapeStartPayload.label (bindingToShape Bindings.startPayloadBinding owner)+  projectFieldValue _ owner = (bindingToShape Bindings.startPayloadBinding owner).label  startPayloadDisplayLabelWitness :: FieldWitness StartPayloadDisplayLabelProjection startPayloadDisplayLabelWitness = fieldWitness @StartPayloadDisplayLabelProjection

+ test/conformance-behavior-complete/behavior-complete-report.cabal view

@@ -0,0 +1,42 @@+cabal-version: 3.0+name:          keiro-dsl-behavior-complete-report+version:       0.0.0.0+build-type:    Simple++executable keiro-dsl-behavior-complete-report+  main-is:            Main.hs+  other-modules:+    BehaviorComplete.Bindings+    BehaviorComplete.Domain+    BehaviorComplete.Journey.BehaviorHoles+    BehaviorComplete.Journey.Holes+    Generated.BehaviorComplete.BehaviorSourceMap+    Generated.BehaviorComplete.Nominals+    Generated.BehaviorComplete.Nominals.Internal+    Generated.BehaviorComplete.Journey.BehaviorContract+    Generated.BehaviorComplete.Journey.Codec+    Generated.BehaviorComplete.Journey.Domain+    Generated.BehaviorComplete.Journey.Transducer+    Generated.BehaviorComplete.Structural.Shape.StartPayload+    Generated.BehaviorComplete.StructuralProjections++  default-language:   GHC2024+  default-extensions:+    DuplicateRecordFields+    ImportQualifiedPost+    LambdaCase+    NoFieldSelectors+    OverloadedLabels+    OverloadedRecordDot+    OverloadedStrings++  ghc-options:        -Wall+  build-depends:+    , aeson       >=2.2  && <2.3+    , base        >=4.21 && <5+    , bytestring  >=0.12 && <0.13+    , containers  >=0.6  && <0.8+    , keiki       >=0.9  && <0.10+    , keiro+    , text        >=2.1  && <2.2+    , time        >=1.12 && <1.15

+ test/conformance-behavior-complete/keiro-dsl-cabal-fragment.context.behavior-complete.txt view

@@ -0,0 +1,45 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/behavior-complete.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    BehaviorComplete.Bindings+    BehaviorComplete.Journey.BehaviorHoles+    Generated.BehaviorComplete.BehaviorSourceMap+    Generated.BehaviorComplete.Journey.BehaviorContract+    Generated.BehaviorComplete.Journey.Codec+    Generated.BehaviorComplete.Journey.Domain+    Generated.BehaviorComplete.Journey.EventStream+    Generated.BehaviorComplete.Journey.Harness+    Generated.BehaviorComplete.Journey.Projection+    Generated.BehaviorComplete.Journey.Transducer+    Generated.BehaviorComplete.Nominals+    Generated.BehaviorComplete.Nominals.Internal+    Generated.BehaviorComplete.ReplayAudit+    Generated.BehaviorComplete.Structural.Shape.StartPayload+    Generated.BehaviorComplete.StructuralConformance+    Generated.BehaviorComplete.StructuralProjections++build-depends:+    , aeson+    , base+    , keiki+    , keiro+    , keiro-dsl+    , text+    , time++consumer-packages:+    keiro-dsl++consumer-modules:+    BehaviorComplete.Bindings+    BehaviorComplete.Domain

+ test/conformance-behavior-complete/keiro-dsl-ledger.context.behavior-complete.txt view

@@ -0,0 +1,65 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/behavior-complete.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":4,"effectiveLanguageVersion":4,"sourceForm":"declared"}+semantic-contract {"languageSupport":"compatibility-only","languageVersion":4,"runtimeSemantics":"keiro-dsl/runtime-semantics/3"}+naming-edition idiomatic-v2+module-role {"family":"StructuralConformance","kind":"generated","ownerKind":"context","ownerName":"context behavior-complete structural conformance","path":"Generated/BehaviorComplete/StructuralConformance.hs"}+module-role {"family":"BehaviorSourceMap","kind":"generated","ownerKind":"context","ownerName":"context behavior-complete behavior source map","path":"Generated/BehaviorComplete/BehaviorSourceMap.hs"}+module-role {"family":"StartPayload","kind":"generated","ownerKind":"mapped","ownerName":"mapped structural StartPayload (line 6)","path":"Generated/BehaviorComplete/Structural/Shape/StartPayload.hs"}+module-role {"family":"StructuralProjections","kind":"generated","ownerKind":"context","ownerName":"context behavior-complete mapped structural facade","path":"Generated/BehaviorComplete/StructuralProjections.hs"}+module-role {"family":"Nominals","kind":"generated","ownerKind":"context","ownerName":"context behavior-complete generated nominal declarations","path":"Generated/BehaviorComplete/Nominals.hs"}+module-role {"family":"Internal","kind":"generated","ownerKind":"context","ownerName":"context behavior-complete generated nominal ID internals","path":"Generated/BehaviorComplete/Nominals/Internal.hs"}+module-role {"family":"Bindings","kind":"hole","ownerKind":"consumer","ownerName":"consumer binding skeleton BehaviorComplete.Bindings","path":"BehaviorComplete/Bindings.hs"}+module-role {"family":"ReplayAudit","kind":"generated","ownerKind":"context","ownerName":"context behavior-complete replay-audit assembly","path":"Generated/BehaviorComplete/ReplayAudit.hs"}+module-role {"family":"Domain","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Journey (line 18)","path":"Generated/BehaviorComplete/Journey/Domain.hs"}+module-role {"family":"Codec","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Journey (line 18)","path":"Generated/BehaviorComplete/Journey/Codec.hs"}+module-role {"family":"Transducer","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Journey (line 18)","path":"Generated/BehaviorComplete/Journey/Transducer.hs"}+module-role {"family":"BehaviorContract","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Journey (line 18)","path":"Generated/BehaviorComplete/Journey/BehaviorContract.hs"}+module-role {"family":"BehaviorHoles","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate behavior witnesses Journey (line 18)","path":"BehaviorComplete/Journey/BehaviorHoles.hs"}+module-role {"family":"EventStream","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Journey (line 18)","path":"Generated/BehaviorComplete/Journey/EventStream.hs"}+module-role {"family":"Projection","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Journey (line 18)","path":"Generated/BehaviorComplete/Journey/Projection.hs"}+module-role {"family":"Harness","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Journey (line 18)","path":"Generated/BehaviorComplete/Journey/Harness.hs"}+generated Generated/BehaviorComplete/StructuralConformance.hs+generated Generated/BehaviorComplete/BehaviorSourceMap.hs+generated Generated/BehaviorComplete/Structural/Shape/StartPayload.hs+generated Generated/BehaviorComplete/StructuralProjections.hs+generated Generated/BehaviorComplete/Nominals.hs+generated Generated/BehaviorComplete/Nominals/Internal.hs+hole BehaviorComplete/Bindings.hs+generated Generated/BehaviorComplete/ReplayAudit.hs+generated Generated/BehaviorComplete/Journey/Domain.hs+generated Generated/BehaviorComplete/Journey/Codec.hs+generated Generated/BehaviorComplete/Journey/Transducer.hs+generated Generated/BehaviorComplete/Journey/BehaviorContract.hs+hole BehaviorComplete/Journey/BehaviorHoles.hs+generated Generated/BehaviorComplete/Journey/EventStream.hs+generated Generated/BehaviorComplete/Journey/Projection.hs+generated Generated/BehaviorComplete/Journey/Harness.hs+mapping {"bindingSymbol":"BehaviorComplete.Bindings.startPayloadBinding","bindingVersion":"1","canonicalType":"behavior-complete.StartPayload.v1","mode":"structural","module":"BehaviorComplete.Domain","package":"keiro-dsl","schema":1,"specName":"StartPayload","type":"StartPayload"}+id-domain id-domain|name=RequestId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=req|separator=_|json=canonical-json-text+nominal-equality 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+binding {"kind":"binding","mappedName":"StartPayload","module":"BehaviorComplete.Bindings","path":"label","schema":1,"signature":"startPayloadBinding.label :: Text","symbol":"startPayloadBinding"}+binding {"kind":"binding","mappedName":"StartPayload","module":"BehaviorComplete.Bindings","path":"note","schema":1,"signature":"startPayloadBinding.note :: Maybe (Text)","symbol":"startPayloadBinding"}+binding {"kind":"fixtures","mappedName":"StartPayload","module":"BehaviorComplete.Bindings","path":null,"schema":1,"signature":"startPayloadCases :: FixtureCases BehaviorComplete.Domain.StartPayload","symbol":"startPayloadCases"}+behavior {"aggregate":"Journey","command":"LegacyStart","evidence":"generated-authoritative","key":"behavior-v1-0128e858fee6f2b3","kind":"replay-transition","outputs":[{"command":"LegacyStart","ownership":"generated-command-identity"}],"source":"Empty"}+behavior {"aggregate":"Journey","command":"Start","evidence":"generated-authoritative","key":"behavior-v1-08a2bda57424a16e","kind":"replay-transition","outputs":[{"command":"Start","ownership":"generated-command-identity"}],"source":"Empty"}+behavior {"aggregate":"Journey","command":"Ping","evidence":"generated-authoritative","key":"behavior-v1-2e1fd6b9580e1a3d","kind":"required-rejection","outputs":[],"source":"Closed"}+behavior {"aggregate":"Journey","command":"Decide","evidence":"generated-authoritative","key":"behavior-v1-2f3ebf37a55781db","kind":"live-transition","outputs":[{"command":"Decide","ownership":"generated-command-identity"}],"source":"Active"}+behavior {"aggregate":"Journey","command":"Start","evidence":"generated-authoritative","key":"behavior-v1-43b8fc7fa48595dd","kind":"required-rejection","outputs":[],"source":"Active"}+behavior {"aggregate":"Journey","command":"Retire","evidence":"generated-authoritative","key":"behavior-v1-68e75665b789892c","kind":"live-transition","outputs":[{"command":"Retire","ownership":"generated-command-identity"},{"command":"Retire","ownership":"generated-command-identity"}],"source":"Active"}+behavior {"aggregate":"Journey","command":"LegacyStart","evidence":"generated-authoritative","key":"behavior-v1-76005937ded24bec","kind":"required-rejection","outputs":[],"source":"Active"}+behavior {"aggregate":"Journey","command":"Decide","evidence":"generated-authoritative","key":"behavior-v1-7ea811586a738ee5","kind":"required-rejection","outputs":[],"source":"Closed"}+behavior {"aggregate":"Journey","command":"Ping","evidence":"generated-authoritative","key":"behavior-v1-83b0a46823e1a788","kind":"required-rejection","outputs":[],"source":"Empty"}+behavior {"aggregate":"Journey","command":"LegacyStart","evidence":"generated-authoritative","key":"behavior-v1-8f79f2e40d8b3bd5","kind":"required-rejection","outputs":[],"source":"Empty"}+behavior {"aggregate":"Journey","command":"Retire","evidence":"generated-authoritative","key":"behavior-v1-926739ffb27d20e7","kind":"required-rejection","outputs":[],"source":"Empty"}+behavior {"aggregate":"Journey","command":"LegacyStart","evidence":"generated-authoritative","key":"behavior-v1-9c61af3593764622","kind":"required-rejection","outputs":[],"source":"Closed"}+behavior {"aggregate":"Journey","command":"Decide","evidence":"generated-authoritative","key":"behavior-v1-ba7053f86d15e1b0","kind":"required-rejection","outputs":[],"source":"Empty"}+behavior {"aggregate":"Journey","command":"Start","evidence":"generated-authoritative","key":"behavior-v1-be8b08a049ab4d8b","kind":"required-rejection","outputs":[],"source":"Closed"}+behavior {"aggregate":"Journey","command":"Start","evidence":"generated-authoritative","key":"behavior-v1-d2fc3eca5c449e84","kind":"live-transition","outputs":[{"command":"Start","ownership":"generated-command-identity"}],"source":"Empty"}+behavior {"aggregate":"Journey","command":"Decide","evidence":"generated-authoritative","key":"behavior-v1-db1a553baa3eda84","kind":"live-transition","outputs":[{"command":"Decide","ownership":"generated-command-identity"}],"source":"Active"}+behavior {"aggregate":"Journey","command":"Ping","evidence":"generated-authoritative","key":"behavior-v1-ea258e9c47d66aac","kind":"live-transition","outputs":[],"source":"Active"}+behavior {"aggregate":"Journey","command":"Retire","evidence":"generated-authoritative","key":"behavior-v1-f0fbe3a3ba0b40e8","kind":"replay-transition","outputs":[{"command":"Retire","ownership":"generated-command-identity"},{"command":"Retire","ownership":"generated-command-identity"}],"source":"Active"}+behavior {"aggregate":"Journey","command":"Retire","evidence":"generated-authoritative","key":"behavior-v1-f9cae2bf4c0d0562","kind":"required-rejection","outputs":[],"source":"Closed"}+semantic-impact {"declarations":[{"consequences":[{"consumer":"Journey","kind":"consumer-build"},{"aggregate":"Journey","kind":"private-event-history"}],"consumerEvidence":[{"consumer":"Journey","operation":null,"path":"Journey command Start .details : StartPayload","surface":"aggregate-command"},{"consumer":"Journey","operation":null,"path":"Journey event Started .details : StartPayload","surface":"private-event-payload"}],"consumers":["Journey"],"declaration":"StartPayload","identity":"structural\u001fkeiro-dsl:BehaviorComplete.Domain:StartPayload\u001fBehaviorComplete.Bindings.startPayloadBinding\u001f1\u001fbehavior-complete.StartPayload.v1\u001fBehaviorComplete.Bindings.startPayloadCases\u001f\u001fff996bf9b1385f2b\u001frecord:StartPayload:label=display_label,note=optional_note"}],"mappedSurfaceEvidenceVersion":1,"serviceInventory":["StartPayload"]}

test/conformance-codec-compare/Conformance/CodecCompare/Historical.hs view

@@ -17,10 +17,10 @@ historicalArtifactInfoCodec :: HistoricalCodec Domain.ArtifactInfo historicalArtifactInfoCodec =     HistoricalCodec-        { hcIdentity = "conformance.structural.ArtifactInfo.aeson"-        , hcVersion = "legacy-v3"-        , hcEncode = encodeArtifactInfo-        , hcDecode = either (Left . T.pack) Right . parseEither parseArtifactInfo+        { identity = "conformance.structural.ArtifactInfo.aeson"+        , version = "legacy-v3"+        , encode = encodeArtifactInfo+        , decode = either (Left . T.pack) Right . parseEither parseArtifactInfo         }  {- | Acceptance control: this stands in for the historical codec after its two@@ -31,10 +31,10 @@ generatedEquivalentArtifactInfoCodec :: HistoricalCodec Domain.ArtifactInfo generatedEquivalentArtifactInfoCodec =     HistoricalCodec-        { hcIdentity = "conformance.structural.ArtifactInfo.generated-equivalent"-        , hcVersion = "cutover-v4"-        , hcEncode = GeneratedCodec.encodeArtifactInfoMapped-        , hcDecode = GeneratedCodec.decodeArtifactInfoMapped+        { identity = "conformance.structural.ArtifactInfo.generated-equivalent"+        , version = "cutover-v4"+        , encode = GeneratedCodec.encodeArtifactInfoMapped+        , decode = GeneratedCodec.decodeArtifactInfoMapped         }  encodeArtifactInfo :: Domain.ArtifactInfo -> Value

test/conformance-codec-compare/Main.hs view

@@ -15,18 +15,18 @@     parityReport <- compareWithHistorical generatedEquivalentArtifactInfoCodec parityCorpusPath     let differences =             [ difference-            | observation <- crObservations report-            , RequiresVersionWork difference <- [classifiedVerdict observation]+            | observation <- report.observations+            , RequiresVersionWork difference <- [observation.verdict]             ]         assertions =             [ ("comparison has explicit differences", not (null differences))             , ("omitted key is not parity", any isArtifactHashDifference differences)             , ("legacy union tag is not parity", any isCanonicalTagDifference differences)-            , ("historical corpus is valid", null (crInputIssues report))-            , ("historical and typed branch coverage is complete", null (crCoverageGaps report))+            , ("historical corpus is valid", null report.inputIssues)+            , ("historical and typed branch coverage is complete", null report.coverageGaps)             , ("differences make the report fail", not (reportSucceeded report))             , ("authority framing is mandatory", "MIGRATION EVIDENCE ONLY" `T.isInfixOf` renderCompareReport report)-            , ("missing canonical arm is a coverage gap", any isCanonicalGap (crCoverageGaps missingArm))+            , ("missing canonical arm is a coverage gap", any isCanonicalGap missingArm.coverageGaps)             , ("removing the historical quirks yields parity", reportSucceeded parityReport)             , ("parity retains authority framing", "MIGRATION EVIDENCE ONLY" `T.isInfixOf` renderCompareReport parityReport)             ]@@ -47,6 +47,6 @@ isCanonicalTagDifference _ = False  isCanonicalGap :: CoverageGap -> Bool-isCanonicalGap gap = case cgKind gap of+isCanonicalGap gap = case gap.kind of     UnionArm arm -> arm == "canonical"     _ -> False

+ test/conformance-codec-compare/RunnerMain.hs view

@@ -0,0 +1,25 @@++module Main (main) where++import Conformance.CodecCompare.Historical (historicalArtifactInfoCodec)+import Data.Text.IO qualified as TIO+import Generated.StructuralConformance.Structural.CodecCompare.ArtifactInfo (compareWithHistorical)+import Keiro.Dsl.CodecCompare (renderCompareReport, reportSucceeded, writeCompareReportAtomic)+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)++main :: IO ()+main = do+    arguments <- getArgs+    case arguments of+        ["--historical-goldens", goldenDirectory, "--report", reportPath] -> do+            report <- compareWithHistorical historicalArtifactInfoCodec goldenDirectory+            TIO.putStr (renderCompareReport report)+            writeResult <- writeCompareReportAtomic reportPath report+            case writeResult of+                Left err -> hPutStrLn stderr (show err) >> exitFailure+                Right () -> if reportSucceeded report then pure () else exitFailure+        _ -> do+            hPutStrLn stderr "usage: keiro-dsl-codec-compare-artifact-info --historical-goldens DIR --report FILE"+            exitFailure

+ test/conformance-codec-compare/fixtures/artifact-info/canonical.json view

@@ -0,0 +1,10 @@+{+  "artifact_key": "artifact-canonical",+  "display_name": "Canonical",+  "artifact_hash": "sha256:03",+  "artifact_kind": "guide",+  "location": {"tag": "Canonical"},+  "metadata": {"note": "legacy tag"},+  "active": true,+  "tags": ["legacy"]+}

+ test/conformance-codec-compare/fixtures/artifact-info/local-dir-null.json view

@@ -0,0 +1,10 @@+{+  "artifact_key": "artifact-directory",+  "display_name": "Local directory",+  "artifact_hash": null,+  "artifact_kind": "reference",+  "location": {"tag": "local_dir", "contents": "/tmp/artifacts"},+  "metadata": {"note": "directory"},+  "active": true,+  "tags": ["legacy"]+}

+ test/conformance-codec-compare/fixtures/artifact-info/local-file-missing.json view

@@ -0,0 +1,6 @@+{+  "artifact_key": "artifact-local",+  "display_name": "Local file",+  "location": {"tag": "local_file", "contents": "/tmp/artifact.txt"},+  "metadata": {"note": null, "legacy_extra": true}+}

+ test/conformance-codec-compare/fixtures/artifact-info/repo-path.json view

@@ -0,0 +1,10 @@+{+  "artifact_key": "artifact-repo",+  "display_name": "Repository path",+  "artifact_hash": "sha256:01",+  "artifact_kind": "guide",+  "location": {"tag": "repo_path", "contents": "docs/artifact.md"},+  "metadata": {"note": "repository"},+  "active": true,+  "tags": ["legacy"]+}

+ test/conformance-codec-compare/fixtures/artifact-info/url.json view

@@ -0,0 +1,10 @@+{+  "artifact_key": "artifact-url",+  "display_name": "URL",+  "artifact_hash": "sha256:02",+  "artifact_kind": "reference",+  "location": {"tag": "url", "contents": "https://example.test/artifact"},+  "metadata": {"note": null},+  "active": false,+  "tags": []+}

+ test/conformance-codec-compare/fixtures/generated-parity/canonical.json view

@@ -0,0 +1,10 @@+{+  "artifact_key": "artifact-canonical",+  "display_name": "Canonical",+  "artifact_hash": "sha256:03",+  "artifact_kind": "guide",+  "location": {"tag": "canonical"},+  "metadata": {"note": "canonical tag"},+  "active": true,+  "tags": ["cutover"]+}

+ test/conformance-codec-compare/fixtures/generated-parity/local-dir-null.json view

@@ -0,0 +1,10 @@+{+  "artifact_key": "artifact-directory",+  "display_name": "Local directory",+  "artifact_hash": null,+  "artifact_kind": "reference",+  "location": {"tag": "local_dir", "contents": "/tmp/artifacts"},+  "metadata": {"note": "directory"},+  "active": true,+  "tags": ["cutover"]+}

+ test/conformance-codec-compare/fixtures/generated-parity/local-file-missing.json view

@@ -0,0 +1,6 @@+{+  "artifact_key": "artifact-local",+  "display_name": "Local file",+  "location": {"tag": "local_file", "contents": "/tmp/artifact.txt"},+  "metadata": {"note": null, "legacy_extra": true}+}

+ test/conformance-codec-compare/fixtures/generated-parity/repo-path.json view

@@ -0,0 +1,10 @@+{+  "artifact_key": "artifact-repo",+  "display_name": "Repository path",+  "artifact_hash": "sha256:01",+  "artifact_kind": "guide",+  "location": {"tag": "repo_path", "contents": "docs/artifact.md"},+  "metadata": {"note": "repository"},+  "active": true,+  "tags": ["cutover"]+}

+ test/conformance-codec-compare/fixtures/generated-parity/url.json view

@@ -0,0 +1,10 @@+{+  "artifact_key": "artifact-url",+  "display_name": "URL",+  "artifact_hash": "sha256:02",+  "artifact_kind": "reference",+  "location": {"tag": "url", "contents": "https://example.test/artifact"},+  "metadata": {"note": null},+  "active": false,+  "tags": []+}

+ test/conformance-codec-compare/fixtures/missing-arm/local-file.json view

@@ -0,0 +1,6 @@+{+  "artifact_key": "artifact-local",+  "display_name": "Local file",+  "location": {"tag": "local_file", "contents": "/tmp/artifact.txt"},+  "metadata": {"note": null}+}

+ test/conformance-coldstart/Billing/Subscription/BehaviorHoles.hs view

@@ -0,0 +1,14 @@+-- Consumer-owned behavioral witnesses. Created once; never overwritten.+module Billing.Subscription.BehaviorHoles (behaviorWitnesses) where++import Generated.Billing.Subscription.BehaviorContract++behaviorWitnesses :: [BehaviorWitness]+behaviorWitnesses =+  [ Pending (BehaviorKey "behavior-v1-09842123ac52dd63")+  , Pending (BehaviorKey "behavior-v1-9399755ba2b617d6")+  , Pending (BehaviorKey "behavior-v1-93f6f3f8cb36420d")+  , Pending (BehaviorKey "behavior-v1-99ac0c974e512f76")+  , Pending (BehaviorKey "behavior-v1-9b81e070774b3ae1")+  , Pending (BehaviorKey "behavior-v1-b5d1ca5d9ad9b2ec")+  ]

test/conformance-coldstart/Generated/Billing/BehaviorSourceMap.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from context billing behavior source map; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from context billing behavior source map; do not edit. module Generated.Billing.BehaviorSourceMap   ( BehaviorSourceLocation (..)   , behaviorSourceLocation@@ -9,9 +9,9 @@ import Data.Text qualified as T  data BehaviorSourceLocation = BehaviorSourceLocation-  { sourceFile :: !FilePath-  , sourceLine :: !Int-  , sourceColumn :: !Int+  { file :: !FilePath+  , line :: !Int+  , column :: !Int   }   deriving stock (Eq, Ord, Show) @@ -27,7 +27,7 @@  renderBehaviorSourceLocation :: Text -> Text renderBehaviorSourceLocation key = case behaviorSourceLocation key of-  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Just location -> T.pack location.file <> ":" <> tshow location.line <> ":" <> tshow location.column   Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"  tshow :: Show value => value -> Text

test/conformance-coldstart/Generated/Billing/Nominals.hs view

@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from context billing generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from context billing generated nominal ID internals; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from context billing replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.15.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/BehaviorContract.hs view

@@ -0,0 +1,399 @@+{-# LANGUAGE OverloadedLabels #-}+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit.+module Generated.Billing.Subscription.BehaviorContract+  ( BehaviorKey (..)+  , unBehaviorKey+  , ObligationKind (..)+  , EvidenceLevel (..)+  , GuardCoverage (..)+  , BehaviorRequirement (..)+  , RejectionClass (..)+  , LiveExpectation (..)+  , BehaviorWitness (..)+  , BehaviorFailure (..)+  , BehaviorConformanceReport (..)+  , behaviorRequirements+  , behaviorCoverageReport+  , behaviorConformancePassed+  , behaviorConformancePassedWith+  , renderBehaviorConformanceText+  ) where++import Generated.Billing.Subscription.Codec (encodeSubscriptionEvent, parseSubscriptionEvent, subscriptionCodec)+import Generated.Billing.Subscription.Domain+import Generated.Billing.Subscription.Transducer (subscriptionTransducer)+import Generated.Billing.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)++unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value++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+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !SubscriptionVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef SubscriptionVertex))+  , target :: !(Maybe SubscriptionVertex)+  , eventKinds :: ![Text]+  }+  deriving stock (Eq, Show)++data RejectionClass = RejectNoOutgoingEdges | RejectNoMatchingEdge+  deriving stock (Eq, Show)++data LiveExpectation+  = Emits (NonEmpty SubscriptionEvent)+  | Rejects RejectionClass+  | NoOp+  deriving stock (Eq, Show)++data BehaviorWitness+  = Pending BehaviorKey+  | LiveWitness+      { key :: BehaviorKey+      , history :: [SubscriptionEvent]+      , command :: SubscriptionCommand+      , expected :: LiveExpectation+      }+  | ReplayWitness+      { key :: BehaviorKey+      , historyPrefix :: [SubscriptionEvent]+      , observedChunk :: [SubscriptionEvent]+      }+  deriving stock (Eq, Show)++data BehaviorFailure = BehaviorFailure+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !Text+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorFailure where+  toJSON behaviorFailure = object+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail+    ]++data BehaviorConformanceReport = BehaviorConformanceReport+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![BehaviorKey]+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorConformanceReport where+  toJSON report = object+    [ "schema" .= ("keiro/behavior-conformance/1" :: Text)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified+    ]++behaviorRequirements :: [BehaviorRequirement]+behaviorRequirements =+  [ -- SubscriptionActive x ActivateSubscription: required rejection+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-09842123ac52dd63"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = SubscriptionActive+      , commandName = "ActivateSubscription"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []+      }+  , -- SubscriptionInactive x ActivateSubscription: live transition+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-9399755ba2b617d6"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardUnknown+      , source = SubscriptionInactive+      , commandName = "ActivateSubscription"+      , expectedEdge = (Just (K.EdgeRef SubscriptionInactive 0))+      , target = Just SubscriptionActive+      , eventKinds = ["SubscriptionActivated"]+      }+  , -- SubscriptionInactive x CancelSubscription: required rejection+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-93f6f3f8cb36420d"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = SubscriptionInactive+      , commandName = "CancelSubscription"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []+      }+  , -- SubscriptionClosed x CancelSubscription: required rejection+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-99ac0c974e512f76"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = SubscriptionClosed+      , commandName = "CancelSubscription"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []+      }+  , -- SubscriptionClosed x ActivateSubscription: required rejection+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-9b81e070774b3ae1"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = SubscriptionClosed+      , commandName = "ActivateSubscription"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []+      }+  , -- SubscriptionActive x CancelSubscription: live transition+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-b5d1ca5d9ad9b2ec"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = SubscriptionActive+      , commandName = "CancelSubscription"+      , expectedEdge = (Just (K.EdgeRef SubscriptionActive 0))+      , target = Just SubscriptionClosed+      , eventKinds = ["SubscriptionCancelled"]+      }+  ]++behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport+behaviorCoverageReport witnesses =+  BehaviorConformanceReport+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]+    }+ where+  requiredByKey = Map.fromList [(requirement.key, 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 report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)++renderBehaviorConformanceText :: BehaviorConformanceReport -> Text+renderBehaviorConformanceText report = T.unlines+  [ "behavior conformance: Subscription"+  , "schema: keiro/behavior-conformance/1"+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]++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 -> [SubscriptionEvent] -> SubscriptionCommand -> LiveExpectation -> Either BehaviorFailure ()+runLive requirement history command expectation = do+  settled <- settleHistory requirement "history" history+  ensure requirement (K.replaySuccessState settled == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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 -> (SubscriptionVertex, K.RegFile SubscriptionRegs) -> SubscriptionCommand -> 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 subscriptionTransducer 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 -> (SubscriptionVertex, K.RegFile SubscriptionRegs) -> SubscriptionCommand -> 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 subscriptionTransducer 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 subscriptionTransducer 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 == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)+      decoded <- either (failure requirement "emitted-codec-decode") Right (decodeEvents actual)+      replayed <- case K.applyEventsDetailedEither subscriptionTransducer 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 SubscriptionRegs SubscriptionVertex SubscriptionEvent -> 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) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)++runReplay :: BehaviorRequirement -> [SubscriptionEvent] -> [SubscriptionEvent] -> Either BehaviorFailure ()+runReplay requirement prefix chunk = case requirement.kind of+  ReplayTransition -> do+    settled <- settleHistory requirement "history-prefix" prefix+    ensure requirement (K.replaySuccessState settled == requirement.source) "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 subscriptionTransducer (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) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)+    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 SubscriptionVertex] -> Either BehaviorFailure ()+checkSingleAttribution requirement expectedMode eventCount trace = case trace of+  [attribution] -> do+    ensure requirement (Just (K.replayAttributionEdge attribution) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)+    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 == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)+    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 -> [SubscriptionEvent] -> Either BehaviorFailure (K.ReplaySuccess SubscriptionRegs SubscriptionVertex)+settleHistory requirement label history = do+  decoded <- either (failure requirement (label <> "-codec-decode")) Right (decodeEvents history)+  case K.applyEventsDetailedEither subscriptionTransducer (SubscriptionInactive, initialSubscriptionRegs) decoded of+    Left replayFailure -> failure requirement (label <> "-replay-failed") (tshow replayFailure)+    Right replaySuccess -> Right replaySuccess++decodeEvents :: [SubscriptionEvent] -> Either Text [SubscriptionEvent]+decodeEvents = traverse (\event -> parseSubscriptionEvent (Codec.eventType subscriptionCodec event) (encodeSubscriptionEvent event))++commandKind :: SubscriptionCommand -> Text+commandKind command = case command of+  ActivateSubscription _ -> "ActivateSubscription"+  CancelSubscription _ -> "CancelSubscription"++eventKind :: SubscriptionEvent -> Text+eventKind event = case Codec.eventType subscriptionCodec event of Codec.EventType tag -> tag++regsEqual :: K.RegFile SubscriptionRegs -> K.RegFile SubscriptionRegs -> Bool+regsEqual left right = (left K.! #plan) == (right K.! #plan)++proofStrength :: BehaviorRequirement -> Bool+proofStrength requirement =+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]++behaviorWitnessKey :: BehaviorWitness -> BehaviorKey+behaviorWitnessKey witness = case witness of+  Pending key -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = 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+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")+        code+        detail+    )+ where+  kindPhrase = case requirement.kind 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-coldstart/Generated/Billing/Subscription/Codec.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit.+-- @generated by keiro-dsl 0.15.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,5 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit.+-- @generated by keiro-dsl 0.15.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

@@ -1,8 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Subscription; do not edit. module Generated.Billing.Subscription.Transducer   ( subscriptionTransducer   , subscriptionFoldFingerprint

+ test/conformance-coldstart/keiro-dsl-cabal-fragment.context.billing.txt view

@@ -0,0 +1,33 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/subscription.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    Billing.Subscription.BehaviorHoles+    Billing.Subscription.Holes+    Generated.Billing.BehaviorSourceMap+    Generated.Billing.Nominals+    Generated.Billing.Nominals.Internal+    Generated.Billing.ReplayAudit+    Generated.Billing.Subscription.BehaviorContract+    Generated.Billing.Subscription.Codec+    Generated.Billing.Subscription.Domain+    Generated.Billing.Subscription.EventStream+    Generated.Billing.Subscription.Harness+    Generated.Billing.Subscription.Projection+    Generated.Billing.Subscription.Transducer++build-depends:+    , aeson+    , base+    , keiki+    , keiro+    , text

+ test/conformance-coldstart/keiro-dsl-ledger.context.billing.txt view

@@ -0,0 +1,45 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/subscription.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":4,"effectiveLanguageVersion":4,"sourceForm":"declared"}+semantic-contract {"languageSupport":"compatibility-only","languageVersion":4,"runtimeSemantics":"keiro-dsl/runtime-semantics/3"}+naming-edition idiomatic-v2+module-role {"family":"BehaviorSourceMap","kind":"generated","ownerKind":"context","ownerName":"context billing behavior source map","path":"Generated/Billing/BehaviorSourceMap.hs"}+module-role {"family":"Nominals","kind":"generated","ownerKind":"context","ownerName":"context billing generated nominal declarations","path":"Generated/Billing/Nominals.hs"}+module-role {"family":"Internal","kind":"generated","ownerKind":"context","ownerName":"context billing generated nominal ID internals","path":"Generated/Billing/Nominals/Internal.hs"}+module-role {"family":"ReplayAudit","kind":"generated","ownerKind":"context","ownerName":"context billing replay-audit assembly","path":"Generated/Billing/ReplayAudit.hs"}+module-role {"family":"Domain","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Subscription (line 9)","path":"Generated/Billing/Subscription/Domain.hs"}+module-role {"family":"Codec","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Subscription (line 9)","path":"Generated/Billing/Subscription/Codec.hs"}+module-role {"family":"Transducer","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Subscription (line 9)","path":"Generated/Billing/Subscription/Transducer.hs"}+module-role {"family":"BehaviorContract","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Subscription (line 9)","path":"Generated/Billing/Subscription/BehaviorContract.hs"}+module-role {"family":"BehaviorHoles","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate behavior witnesses Subscription (line 9)","path":"Billing/Subscription/BehaviorHoles.hs"}+module-role {"family":"EventStream","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Subscription (line 9)","path":"Generated/Billing/Subscription/EventStream.hs"}+module-role {"family":"Projection","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Subscription (line 9)","path":"Generated/Billing/Subscription/Projection.hs"}+module-role {"family":"Holes","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate Subscription (line 9)","path":"Billing/Subscription/Holes.hs"}+module-role {"family":"Harness","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Subscription (line 9)","path":"Generated/Billing/Subscription/Harness.hs"}+generated Generated/Billing/BehaviorSourceMap.hs+generated Generated/Billing/Nominals.hs+generated Generated/Billing/Nominals/Internal.hs+generated Generated/Billing/ReplayAudit.hs+generated Generated/Billing/Subscription/Domain.hs+generated Generated/Billing/Subscription/Codec.hs+generated Generated/Billing/Subscription/Transducer.hs+generated Generated/Billing/Subscription/BehaviorContract.hs+hole Billing/Subscription/BehaviorHoles.hs+generated Generated/Billing/Subscription/EventStream.hs+generated Generated/Billing/Subscription/Projection.hs+hole Billing/Subscription/Holes.hs+generated Generated/Billing/Subscription/Harness.hs+id-domain id-domain|name=SubscriptionId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=sub|separator=_|json=canonical-json-text+id-domain id-domain|name=CustomerId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=cust|separator=_|json=canonical-json-text+nominal-equality nominal-equality|name=CustomerId|contract=keiro-dsl/nominal-equality/2|key=Text|domain=typeid-v7-text:cust:keiro-dsl/id-domain/typeid-v7/1|owner=generated+nominal-equality nominal-equality|name=Plan|contract=keiro-dsl/nominal-equality/1|key=Text|domain=finite-text:paid,free|owner=generated+nominal-equality nominal-equality|name=SubscriptionId|contract=keiro-dsl/nominal-equality/2|key=Text|domain=typeid-v7-text:sub:keiro-dsl/id-domain/typeid-v7/1|owner=generated+behavior {"aggregate":"Subscription","command":"ActivateSubscription","evidence":"generated-authoritative","key":"behavior-v1-09842123ac52dd63","kind":"required-rejection","outputs":[],"source":"Active"}+behavior {"aggregate":"Subscription","command":"ActivateSubscription","evidence":"generated-authoritative","key":"behavior-v1-9399755ba2b617d6","kind":"live-transition","outputs":[{"command":"ActivateSubscription","ownership":"generated-command-identity"}],"source":"Inactive"}+behavior {"aggregate":"Subscription","command":"CancelSubscription","evidence":"generated-authoritative","key":"behavior-v1-93f6f3f8cb36420d","kind":"required-rejection","outputs":[],"source":"Inactive"}+behavior {"aggregate":"Subscription","command":"CancelSubscription","evidence":"generated-authoritative","key":"behavior-v1-99ac0c974e512f76","kind":"required-rejection","outputs":[],"source":"Closed"}+behavior {"aggregate":"Subscription","command":"ActivateSubscription","evidence":"generated-authoritative","key":"behavior-v1-9b81e070774b3ae1","kind":"required-rejection","outputs":[],"source":"Closed"}+behavior {"aggregate":"Subscription","command":"CancelSubscription","evidence":"generated-authoritative","key":"behavior-v1-b5d1ca5d9ad9b2ec","kind":"live-transition","outputs":[{"obligation":"event-output-v1/Subscription/live/Active/CancelSubscription/unguarded//SubscriptionCancelled/Closed/1/SubscriptionCancelled","ownership":"hand-owned"}],"source":"Active"}+semantic-impact {"declarations":[],"mappedSurfaceEvidenceVersion":1,"serviceInventory":[]}

test/conformance-contract-v1-compat/Generated/HospitalCapacity/Emergency/Contract.hs view

@@ -1,6 +1,4 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 1) from contract emergency; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 1) from contract emergency; do not edit. module Generated.HospitalCapacity.Emergency.Contract   ( EmergencyPayload (..)   , IncidentTransferNeedDeclaredData (..)

+ test/conformance-contract-v1-compat/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

@@ -0,0 +1,19 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/contract-v1-compat.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    Generated.HospitalCapacity.Emergency.Contract++build-depends:+    , aeson+    , base+    , text

+ test/conformance-contract-v1-compat/keiro-dsl-ledger.context.hospital-capacity.txt view

@@ -0,0 +1,10 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/contract-v1-compat.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":1,"effectiveLanguageVersion":1,"sourceForm":"declared"}+semantic-contract {"languageSupport":"compatibility-only","languageVersion":1,"runtimeSemantics":"keiro-dsl/runtime-semantics/1"}+naming-edition idiomatic-v2+module-role {"family":"Contract","kind":"generated","ownerKind":"contract","ownerName":"contract emergency (line 4)","path":"Generated/HospitalCapacity/Emergency/Contract.hs"}+generated Generated/HospitalCapacity/Emergency/Contract.hs+semantic-impact {"declarations":[],"mappedSurfaceEvidenceVersion":1,"serviceInventory":[]}

test/conformance-contract/Generated/HospitalCapacity/Emergency/Contract.hs view

@@ -1,6 +1,4 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from contract emergency; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from contract emergency; do not edit. module Generated.HospitalCapacity.Emergency.Contract   ( EmergencyPayload (..)   , IncidentTransferNeedDeclaredData (..)

test/conformance-contract/Main.hs view

@@ -73,9 +73,9 @@           ( "contract selectors are distinct from wire keys",             case incidentPayload of               IncidentTransferNeedDeclared payload ->-                family payload == "adoption"-                  && payloadType payload == "payload-type"-                  && serviceRegion payload == "north"+                payload.family == "adoption"+                  && payload.payloadType == "payload-type"+                  && payload.serviceRegion == "north"               _ -> False           ),           ( "TransferReservationAccepted round-trip",

+ test/conformance-contract/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

@@ -0,0 +1,21 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/contract.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    Generated.HospitalCapacity.Emergency.Contract++build-depends:+    , aeson+    , base+    , keiro-core+    , mmzk-typeid+    , text

+ test/conformance-contract/keiro-dsl-ledger.context.hospital-capacity.txt view

@@ -0,0 +1,14 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/contract.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":4,"effectiveLanguageVersion":4,"sourceForm":"declared"}+semantic-contract {"languageSupport":"compatibility-only","languageVersion":4,"runtimeSemantics":"keiro-dsl/runtime-semantics/3"}+naming-edition idiomatic-v2+module-role {"family":"Contract","kind":"generated","ownerKind":"contract","ownerName":"contract emergency (line 4)","path":"Generated/HospitalCapacity/Emergency/Contract.hs"}+generated Generated/HospitalCapacity/Emergency/Contract.hs+id-domain id-domain|name=contract:emergency.IncidentTransferNeedDeclared.incidentId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=inc|separator=_|json=canonical-json-text+id-domain id-domain|name=contract:emergency.TransferReservationAccepted.incidentId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=inc|separator=_|json=canonical-json-text+id-domain id-domain|name=contract:emergency.TransferReservationAccepted.reservationId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=rsv|separator=_|json=canonical-json-text+id-domain id-domain|name=contract:emergency.TransferReservationAccepted.hospitalId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=hsp|separator=_|json=canonical-json-text+semantic-impact {"declarations":[],"mappedSurfaceEvidenceVersion":1,"serviceInventory":[]}

+ test/conformance-corpus-manifest.txt view

@@ -0,0 +1,127 @@+keiro-dsl conformance corpus manifest v1+# Rows supplement facts that scaffold records cannot retain. Paths are repository-relative.+# workspace <manifest-path> <out-dir>+# skeleton <kind> <module-root> <out-dir>+# frozen <out-dir>+# extra-args <out-dir> <keiro-dsl scaffold arguments...>+# uncompiled-generated <generated-module-path>+# legacy-generated <generated-module-path>++workspace keiro-dsl/test/fixtures/workspace-nominals/service.keiro-workspace keiro-dsl/test/conformance-workspace-nominals+workspace keiro-dsl/test/conformance-service-package/service.keiro-workspace keiro-dsl/test/conformance-service-package/runtime/src++# This published-language-4 fixture proves compatibility and must not be rewritten+# when `keiro-dsl new` advances to an unreleased candidate authoring language.+frozen keiro-dsl/test/conformance-skeletons++extra-args keiro-dsl/test/conformance-structural --codec-comparison ArtifactInfo --comparison-out keiro-dsl/test/conformance-structural/Generated/StructuralConformance/Structural/CodecCompare/ArtifactInfo.hs++# Reviewed legacy suites intentionally compile only the output surface under test.+uncompiled-generated keiro-dsl/test/conformance-aggregate-scalars/Generated/AggregateScalars/ScalarLedger/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-coldstart/Generated/Billing/Subscription/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-dispatch-full/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModel.hs+uncompiled-generated keiro-dsl/test/conformance-dispatch-full/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelHarness.hs+uncompiled-generated keiro-dsl/test/conformance-dispatch-full/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelTable.hs+uncompiled-generated keiro-dsl/test/conformance-dispatch-full/Generated/HospitalCapacity/TransferDecisions/ReadModel.hs+uncompiled-generated keiro-dsl/test/conformance-dispatch-full/Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs+uncompiled-generated keiro-dsl/test/conformance-dispatch-full/Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs+uncompiled-generated keiro-dsl/test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/EventStream.hs+uncompiled-generated keiro-dsl/test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Harness.hs+uncompiled-generated keiro-dsl/test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Projection.hs+uncompiled-generated keiro-dsl/test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Transducer.hs+uncompiled-generated keiro-dsl/test/conformance-id-domain-migration/Generated/IdDomainMigration/ReplayAudit.hs+uncompiled-generated keiro-dsl/test/conformance-intake-full/Generated/HospitalCapacity/Emergency/Contract.hs+uncompiled-generated keiro-dsl/test/conformance-intake-runtime/Generated/HospitalCapacity/Emergency/Contract.hs+uncompiled-generated keiro-dsl/test/conformance-newsurface/Generated/TransferRouting/Hospital/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-process-full/Generated/SurgeDemo/Hospital/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-process-full/Generated/SurgeDemo/Hospital/Harness.hs+uncompiled-generated keiro-dsl/test/conformance-process-full/Generated/SurgeDemo/Surge/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-process-full/Generated/SurgeDemo/Surge/Harness.hs+uncompiled-generated keiro-dsl/test/conformance-process-full/Generated/SurgeDemo/SurgeFlow/ProcessHarness.hs+uncompiled-generated keiro-dsl/test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/Codec.hs+uncompiled-generated keiro-dsl/test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/Domain.hs+uncompiled-generated keiro-dsl/test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/EventStream.hs+uncompiled-generated keiro-dsl/test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/Harness.hs+uncompiled-generated keiro-dsl/test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/Projection.hs+uncompiled-generated keiro-dsl/test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/Transducer.hs+uncompiled-generated keiro-dsl/test/conformance-process-runtime/Generated/HospitalCapacity/HospitalSurge/ProcessHarness.hs+uncompiled-generated keiro-dsl/test/conformance-process-runtime/Generated/HospitalCapacity/ReplayAudit.hs+uncompiled-generated keiro-dsl/test/conformance-process-runtime/Generated/HospitalCapacity/Surge/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Harness.hs+uncompiled-generated keiro-dsl/test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Projection.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Hospital/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Hospital/Codec.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Hospital/Domain.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Hospital/EventStream.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Hospital/Harness.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Hospital/Projection.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Hospital/Transducer.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/HospitalSurge/Process.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Nominals.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Nominals/Internal.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/ReplayAudit.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Surge/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Surge/Codec.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Surge/Domain.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Surge/EventStream.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Surge/Harness.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Surge/Projection.hs+uncompiled-generated keiro-dsl/test/conformance-process/Generated/HospitalCapacity/Surge/Transducer.hs+uncompiled-generated keiro-dsl/test/conformance-publisher-runtime/Generated/HospitalCapacity/Emergency/Contract.hs+uncompiled-generated keiro-dsl/test/conformance-queue-runtime/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModel.hs+uncompiled-generated keiro-dsl/test/conformance-queue-runtime/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelHarness.hs+uncompiled-generated keiro-dsl/test/conformance-queue-runtime/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelTable.hs+uncompiled-generated keiro-dsl/test/conformance-queue-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModel.hs+uncompiled-generated keiro-dsl/test/conformance-queue-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs+uncompiled-generated keiro-dsl/test/conformance-queue-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs+uncompiled-generated keiro-dsl/test/conformance-queue/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModel.hs+uncompiled-generated keiro-dsl/test/conformance-queue/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelHarness.hs+uncompiled-generated keiro-dsl/test/conformance-queue/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelTable.hs+uncompiled-generated keiro-dsl/test/conformance-queue/Generated/HospitalCapacity/ReservationWork/QueuePolicy.hs+uncompiled-generated keiro-dsl/test/conformance-queue/Generated/HospitalCapacity/TransferDecisions/ReadModel.hs+uncompiled-generated keiro-dsl/test/conformance-queue/Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs+uncompiled-generated keiro-dsl/test/conformance-queue/Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs+uncompiled-generated keiro-dsl/test/conformance-replay/Generated/ReplayDivergence/Note/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-router-full/Generated/IncidentPaging/Page/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-router-full/Generated/IncidentPaging/Page/Harness.hs+uncompiled-generated keiro-dsl/test/conformance-router-full/Generated/IncidentPaging/Page/Projection.hs+uncompiled-generated keiro-dsl/test/conformance-router-full/Generated/IncidentPaging/ServiceOncall/ReadModel.hs+uncompiled-generated keiro-dsl/test/conformance-router-full/Generated/IncidentPaging/ServiceOncall/ReadModelHarness.hs+uncompiled-generated keiro-dsl/test/conformance-router-full/Generated/IncidentPaging/ServiceOncall/ReadModelTable.hs+uncompiled-generated keiro-dsl/test/conformance-router-runtime/Generated/IncidentPaging/Page/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-router-runtime/Generated/IncidentPaging/Page/Codec.hs+uncompiled-generated keiro-dsl/test/conformance-router-runtime/Generated/IncidentPaging/Page/Domain.hs+uncompiled-generated keiro-dsl/test/conformance-router-runtime/Generated/IncidentPaging/Page/EventStream.hs+uncompiled-generated keiro-dsl/test/conformance-router-runtime/Generated/IncidentPaging/Page/Harness.hs+uncompiled-generated keiro-dsl/test/conformance-router-runtime/Generated/IncidentPaging/Page/Projection.hs+uncompiled-generated keiro-dsl/test/conformance-router-runtime/Generated/IncidentPaging/Page/Transducer.hs+uncompiled-generated keiro-dsl/test/conformance-router-runtime/Generated/IncidentPaging/ReplayAudit.hs+uncompiled-generated keiro-dsl/test/conformance-router-runtime/Generated/IncidentPaging/ServiceOncall/ReadModel.hs+uncompiled-generated keiro-dsl/test/conformance-router-runtime/Generated/IncidentPaging/ServiceOncall/ReadModelHarness.hs+uncompiled-generated keiro-dsl/test/conformance-router-runtime/Generated/IncidentPaging/ServiceOncall/ReadModelTable.hs+uncompiled-generated keiro-dsl/test/conformance-router/Generated/IncidentPaging/Page/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-router/Generated/IncidentPaging/Page/Codec.hs+uncompiled-generated keiro-dsl/test/conformance-router/Generated/IncidentPaging/Page/Domain.hs+uncompiled-generated keiro-dsl/test/conformance-router/Generated/IncidentPaging/Page/EventStream.hs+uncompiled-generated keiro-dsl/test/conformance-router/Generated/IncidentPaging/Page/Harness.hs+uncompiled-generated keiro-dsl/test/conformance-router/Generated/IncidentPaging/Page/Projection.hs+uncompiled-generated keiro-dsl/test/conformance-router/Generated/IncidentPaging/Page/Transducer.hs+uncompiled-generated keiro-dsl/test/conformance-router/Generated/IncidentPaging/PagingRouter/Router.hs+uncompiled-generated keiro-dsl/test/conformance-router/Generated/IncidentPaging/ReplayAudit.hs+uncompiled-generated keiro-dsl/test/conformance-router/Generated/IncidentPaging/ServiceOncall/ReadModel.hs+uncompiled-generated keiro-dsl/test/conformance-router/Generated/IncidentPaging/ServiceOncall/ReadModelHarness.hs+uncompiled-generated keiro-dsl/test/conformance-router/Generated/IncidentPaging/ServiceOncall/ReadModelTable.hs+uncompiled-generated keiro-dsl/test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-skeletons/SkelRouter/Generated/MyService/Page/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-snapshot/Generated/HospitalCapacity/Reservation/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Harness.hs+uncompiled-generated keiro-dsl/test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Projection.hs+uncompiled-generated keiro-dsl/test/conformance-v2/Generated/HospitalCapacity/Reservation/BehaviorContract.hs+uncompiled-generated keiro-dsl/test/conformance-workflow-full/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowFacts.hs+uncompiled-generated keiro-dsl/test/conformance-workflow-runtime/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowFacts.hs+uncompiled-generated keiro-dsl/test/conformance-workflow/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs+uncompiled-generated keiro-dsl/test/conformance/Generated/HospitalCapacity/Reservation/BehaviorContract.hs+legacy-generated keiro-dsl/test/conformance-newsurface/Generated/TransferRouting/Conformance.hs

test/conformance-declarative-router/Generated/TransferRouting/BehaviorSourceMap.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from context transfer-routing behavior source map; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from context transfer-routing behavior source map; do not edit. module Generated.TransferRouting.BehaviorSourceMap   ( BehaviorSourceLocation (..)   , behaviorSourceLocation@@ -9,9 +9,9 @@ import Data.Text qualified as T  data BehaviorSourceLocation = BehaviorSourceLocation-  { sourceFile :: !FilePath-  , sourceLine :: !Int-  , sourceColumn :: !Int+  { file :: !FilePath+  , line :: !Int+  , column :: !Int   }   deriving stock (Eq, Ord, Show) @@ -23,7 +23,7 @@  renderBehaviorSourceLocation :: Text -> Text renderBehaviorSourceLocation key = case behaviorSourceLocation key of-  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Just location -> T.pack location.file <> ":" <> tshow location.line <> ":" <> tshow location.column   Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"  tshow :: Show value => value -> Text

test/conformance-declarative-router/Generated/TransferRouting/Hospital/BehaviorContract.hs view

@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit. module Generated.TransferRouting.Hospital.BehaviorContract   ( BehaviorKey (..)+  , unBehaviorKey   , ObligationKind (..)   , EvidenceLevel (..)   , GuardCoverage (..)@@ -35,6 +36,9 @@ newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }   deriving stock (Eq, Ord, Show) +unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value+ data ObligationKind = LiveTransition | RequiredRejection | ReplayTransition   deriving stock (Eq, Ord, Show) @@ -45,15 +49,15 @@   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]+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !HospitalVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef HospitalVertex))+  , target :: !(Maybe HospitalVertex)+  , eventKinds :: ![Text]   }   deriving stock (Eq, Show) @@ -69,104 +73,104 @@ data BehaviorWitness   = Pending BehaviorKey   | LiveWitness-      { witnessKey :: BehaviorKey-      , witnessHistory :: [HospitalEvent]-      , witnessCommand :: HospitalCommand-      , witnessExpected :: LiveExpectation+      { key :: BehaviorKey+      , history :: [HospitalEvent]+      , command :: HospitalCommand+      , expected :: LiveExpectation       }   | ReplayWitness-      { witnessKey :: BehaviorKey-      , witnessHistoryPrefix :: [HospitalEvent]-      , witnessObservedChunk :: [HospitalEvent]+      { key :: BehaviorKey+      , historyPrefix :: [HospitalEvent]+      , observedChunk :: [HospitalEvent]       }   deriving stock (Eq, Show)  data BehaviorFailure = BehaviorFailure-  { failureKey :: !BehaviorKey-  , failureSubject :: !Text-  , failureCode :: !Text-  , failureDetail :: !Text+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !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+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail     ]  data BehaviorConformanceReport = BehaviorConformanceReport-  { reportRequired :: ![BehaviorKey]-  , reportFilled :: ![BehaviorKey]-  , reportPending :: ![BehaviorKey]-  , reportMissing :: ![BehaviorKey]-  , reportDuplicate :: ![BehaviorKey]-  , reportStale :: ![BehaviorKey]-  , reportFailed :: ![BehaviorFailure]-  , reportVerified :: ![BehaviorKey]-  , reportUnverified :: ![BehaviorKey]+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![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)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified     ]  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 = []+      { key = BehaviorKey "behavior-v1-51a443ca8bbb0eab"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = HospitalRouted+      , commandName = "RouteAcceptedTransferNeed"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []       }   , -- 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"]+      { key = BehaviorKey "behavior-v1-6dc56a81dec7fe2b"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = HospitalOpen+      , commandName = "RouteAcceptedTransferNeed"+      , expectedEdge = (Just (K.EdgeRef HospitalOpen 0))+      , target = Just HospitalRouted+      , eventKinds = ["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)]+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]     }  where-  requiredByKey = Map.fromList [(requirementKey requirement, requirement) | requirement <- behaviorRequirements]+  requiredByKey = Map.fromList [(requirement.key, requirement) | requirement <- behaviorRequirements]   witnessGroups = Map.fromListWith (flip (<>)) [(behaviorWitnessKey witness, [witness]) | witness <- witnesses]   executions =     [ (requirement, runWitness requirement witness)@@ -181,27 +185,27 @@  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))+  null report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)  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]+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]  runWitness :: BehaviorRequirement -> BehaviorWitness -> Either BehaviorFailure () runWitness requirement witness = case witness of@@ -212,9 +216,9 @@ 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+  ensure requirement (K.replaySuccessState settled == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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@@ -246,7 +250,7 @@       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))+      ensure requirement (map eventKind actual == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)       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)@@ -258,30 +262,30 @@ 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))+  ensure requirement (Just (K.stepSuccessEdge success) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)  runReplay :: BehaviorRequirement -> [HospitalEvent] -> [HospitalEvent] -> Either BehaviorFailure ()-runReplay requirement prefix chunk = case requirementKind requirement of+runReplay requirement prefix chunk = case requirement.kind 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 (K.replaySuccessState settled == requirement.source) "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))+    ensure requirement (Just (K.replaySuccessState replayed) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)     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 (Just (K.replayAttributionEdge attribution) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)     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.replayAttributionSource attribution == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)     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" @@ -307,14 +311,14 @@  proofStrength :: BehaviorRequirement -> Bool proofStrength requirement =-  requirementEvidence requirement == GeneratedAuthoritative-    && requirementGuardCoverage requirement `elem` [GuardTotal, GuardNotApplicable]+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]  behaviorWitnessKey :: BehaviorWitness -> BehaviorKey behaviorWitnessKey witness = case witness of   Pending key -> key-  LiveWitness { witnessKey = key } -> key-  ReplayWitness { witnessKey = key } -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = key } -> key  isPending :: BehaviorWitness -> Bool isPending Pending {} = True@@ -326,13 +330,13 @@ failure requirement code detail =   Left     ( BehaviorFailure-        (requirementKey requirement)-        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey requirement)) <> ")")+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")         code         detail     )  where-  kindPhrase = case requirementKind requirement of+  kindPhrase = case requirement.kind of     LiveTransition -> "live transition"     RequiredRejection -> "required rejection"     ReplayTransition -> "replay-only transition"

test/conformance-declarative-router/Generated/TransferRouting/Hospital/Codec.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit. module Generated.TransferRouting.Hospital.Codec (     hospitalCodec,     parseHospitalEvent,

test/conformance-declarative-router/Generated/TransferRouting/Hospital/Domain.hs view

@@ -1,6 +1,5 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit. module Generated.TransferRouting.Hospital.Domain where  import Data.Proxy (Proxy (..))

test/conformance-declarative-router/Generated/TransferRouting/Hospital/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit. module Generated.TransferRouting.Hospital.EventStream   ( hospitalCategory   , hospitalCommandCategory

test/conformance-declarative-router/Generated/TransferRouting/Hospital/Harness.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit. module Generated.TransferRouting.Hospital.Harness (harnessAssertions) where  import Generated.TransferRouting.Hospital.Domain

test/conformance-declarative-router/Generated/TransferRouting/Hospital/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.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

@@ -1,7 +1,6 @@ {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Hospital; do not edit. module Generated.TransferRouting.Hospital.Transducer   ( hospitalTransducer   , hospitalFoldFingerprint

test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/QueryContract.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel hospital_load; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from readmodel hospital_load; do not edit. module Generated.TransferRouting.HospitalLoad.QueryContract   ( HospitalLoadQueryInput   , HospitalLoadQueryResult

test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/ReadModel.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel hospital_load; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from readmodel hospital_load; do not edit. module Generated.TransferRouting.HospitalLoad.ReadModel   ( hospitalLoadReadModel   , hospitalLoadQualifiedTable

test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/ReadModelHarness.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel hospital_load; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-declarative-router/Generated/TransferRouting/HospitalLoad/ReadModelTable.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel hospital_load; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from readmodel hospital_load; do not edit. module Generated.TransferRouting.HospitalLoad.ReadModelTable (hospitalLoadQualifiedTable) where  import Data.Text (Text)

test/conformance-declarative-router/Generated/TransferRouting/HospitalTransferRouter/Router.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from router HospitalTransferRouter; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from router HospitalTransferRouter; do not edit. module Generated.TransferRouting.HospitalTransferRouter.Router   ( hospitalTransferRouterName   , hospitalTransferRouterWorkerOptions

test/conformance-declarative-router/Generated/TransferRouting/HospitalTransferRouter/RouterHarness.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from router HospitalTransferRouter; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from router HospitalTransferRouter; do not edit. module Generated.TransferRouting.HospitalTransferRouter.RouterHarness (routerHarnessValues) where  routerHarnessValues :: [(String, String)]

test/conformance-declarative-router/Generated/TransferRouting/ProjectionCatalog.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from projection-catalog transfer-routing; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from projection-catalog transfer-routing; do not edit. {-# LANGUAGE OverloadedStrings #-} module Generated.TransferRouting.ProjectionCatalog   ( projectionCatalog

test/conformance-declarative-router/Generated/TransferRouting/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from context transfer-routing replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.15.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;

test/conformance-declarative-router/Generated/TransferRouting/Structural/Shape/HospitalLoadRow.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from mapped structural HospitalLoadRow; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-declarative-router/Generated/TransferRouting/Structural/Shape/TransferRouteInput.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from mapped structural TransferRouteInput; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-declarative-router/Generated/TransferRouting/StructuralConformance.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from context transfer-routing structural conformance; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from context transfer-routing structural conformance; do not edit. module Generated.TransferRouting.StructuralConformance   ( structuralConformanceAssertions   ) where@@ -11,10 +11,10 @@ import Keiki.Shape (CanonicalTypeName (..)) import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape) import Generated.TransferRouting.StructuralProjections qualified as StructuralProjections+import Generated.TransferRouting.Structural.Shape.HospitalLoadRow (HospitalLoadRowShape(availableBeds, hospitalId, region))+import Generated.TransferRouting.Structural.Shape.TransferRouteInput (TransferRouteInputShape(region, transferNeedId)) 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 =@@ -66,9 +66,9 @@  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)))+  [ ("projection witness agreement: conformance.declarative-router.HospitalLoadRow.v1/available_beds", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.hospitalLoadRowAvailableBedsWitness (\referenceOwner -> (bindingToShape Bindings.hospitalLoadRowBinding referenceOwner).availableBeds) owner) (NonEmpty.toList (fixtureCases Bindings.hospitalLoadRowCases)))+  , ("projection witness agreement: conformance.declarative-router.HospitalLoadRow.v1/hospital_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.hospitalLoadRowHospitalIdWitness (\referenceOwner -> (bindingToShape Bindings.hospitalLoadRowBinding referenceOwner).hospitalId) owner) (NonEmpty.toList (fixtureCases Bindings.hospitalLoadRowCases)))+  , ("projection witness agreement: conformance.declarative-router.HospitalLoadRow.v1/region", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.hospitalLoadRowRegionWitness (\referenceOwner -> (bindingToShape Bindings.hospitalLoadRowBinding referenceOwner).region) owner) (NonEmpty.toList (fixtureCases Bindings.hospitalLoadRowCases)))+  , ("projection witness agreement: conformance.declarative-router.TransferRouteInput.v1/region", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.transferRouteInputRegionWitness (\referenceOwner -> (bindingToShape Bindings.transferRouteInputBinding referenceOwner).region) owner) (NonEmpty.toList (fixtureCases Bindings.transferRouteInputCases)))+  , ("projection witness agreement: conformance.declarative-router.TransferRouteInput.v1/transfer_need_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.transferRouteInputTransferNeedIdWitness (\referenceOwner -> (bindingToShape Bindings.transferRouteInputBinding referenceOwner).transferNeedId) owner) (NonEmpty.toList (fixtureCases Bindings.transferRouteInputCases)))   ]

test/conformance-declarative-router/Generated/TransferRouting/StructuralProjections.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from context transfer-routing mapped structural facade; do not edit.+-- @generated by keiro-dsl 0.15.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@@ -13,10 +13,10 @@ import Data.Text (Text) import Keiro.Codec.Structural (bindingToShape) import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)+import Generated.TransferRouting.Structural.Shape.HospitalLoadRow (HospitalLoadRowShape(availableBeds, hospitalId, region))+import Generated.TransferRouting.Structural.Shape.TransferRouteInput (TransferRouteInputShape(region, transferNeedId)) 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 @@ -25,7 +25,7 @@   type FieldOwner HospitalLoadRowAvailableBedsProjection = HospitalLoadRow   type FieldResult HospitalLoadRowAvailableBedsProjection = Int   fieldShapeId _ = "conformance.declarative-router.HospitalLoadRow.v1"-  projectFieldValue _ owner = ShapeHospitalLoadRow.availableBeds (bindingToShape Bindings.hospitalLoadRowBinding owner)+  projectFieldValue _ owner = (bindingToShape Bindings.hospitalLoadRowBinding owner).availableBeds  hospitalLoadRowAvailableBedsWitness :: FieldWitness HospitalLoadRowAvailableBedsProjection hospitalLoadRowAvailableBedsWitness = fieldWitness @HospitalLoadRowAvailableBedsProjection@@ -37,7 +37,7 @@   type FieldOwner HospitalLoadRowHospitalIdProjection = HospitalLoadRow   type FieldResult HospitalLoadRowHospitalIdProjection = Text   fieldShapeId _ = "conformance.declarative-router.HospitalLoadRow.v1"-  projectFieldValue _ owner = ShapeHospitalLoadRow.hospitalId (bindingToShape Bindings.hospitalLoadRowBinding owner)+  projectFieldValue _ owner = (bindingToShape Bindings.hospitalLoadRowBinding owner).hospitalId  hospitalLoadRowHospitalIdWitness :: FieldWitness HospitalLoadRowHospitalIdProjection hospitalLoadRowHospitalIdWitness = fieldWitness @HospitalLoadRowHospitalIdProjection@@ -49,7 +49,7 @@   type FieldOwner HospitalLoadRowRegionProjection = HospitalLoadRow   type FieldResult HospitalLoadRowRegionProjection = Text   fieldShapeId _ = "conformance.declarative-router.HospitalLoadRow.v1"-  projectFieldValue _ owner = ShapeHospitalLoadRow.region (bindingToShape Bindings.hospitalLoadRowBinding owner)+  projectFieldValue _ owner = (bindingToShape Bindings.hospitalLoadRowBinding owner).region  hospitalLoadRowRegionWitness :: FieldWitness HospitalLoadRowRegionProjection hospitalLoadRowRegionWitness = fieldWitness @HospitalLoadRowRegionProjection@@ -61,7 +61,7 @@   type FieldOwner TransferRouteInputRegionProjection = TransferRouteInput   type FieldResult TransferRouteInputRegionProjection = Text   fieldShapeId _ = "conformance.declarative-router.TransferRouteInput.v1"-  projectFieldValue _ owner = ShapeTransferRouteInput.region (bindingToShape Bindings.transferRouteInputBinding owner)+  projectFieldValue _ owner = (bindingToShape Bindings.transferRouteInputBinding owner).region  transferRouteInputRegionWitness :: FieldWitness TransferRouteInputRegionProjection transferRouteInputRegionWitness = fieldWitness @TransferRouteInputRegionProjection@@ -73,7 +73,7 @@   type FieldOwner TransferRouteInputTransferNeedIdProjection = TransferRouteInput   type FieldResult TransferRouteInputTransferNeedIdProjection = Text   fieldShapeId _ = "conformance.declarative-router.TransferRouteInput.v1"-  projectFieldValue _ owner = ShapeTransferRouteInput.transferNeedId (bindingToShape Bindings.transferRouteInputBinding owner)+  projectFieldValue _ owner = (bindingToShape Bindings.transferRouteInputBinding owner).transferNeedId  transferRouteInputTransferNeedIdWitness :: FieldWitness TransferRouteInputTransferNeedIdProjection transferRouteInputTransferNeedIdWitness = fieldWitness @TransferRouteInputTransferNeedIdProjection

+ test/conformance-declarative-router/README.md view

@@ -0,0 +1,23 @@+# Declarative Router Conformance++This candidate Language 5 conformance service is scaffolded from+[`../fixtures/declarative-router/valid.keiro`](../fixtures/declarative-router/valid.keiro).+Its generated module inventory and selection snapshot are tracked by the Cabal+fragment and ledger in this directory.++The executable owns a real PostgreSQL proof of the generated boundary. The+application query deliberately returns `B,A,A`; generated normalization+dispatches `A,B`. After the rows drift to `B,C`, redelivery confirms `B` as a+duplicate and appends only `C`. A second selection maps unequal commands to one+physical stream and proves that conflict detection writes nothing.++Run it from the repository root with:++```bash+cabal test keiro-dsl-conformance-declarative-router+```++Do not edit scaffold-owned generated modules to change behavior. Update the+fixture and regenerate through the normal scaffold/conformance workflow;+create-once read-model binding and query implementations remain+application-owned.

+ test/conformance-declarative-router/keiro-dsl-cabal-fragment.context.transfer-routing.txt view

@@ -0,0 +1,56 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/declarative-router/valid.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    Conformance.DeclarativeRouter.Bindings+    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+    , base+    , effectful-core+    , hasql-transaction+    , keiki+    , keiro+    , keiro-dsl+    , kiroku-store+    , shibuya-core+    , text++consumer-packages:+    keiro-dsl++consumer-modules:+    Conformance.DeclarativeRouter.Bindings+    Conformance.DeclarativeRouter.Domain

+ test/conformance-declarative-router/keiro-dsl-ledger.context.transfer-routing.txt view

@@ -0,0 +1,79 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/declarative-router/valid.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":5,"effectiveLanguageVersion":5,"sourceForm":"declared"}+semantic-contract {"languageSupport":"stable","languageVersion":5,"runtimeSemantics":"keiro-dsl/runtime-semantics/4"}+naming-edition idiomatic-v2+module-role {"family":"StructuralConformance","kind":"generated","ownerKind":"context","ownerName":"context transfer-routing structural conformance","path":"Generated/TransferRouting/StructuralConformance.hs"}+module-role {"family":"BehaviorSourceMap","kind":"generated","ownerKind":"context","ownerName":"context transfer-routing behavior source map","path":"Generated/TransferRouting/BehaviorSourceMap.hs"}+module-role {"family":"HospitalLoadRow","kind":"generated","ownerKind":"mapped","ownerName":"mapped structural HospitalLoadRow (line 16)","path":"Generated/TransferRouting/Structural/Shape/HospitalLoadRow.hs"}+module-role {"family":"TransferRouteInput","kind":"generated","ownerKind":"mapped","ownerName":"mapped structural TransferRouteInput (line 4)","path":"Generated/TransferRouting/Structural/Shape/TransferRouteInput.hs"}+module-role {"family":"StructuralProjections","kind":"generated","ownerKind":"context","ownerName":"context transfer-routing mapped structural facade","path":"Generated/TransferRouting/StructuralProjections.hs"}+module-role {"family":"Bindings","kind":"hole","ownerKind":"consumer","ownerName":"consumer binding skeleton Conformance.DeclarativeRouter.Bindings","path":"Conformance/DeclarativeRouter/Bindings.hs"}+module-role {"family":"ReplayAudit","kind":"generated","ownerKind":"context","ownerName":"context transfer-routing replay-audit assembly","path":"Generated/TransferRouting/ReplayAudit.hs"}+module-role {"family":"ProjectionCatalog","kind":"generated","ownerKind":"projection-catalog","ownerName":"projection-catalog transfer-routing","path":"Generated/TransferRouting/ProjectionCatalog.hs"}+module-role {"family":"ProjectionCatalogHoles","kind":"hole","ownerKind":"projection-catalog","ownerName":"projection-catalog transfer-routing","path":"TransferRouting/ProjectionCatalog/ProjectionCatalogHoles.hs"}+module-role {"family":"ReadModelTable","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel hospital_load (line 52)","path":"Generated/TransferRouting/HospitalLoad/ReadModelTable.hs"}+module-role {"family":"QueryContract","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel hospital_load (line 52)","path":"Generated/TransferRouting/HospitalLoad/QueryContract.hs"}+module-role {"family":"ReadModel","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel hospital_load (line 52)","path":"Generated/TransferRouting/HospitalLoad/ReadModel.hs"}+module-role {"family":"ReadModelHoles","kind":"hole","ownerKind":"readmodel","ownerName":"readmodel hospital_load (line 52)","path":"TransferRouting/HospitalLoad/ReadModelHoles.hs"}+module-role {"family":"ReadModelHarness","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel hospital_load (line 52)","path":"Generated/TransferRouting/HospitalLoad/ReadModelHarness.hs"}+module-role {"family":"Domain","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 63)","path":"Generated/TransferRouting/Hospital/Domain.hs"}+module-role {"family":"Codec","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 63)","path":"Generated/TransferRouting/Hospital/Codec.hs"}+module-role {"family":"Transducer","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 63)","path":"Generated/TransferRouting/Hospital/Transducer.hs"}+module-role {"family":"BehaviorContract","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 63)","path":"Generated/TransferRouting/Hospital/BehaviorContract.hs"}+module-role {"family":"BehaviorHoles","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate behavior witnesses Hospital (line 63)","path":"TransferRouting/Hospital/BehaviorHoles.hs"}+module-role {"family":"EventStream","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 63)","path":"Generated/TransferRouting/Hospital/EventStream.hs"}+module-role {"family":"Projection","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 63)","path":"Generated/TransferRouting/Hospital/Projection.hs"}+module-role {"family":"Harness","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 63)","path":"Generated/TransferRouting/Hospital/Harness.hs"}+module-role {"family":"Router","kind":"generated","ownerKind":"router","ownerName":"router HospitalTransferRouter (line 75)","path":"Generated/TransferRouting/HospitalTransferRouter/Router.hs"}+module-role {"family":"RouterHarness","kind":"generated","ownerKind":"router","ownerName":"router HospitalTransferRouter (line 75)","path":"Generated/TransferRouting/HospitalTransferRouter/RouterHarness.hs"}+generated Generated/TransferRouting/StructuralConformance.hs+generated Generated/TransferRouting/BehaviorSourceMap.hs+generated Generated/TransferRouting/Structural/Shape/HospitalLoadRow.hs+generated Generated/TransferRouting/Structural/Shape/TransferRouteInput.hs+generated Generated/TransferRouting/StructuralProjections.hs+hole Conformance/DeclarativeRouter/Bindings.hs+generated Generated/TransferRouting/ReplayAudit.hs+generated Generated/TransferRouting/ProjectionCatalog.hs+hole TransferRouting/ProjectionCatalog/ProjectionCatalogHoles.hs+generated Generated/TransferRouting/HospitalLoad/ReadModelTable.hs+generated Generated/TransferRouting/HospitalLoad/QueryContract.hs+generated Generated/TransferRouting/HospitalLoad/ReadModel.hs+hole TransferRouting/HospitalLoad/ReadModelHoles.hs+generated Generated/TransferRouting/HospitalLoad/ReadModelHarness.hs+generated Generated/TransferRouting/Hospital/Domain.hs+generated Generated/TransferRouting/Hospital/Codec.hs+generated Generated/TransferRouting/Hospital/Transducer.hs+generated Generated/TransferRouting/Hospital/BehaviorContract.hs+hole TransferRouting/Hospital/BehaviorHoles.hs+generated Generated/TransferRouting/Hospital/EventStream.hs+generated Generated/TransferRouting/Hospital/Projection.hs+generated Generated/TransferRouting/Hospital/Harness.hs+generated Generated/TransferRouting/HospitalTransferRouter/Router.hs+generated Generated/TransferRouting/HospitalTransferRouter/RouterHarness.hs+mapping {"bindingSymbol":"Conformance.DeclarativeRouter.Bindings.hospitalLoadRowBinding","bindingVersion":"1","canonicalType":"conformance.declarative-router.HospitalLoadRow.v1","mode":"structural","module":"Conformance.DeclarativeRouter.Domain","package":"keiro-dsl","schema":1,"specName":"HospitalLoadRow","type":"HospitalLoadRow"}+mapping {"bindingSymbol":"Conformance.DeclarativeRouter.Bindings.transferRouteInputBinding","bindingVersion":"1","canonicalType":"conformance.declarative-router.TransferRouteInput.v1","mode":"structural","module":"Conformance.DeclarativeRouter.Domain","package":"keiro-dsl","schema":1,"specName":"TransferRouteInput","type":"TransferRouteInput"}+binding {"kind":"binding","mappedName":"HospitalLoadRow","module":"Conformance.DeclarativeRouter.Bindings","path":"availableBeds","schema":1,"signature":"hospitalLoadRowBinding.availableBeds :: Int","symbol":"hospitalLoadRowBinding"}+binding {"kind":"binding","mappedName":"HospitalLoadRow","module":"Conformance.DeclarativeRouter.Bindings","path":"hospitalId","schema":1,"signature":"hospitalLoadRowBinding.hospitalId :: Text","symbol":"hospitalLoadRowBinding"}+binding {"kind":"binding","mappedName":"HospitalLoadRow","module":"Conformance.DeclarativeRouter.Bindings","path":"region","schema":1,"signature":"hospitalLoadRowBinding.region :: Text","symbol":"hospitalLoadRowBinding"}+binding {"kind":"fixtures","mappedName":"HospitalLoadRow","module":"Conformance.DeclarativeRouter.Bindings","path":null,"schema":1,"signature":"hospitalLoadRowCases :: FixtureCases Conformance.DeclarativeRouter.Domain.HospitalLoadRow","symbol":"hospitalLoadRowCases"}+binding {"kind":"binding","mappedName":"TransferRouteInput","module":"Conformance.DeclarativeRouter.Bindings","path":"region","schema":1,"signature":"transferRouteInputBinding.region :: Text","symbol":"transferRouteInputBinding"}+binding {"kind":"binding","mappedName":"TransferRouteInput","module":"Conformance.DeclarativeRouter.Bindings","path":"transferNeedId","schema":1,"signature":"transferRouteInputBinding.transferNeedId :: Text","symbol":"transferRouteInputBinding"}+binding {"kind":"fixtures","mappedName":"TransferRouteInput","module":"Conformance.DeclarativeRouter.Bindings","path":null,"schema":1,"signature":"transferRouteInputCases :: FixtureCases Conformance.DeclarativeRouter.Domain.TransferRouteInput","symbol":"transferRouteInputCases"}+behavior {"aggregate":"Hospital","command":"RouteAcceptedTransferNeed","evidence":"generated-authoritative","key":"behavior-v1-51a443ca8bbb0eab","kind":"required-rejection","outputs":[],"source":"Routed"}+behavior {"aggregate":"Hospital","command":"RouteAcceptedTransferNeed","evidence":"generated-authoritative","key":"behavior-v1-6dc56a81dec7fe2b","kind":"live-transition","outputs":[{"command":"RouteAcceptedTransferNeed","ownership":"generated-command-identity"}],"source":"Open"}+projection-catalog-fact cursor|hospital_load|declarative-router-hospital-load|52+projection-catalog-fact delivery|hospital_load_writer|subscription|40+projection-catalog-fact freshness|hospital_load|wait-for-head:category:hospitalLoad|52+projection-catalog-fact group|reporting|hospital_load_table|hospital_load_table|35+projection-catalog-fact owner|hospital_load_writer|category:hospitalLoad|reporting|hospital_load_table|10|declarative-router-hospital-load|declarative-router-hospital-load-v1|fail|explicit|40+projection-catalog-fact query|hospital_load|reporting|hospital_load_table|hospital_load_table|52+projection-catalog-fact supply|hospital_load|hospital_load_writer|reporting|hospital_load_table|52|40+projection-catalog-fact target|hospital_load_table|public|hospital_load|clear||29+query-contract-baseline v1+query-contract {"mappedDependencies":["TransferRouteInput"],"position":"input","readModel":"hospital_load","typeExpression":"TransferRouteInput"}+query-contract {"mappedDependencies":["HospitalLoadRow"],"position":"result","readModel":"hospital_load","typeExpression":"List HospitalLoadRow"}+router-selection {"fingerprint":"64cef46d4f1d19cda4ed0cf91b1e0d783f72580ef0cbabdd2b52c83a6fadc3a9","identity":"hospital-transfer-selection","router":"HospitalTransferRouter","verification":"declarative-verified","version":1}+semantic-impact {"declarations":[{"consequences":[{"consumer":"read-model-query:hospital_load:result","kind":"consumer-build"},{"consumer":"router-selection:HospitalTransferRouter:predicate","kind":"consumer-build"},{"consumer":"router-selection:HospitalTransferRouter:recipient","kind":"consumer-build"},{"consumer":"router-selection:HospitalTransferRouter:command-field:hospitalId","kind":"consumer-build"},{"kind":"query-api","position":"result","readModel":"hospital_load"},{"kind":"router-selection-build","router":"HospitalTransferRouter"},{"kind":"router-selection-coordination-review","router":"HospitalTransferRouter"}],"consumerEvidence":[{"consumer":"read-model-query:hospital_load:result","operation":null,"path":"readmodel hospital_load query result : HospitalLoadRow []","surface":"read-model-query-result"},{"consumer":"router-selection:HospitalTransferRouter:predicate","operation":null,"path":"router HospitalTransferRouter selection predicate row.availableBeds as 'available_beds'","surface":"router-selection-predicate"},{"consumer":"router-selection:HospitalTransferRouter:predicate","operation":null,"path":"router HospitalTransferRouter selection predicate row.region","surface":"router-selection-predicate"},{"consumer":"router-selection:HospitalTransferRouter:recipient","operation":null,"path":"router HospitalTransferRouter selection recipient row.hospitalId as 'hospital_id'","surface":"router-selection-recipient"},{"consumer":"router-selection:HospitalTransferRouter:command-field:hospitalId","operation":null,"path":"router HospitalTransferRouter selection command field hospitalId row.hospitalId as 'hospital_id'","surface":"router-selection-command-field"}],"consumers":["read-model-query:hospital_load:result","router-selection:HospitalTransferRouter:predicate","router-selection:HospitalTransferRouter:recipient","router-selection:HospitalTransferRouter:command-field:hospitalId"],"declaration":"HospitalLoadRow","identity":"structural\u001fkeiro-dsl:Conformance.DeclarativeRouter.Domain:HospitalLoadRow\u001fConformance.DeclarativeRouter.Bindings.hospitalLoadRowBinding\u001f1\u001fconformance.declarative-router.HospitalLoadRow.v1\u001fConformance.DeclarativeRouter.Bindings.hospitalLoadRowCases\u001f\u001fd594e982a2e8d881\u001frecord:HospitalLoadRow:availableBeds=available_beds,hospitalId=hospital_id,region=region"},{"consequences":[{"consumer":"read-model-query:hospital_load:input","kind":"consumer-build"},{"consumer":"router-selection:HospitalTransferRouter:query-input","kind":"consumer-build"},{"consumer":"router-selection:HospitalTransferRouter:predicate","kind":"consumer-build"},{"consumer":"router-selection:HospitalTransferRouter:command-field:transferNeedId","kind":"consumer-build"},{"kind":"query-api","position":"input","readModel":"hospital_load"},{"kind":"router-selection-build","router":"HospitalTransferRouter"},{"kind":"router-selection-coordination-review","router":"HospitalTransferRouter"}],"consumerEvidence":[{"consumer":"read-model-query:hospital_load:input","operation":null,"path":"readmodel hospital_load query input : TransferRouteInput","surface":"read-model-query-input"},{"consumer":"router-selection:HospitalTransferRouter:query-input","operation":null,"path":"router HospitalTransferRouter selection query input","surface":"router-selection-query-input"},{"consumer":"router-selection:HospitalTransferRouter:predicate","operation":null,"path":"router HospitalTransferRouter selection predicate input.region","surface":"router-selection-predicate"},{"consumer":"router-selection:HospitalTransferRouter:command-field:transferNeedId","operation":null,"path":"router HospitalTransferRouter selection command field transferNeedId input.transferNeedId as 'transfer_need_id'","surface":"router-selection-command-field"}],"consumers":["read-model-query:hospital_load:input","router-selection:HospitalTransferRouter:query-input","router-selection:HospitalTransferRouter:predicate","router-selection:HospitalTransferRouter:command-field:transferNeedId"],"declaration":"TransferRouteInput","identity":"structural\u001fkeiro-dsl:Conformance.DeclarativeRouter.Domain:TransferRouteInput\u001fConformance.DeclarativeRouter.Bindings.transferRouteInputBinding\u001f1\u001fconformance.declarative-router.TransferRouteInput.v1\u001fConformance.DeclarativeRouter.Bindings.transferRouteInputCases\u001f\u001f5c14d7208f920522\u001frecord:TransferRouteInput:region=region,transferNeedId=transfer_need_id"}],"mappedSurfaceEvidenceVersion":1,"serviceInventory":["HospitalLoadRow","TransferRouteInput"]}

+ test/conformance-dispatch-full/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModel.hs view

@@ -0,0 +1,60 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from readmodel accepted_transfer_needs; do not edit.+module Generated.HospitalCapacity.AcceptedTransferNeeds.ReadModel+  ( acceptedTransferNeedsReadModel+  , acceptedTransferNeedsQualifiedTable+  , registerAcceptedTransferNeeds+  , startAcceptedTransferNeedsRebuild+  , finishAcceptedTransferNeedsRebuild+  , abandonAcceptedTransferNeedsRebuild+  , acceptedTransferNeedsAsyncProjection+  ) where++import Data.Functor (void)+import Effectful (Eff, (:>))+import Generated.HospitalCapacity.AcceptedTransferNeeds.ReadModelTable (acceptedTransferNeedsQualifiedTable)+import HospitalCapacity.AcceptedTransferNeeds.ReadModelHoles (AcceptedTransferNeedsQueryInput, AcceptedTransferNeedsQueryResult, acceptedTransferNeedsQuery, applyAcceptedTransferNeeds)+import Keiro.Projection (AsyncProjection (..))+import Keiro.ReadModel (ConsistencyMode (..), ReadModel (..), ReadModelMetadata, StrongScope (..), registerReadModel)+import Keiro.ReadModel.Rebuild qualified as Rebuild+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Types (GlobalPosition, RecordedEvent (..))++acceptedTransferNeedsReadModel :: ReadModel AcceptedTransferNeedsQueryInput AcceptedTransferNeedsQueryResult+acceptedTransferNeedsReadModel =+  ReadModel+    { name = "hospital-capacity-accepted-transfer-needs"+    , tableName = "accepted_transfer_needs"+    , schema = "hospital_capacity"+    , subscriptionName = "hospital-capacity-accepted-transfer-needs-sub"+    , version = 1+    , shapeHash = "fnv1a:fec517dae7760b8a"+    , defaultConsistency = Eventual+    , strongScope = EntireLog+    , query = acceptedTransferNeedsQuery+    }++-- Call once at projection startup before serving queries.+registerAcceptedTransferNeeds :: (Store :> es) => Eff es ()+registerAcceptedTransferNeeds =+  void (registerReadModel "hospital-capacity-accepted-transfer-needs" 1 "fnv1a:fec517dae7760b8a")++startAcceptedTransferNeedsRebuild :: (Store :> es) => GlobalPosition -> Eff es ReadModelMetadata+startAcceptedTransferNeedsRebuild =+  Rebuild.startRebuild acceptedTransferNeedsReadModel ["hospital-capacity-accepted-transfer-needs-async"]++finishAcceptedTransferNeedsRebuild :: (Store :> es) => GlobalPosition -> Eff es (Either Rebuild.RebuildError ReadModelMetadata)+finishAcceptedTransferNeedsRebuild =+  Rebuild.finishRebuild acceptedTransferNeedsReadModel ["hospital-capacity-accepted-transfer-needs-async"]++abandonAcceptedTransferNeedsRebuild :: (Store :> es) => Eff es ReadModelMetadata+abandonAcceptedTransferNeedsRebuild = Rebuild.abandonRebuild acceptedTransferNeedsReadModel++acceptedTransferNeedsAsyncProjection :: AsyncProjection+acceptedTransferNeedsAsyncProjection =+  AsyncProjection+    { name = "hospital-capacity-accepted-transfer-needs-async"+    , readModelName = "hospital-capacity-accepted-transfer-needs"+    , subscriptionName = "hospital-capacity-accepted-transfer-needs-sub"+    , applyRecorded = applyAcceptedTransferNeeds+    , idempotencyKey = \recorded -> recorded.eventId+    }

+ test/conformance-dispatch-full/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelHarness.hs view

@@ -0,0 +1,32 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from readmodel accepted_transfer_needs; do not edit.+module Generated.HospitalCapacity.AcceptedTransferNeeds.ReadModelHarness (readModelFacts, readModelFactResults, runReadModelFacts) where++import Generated.HospitalCapacity.AcceptedTransferNeeds.ReadModel (acceptedTransferNeedsReadModel, acceptedTransferNeedsAsyncProjection)+import Data.Text qualified as T+import Keiro.ReadModel (ReadModel (..), StrongScope (..))+import Keiro.Projection (AsyncProjection (..))++-- | (fact, expected from notation, actual generated runtime value).+readModelFacts :: [(String, String, String)]+readModelFacts =+  [ ("registryName", "hospital-capacity-accepted-transfer-needs", T.unpack acceptedTransferNeedsReadModel.name)+  , ("subscriptionName", "hospital-capacity-accepted-transfer-needs-sub", T.unpack acceptedTransferNeedsReadModel.subscriptionName)+  , ("shapeHash", "fnv1a:fec517dae7760b8a", T.unpack acceptedTransferNeedsReadModel.shapeHash)+  , ("asyncProjectionName", "hospital-capacity-accepted-transfer-needs-async", T.unpack acceptedTransferNeedsAsyncProjection.name)+  , ("consistency", "Eventual", show acceptedTransferNeedsReadModel.defaultConsistency)+  , ("strongScope", "EntireLog", renderStrongScope acceptedTransferNeedsReadModel.strongScope)+  ]++renderStrongScope :: StrongScope -> String+renderStrongScope EntireLog = "EntireLog"+renderStrongScope (CategoryHead categoryName) = "CategoryHead " <> T.unpack categoryName++readModelFactResults :: [(String, Bool)]+readModelFactResults =+  [(fact, expected == actual) | (fact, expected, actual) <- readModelFacts]++runReadModelFacts :: IO Bool+runReadModelFacts = do+  let failures = [(fact, expected, actual) | (fact, expected, actual) <- readModelFacts, expected /= actual]+  mapM_ (\(fact, expected, actual) -> putStrLn ("FAIL  " <> fact <> " expected=" <> show expected <> " actual=" <> show actual)) failures+  pure (null failures)

+ test/conformance-dispatch-full/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelTable.hs view

@@ -0,0 +1,9 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from readmodel accepted_transfer_needs; do not edit.+module Generated.HospitalCapacity.AcceptedTransferNeeds.ReadModelTable (acceptedTransferNeedsQualifiedTable) where++import Data.Text (Text)+import Keiro.Connection (qualifyTable)++-- The fully-qualified, double-quoted data-table reference.+acceptedTransferNeedsQualifiedTable :: Text+acceptedTransferNeedsQualifiedTable = qualifyTable "hospital_capacity" "accepted_transfer_needs"

test/conformance-dispatch-full/Generated/HospitalCapacity/ReservationWork/Queue.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from workqueue reservation_work; do not edit. module Generated.HospitalCapacity.ReservationWork.QueuePolicy   ( ReservationWorkOutcome (..)   , retryPolicy, jobOutcomeFor

+ test/conformance-dispatch-full/Generated/HospitalCapacity/TransferDecisions/ReadModel.hs view

@@ -0,0 +1,60 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from readmodel transfer_decisions; do not edit.+module Generated.HospitalCapacity.TransferDecisions.ReadModel+  ( transferDecisionsReadModel+  , transferDecisionsQualifiedTable+  , registerTransferDecisions+  , startTransferDecisionsRebuild+  , finishTransferDecisionsRebuild+  , abandonTransferDecisionsRebuild+  , transferDecisionsAsyncProjection+  ) where++import Data.Functor (void)+import Effectful (Eff, (:>))+import Generated.HospitalCapacity.TransferDecisions.ReadModelTable (transferDecisionsQualifiedTable)+import HospitalCapacity.TransferDecisions.ReadModelHoles (TransferDecisionsQueryInput, TransferDecisionsQueryResult, transferDecisionsQuery, applyTransferDecisions)+import Keiro.Projection (AsyncProjection (..))+import Keiro.ReadModel (ConsistencyMode (..), ReadModel (..), ReadModelMetadata, StrongScope (..), registerReadModel)+import Keiro.ReadModel.Rebuild qualified as Rebuild+import Kiroku.Store.Effect (Store)+import Kiroku.Store.Types (GlobalPosition, RecordedEvent (..))++transferDecisionsReadModel :: ReadModel TransferDecisionsQueryInput TransferDecisionsQueryResult+transferDecisionsReadModel =+  ReadModel+    { name = "hospital-capacity-transfer-decisions"+    , tableName = "transfer_decisions"+    , schema = "hospital_capacity"+    , subscriptionName = "hospital-capacity-transfer-decisions-sub"+    , version = 1+    , shapeHash = "fnv1a:d44d218822582783"+    , defaultConsistency = Eventual+    , strongScope = EntireLog+    , query = transferDecisionsQuery+    }++-- Call once at projection startup before serving queries.+registerTransferDecisions :: (Store :> es) => Eff es ()+registerTransferDecisions =+  void (registerReadModel "hospital-capacity-transfer-decisions" 1 "fnv1a:d44d218822582783")++startTransferDecisionsRebuild :: (Store :> es) => GlobalPosition -> Eff es ReadModelMetadata+startTransferDecisionsRebuild =+  Rebuild.startRebuild transferDecisionsReadModel ["hospital-capacity-transfer-decisions-async"]++finishTransferDecisionsRebuild :: (Store :> es) => GlobalPosition -> Eff es (Either Rebuild.RebuildError ReadModelMetadata)+finishTransferDecisionsRebuild =+  Rebuild.finishRebuild transferDecisionsReadModel ["hospital-capacity-transfer-decisions-async"]++abandonTransferDecisionsRebuild :: (Store :> es) => Eff es ReadModelMetadata+abandonTransferDecisionsRebuild = Rebuild.abandonRebuild transferDecisionsReadModel++transferDecisionsAsyncProjection :: AsyncProjection+transferDecisionsAsyncProjection =+  AsyncProjection+    { name = "hospital-capacity-transfer-decisions-async"+    , readModelName = "hospital-capacity-transfer-decisions"+    , subscriptionName = "hospital-capacity-transfer-decisions-sub"+    , applyRecorded = applyTransferDecisions+    , idempotencyKey = \recorded -> recorded.eventId+    }

+ test/conformance-dispatch-full/Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs view

@@ -0,0 +1,32 @@+-- @generated by keiro-dsl 0.15.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)+import Data.Text qualified as T+import Keiro.ReadModel (ReadModel (..), StrongScope (..))+import Keiro.Projection (AsyncProjection (..))++-- | (fact, expected from notation, actual generated runtime value).+readModelFacts :: [(String, String, String)]+readModelFacts =+  [ ("registryName", "hospital-capacity-transfer-decisions", T.unpack transferDecisionsReadModel.name)+  , ("subscriptionName", "hospital-capacity-transfer-decisions-sub", T.unpack transferDecisionsReadModel.subscriptionName)+  , ("shapeHash", "fnv1a:d44d218822582783", T.unpack transferDecisionsReadModel.shapeHash)+  , ("asyncProjectionName", "hospital-capacity-transfer-decisions-async", T.unpack transferDecisionsAsyncProjection.name)+  , ("consistency", "Eventual", show transferDecisionsReadModel.defaultConsistency)+  , ("strongScope", "EntireLog", renderStrongScope transferDecisionsReadModel.strongScope)+  ]++renderStrongScope :: StrongScope -> String+renderStrongScope EntireLog = "EntireLog"+renderStrongScope (CategoryHead categoryName) = "CategoryHead " <> T.unpack categoryName++readModelFactResults :: [(String, Bool)]+readModelFactResults =+  [(fact, expected == actual) | (fact, expected, actual) <- readModelFacts]++runReadModelFacts :: IO Bool+runReadModelFacts = do+  let failures = [(fact, expected, actual) | (fact, expected, actual) <- readModelFacts, expected /= actual]+  mapM_ (\(fact, expected, actual) -> putStrLn ("FAIL  " <> fact <> " expected=" <> show expected <> " actual=" <> show actual)) failures+  pure (null failures)

+ test/conformance-dispatch-full/Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs view

@@ -0,0 +1,9 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from readmodel transfer_decisions; do not edit.+module Generated.HospitalCapacity.TransferDecisions.ReadModelTable (transferDecisionsQualifiedTable) where++import Data.Text (Text)+import Keiro.Connection (qualifyTable)++-- The fully-qualified, double-quoted data-table reference.+transferDecisionsQualifiedTable :: Text+transferDecisionsQualifiedTable = qualifyTable "hospital_capacity" "transfer_decisions"

+ test/conformance-dispatch-full/HospitalCapacity/AcceptedTransferNeeds/ReadModelHoles.hs view

@@ -0,0 +1,26 @@+-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.+module HospitalCapacity.AcceptedTransferNeeds.ReadModelHoles+  ( AcceptedTransferNeedsQueryInput+  , AcceptedTransferNeedsQueryResult+  , acceptedTransferNeedsQuery+  , applyAcceptedTransferNeeds+  ) where++import Generated.HospitalCapacity.AcceptedTransferNeeds.ReadModelTable (acceptedTransferNeedsQualifiedTable)+import Hasql.Transaction qualified as Tx+import Kiroku.Store.Types (RecordedEvent(..))++-- HOLE: replace these aliases with the real query input and result types.+type AcceptedTransferNeedsQueryInput = ()+type AcceptedTransferNeedsQueryResult = ()++-- HOLE: query "hospital_capacity"."accepted_transfer_needs" via acceptedTransferNeedsQualifiedTable; never rely on search_path.+-- Declared columns:+--   reservation_id text NOT NULL+--   hospital_id text NOT NULL+acceptedTransferNeedsQuery :: AcceptedTransferNeedsQueryInput -> Tx.Transaction AcceptedTransferNeedsQueryResult+acceptedTransferNeedsQuery _input = acceptedTransferNeedsQualifiedTable `seq` error "HOLE: fill accepted_transfer_needs query"++-- HOLE: apply one recorded event; runtime deduplication makes redelivery safe.+applyAcceptedTransferNeeds :: RecordedEvent -> Tx.Transaction ()+applyAcceptedTransferNeeds _recorded = error "HOLE: fill accepted_transfer_needs async apply"

+ test/conformance-dispatch-full/HospitalCapacity/TransferDecisions/ReadModelHoles.hs view

@@ -0,0 +1,25 @@+-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.+module HospitalCapacity.TransferDecisions.ReadModelHoles+  ( TransferDecisionsQueryInput+  , TransferDecisionsQueryResult+  , transferDecisionsQuery+  , applyTransferDecisions+  ) where++import Generated.HospitalCapacity.TransferDecisions.ReadModelTable (transferDecisionsQualifiedTable)+import Hasql.Transaction qualified as Tx+import Kiroku.Store.Types (RecordedEvent(..))++-- HOLE: replace these aliases with the real query input and result types.+type TransferDecisionsQueryInput = ()+type TransferDecisionsQueryResult = ()++-- HOLE: query "hospital_capacity"."transfer_decisions" via transferDecisionsQualifiedTable; never rely on search_path.+-- Declared columns:+--   reservation_id text NOT NULL+transferDecisionsQuery :: TransferDecisionsQueryInput -> Tx.Transaction TransferDecisionsQueryResult+transferDecisionsQuery _input = transferDecisionsQualifiedTable `seq` error "HOLE: fill transfer_decisions query"++-- HOLE: apply one recorded event; runtime deduplication makes redelivery safe.+applyTransferDecisions :: RecordedEvent -> Tx.Transaction ()+applyTransferDecisions _recorded = error "HOLE: fill transfer_decisions async apply"

+ test/conformance-dispatch-full/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

@@ -0,0 +1,35 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/reservation-work.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    Generated.HospitalCapacity.AcceptedTransferNeeds.ReadModel+    Generated.HospitalCapacity.AcceptedTransferNeeds.ReadModelHarness+    Generated.HospitalCapacity.AcceptedTransferNeeds.ReadModelTable+    Generated.HospitalCapacity.ReservationWork.Queue+    Generated.HospitalCapacity.ReservationWork.QueueCodec+    Generated.HospitalCapacity.ReservationWork.QueuePolicy+    Generated.HospitalCapacity.TransferDecisions.ReadModel+    Generated.HospitalCapacity.TransferDecisions.ReadModelHarness+    Generated.HospitalCapacity.TransferDecisions.ReadModelTable+    HospitalCapacity.AcceptedTransferNeeds.ReadModelHoles+    HospitalCapacity.TransferDecisions.ReadModelHoles++build-depends:+    , aeson+    , base+    , effectful-core+    , hasql-transaction+    , keiro+    , keiro-core+    , keiro-pgmq+    , kiroku-store+    , text

+ test/conformance-dispatch-full/keiro-dsl-ledger.context.hospital-capacity.txt view

@@ -0,0 +1,30 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/reservation-work.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":4,"effectiveLanguageVersion":4,"sourceForm":"declared"}+semantic-contract {"languageSupport":"compatibility-only","languageVersion":4,"runtimeSemantics":"keiro-dsl/runtime-semantics/3"}+naming-edition idiomatic-v2+module-role {"family":"ReadModelTable","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel accepted_transfer_needs (line 4)","path":"Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelTable.hs"}+module-role {"family":"ReadModel","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel accepted_transfer_needs (line 4)","path":"Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModel.hs"}+module-role {"family":"ReadModelHoles","kind":"hole","ownerKind":"readmodel","ownerName":"readmodel accepted_transfer_needs (line 4)","path":"HospitalCapacity/AcceptedTransferNeeds/ReadModelHoles.hs"}+module-role {"family":"ReadModelHarness","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel accepted_transfer_needs (line 4)","path":"Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelHarness.hs"}+module-role {"family":"ReadModelTable","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel transfer_decisions (line 17)","path":"Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs"}+module-role {"family":"ReadModel","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel transfer_decisions (line 17)","path":"Generated/HospitalCapacity/TransferDecisions/ReadModel.hs"}+module-role {"family":"ReadModelHoles","kind":"hole","ownerKind":"readmodel","ownerName":"readmodel transfer_decisions (line 17)","path":"HospitalCapacity/TransferDecisions/ReadModelHoles.hs"}+module-role {"family":"ReadModelHarness","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel transfer_decisions (line 17)","path":"Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs"}+module-role {"family":"Queue","kind":"generated","ownerKind":"workqueue","ownerName":"workqueue reservation_work (line 29)","path":"Generated/HospitalCapacity/ReservationWork/Queue.hs"}+module-role {"family":"QueuePolicy","kind":"generated","ownerKind":"workqueue","ownerName":"workqueue reservation_work (line 29)","path":"Generated/HospitalCapacity/ReservationWork/QueuePolicy.hs"}+module-role {"family":"QueueCodec","kind":"generated","ownerKind":"workqueue","ownerName":"workqueue reservation_work (line 29)","path":"Generated/HospitalCapacity/ReservationWork/QueueCodec.hs"}+generated Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelTable.hs+generated Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModel.hs+hole HospitalCapacity/AcceptedTransferNeeds/ReadModelHoles.hs+generated Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelHarness.hs+generated Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs+generated Generated/HospitalCapacity/TransferDecisions/ReadModel.hs+hole HospitalCapacity/TransferDecisions/ReadModelHoles.hs+generated Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs+generated Generated/HospitalCapacity/ReservationWork/Queue.hs+generated Generated/HospitalCapacity/ReservationWork/QueuePolicy.hs+generated Generated/HospitalCapacity/ReservationWork/QueueCodec.hs+semantic-impact {"declarations":[],"mappedSurfaceEvidenceVersion":1,"serviceInventory":[]}

test/conformance-domain-outcomes/Generated/DomainOutcomes/BehaviorSourceMap.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from context domain-outcomes behavior source map; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from context domain-outcomes behavior source map; do not edit. module Generated.DomainOutcomes.BehaviorSourceMap   ( BehaviorSourceLocation (..)   , behaviorSourceLocation@@ -9,9 +9,9 @@ import Data.Text qualified as T  data BehaviorSourceLocation = BehaviorSourceLocation-  { sourceFile :: !FilePath-  , sourceLine :: !Int-  , sourceColumn :: !Int+  { file :: !FilePath+  , line :: !Int+  , column :: !Int   }   deriving stock (Eq, Ord, Show) @@ -24,7 +24,7 @@  renderBehaviorSourceLocation :: Text -> Text renderBehaviorSourceLocation key = case behaviorSourceLocation key of-  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Just location -> T.pack location.file <> ":" <> tshow location.line <> ":" <> tshow location.column   Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"  tshow :: Show value => value -> Text

test/conformance-domain-outcomes/Generated/DomainOutcomes/Nominals.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from context domain-outcomes generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-domain-outcomes/Generated/DomainOutcomes/ReplayAudit.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from context domain-outcomes replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.15.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;

test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/BehaviorContract.hs view

@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit. module Generated.DomainOutcomes.Reservation.BehaviorContract   ( BehaviorKey (..)+  , unBehaviorKey   , ObligationKind (..)   , EvidenceLevel (..)   , GuardCoverage (..)@@ -38,6 +39,9 @@ newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }   deriving stock (Eq, Ord, Show) +unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value+ data ObligationKind = LiveTransition | RequiredRejection | ReplayTransition   deriving stock (Eq, Ord, Show) @@ -48,15 +52,15 @@   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]+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !ReservationVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef ReservationVertex))+  , target :: !(Maybe ReservationVertex)+  , eventKinds :: ![Text]   }   deriving stock (Eq, Show) @@ -74,116 +78,116 @@ data BehaviorWitness   = Pending BehaviorKey   | LiveWitness-      { witnessKey :: BehaviorKey-      , witnessHistory :: [ReservationEvent]-      , witnessCommand :: ReservationCommand-      , witnessExpected :: LiveExpectation+      { key :: BehaviorKey+      , history :: [ReservationEvent]+      , command :: ReservationCommand+      , expected :: LiveExpectation       }   | ReplayWitness-      { witnessKey :: BehaviorKey-      , witnessHistoryPrefix :: [ReservationEvent]-      , witnessObservedChunk :: [ReservationEvent]+      { key :: BehaviorKey+      , historyPrefix :: [ReservationEvent]+      , observedChunk :: [ReservationEvent]       }   deriving stock (Eq, Show)  data BehaviorFailure = BehaviorFailure-  { failureKey :: !BehaviorKey-  , failureSubject :: !Text-  , failureCode :: !Text-  , failureDetail :: !Text+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !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+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail     ]  data BehaviorConformanceReport = BehaviorConformanceReport-  { reportRequired :: ![BehaviorKey]-  , reportFilled :: ![BehaviorKey]-  , reportPending :: ![BehaviorKey]-  , reportMissing :: ![BehaviorKey]-  , reportDuplicate :: ![BehaviorKey]-  , reportStale :: ![BehaviorKey]-  , reportFailed :: ![BehaviorFailure]-  , reportVerified :: ![BehaviorKey]-  , reportUnverified :: ![BehaviorKey]+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![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)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified     ]  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"]+      { key = BehaviorKey "behavior-v1-0b1588f69a27bc77"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = ReservationEligible+      , commandName = "Cancel"+      , expectedEdge = (Just (K.EdgeRef ReservationEligible 0))+      , target = Just ReservationCancelledState+      , eventKinds = ["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 = []+      { key = BehaviorKey "behavior-v1-316c9e96fc1a94b1"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = ReservationCancelledState+      , commandName = "Cancel"+      , expectedEdge = (Just (K.EdgeRef ReservationCancelledState 0))+      , target = Just ReservationCancelledState+      , eventKinds = []       }   , -- 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 = []+      { key = BehaviorKey "behavior-v1-fd391b55fbbfa640"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = ReservationCancelledState+      , commandName = "Cancel"+      , expectedEdge = (Just (K.EdgeRef ReservationCancelledState 1))+      , target = Just ReservationCancelledState+      , eventKinds = []       }   ]  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)]+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]     }  where-  requiredByKey = Map.fromList [(requirementKey requirement, requirement) | requirement <- behaviorRequirements]+  requiredByKey = Map.fromList [(requirement.key, requirement) | requirement <- behaviorRequirements]   witnessGroups = Map.fromListWith (flip (<>)) [(behaviorWitnessKey witness, [witness]) | witness <- witnesses]   executions =     [ (requirement, runWitness requirement witness)@@ -198,27 +202,27 @@  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))+  null report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)  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]+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]  runWitness :: BehaviorRequirement -> BehaviorWitness -> Either BehaviorFailure () runWitness requirement witness = case witness of@@ -229,9 +233,9 @@ 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+  ensure requirement (K.replaySuccessState settled == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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@@ -269,7 +273,7 @@       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))+      ensure requirement (map eventKind actual == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)       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)@@ -297,30 +301,30 @@ 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))+  ensure requirement (Just (K.stepSuccessEdge success) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)  runReplay :: BehaviorRequirement -> [ReservationEvent] -> [ReservationEvent] -> Either BehaviorFailure ()-runReplay requirement prefix chunk = case requirementKind requirement of+runReplay requirement prefix chunk = case requirement.kind 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 (K.replaySuccessState settled == requirement.source) "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))+    ensure requirement (Just (K.replaySuccessState replayed) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)     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 (Just (K.replayAttributionEdge attribution) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)     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.replayAttributionSource attribution == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)     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" @@ -346,14 +350,14 @@  proofStrength :: BehaviorRequirement -> Bool proofStrength requirement =-  requirementEvidence requirement == GeneratedAuthoritative-    && requirementGuardCoverage requirement `elem` [GuardTotal, GuardNotApplicable]+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]  behaviorWitnessKey :: BehaviorWitness -> BehaviorKey behaviorWitnessKey witness = case witness of   Pending key -> key-  LiveWitness { witnessKey = key } -> key-  ReplayWitness { witnessKey = key } -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = key } -> key  isPending :: BehaviorWitness -> Bool isPending Pending {} = True@@ -365,13 +369,13 @@ failure requirement code detail =   Left     ( BehaviorFailure-        (requirementKey requirement)-        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey requirement)) <> ")")+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")         code         detail     )  where-  kindPhrase = case requirementKind requirement of+  kindPhrase = case requirement.kind of     LiveTransition -> "live transition"     RequiredRejection -> "required rejection"     ReplayTransition -> "replay-only transition"

test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Codec.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit. module Generated.DomainOutcomes.Reservation.Codec (     reservationCodec,     parseReservationEvent,

test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Domain.hs view

@@ -1,6 +1,5 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit. module Generated.DomainOutcomes.Reservation.Domain where  import Data.Proxy (Proxy (..))

test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit. module Generated.DomainOutcomes.Reservation.EventStream   ( reservationCategory   , reservationCommandCategory

test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Harness.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit. module Generated.DomainOutcomes.Reservation.Harness (harnessAssertions) where  import Generated.DomainOutcomes.Reservation.Domain

test/conformance-domain-outcomes/Generated/DomainOutcomes/Reservation/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.15.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

@@ -1,7 +1,6 @@ {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Reservation; do not edit. module Generated.DomainOutcomes.Reservation.Transducer   ( reservationTransducer   , reservationFoldFingerprint

+ test/conformance-domain-outcomes/keiro-dsl-cabal-fragment.context.domain-outcomes.txt view

@@ -0,0 +1,31 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/domain-command-outcomes.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++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+    , base+    , keiki+    , keiro+    , text

+ test/conformance-domain-outcomes/keiro-dsl-ledger.context.domain-outcomes.txt view

@@ -0,0 +1,35 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/domain-command-outcomes.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":5,"effectiveLanguageVersion":5,"sourceForm":"declared"}+semantic-contract {"languageSupport":"stable","languageVersion":5,"runtimeSemantics":"keiro-dsl/runtime-semantics/4"}+naming-edition idiomatic-v2+module-role {"family":"BehaviorSourceMap","kind":"generated","ownerKind":"context","ownerName":"context domain-outcomes behavior source map","path":"Generated/DomainOutcomes/BehaviorSourceMap.hs"}+module-role {"family":"Nominals","kind":"generated","ownerKind":"context","ownerName":"context domain-outcomes generated nominal declarations","path":"Generated/DomainOutcomes/Nominals.hs"}+module-role {"family":"ReplayAudit","kind":"generated","ownerKind":"context","ownerName":"context domain-outcomes replay-audit assembly","path":"Generated/DomainOutcomes/ReplayAudit.hs"}+module-role {"family":"Domain","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Reservation (line 7)","path":"Generated/DomainOutcomes/Reservation/Domain.hs"}+module-role {"family":"Codec","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Reservation (line 7)","path":"Generated/DomainOutcomes/Reservation/Codec.hs"}+module-role {"family":"Transducer","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Reservation (line 7)","path":"Generated/DomainOutcomes/Reservation/Transducer.hs"}+module-role {"family":"BehaviorContract","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Reservation (line 7)","path":"Generated/DomainOutcomes/Reservation/BehaviorContract.hs"}+module-role {"family":"BehaviorHoles","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate behavior witnesses Reservation (line 7)","path":"DomainOutcomes/Reservation/BehaviorHoles.hs"}+module-role {"family":"EventStream","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Reservation (line 7)","path":"Generated/DomainOutcomes/Reservation/EventStream.hs"}+module-role {"family":"Projection","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Reservation (line 7)","path":"Generated/DomainOutcomes/Reservation/Projection.hs"}+module-role {"family":"Harness","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Reservation (line 7)","path":"Generated/DomainOutcomes/Reservation/Harness.hs"}+generated Generated/DomainOutcomes/BehaviorSourceMap.hs+generated Generated/DomainOutcomes/Nominals.hs+generated Generated/DomainOutcomes/ReplayAudit.hs+generated Generated/DomainOutcomes/Reservation/Domain.hs+generated Generated/DomainOutcomes/Reservation/Codec.hs+generated Generated/DomainOutcomes/Reservation/Transducer.hs+generated Generated/DomainOutcomes/Reservation/BehaviorContract.hs+hole DomainOutcomes/Reservation/BehaviorHoles.hs+generated Generated/DomainOutcomes/Reservation/EventStream.hs+generated Generated/DomainOutcomes/Reservation/Projection.hs+generated Generated/DomainOutcomes/Reservation/Harness.hs+nominal-equality nominal-equality|name=ReservationNoOp|contract=keiro-dsl/nominal-equality/1|key=Text|domain=finite-text:duplicate-request|owner=generated+nominal-equality nominal-equality|name=ReservationRejection|contract=keiro-dsl/nominal-equality/1|key=Text|domain=finite-text:already-cancelled,capacity-unavailable|owner=generated+behavior {"aggregate":"Reservation","command":"Cancel","evidence":"generated-authoritative","key":"behavior-v1-0b1588f69a27bc77","kind":"live-transition","outputs":[{"command":"Cancel","ownership":"generated-command-identity"}],"source":"Eligible"}+behavior {"aggregate":"Reservation","command":"Cancel","evidence":"generated-authoritative","key":"behavior-v1-316c9e96fc1a94b1","kind":"live-transition","outputs":[],"source":"CancelledState"}+behavior {"aggregate":"Reservation","command":"Cancel","evidence":"generated-authoritative","key":"behavior-v1-fd391b55fbbfa640","kind":"live-transition","outputs":[],"source":"CancelledState"}+semantic-impact {"declarations":[],"mappedSurfaceEvidenceVersion":1,"serviceInventory":[]}

test/conformance-id-domain-migration/Generated/IdDomainMigration/BehaviorSourceMap.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 3) from context id-domain-migration behavior source map; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 3) from context id-domain-migration behavior source map; do not edit. module Generated.IdDomainMigration.BehaviorSourceMap   ( BehaviorSourceLocation (..)   , behaviorSourceLocation@@ -9,9 +9,9 @@ import Data.Text qualified as T  data BehaviorSourceLocation = BehaviorSourceLocation-  { sourceFile :: !FilePath-  , sourceLine :: !Int-  , sourceColumn :: !Int+  { file :: !FilePath+  , line :: !Int+  , column :: !Int   }   deriving stock (Eq, Ord, Show) @@ -23,7 +23,7 @@  renderBehaviorSourceLocation :: Text -> Text renderBehaviorSourceLocation key = case behaviorSourceLocation key of-  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Just location -> T.pack location.file <> ":" <> tshow location.line <> ":" <> tshow location.column   Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"  tshow :: Show value => value -> Text

test/conformance-id-domain-migration/Generated/IdDomainMigration/Nominals.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 3) from context id-domain-migration generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 3) from context id-domain-migration generated nominal ID internals; do not edit.+-- @generated by keiro-dsl 0.15.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/BehaviorContract.hs view

@@ -0,0 +1,350 @@+{-# LANGUAGE OverloadedLabels #-}+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 3) from aggregate OrderBook; do not edit.+module Generated.IdDomainMigration.OrderBook.BehaviorContract+  ( BehaviorKey (..)+  , unBehaviorKey+  , ObligationKind (..)+  , EvidenceLevel (..)+  , GuardCoverage (..)+  , BehaviorRequirement (..)+  , RejectionClass (..)+  , LiveExpectation (..)+  , BehaviorWitness (..)+  , BehaviorFailure (..)+  , BehaviorConformanceReport (..)+  , behaviorRequirements+  , behaviorCoverageReport+  , behaviorConformancePassed+  , behaviorConformancePassedWith+  , renderBehaviorConformanceText+  ) where++import Generated.IdDomainMigration.OrderBook.Codec (encodeOrderBookEvent, parseOrderBookEvent, orderBookCodec)+import Generated.IdDomainMigration.OrderBook.Domain+import Generated.IdDomainMigration.OrderBook.Transducer (orderBookTransducer)+import Generated.IdDomainMigration.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)++unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value++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+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !OrderBookVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef OrderBookVertex))+  , target :: !(Maybe OrderBookVertex)+  , eventKinds :: ![Text]+  }+  deriving stock (Eq, Show)++data RejectionClass = RejectNoOutgoingEdges | RejectNoMatchingEdge+  deriving stock (Eq, Show)++data LiveExpectation+  = Emits (NonEmpty OrderBookEvent)+  | Rejects RejectionClass+  | NoOp+  deriving stock (Eq, Show)++data BehaviorWitness+  = Pending BehaviorKey+  | LiveWitness+      { key :: BehaviorKey+      , history :: [OrderBookEvent]+      , command :: OrderBookCommand+      , expected :: LiveExpectation+      }+  | ReplayWitness+      { key :: BehaviorKey+      , historyPrefix :: [OrderBookEvent]+      , observedChunk :: [OrderBookEvent]+      }+  deriving stock (Eq, Show)++data BehaviorFailure = BehaviorFailure+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !Text+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorFailure where+  toJSON behaviorFailure = object+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail+    ]++data BehaviorConformanceReport = BehaviorConformanceReport+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![BehaviorKey]+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorConformanceReport where+  toJSON report = object+    [ "schema" .= ("keiro/behavior-conformance/1" :: Text)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified+    ]++behaviorRequirements :: [BehaviorRequirement]+behaviorRequirements =+  [ -- OrderBookRecorded x Record: required rejection+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-6b331af859e674ea"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = OrderBookRecorded+      , commandName = "Record"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []+      }+  , -- OrderBookEmpty x Record: live transition+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-a396f60ddb8f99be"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = OrderBookEmpty+      , commandName = "Record"+      , expectedEdge = (Just (K.EdgeRef OrderBookEmpty 0))+      , target = Just OrderBookRecorded+      , eventKinds = ["OrderRecorded"]+      }+  ]++behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport+behaviorCoverageReport witnesses =+  BehaviorConformanceReport+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]+    }+ where+  requiredByKey = Map.fromList [(requirement.key, 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 report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)++renderBehaviorConformanceText :: BehaviorConformanceReport -> Text+renderBehaviorConformanceText report = T.unlines+  [ "behavior conformance: OrderBook"+  , "schema: keiro/behavior-conformance/1"+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]++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 -> [OrderBookEvent] -> OrderBookCommand -> LiveExpectation -> Either BehaviorFailure ()+runLive requirement history command expectation = do+  settled <- settleHistory requirement "history" history+  ensure requirement (K.replaySuccessState settled == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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 -> (OrderBookVertex, K.RegFile OrderBookRegs) -> OrderBookCommand -> 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 orderBookTransducer 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 -> (OrderBookVertex, K.RegFile OrderBookRegs) -> OrderBookCommand -> 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 orderBookTransducer 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 orderBookTransducer 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 == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)+      decoded <- either (failure requirement "emitted-codec-decode") Right (decodeEvents actual)+      replayed <- case K.applyEventsDetailedEither orderBookTransducer 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 OrderBookRegs OrderBookVertex OrderBookEvent -> 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) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)++runReplay :: BehaviorRequirement -> [OrderBookEvent] -> [OrderBookEvent] -> Either BehaviorFailure ()+runReplay requirement prefix chunk = case requirement.kind of+  ReplayTransition -> do+    settled <- settleHistory requirement "history-prefix" prefix+    ensure requirement (K.replaySuccessState settled == requirement.source) "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 orderBookTransducer (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) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)+    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 OrderBookVertex] -> Either BehaviorFailure ()+checkSingleAttribution requirement expectedMode eventCount trace = case trace of+  [attribution] -> do+    ensure requirement (Just (K.replayAttributionEdge attribution) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)+    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 == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)+    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 -> [OrderBookEvent] -> Either BehaviorFailure (K.ReplaySuccess OrderBookRegs OrderBookVertex)+settleHistory requirement label history = do+  decoded <- either (failure requirement (label <> "-codec-decode")) Right (decodeEvents history)+  case K.applyEventsDetailedEither orderBookTransducer (OrderBookEmpty, initialOrderBookRegs) decoded of+    Left replayFailure -> failure requirement (label <> "-replay-failed") (tshow replayFailure)+    Right replaySuccess -> Right replaySuccess++decodeEvents :: [OrderBookEvent] -> Either Text [OrderBookEvent]+decodeEvents = traverse (\event -> parseOrderBookEvent (Codec.eventType orderBookCodec event) (encodeOrderBookEvent event))++commandKind :: OrderBookCommand -> Text+commandKind command = case command of+  Record _ -> "Record"++eventKind :: OrderBookEvent -> Text+eventKind event = case Codec.eventType orderBookCodec event of Codec.EventType tag -> tag++regsEqual :: K.RegFile OrderBookRegs -> K.RegFile OrderBookRegs -> Bool+regsEqual left right = (left K.! #orderId) == (right K.! #orderId)++proofStrength :: BehaviorRequirement -> Bool+proofStrength requirement =+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]++behaviorWitnessKey :: BehaviorWitness -> BehaviorKey+behaviorWitnessKey witness = case witness of+  Pending key -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = 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+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")+        code+        detail+    )+ where+  kindPhrase = case requirement.kind 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-id-domain-migration/Generated/IdDomainMigration/OrderBook/Codec.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 3) from aggregate OrderBook; do not edit.+-- @generated by keiro-dsl 0.15.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,6 @@ {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 3) from aggregate OrderBook; do not edit.+-- @generated by keiro-dsl 0.15.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-id-domain-migration/Generated/IdDomainMigration/OrderBook/EventStream.hs view

@@ -0,0 +1,63 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 3) from aggregate OrderBook; do not edit.+module Generated.IdDomainMigration.OrderBook.EventStream+  ( orderBookCategory+  , orderBookCommandCategory+  , orderBookEventStream+  , orderBookEventStreamDef+  , OrderBookEventStream+  , OrderBookEventStreamDef+  , orderBookSnapshotFixture+  ) where++import Generated.IdDomainMigration.OrderBook.Domain+import Generated.IdDomainMigration.OrderBook.Codec (orderBookCodec)+import Generated.IdDomainMigration.OrderBook.Transducer (orderBookFoldFingerprint, orderBookTransducer)+import Keiki.Core (HsPred)+import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))+import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)+import Data.Text (Text)+import Keiro.Snapshot.Codec (defaultStateCodec, withFoldFingerprint)+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.+orderBookCategory :: Stream.StreamCategory OrderBookEventStreamDef+orderBookCategory = Stream.categoryUnsafe "orderBook"++-- The same category text, typed for command envelopes such as PMCommand.+orderBookCommandCategory :: Stream.StreamCategory OrderBookCommand+orderBookCommandCategory = Stream.categoryUnsafe "orderBook"++type OrderBookEventStreamDef =+  EventStream (HsPred OrderBookRegs OrderBookCommand) OrderBookRegs OrderBookVertex OrderBookCommand OrderBookEvent++type OrderBookEventStream =+  ValidatedEventStream (HsPred OrderBookRegs OrderBookCommand) OrderBookRegs OrderBookVertex OrderBookCommand OrderBookEvent++orderBookEventStreamDef :: OrderBookEventStreamDef+orderBookEventStreamDef =+  EventStream+    { transducer = orderBookTransducer,+      initialState = OrderBookEmpty,+      initialRegisters = initialOrderBookRegs,+      eventCodec = orderBookCodec,+      resolveStreamName = Stream.streamName,+      snapshotPolicy = Every 1,+      -- 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 = Just (withFoldFingerprint orderBookFoldFingerprint (defaultStateCodec 1))+    }++orderBookSnapshotFixture :: (Int, Text)+orderBookSnapshotFixture = (1, "id-domain-migration-v3")++orderBookEventStream :: OrderBookEventStream+orderBookEventStream =+  mkEventStreamOrThrow "OrderBook" orderBookEventStreamDef

+ test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Harness.hs view

@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedLabels #-}+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 3) from aggregate OrderBook; do not edit.+module Generated.IdDomainMigration.OrderBook.Harness (harnessAssertions) where++import Generated.IdDomainMigration.OrderBook.Domain+import Generated.IdDomainMigration.OrderBook.Codec (encodeOrderBookEvent, parseOrderBookEvent, orderBookCodec)+import Generated.IdDomainMigration.OrderBook.Transducer (orderBookTransducer)+import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!))+import Keiro.Codec (eventType)+import Generated.IdDomainMigration.Nominals (OrderId, parseOrderId)++-- | (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 orderBookTransducer))+  -- clock-free: spec samples no wall clock (verified at scaffold time)+  , ("golden round-trip: OrderRecorded", roundTrips sampleEventOrderRecorded)+  , ("accepts Record from OrderBookEmpty", acceptRecord)+  ]+  ++ forwardReplayRecord++roundTrips :: OrderBookEvent -> Bool+roundTrips e = parseOrderBookEvent (eventType orderBookCodec e) (encodeOrderBookEvent e) == Right e++sampleOrderId :: OrderId+sampleOrderId =+  case parseOrderId "ord_01h455vb4pex5vsknk084sn02q" of+    Right parsed -> parsed+    Left problem -> error (show problem)++sampleEventOrderRecorded :: OrderBookEvent+sampleEventOrderRecorded = OrderRecorded (OrderRecordedData sampleOrderId)++acceptRecord :: Bool+acceptRecord =+  case step orderBookTransducer (OrderBookEmpty, initialOrderBookRegs) (Record (RecordData sampleOrderId)) of+    Just (v, _, _) -> v == OrderBookRecorded+    Nothing -> False++-- forward/replay equality (plan 147): cross the persisted codec boundary,+-- replay the emitted chain, and compare the final vertex and every register.+forwardReplayRecord :: [(String, Bool)]+forwardReplayRecord =+  case step orderBookTransducer (OrderBookEmpty, initialOrderBookRegs) (Record (RecordData sampleOrderId)) of+    Nothing -> [(prefix <> "forward step accepted", False)]+    Just (forwardVertex, forwardRegs, emitted) ->+      case mapM (\event -> parseOrderBookEvent (eventType orderBookCodec event) (encodeOrderBookEvent event)) emitted of+        Left _ -> [(prefix <> "emitted chain decodes", False)]+        Right decodedEvents ->+          case applyEventsEither orderBookTransducer (OrderBookEmpty, initialOrderBookRegs) decodedEvents of+            Left _ -> [(prefix <> "replay succeeds", False)]+            Right (replayVertex, replayRegs) ->+              [ (prefix <> "final vertex", replayVertex == forwardVertex)+              , (prefix <> "register orderId", (replayRegs ! #orderId) == (forwardRegs ! #orderId))+              ]+  where+    prefix = "forward/replay equality: Record from OrderBookEmpty -- "

+ test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Projection.hs view

@@ -0,0 +1,4 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 3) from aggregate OrderBook; do not edit.+module Generated.IdDomainMigration.OrderBook.Projection () where++-- No projection declarations are present; this module keeps the generated manifest inventory total.

+ test/conformance-id-domain-migration/Generated/IdDomainMigration/OrderBook/Transducer.hs view

@@ -0,0 +1,57 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE QualifiedDo #-}+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 3) from aggregate OrderBook; do not edit.+module Generated.IdDomainMigration.OrderBook.Transducer+  ( orderBookTransducer+  , orderBookFoldFingerprint+  , BehaviorOwnership (..)+  , orderBookPredicateVerifications+  ) where++import Generated.IdDomainMigration.OrderBook.Domain+import Data.Text (Text)+import Generated.IdDomainMigration.Nominals (OrderId)+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 ((=:))++orderBookTransducer+  :: SymTransducer+       (HsPred OrderBookRegs OrderBookCommand)+       OrderBookRegs+       OrderBookVertex+       OrderBookCommand+       OrderBookEvent+orderBookTransducer =+  B.buildTransducer OrderBookEmpty initialOrderBookRegs isTerminal do+    B.from OrderBookEmpty do+      B.onCmd inCtorRecord $ \d -> B.do+        B.slot @"orderId" =: d.orderId+        B.emit wireOrderRecorded (OrderRecordedTermFields+          { orderId = d.orderId+          })+        B.goto OrderBookRecorded+ where+  isTerminal = \case+    OrderBookRecorded -> True+    _ -> False++orderBookFoldFingerprint :: Text+orderBookFoldFingerprint = "d169ad9824b76fafe43c6c86bb601ebd"++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.+orderBookPredicateVerifications :: IO [(Text, BehaviorOwnership, S.PredicateVerification)]+orderBookPredicateVerifications = sequence+  [ verifyTransition "transition1EmptyRecord" GeneratedOwned OrderBookEmpty 0+  ]+ where+  verifyTransition label owner source edgeIndex =+    case drop edgeIndex (K.edgesOut orderBookTransducer source) of+      K.Edge predicate _ _ _ _ : _ -> (\result -> (label, owner, result)) <$> S.verifyPredicate predicate+      [] -> pure (label, owner, S.UnverifiedSolverFailure "generated transition edge missing")

+ test/conformance-id-domain-migration/Generated/IdDomainMigration/ReplayAudit.hs view

@@ -0,0 +1,23 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 3) from context id-domain-migration 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.IdDomainMigration.ReplayAudit (auditTargets) where++import Generated.IdDomainMigration.OrderBook.EventStream qualified as OrderBook+import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory)+import Keiro.Stream qualified as Stream++auditTargets :: [SomeAuditTarget]+auditTargets =+  [ SomeAuditTarget+      AuditTarget+        { eventStream = OrderBook.orderBookEventStream+        , category = Stream.categoryText OrderBook.orderBookCategory+        , mkStream = streamInCategory (Stream.categoryText OrderBook.orderBookCategory)+        }+  ]

+ test/conformance-id-domain-migration/IdDomainMigration/OrderBook/BehaviorHoles.hs view

@@ -0,0 +1,10 @@+-- Consumer-owned behavioral witnesses. Created once; never overwritten.+module IdDomainMigration.OrderBook.BehaviorHoles (behaviorWitnesses) where++import Generated.IdDomainMigration.OrderBook.BehaviorContract++behaviorWitnesses :: [BehaviorWitness]+behaviorWitnesses =+  [ Pending (BehaviorKey "behavior-v1-6b331af859e674ea")+  , Pending (BehaviorKey "behavior-v1-a396f60ddb8f99be")+  ]

test/conformance-id-domain-migration/Main.hs view

@@ -37,7 +37,7 @@ legacyReplayAccepts :: Bool legacyReplayAccepts =   case parseOrderBookEvent (EventType "OrderRecorded") legacyPayload of-    Right (OrderRecorded payload) -> orderIdText (orderId payload) == legacyInvalidText+    Right (OrderRecorded payload) -> orderIdText payload.orderId == legacyInvalidText     Left _ -> False  newAdmissionRejects :: Bool

+ test/conformance-id-domain-migration/keiro-dsl-cabal-fragment.context.id-domain-migration.txt view

@@ -0,0 +1,32 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/id-domain-migration-v3.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    Generated.IdDomainMigration.BehaviorSourceMap+    Generated.IdDomainMigration.Nominals+    Generated.IdDomainMigration.Nominals.Internal+    Generated.IdDomainMigration.OrderBook.BehaviorContract+    Generated.IdDomainMigration.OrderBook.Codec+    Generated.IdDomainMigration.OrderBook.Domain+    Generated.IdDomainMigration.OrderBook.EventStream+    Generated.IdDomainMigration.OrderBook.Harness+    Generated.IdDomainMigration.OrderBook.Projection+    Generated.IdDomainMigration.OrderBook.Transducer+    Generated.IdDomainMigration.ReplayAudit+    IdDomainMigration.OrderBook.BehaviorHoles++build-depends:+    , aeson+    , base+    , keiki+    , keiro+    , text

+ test/conformance-id-domain-migration/keiro-dsl-ledger.context.id-domain-migration.txt view

@@ -0,0 +1,36 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/id-domain-migration-v3.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":3,"effectiveLanguageVersion":3,"sourceForm":"declared"}+semantic-contract {"languageSupport":"compatibility-only","languageVersion":3,"runtimeSemantics":"keiro-dsl/runtime-semantics/2"}+naming-edition idiomatic-v2+module-role {"family":"BehaviorSourceMap","kind":"generated","ownerKind":"context","ownerName":"context id-domain-migration behavior source map","path":"Generated/IdDomainMigration/BehaviorSourceMap.hs"}+module-role {"family":"Nominals","kind":"generated","ownerKind":"context","ownerName":"context id-domain-migration generated nominal declarations","path":"Generated/IdDomainMigration/Nominals.hs"}+module-role {"family":"Internal","kind":"generated","ownerKind":"context","ownerName":"context id-domain-migration generated nominal ID internals","path":"Generated/IdDomainMigration/Nominals/Internal.hs"}+module-role {"family":"ReplayAudit","kind":"generated","ownerKind":"context","ownerName":"context id-domain-migration replay-audit assembly","path":"Generated/IdDomainMigration/ReplayAudit.hs"}+module-role {"family":"Domain","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate OrderBook (line 6)","path":"Generated/IdDomainMigration/OrderBook/Domain.hs"}+module-role {"family":"Codec","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate OrderBook (line 6)","path":"Generated/IdDomainMigration/OrderBook/Codec.hs"}+module-role {"family":"Transducer","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate OrderBook (line 6)","path":"Generated/IdDomainMigration/OrderBook/Transducer.hs"}+module-role {"family":"BehaviorContract","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate OrderBook (line 6)","path":"Generated/IdDomainMigration/OrderBook/BehaviorContract.hs"}+module-role {"family":"BehaviorHoles","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate behavior witnesses OrderBook (line 6)","path":"IdDomainMigration/OrderBook/BehaviorHoles.hs"}+module-role {"family":"EventStream","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate OrderBook (line 6)","path":"Generated/IdDomainMigration/OrderBook/EventStream.hs"}+module-role {"family":"Projection","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate OrderBook (line 6)","path":"Generated/IdDomainMigration/OrderBook/Projection.hs"}+module-role {"family":"Harness","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate OrderBook (line 6)","path":"Generated/IdDomainMigration/OrderBook/Harness.hs"}+generated Generated/IdDomainMigration/BehaviorSourceMap.hs+generated Generated/IdDomainMigration/Nominals.hs+generated Generated/IdDomainMigration/Nominals/Internal.hs+generated Generated/IdDomainMigration/ReplayAudit.hs+generated Generated/IdDomainMigration/OrderBook/Domain.hs+generated Generated/IdDomainMigration/OrderBook/Codec.hs+generated Generated/IdDomainMigration/OrderBook/Transducer.hs+generated Generated/IdDomainMigration/OrderBook/BehaviorContract.hs+hole IdDomainMigration/OrderBook/BehaviorHoles.hs+generated Generated/IdDomainMigration/OrderBook/EventStream.hs+generated Generated/IdDomainMigration/OrderBook/Projection.hs+generated Generated/IdDomainMigration/OrderBook/Harness.hs+id-domain id-domain|name=OrderId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=ord|separator=_|json=canonical-json-text+nominal-equality nominal-equality|name=OrderId|contract=keiro-dsl/nominal-equality/2|key=Text|domain=typeid-v7-text:ord:keiro-dsl/id-domain/typeid-v7/1|owner=generated+behavior {"aggregate":"OrderBook","command":"Record","evidence":"generated-authoritative","key":"behavior-v1-6b331af859e674ea","kind":"required-rejection","outputs":[],"source":"Recorded"}+behavior {"aggregate":"OrderBook","command":"Record","evidence":"generated-authoritative","key":"behavior-v1-a396f60ddb8f99be","kind":"live-transition","outputs":[{"command":"Record","ownership":"generated-command-identity"}],"source":"Empty"}+semantic-impact {"declarations":[],"mappedSurfaceEvidenceVersion":1,"serviceInventory":[]}

test/conformance-import-planning/Generated/ImportPlanningCollisions/BehaviorSourceMap.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from context import-planning-collisions behavior source map; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from context import-planning-collisions behavior source map; do not edit. module Generated.ImportPlanningCollisions.BehaviorSourceMap   ( BehaviorSourceLocation (..)   , behaviorSourceLocation@@ -9,9 +9,9 @@ import Data.Text qualified as T  data BehaviorSourceLocation = BehaviorSourceLocation-  { sourceFile :: !FilePath-  , sourceLine :: !Int-  , sourceColumn :: !Int+  { file :: !FilePath+  , line :: !Int+  , column :: !Int   }   deriving stock (Eq, Ord, Show) @@ -23,7 +23,7 @@  renderBehaviorSourceLocation :: Text -> Text renderBehaviorSourceLocation key = case behaviorSourceLocation key of-  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Just location -> T.pack location.file <> ":" <> tshow location.line <> ":" <> tshow location.column   Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"  tshow :: Show value => value -> Text

test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/BehaviorContract.hs view

@@ -1,6 +1,7 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit. module Generated.ImportPlanningCollisions.CollisionLedger.BehaviorContract   ( BehaviorKey (..)+  , unBehaviorKey   , ObligationKind (..)   , EvidenceLevel (..)   , GuardCoverage (..)@@ -34,6 +35,9 @@ newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }   deriving stock (Eq, Ord, Show) +unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value+ data ObligationKind = LiveTransition | RequiredRejection | ReplayTransition   deriving stock (Eq, Ord, Show) @@ -44,15 +48,15 @@   deriving stock (Eq, Ord, Show)  data BehaviorRequirement = BehaviorRequirement-  { requirementKey :: !BehaviorKey-  , requirementKind :: !ObligationKind-  , requirementEvidence :: !EvidenceLevel-  , requirementGuardCoverage :: !GuardCoverage-  , requirementSource :: !CollisionLedgerVertex-  , requirementCommandName :: !Text-  , requirementExpectedEdge :: !(Maybe (K.EdgeRef CollisionLedgerVertex))-  , requirementTarget :: !(Maybe CollisionLedgerVertex)-  , requirementEventKinds :: ![Text]+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !CollisionLedgerVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef CollisionLedgerVertex))+  , target :: !(Maybe CollisionLedgerVertex)+  , eventKinds :: ![Text]   }   deriving stock (Eq, Show) @@ -68,104 +72,104 @@ data BehaviorWitness   = Pending BehaviorKey   | LiveWitness-      { witnessKey :: BehaviorKey-      , witnessHistory :: [CollisionLedgerEvent]-      , witnessCommand :: CollisionLedgerCommand-      , witnessExpected :: LiveExpectation+      { key :: BehaviorKey+      , history :: [CollisionLedgerEvent]+      , command :: CollisionLedgerCommand+      , expected :: LiveExpectation       }   | ReplayWitness-      { witnessKey :: BehaviorKey-      , witnessHistoryPrefix :: [CollisionLedgerEvent]-      , witnessObservedChunk :: [CollisionLedgerEvent]+      { key :: BehaviorKey+      , historyPrefix :: [CollisionLedgerEvent]+      , observedChunk :: [CollisionLedgerEvent]       }   deriving stock (Eq, Show)  data BehaviorFailure = BehaviorFailure-  { failureKey :: !BehaviorKey-  , failureSubject :: !Text-  , failureCode :: !Text-  , failureDetail :: !Text+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !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+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail     ]  data BehaviorConformanceReport = BehaviorConformanceReport-  { reportRequired :: ![BehaviorKey]-  , reportFilled :: ![BehaviorKey]-  , reportPending :: ![BehaviorKey]-  , reportMissing :: ![BehaviorKey]-  , reportDuplicate :: ![BehaviorKey]-  , reportStale :: ![BehaviorKey]-  , reportFailed :: ![BehaviorFailure]-  , reportVerified :: ![BehaviorKey]-  , reportUnverified :: ![BehaviorKey]+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![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)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified     ]  behaviorRequirements :: [BehaviorRequirement] behaviorRequirements =   [ -- CollisionLedgerEmpty x Record: live transition     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-2134fce4a19c59d7"-      , requirementKind = LiveTransition-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardTotal-      , requirementSource = CollisionLedgerEmpty-      , requirementCommandName = "Record"-      , requirementExpectedEdge = (Just (K.EdgeRef CollisionLedgerEmpty 0))-      , requirementTarget = Just CollisionLedgerRecorded-      , requirementEventKinds = ["RecordedValues"]+      { key = BehaviorKey "behavior-v1-2134fce4a19c59d7"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = CollisionLedgerEmpty+      , commandName = "Record"+      , expectedEdge = (Just (K.EdgeRef CollisionLedgerEmpty 0))+      , target = Just CollisionLedgerRecorded+      , eventKinds = ["RecordedValues"]       }   , -- CollisionLedgerRecorded x Record: required rejection     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-995f9bf710ce7c6c"-      , requirementKind = RequiredRejection-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = CollisionLedgerRecorded-      , requirementCommandName = "Record"-      , requirementExpectedEdge = Nothing-      , requirementTarget = Nothing-      , requirementEventKinds = []+      { key = BehaviorKey "behavior-v1-995f9bf710ce7c6c"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = CollisionLedgerRecorded+      , commandName = "Record"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []       }   ]  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)]+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]     }  where-  requiredByKey = Map.fromList [(requirementKey requirement, requirement) | requirement <- behaviorRequirements]+  requiredByKey = Map.fromList [(requirement.key, requirement) | requirement <- behaviorRequirements]   witnessGroups = Map.fromListWith (flip (<>)) [(behaviorWitnessKey witness, [witness]) | witness <- witnesses]   executions =     [ (requirement, runWitness requirement witness)@@ -180,27 +184,27 @@  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))+  null report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)  renderBehaviorConformanceText :: BehaviorConformanceReport -> Text renderBehaviorConformanceText report = T.unlines   [ "behavior conformance: CollisionLedger"   , "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]+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]  runWitness :: BehaviorRequirement -> BehaviorWitness -> Either BehaviorFailure () runWitness requirement witness = case witness of@@ -211,9 +215,9 @@ runLive :: BehaviorRequirement -> [CollisionLedgerEvent] -> CollisionLedgerCommand -> 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+  ensure requirement (K.replaySuccessState settled == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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@@ -245,7 +249,7 @@       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))+      ensure requirement (map eventKind actual == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)       decoded <- either (failure requirement "emitted-codec-decode") Right (decodeEvents actual)       replayed <- case K.applyEventsDetailedEither collisionLedgerTransducer seed decoded of         Left replayFailure -> failure requirement "emitted-replay-failed" (tshow replayFailure)@@ -257,30 +261,30 @@ checkAcceptedEnvelope :: BehaviorRequirement -> K.StepSuccess CollisionLedgerRegs CollisionLedgerVertex CollisionLedgerEvent -> 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))+  ensure requirement (Just (K.stepSuccessEdge success) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)  runReplay :: BehaviorRequirement -> [CollisionLedgerEvent] -> [CollisionLedgerEvent] -> Either BehaviorFailure ()-runReplay requirement prefix chunk = case requirementKind requirement of+runReplay requirement prefix chunk = case requirement.kind 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 (K.replaySuccessState settled == requirement.source) "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 collisionLedgerTransducer (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))+    ensure requirement (Just (K.replaySuccessState replayed) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)     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 CollisionLedgerVertex] -> 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 (Just (K.replayAttributionEdge attribution) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)     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.replayAttributionSource attribution == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)     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" @@ -306,14 +310,14 @@  proofStrength :: BehaviorRequirement -> Bool proofStrength requirement =-  requirementEvidence requirement == GeneratedAuthoritative-    && requirementGuardCoverage requirement `elem` [GuardTotal, GuardNotApplicable]+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]  behaviorWitnessKey :: BehaviorWitness -> BehaviorKey behaviorWitnessKey witness = case witness of   Pending key -> key-  LiveWitness { witnessKey = key } -> key-  ReplayWitness { witnessKey = key } -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = key } -> key  isPending :: BehaviorWitness -> Bool isPending Pending {} = True@@ -325,13 +329,13 @@ failure requirement code detail =   Left     ( BehaviorFailure-        (requirementKey requirement)-        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey requirement)) <> ")")+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")         code         detail     )  where-  kindPhrase = case requirementKind requirement of+  kindPhrase = case requirement.kind of     LiveTransition -> "live transition"     RequiredRejection -> "required rejection"     ReplayTransition -> "replay-only transition"

test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Codec.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit. module Generated.ImportPlanningCollisions.CollisionLedger.Codec (     collisionLedgerCodec,     parseCollisionLedgerEvent,@@ -46,7 +45,7 @@ encodeDetailsShape :: ShapeDetails.DetailsShape -> Value encodeDetailsShape shape =   object-      [ "label" .= toJSON (ShapeDetails.label shape)+      [ "label" .= toJSON (shape.label)       ]  parseDetailsShape :: Value -> Parser ShapeDetails.DetailsShape

test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Domain.hs view

@@ -1,6 +1,5 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit. module Generated.ImportPlanningCollisions.CollisionLedger.Harness (harnessAssertions) where  import Generated.ImportPlanningCollisions.CollisionLedger.Domain

test/conformance-import-planning/Generated/ImportPlanningCollisions/CollisionLedger/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit.+-- @generated by keiro-dsl 0.15.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,6 @@ {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate CollisionLedger; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from context import-planning-collisions nominal scalar projection facade; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from context import-planning-collisions replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from mapped structural Details; do not edit.+-- @generated by keiro-dsl 0.15.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

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from context import-planning-collisions structural conformance; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from context import-planning-collisions structural conformance; do not edit. module Generated.ImportPlanningCollisions.StructuralConformance   ( structuralConformanceAssertions   ) where@@ -11,7 +11,7 @@ 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 Generated.ImportPlanningCollisions.Structural.Shape.Details (DetailsShape(label)) import ImportPlanning.Bindings qualified as Bindings import ImportPlanning.Consumer.Shared.Types (Details) @@ -47,5 +47,5 @@  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)))+  [ ("projection witness agreement: import-planning.Details.v1/label", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.detailsLabelWitness (\referenceOwner -> (bindingToShape Bindings.detailsBinding referenceOwner).label) 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.14.0.0 (language keiro-dsl 4) from context import-planning-collisions mapped structural facade; do not edit.+-- @generated by keiro-dsl 0.15.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@@ -9,7 +9,7 @@ import Data.Text (Text) import Keiro.Codec.Structural (bindingToShape) import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)-import Generated.ImportPlanningCollisions.Structural.Shape.Details qualified as ShapeDetails+import Generated.ImportPlanningCollisions.Structural.Shape.Details (DetailsShape(label)) import ImportPlanning.Bindings qualified as Bindings import ImportPlanning.Consumer.Shared.Types (Details) @@ -20,7 +20,7 @@   type FieldOwner DetailsLabelProjection = Details   type FieldResult DetailsLabelProjection = Text   fieldShapeId _ = "import-planning.Details.v1"-  projectFieldValue _ owner = ShapeDetails.label (bindingToShape Bindings.detailsBinding owner)+  projectFieldValue _ owner = (bindingToShape Bindings.detailsBinding owner).label  detailsLabelWitness :: FieldWitness DetailsLabelProjection detailsLabelWitness = fieldWitness @DetailsLabelProjection

+ test/conformance-import-planning/keiro-dsl-cabal-fragment.context.import-planning-collisions.txt view

@@ -0,0 +1,46 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/import-planning-collisions.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    Generated.ImportPlanningCollisions.BehaviorSourceMap+    Generated.ImportPlanningCollisions.CollisionLedger.BehaviorContract+    Generated.ImportPlanningCollisions.CollisionLedger.Codec+    Generated.ImportPlanningCollisions.CollisionLedger.Domain+    Generated.ImportPlanningCollisions.CollisionLedger.EventStream+    Generated.ImportPlanningCollisions.CollisionLedger.Harness+    Generated.ImportPlanningCollisions.CollisionLedger.Projection+    Generated.ImportPlanningCollisions.CollisionLedger.Transducer+    Generated.ImportPlanningCollisions.NominalProjections+    Generated.ImportPlanningCollisions.ReplayAudit+    Generated.ImportPlanningCollisions.Structural.Shape.Details+    Generated.ImportPlanningCollisions.StructuralConformance+    Generated.ImportPlanningCollisions.StructuralProjections+    ImportPlanning.Bindings+    ImportPlanningCollisions.CollisionLedger.BehaviorHoles++build-depends:+    , aeson+    , base+    , keiki+    , keiro+    , keiro-dsl+    , text++consumer-packages:+    keiro-dsl++consumer-modules:+    ImportPlanning.Bindings+    ImportPlanning.Consumer.Domain+    ImportPlanning.Consumer.Invoice.Types+    ImportPlanning.Consumer.Order.Types+    ImportPlanning.Consumer.Shared.Types

+ test/conformance-import-planning/keiro-dsl-ledger.context.import-planning-collisions.txt view

@@ -0,0 +1,52 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/import-planning-collisions.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":4,"effectiveLanguageVersion":4,"sourceForm":"declared"}+semantic-contract {"languageSupport":"compatibility-only","languageVersion":4,"runtimeSemantics":"keiro-dsl/runtime-semantics/3"}+naming-edition idiomatic-v2+module-role {"family":"StructuralConformance","kind":"generated","ownerKind":"context","ownerName":"context import-planning-collisions structural conformance","path":"Generated/ImportPlanningCollisions/StructuralConformance.hs"}+module-role {"family":"BehaviorSourceMap","kind":"generated","ownerKind":"context","ownerName":"context import-planning-collisions behavior source map","path":"Generated/ImportPlanningCollisions/BehaviorSourceMap.hs"}+module-role {"family":"Details","kind":"generated","ownerKind":"mapped","ownerName":"mapped structural Details (line 28)","path":"Generated/ImportPlanningCollisions/Structural/Shape/Details.hs"}+module-role {"family":"StructuralProjections","kind":"generated","ownerKind":"context","ownerName":"context import-planning-collisions mapped structural facade","path":"Generated/ImportPlanningCollisions/StructuralProjections.hs"}+module-role {"family":"NominalProjections","kind":"generated","ownerKind":"context","ownerName":"context import-planning-collisions nominal scalar projection facade","path":"Generated/ImportPlanningCollisions/NominalProjections.hs"}+module-role {"family":"Bindings","kind":"hole","ownerKind":"consumer","ownerName":"consumer binding skeleton ImportPlanning.Bindings","path":"ImportPlanning/Bindings.hs"}+module-role {"family":"ReplayAudit","kind":"generated","ownerKind":"context","ownerName":"context import-planning-collisions replay-audit assembly","path":"Generated/ImportPlanningCollisions/ReplayAudit.hs"}+module-role {"family":"Domain","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate CollisionLedger (line 39)","path":"Generated/ImportPlanningCollisions/CollisionLedger/Domain.hs"}+module-role {"family":"Codec","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate CollisionLedger (line 39)","path":"Generated/ImportPlanningCollisions/CollisionLedger/Codec.hs"}+module-role {"family":"Transducer","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate CollisionLedger (line 39)","path":"Generated/ImportPlanningCollisions/CollisionLedger/Transducer.hs"}+module-role {"family":"BehaviorContract","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate CollisionLedger (line 39)","path":"Generated/ImportPlanningCollisions/CollisionLedger/BehaviorContract.hs"}+module-role {"family":"BehaviorHoles","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate behavior witnesses CollisionLedger (line 39)","path":"ImportPlanningCollisions/CollisionLedger/BehaviorHoles.hs"}+module-role {"family":"EventStream","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate CollisionLedger (line 39)","path":"Generated/ImportPlanningCollisions/CollisionLedger/EventStream.hs"}+module-role {"family":"Projection","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate CollisionLedger (line 39)","path":"Generated/ImportPlanningCollisions/CollisionLedger/Projection.hs"}+module-role {"family":"Harness","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate CollisionLedger (line 39)","path":"Generated/ImportPlanningCollisions/CollisionLedger/Harness.hs"}+generated Generated/ImportPlanningCollisions/StructuralConformance.hs+generated Generated/ImportPlanningCollisions/BehaviorSourceMap.hs+generated Generated/ImportPlanningCollisions/Structural/Shape/Details.hs+generated Generated/ImportPlanningCollisions/StructuralProjections.hs+generated Generated/ImportPlanningCollisions/NominalProjections.hs+hole ImportPlanning/Bindings.hs+generated Generated/ImportPlanningCollisions/ReplayAudit.hs+generated Generated/ImportPlanningCollisions/CollisionLedger/Domain.hs+generated Generated/ImportPlanningCollisions/CollisionLedger/Codec.hs+generated Generated/ImportPlanningCollisions/CollisionLedger/Transducer.hs+generated Generated/ImportPlanningCollisions/CollisionLedger/BehaviorContract.hs+hole ImportPlanningCollisions/CollisionLedger/BehaviorHoles.hs+generated Generated/ImportPlanningCollisions/CollisionLedger/EventStream.hs+generated Generated/ImportPlanningCollisions/CollisionLedger/Projection.hs+generated Generated/ImportPlanningCollisions/CollisionLedger/Harness.hs+mapping {"bindingSymbol":"ImportPlanning.Bindings.detailsBinding","bindingVersion":"1","canonicalType":"import-planning.Details.v1","mode":"structural","module":"ImportPlanning.Consumer.Shared.Types","package":"keiro-dsl","schema":1,"specName":"Details","type":"Details"}+nominal-mapping {"bindingSymbol":"ImportPlanning.Bindings.invoiceStatusBinding","bindingVersion":"1","canonicalType":"import-planning.InvoiceStatus.v1","category":"scalar","fixtureSymbol":"ImportPlanning.Bindings.invoiceStatusFixtures","initialSymbol":null,"mode":"nominal","module":"ImportPlanning.Consumer.Invoice.Types","package":"keiro-dsl","representation":"Text","schema":1,"specName":"InvoiceStatus","type":"Status"}+nominal-mapping {"bindingSymbol":"ImportPlanning.Bindings.localCollisionBinding","bindingVersion":"1","canonicalType":"import-planning.LocalCollision.v1","category":"scalar","fixtureSymbol":"ImportPlanning.Bindings.localCollisionFixtures","initialSymbol":null,"mode":"nominal","module":"ImportPlanning.Consumer.Domain","package":"keiro-dsl","representation":"Text","schema":1,"specName":"LocalCollision","type":"CollisionLedgerCommand"}+nominal-mapping {"bindingSymbol":"ImportPlanning.Bindings.orderStatusBinding","bindingVersion":"1","canonicalType":"import-planning.OrderStatus.v1","category":"scalar","fixtureSymbol":"ImportPlanning.Bindings.orderStatusFixtures","initialSymbol":null,"mode":"nominal","module":"ImportPlanning.Consumer.Order.Types","package":"keiro-dsl","representation":"Text","schema":1,"specName":"OrderStatus","type":"Status"}+binding {"kind":"binding","mappedName":"Details","module":"ImportPlanning.Bindings","path":"label","schema":1,"signature":"detailsBinding.label :: Text","symbol":"detailsBinding"}+binding {"kind":"fixtures","mappedName":"Details","module":"ImportPlanning.Bindings","path":null,"schema":1,"signature":"detailsFixtures :: FixtureCases ImportPlanning.Consumer.Shared.Types.Details","symbol":"detailsFixtures"}+binding {"kind":"binding","mappedName":"InvoiceStatus","module":"ImportPlanning.Bindings","path":null,"schema":1,"signature":"invoiceStatusBinding :: NominalBinding ImportPlanning.Consumer.Invoice.Types.Status Text","symbol":"invoiceStatusBinding"}+binding {"kind":"fixtures","mappedName":"InvoiceStatus","module":"ImportPlanning.Bindings","path":null,"schema":1,"signature":"invoiceStatusFixtures :: NominalFixtureCases ImportPlanning.Consumer.Invoice.Types.Status","symbol":"invoiceStatusFixtures"}+binding {"kind":"binding","mappedName":"LocalCollision","module":"ImportPlanning.Bindings","path":null,"schema":1,"signature":"localCollisionBinding :: NominalBinding ImportPlanning.Consumer.Domain.CollisionLedgerCommand Text","symbol":"localCollisionBinding"}+binding {"kind":"fixtures","mappedName":"LocalCollision","module":"ImportPlanning.Bindings","path":null,"schema":1,"signature":"localCollisionFixtures :: NominalFixtureCases ImportPlanning.Consumer.Domain.CollisionLedgerCommand","symbol":"localCollisionFixtures"}+binding {"kind":"binding","mappedName":"OrderStatus","module":"ImportPlanning.Bindings","path":null,"schema":1,"signature":"orderStatusBinding :: NominalBinding ImportPlanning.Consumer.Order.Types.Status Text","symbol":"orderStatusBinding"}+binding {"kind":"fixtures","mappedName":"OrderStatus","module":"ImportPlanning.Bindings","path":null,"schema":1,"signature":"orderStatusFixtures :: NominalFixtureCases ImportPlanning.Consumer.Order.Types.Status","symbol":"orderStatusFixtures"}+behavior {"aggregate":"CollisionLedger","command":"Record","evidence":"generated-authoritative","key":"behavior-v1-2134fce4a19c59d7","kind":"live-transition","outputs":[{"command":"Record","ownership":"generated-command-identity"}],"source":"Empty"}+behavior {"aggregate":"CollisionLedger","command":"Record","evidence":"generated-authoritative","key":"behavior-v1-995f9bf710ce7c6c","kind":"required-rejection","outputs":[],"source":"Recorded"}+semantic-impact {"declarations":[{"consequences":[{"consumer":"CollisionLedger","kind":"consumer-build"},{"aggregate":"CollisionLedger","kind":"private-event-history"}],"consumerEvidence":[{"consumer":"CollisionLedger","operation":null,"path":"CollisionLedger command Record .details : Details","surface":"aggregate-command"},{"consumer":"CollisionLedger","operation":null,"path":"CollisionLedger event RecordedValues .details : Details","surface":"private-event-payload"}],"consumers":["CollisionLedger"],"declaration":"Details","identity":"structural\u001fkeiro-dsl:ImportPlanning.Consumer.Shared.Types:Details\u001fImportPlanning.Bindings.detailsBinding\u001f1\u001fimport-planning.Details.v1\u001fImportPlanning.Bindings.detailsFixtures\u001f\u001f7b2032febfe42f05\u001frecord:Details:label=label"}],"mappedSurfaceEvidenceVersion":1,"serviceInventory":["Details"]}

+ test/conformance-intake-full/Generated/HospitalCapacity/Emergency/Contract.hs view

@@ -0,0 +1,64 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from contract emergency; do not edit.+module Generated.HospitalCapacity.Emergency.Contract+  ( EmergencyPayload (..)+  , IncidentTransferNeedDeclaredData (..)+  , incidentEventsTopic+  , messageTypeOf+  , encodeEmergencyPayload+  , parseEmergencyPayload+  ) where++import Data.Aeson (Value, object, withObject, withText, (.:), (.=))+import Data.Aeson.Types (Parser, explicitParseField, parseEither)+import Data.KindID (KindID)+import qualified Data.KindID as KindID+import Data.Text (Text)+import qualified Data.Text as T+import Keiro.Codec.IdDomain (parseKindIdV7Value)++-- topic constants+incidentEventsTopic :: Text+incidentEventsTopic = "emergency.incident.events"++-- the closed payload set (discriminated by "messageType")+data IncidentTransferNeedDeclaredData = IncidentTransferNeedDeclaredData {incidentId :: !(KindID "inc"), region :: !Text}+  deriving stock (Eq, Show)++data EmergencyPayload+  = IncidentTransferNeedDeclared !IncidentTransferNeedDeclaredData+  deriving stock (Eq, Show)++messageTypeOf :: EmergencyPayload -> Text+messageTypeOf = \case+  IncidentTransferNeedDeclared {} -> "IncidentTransferNeedDeclared"++encodeEmergencyPayload :: EmergencyPayload -> Value+encodeEmergencyPayload = \case+  IncidentTransferNeedDeclared payload ->+    object+      [ "messageType" .= ("IncidentTransferNeedDeclared" :: Text),+        "incidentId" .= KindID.toText payload.incidentId,+        "region" .= payload.region+      ]++parseEmergencyPayload :: Value -> Either Text EmergencyPayload+parseEmergencyPayload = mapLeftText . parseEither (withObject "EmergencyPayload" go)+  where+    go o = do+      kind <- explicitParseField (withText "messageType" validateMessageType) o "messageType"+      case kind of+        "IncidentTransferNeedDeclared" ->+          IncidentTransferNeedDeclared+            <$> ( IncidentTransferNeedDeclaredData+                    <$> explicitParseField (parseKindIdV7Value @"inc") o "incidentId"+                    <*> o .: "region"+                )+        _ -> 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` ["IncidentTransferNeedDeclared"] = pure kind+  | otherwise = fail ("unknown message type " <> show kind <> "; expected one of: IncidentTransferNeedDeclared")

test/conformance-intake-full/Generated/HospitalCapacity/IncidentInbox/Inbox.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from intake incidentInbox; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from intake incidentInbox; do not edit. module Generated.HospitalCapacity.IncidentInbox.Inbox   ( InboxFailure (..)   , IncidentInboxOutcome (..)@@ -24,8 +24,8 @@  -- Runtime failure detail retained when the inbox wrapper reports a failed handler attempt. data InboxFailure = InboxFailure-  { inboxFailureReason :: !Text-  , inboxFailureAttempt :: !(Maybe Int)+  { reason :: !Text+  , attempt :: !(Maybe Int)   }   deriving stock (Eq, Show)

+ test/conformance-intake-full/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

@@ -0,0 +1,26 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/intake.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    Generated.HospitalCapacity.Emergency.Contract+    Generated.HospitalCapacity.IncidentInbox.Inbox++build-depends:+    , aeson+    , base+    , effectful-core+    , hasql-transaction+    , keiro+    , keiro-core+    , kiroku-store+    , mmzk-typeid+    , text

+ test/conformance-intake-full/keiro-dsl-ledger.context.hospital-capacity.txt view

@@ -0,0 +1,13 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/intake.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":4,"effectiveLanguageVersion":4,"sourceForm":"declared"}+semantic-contract {"languageSupport":"compatibility-only","languageVersion":4,"runtimeSemantics":"keiro-dsl/runtime-semantics/3"}+naming-edition idiomatic-v2+module-role {"family":"Contract","kind":"generated","ownerKind":"contract","ownerName":"contract emergency (line 4)","path":"Generated/HospitalCapacity/Emergency/Contract.hs"}+module-role {"family":"Inbox","kind":"generated","ownerKind":"intake","ownerName":"intake incidentInbox (line 14)","path":"Generated/HospitalCapacity/IncidentInbox/Inbox.hs"}+generated Generated/HospitalCapacity/Emergency/Contract.hs+generated Generated/HospitalCapacity/IncidentInbox/Inbox.hs+id-domain id-domain|name=contract:emergency.IncidentTransferNeedDeclared.incidentId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=inc|separator=_|json=canonical-json-text+semantic-impact {"declarations":[],"mappedSurfaceEvidenceVersion":1,"serviceInventory":[]}

+ test/conformance-intake-runtime/Generated/HospitalCapacity/Emergency/Contract.hs view

@@ -0,0 +1,64 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from contract emergency; do not edit.+module Generated.HospitalCapacity.Emergency.Contract+  ( EmergencyPayload (..)+  , IncidentTransferNeedDeclaredData (..)+  , incidentEventsTopic+  , messageTypeOf+  , encodeEmergencyPayload+  , parseEmergencyPayload+  ) where++import Data.Aeson (Value, object, withObject, withText, (.:), (.=))+import Data.Aeson.Types (Parser, explicitParseField, parseEither)+import Data.KindID (KindID)+import qualified Data.KindID as KindID+import Data.Text (Text)+import qualified Data.Text as T+import Keiro.Codec.IdDomain (parseKindIdV7Value)++-- topic constants+incidentEventsTopic :: Text+incidentEventsTopic = "emergency.incident.events"++-- the closed payload set (discriminated by "messageType")+data IncidentTransferNeedDeclaredData = IncidentTransferNeedDeclaredData {incidentId :: !(KindID "inc"), region :: !Text}+  deriving stock (Eq, Show)++data EmergencyPayload+  = IncidentTransferNeedDeclared !IncidentTransferNeedDeclaredData+  deriving stock (Eq, Show)++messageTypeOf :: EmergencyPayload -> Text+messageTypeOf = \case+  IncidentTransferNeedDeclared {} -> "IncidentTransferNeedDeclared"++encodeEmergencyPayload :: EmergencyPayload -> Value+encodeEmergencyPayload = \case+  IncidentTransferNeedDeclared payload ->+    object+      [ "messageType" .= ("IncidentTransferNeedDeclared" :: Text),+        "incidentId" .= KindID.toText payload.incidentId,+        "region" .= payload.region+      ]++parseEmergencyPayload :: Value -> Either Text EmergencyPayload+parseEmergencyPayload = mapLeftText . parseEither (withObject "EmergencyPayload" go)+  where+    go o = do+      kind <- explicitParseField (withText "messageType" validateMessageType) o "messageType"+      case kind of+        "IncidentTransferNeedDeclared" ->+          IncidentTransferNeedDeclared+            <$> ( IncidentTransferNeedDeclaredData+                    <$> explicitParseField (parseKindIdV7Value @"inc") o "incidentId"+                    <*> o .: "region"+                )+        _ -> 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` ["IncidentTransferNeedDeclared"] = pure kind+  | otherwise = fail ("unknown message type " <> show kind <> "; expected one of: IncidentTransferNeedDeclared")

test/conformance-intake-runtime/Generated/HospitalCapacity/IncidentInbox/Inbox.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from intake incidentInbox; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from intake incidentInbox; do not edit. module Generated.HospitalCapacity.IncidentInbox.Inbox   ( InboxFailure (..)   , IncidentInboxOutcome (..)@@ -24,8 +24,8 @@  -- Runtime failure detail retained when the inbox wrapper reports a failed handler attempt. data InboxFailure = InboxFailure-  { inboxFailureReason :: !Text-  , inboxFailureAttempt :: !(Maybe Int)+  { reason :: !Text+  , attempt :: !(Maybe Int)   }   deriving stock (Eq, Show)

+ test/conformance-intake-runtime/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

@@ -0,0 +1,26 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/intake.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    Generated.HospitalCapacity.Emergency.Contract+    Generated.HospitalCapacity.IncidentInbox.Inbox++build-depends:+    , aeson+    , base+    , effectful-core+    , hasql-transaction+    , keiro+    , keiro-core+    , kiroku-store+    , mmzk-typeid+    , text

+ test/conformance-intake-runtime/keiro-dsl-ledger.context.hospital-capacity.txt view

@@ -0,0 +1,13 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/intake.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":4,"effectiveLanguageVersion":4,"sourceForm":"declared"}+semantic-contract {"languageSupport":"compatibility-only","languageVersion":4,"runtimeSemantics":"keiro-dsl/runtime-semantics/3"}+naming-edition idiomatic-v2+module-role {"family":"Contract","kind":"generated","ownerKind":"contract","ownerName":"contract emergency (line 4)","path":"Generated/HospitalCapacity/Emergency/Contract.hs"}+module-role {"family":"Inbox","kind":"generated","ownerKind":"intake","ownerName":"intake incidentInbox (line 14)","path":"Generated/HospitalCapacity/IncidentInbox/Inbox.hs"}+generated Generated/HospitalCapacity/Emergency/Contract.hs+generated Generated/HospitalCapacity/IncidentInbox/Inbox.hs+id-domain id-domain|name=contract:emergency.IncidentTransferNeedDeclared.incidentId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=inc|separator=_|json=canonical-json-text+semantic-impact {"declarations":[],"mappedSurfaceEvidenceVersion":1,"serviceInventory":[]}

test/conformance-mapped-queue/Generated/MappedQueue/MappedJobs/Queue.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from workqueue mapped_jobs; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from workqueue mapped_jobs; do not edit. module Generated.MappedQueue.MappedJobs.Queue   ( MappedJob (..)   , encodeMappedJob@@ -49,7 +48,7 @@ encodeJobMetadataShape :: ShapeJobMetadata.JobMetadataShape -> Value encodeJobMetadataShape shape =   object-      [ "note" .= maybe Null (\item -> toJSON (item)) (ShapeJobMetadata.note shape)+      [ "note" .= maybe Null (\item -> toJSON (item)) (shape.note)       ]  parseJobMetadataShape :: Value -> Parser ShapeJobMetadata.JobMetadataShape@@ -69,10 +68,10 @@ 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)+      [ "job_id" .= toJSON (shape.jobId)+      , "label" .= toJSON (shape.label)+      , "metadata" .= maybe Null (\item -> encodeJobMetadataShape (item)) (shape.metadata)+      , "geometry" .= toJSON (shape.geometry)       ]  parseJobPayloadShape :: Value -> Parser ShapeJobPayload.JobPayloadShape

test/conformance-mapped-queue/Generated/MappedQueue/MappedJobs/QueueCodec.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from workqueue mapped_jobs; do not edit.+-- @generated by keiro-dsl 0.15.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

test/conformance-mapped-queue/Generated/MappedQueue/MappedJobs/QueuePolicy.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from workqueue mapped_jobs; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from workqueue mapped_jobs; do not edit. module Generated.MappedQueue.MappedJobs.QueuePolicy   ( MappedJobsOutcome (..)   , retryPolicy, jobOutcomeFor

test/conformance-mapped-queue/Generated/MappedQueue/Structural/Shape/JobMetadata.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from mapped structural JobMetadata; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-mapped-queue/Generated/MappedQueue/Structural/Shape/JobPayload.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from mapped structural JobPayload; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-mapped-queue/Generated/MappedQueue/StructuralConformance.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from context mapped-queue structural conformance; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from context mapped-queue structural conformance; do not edit. module Generated.MappedQueue.StructuralConformance   ( structuralConformanceAssertions   ) where@@ -13,10 +13,10 @@ import Keiki.Shape (CanonicalTypeName (..)) import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape) import Generated.MappedQueue.StructuralProjections qualified as StructuralProjections+import Generated.MappedQueue.Structural.Shape.JobMetadata (JobMetadataShape(note))+import Generated.MappedQueue.Structural.Shape.JobPayload (JobPayloadShape(jobId, label, metadata)) 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 =@@ -71,17 +71,17 @@     cases = fixtureCases Bindings.geometryCases  coverageJobMetadata :: Bool-coverageJobMetadata = any (isNothing . ShapeJobMetadata.note) shapes && any (isJust . ShapeJobMetadata.note) shapes+coverageJobMetadata = any (isNothing . (.note)) shapes && any (isJust . (.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+coverageJobPayload = any (isNothing . (.metadata)) shapes && any (isJust . (.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)))+  [ ("projection witness agreement: conformance.mapped-queue.JobPayload.v1/job_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.jobPayloadJobIdWitness (\referenceOwner -> (bindingToShape Bindings.jobPayloadBinding referenceOwner).jobId) owner) (NonEmpty.toList (fixtureCases Bindings.jobPayloadCases)))+  , ("projection witness agreement: conformance.mapped-queue.JobPayload.v1/label", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.jobPayloadLabelWitness (\referenceOwner -> (bindingToShape Bindings.jobPayloadBinding referenceOwner).label) owner) (NonEmpty.toList (fixtureCases Bindings.jobPayloadCases)))   ]

test/conformance-mapped-queue/Generated/MappedQueue/StructuralProjections.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from context mapped-queue mapped structural facade; do not edit.+-- @generated by keiro-dsl 0.15.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@@ -10,9 +10,9 @@ import Data.Text (Text) import Keiro.Codec.Structural (bindingToShape) import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)+import Generated.MappedQueue.Structural.Shape.JobPayload (JobPayloadShape(jobId, label)) import Conformance.MappedQueue.Bindings qualified as Bindings import Conformance.MappedQueue.Domain (JobPayload)-import Generated.MappedQueue.Structural.Shape.JobPayload qualified as ShapeJobPayload  data JobPayloadJobIdProjection @@ -21,7 +21,7 @@   type FieldOwner JobPayloadJobIdProjection = JobPayload   type FieldResult JobPayloadJobIdProjection = Text   fieldShapeId _ = "conformance.mapped-queue.JobPayload.v1"-  projectFieldValue _ owner = ShapeJobPayload.jobId (bindingToShape Bindings.jobPayloadBinding owner)+  projectFieldValue _ owner = (bindingToShape Bindings.jobPayloadBinding owner).jobId  jobPayloadJobIdWitness :: FieldWitness JobPayloadJobIdProjection jobPayloadJobIdWitness = fieldWitness @JobPayloadJobIdProjection@@ -33,7 +33,7 @@   type FieldOwner JobPayloadLabelProjection = JobPayload   type FieldResult JobPayloadLabelProjection = Text   fieldShapeId _ = "conformance.mapped-queue.JobPayload.v1"-  projectFieldValue _ owner = ShapeJobPayload.label (bindingToShape Bindings.jobPayloadBinding owner)+  projectFieldValue _ owner = (bindingToShape Bindings.jobPayloadBinding owner).label  jobPayloadLabelWitness :: FieldWitness JobPayloadLabelProjection jobPayloadLabelWitness = fieldWitness @JobPayloadLabelProjection

test/conformance-mapped-queue/Main.hs view

@@ -47,7 +47,7 @@         [ ("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),+          ("present null admits Optional", ((\mappedJob -> mappedJob.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")

+ test/conformance-mapped-queue/keiro-dsl-cabal-fragment.context.mapped-queue.txt view

@@ -0,0 +1,36 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/mapped-workqueue.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    Conformance.MappedQueue.Bindings+    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+    , base+    , keiro-core+    , keiro-dsl+    , keiro-pgmq+    , text++consumer-packages:+    keiro-dsl++consumer-modules:+    Conformance.MappedQueue.Bindings+    Conformance.MappedQueue.Domain

+ test/conformance-mapped-queue/keiro-dsl-ledger.context.mapped-queue.txt view

@@ -0,0 +1,34 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/mapped-workqueue.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":5,"effectiveLanguageVersion":5,"sourceForm":"declared"}+semantic-contract {"languageSupport":"stable","languageVersion":5,"runtimeSemantics":"keiro-dsl/runtime-semantics/4"}+naming-edition idiomatic-v2+module-role {"family":"StructuralConformance","kind":"generated","ownerKind":"context","ownerName":"context mapped-queue structural conformance","path":"Generated/MappedQueue/StructuralConformance.hs"}+module-role {"family":"JobMetadata","kind":"generated","ownerKind":"mapped","ownerName":"mapped structural JobMetadata (line 4)","path":"Generated/MappedQueue/Structural/Shape/JobMetadata.hs"}+module-role {"family":"JobPayload","kind":"generated","ownerKind":"mapped","ownerName":"mapped structural JobPayload (line 22)","path":"Generated/MappedQueue/Structural/Shape/JobPayload.hs"}+module-role {"family":"StructuralProjections","kind":"generated","ownerKind":"context","ownerName":"context mapped-queue mapped structural facade","path":"Generated/MappedQueue/StructuralProjections.hs"}+module-role {"family":"Bindings","kind":"hole","ownerKind":"consumer","ownerName":"consumer binding skeleton Conformance.MappedQueue.Bindings","path":"Conformance/MappedQueue/Bindings.hs"}+module-role {"family":"Queue","kind":"generated","ownerKind":"workqueue","ownerName":"workqueue mapped_jobs (line 36)","path":"Generated/MappedQueue/MappedJobs/Queue.hs"}+module-role {"family":"QueuePolicy","kind":"generated","ownerKind":"workqueue","ownerName":"workqueue mapped_jobs (line 36)","path":"Generated/MappedQueue/MappedJobs/QueuePolicy.hs"}+module-role {"family":"QueueCodec","kind":"generated","ownerKind":"workqueue","ownerName":"workqueue mapped_jobs (line 36)","path":"Generated/MappedQueue/MappedJobs/QueueCodec.hs"}+generated Generated/MappedQueue/StructuralConformance.hs+generated Generated/MappedQueue/Structural/Shape/JobMetadata.hs+generated Generated/MappedQueue/Structural/Shape/JobPayload.hs+generated Generated/MappedQueue/StructuralProjections.hs+hole Conformance/MappedQueue/Bindings.hs+generated Generated/MappedQueue/MappedJobs/Queue.hs+generated Generated/MappedQueue/MappedJobs/QueuePolicy.hs+generated Generated/MappedQueue/MappedJobs/QueueCodec.hs+mapping {"bindingSymbol":"Conformance.MappedQueue.Bindings.jobMetadataBinding","bindingVersion":"1","canonicalType":"conformance.mapped-queue.JobMetadata.v1","mode":"structural","module":"Conformance.MappedQueue.Domain","package":"keiro-dsl","schema":1,"specName":"JobMetadata","type":"JobMetadata"}+mapping {"bindingSymbol":"Conformance.MappedQueue.Bindings.jobPayloadBinding","bindingVersion":"1","canonicalType":"conformance.mapped-queue.JobPayload.v1","mode":"structural","module":"Conformance.MappedQueue.Domain","package":"keiro-dsl","schema":1,"specName":"JobPayload","type":"JobPayload"}+mapping {"codecIdentity":"vendor.geometry.json","codecVersion":"3","mode":"opaque","module":"Conformance.MappedQueue.Domain","package":"keiro-dsl","schema":1,"specName":"VendorGeometry","type":"Geometry"}+binding {"kind":"binding","mappedName":"JobMetadata","module":"Conformance.MappedQueue.Bindings","path":"note","schema":1,"signature":"jobMetadataBinding.note :: Maybe (Text)","symbol":"jobMetadataBinding"}+binding {"kind":"fixtures","mappedName":"JobMetadata","module":"Conformance.MappedQueue.Bindings","path":null,"schema":1,"signature":"jobMetadataCases :: FixtureCases Conformance.MappedQueue.Domain.JobMetadata","symbol":"jobMetadataCases"}+binding {"kind":"binding","mappedName":"JobPayload","module":"Conformance.MappedQueue.Bindings","path":"geometry","schema":1,"signature":"jobPayloadBinding.geometry :: VendorGeometry","symbol":"jobPayloadBinding"}+binding {"kind":"binding","mappedName":"JobPayload","module":"Conformance.MappedQueue.Bindings","path":"jobId","schema":1,"signature":"jobPayloadBinding.jobId :: Text","symbol":"jobPayloadBinding"}+binding {"kind":"binding","mappedName":"JobPayload","module":"Conformance.MappedQueue.Bindings","path":"label","schema":1,"signature":"jobPayloadBinding.label :: Text","symbol":"jobPayloadBinding"}+binding {"kind":"binding","mappedName":"JobPayload","module":"Conformance.MappedQueue.Bindings","path":"metadata","schema":1,"signature":"jobPayloadBinding.metadata :: Maybe (JobMetadata)","symbol":"jobPayloadBinding"}+binding {"kind":"fixtures","mappedName":"JobPayload","module":"Conformance.MappedQueue.Bindings","path":null,"schema":1,"signature":"jobPayloadCases :: FixtureCases Conformance.MappedQueue.Domain.JobPayload","symbol":"jobPayloadCases"}+semantic-impact {"declarations":[{"consequences":[{"consumer":"workqueue:mapped_jobs","kind":"consumer-build"},{"kind":"workqueue-history","workqueue":"mapped_jobs"}],"consumerEvidence":[{"consumer":"workqueue:mapped_jobs","operation":null,"path":"workqueue mapped_jobs payload .job : JobPayload .metadata optional : JobMetadata","surface":"workqueue-payload"},{"consumer":"workqueue:mapped_jobs","operation":null,"path":"workqueue mapped_jobs payload .maybeJob : JobPayload optional .metadata optional : JobMetadata","surface":"workqueue-payload"}],"consumers":["workqueue:mapped_jobs"],"declaration":"JobMetadata","identity":"structural\u001fkeiro-dsl:Conformance.MappedQueue.Domain:JobMetadata\u001fConformance.MappedQueue.Bindings.jobMetadataBinding\u001f1\u001fconformance.mapped-queue.JobMetadata.v1\u001fConformance.MappedQueue.Bindings.jobMetadataCases\u001f\u001ff10533b35dd555c7\u001frecord:JobMetadata:note=note"},{"consequences":[{"consumer":"workqueue:mapped_jobs","kind":"consumer-build"},{"kind":"workqueue-history","workqueue":"mapped_jobs"}],"consumerEvidence":[{"consumer":"workqueue:mapped_jobs","operation":null,"path":"workqueue mapped_jobs payload .job : JobPayload","surface":"workqueue-payload"},{"consumer":"workqueue:mapped_jobs","operation":null,"path":"workqueue mapped_jobs payload .maybeJob : JobPayload optional","surface":"workqueue-payload"}],"consumers":["workqueue:mapped_jobs"],"declaration":"JobPayload","identity":"structural\u001fkeiro-dsl:Conformance.MappedQueue.Domain:JobPayload\u001fConformance.MappedQueue.Bindings.jobPayloadBinding\u001f1\u001fconformance.mapped-queue.JobPayload.v1\u001fConformance.MappedQueue.Bindings.jobPayloadCases\u001f\u001f505e56c69372c292\u001frecord:JobPayload:geometry=geometry,jobId=job_id,label=label,metadata=metadata"},{"consequences":[{"consumer":"workqueue:mapped_jobs","kind":"consumer-build"},{"kind":"workqueue-history","workqueue":"mapped_jobs"}],"consumerEvidence":[{"consumer":"workqueue:mapped_jobs","operation":null,"path":"workqueue mapped_jobs payload .job : JobPayload .geometry : VendorGeometry","surface":"workqueue-payload"},{"consumer":"workqueue:mapped_jobs","operation":null,"path":"workqueue mapped_jobs payload .maybeJob : JobPayload optional .geometry : VendorGeometry","surface":"workqueue-payload"}],"consumers":["workqueue:mapped_jobs"],"declaration":"VendorGeometry","identity":"opaque\u001fkeiro-dsl:Conformance.MappedQueue.Domain:Geometry\u001fvendor.geometry.json\u001f3\u001fConformance.MappedQueue.Bindings.geometryCases\u001f\u001f0555463e4335c898"}],"mappedSurfaceEvidenceVersion":1,"serviceInventory":["JobMetadata","JobPayload","VendorGeometry"]}

test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/QueryContract.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel account_summary; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from readmodel account_summary; do not edit. module Generated.MappedReadmodel.AccountSummary.QueryContract   ( AccountSummaryQueryInput   , AccountSummaryQueryResult

test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/ReadModel.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel account_summary; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from readmodel account_summary; do not edit. module Generated.MappedReadmodel.AccountSummary.ReadModel   ( accountSummaryReadModel   , accountSummaryQualifiedTable

test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/ReadModelHarness.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel account_summary; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-mapped-readmodel/Generated/MappedReadmodel/AccountSummary/ReadModelTable.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel account_summary; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from readmodel account_summary; do not edit. module Generated.MappedReadmodel.AccountSummary.ReadModelTable (accountSummaryQualifiedTable) where  import Data.Text (Text)

test/conformance-mapped-readmodel/Generated/MappedReadmodel/ProjectionCatalog.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from projection-catalog mapped-readmodel; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from projection-catalog mapped-readmodel; do not edit. {-# LANGUAGE OverloadedStrings #-} module Generated.MappedReadmodel.ProjectionCatalog   ( projectionCatalog

test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/AccountLookup.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from mapped structural AccountLookup; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/AccountProfile.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from mapped structural AccountProfile; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/AccountSummary.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from mapped structural AccountSummary; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/TenantKey.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from mapped structural TenantKey; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-mapped-readmodel/Generated/MappedReadmodel/Structural/Shape/UnusedFilter.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from mapped structural UnusedFilter; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-mapped-readmodel/Generated/MappedReadmodel/StructuralConformance.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from context mapped-readmodel structural conformance; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from context mapped-readmodel structural conformance; do not edit. module Generated.MappedReadmodel.StructuralConformance   ( structuralConformanceAssertions   ) where@@ -12,13 +12,13 @@ import Keiki.Shape (CanonicalTypeName (..)) import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape) import Generated.MappedReadmodel.StructuralProjections qualified as StructuralProjections+import Generated.MappedReadmodel.Structural.Shape.AccountLookup (AccountLookupShape(accountId, tenant))+import Generated.MappedReadmodel.Structural.Shape.AccountProfile (AccountProfileShape(displayName))+import Generated.MappedReadmodel.Structural.Shape.AccountSummary (AccountSummaryShape(accountId, profile, tenant))+import Generated.MappedReadmodel.Structural.Shape.TenantKey (TenantKeyShape(tenantId))+import Generated.MappedReadmodel.Structural.Shape.UnusedFilter (UnusedFilterShape(prefix)) 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 =@@ -114,7 +114,7 @@ coverageAccountProfile = True  coverageAccountSummary :: Bool-coverageAccountSummary = any (isNothing . ShapeAccountSummary.profile) shapes && any (isJust . ShapeAccountSummary.profile) shapes+coverageAccountSummary = any (isNothing . (.profile)) shapes && any (isJust . (.profile)) shapes   where     shapes = map (bindingToShape Bindings.accountSummaryBinding . snd) (NonEmpty.toList (fixtureCases Bindings.accountSummaryCases)) @@ -126,11 +126,11 @@  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)))+  [ ("projection witness agreement: conformance.mapped-readmodel.AccountLookup.v1/account_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.accountLookupAccountIdWitness (\referenceOwner -> (bindingToShape Bindings.accountLookupBinding referenceOwner).accountId) owner) (NonEmpty.toList (fixtureCases Bindings.accountLookupCases)))+  , ("projection witness agreement: conformance.mapped-readmodel.AccountLookup.v1/tenant/tenant_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.accountLookupTenantTenantIdWitness (\referenceOwner -> ((bindingToShape Bindings.accountLookupBinding referenceOwner).tenant).tenantId) owner) (NonEmpty.toList (fixtureCases Bindings.accountLookupCases)))+  , ("projection witness agreement: conformance.mapped-readmodel.AccountProfile.v1/display_name", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.accountProfileDisplayNameWitness (\referenceOwner -> (bindingToShape Bindings.accountProfileBinding referenceOwner).displayName) owner) (NonEmpty.toList (fixtureCases Bindings.accountProfileCases)))+  , ("projection witness agreement: conformance.mapped-readmodel.AccountSummary.v1/account_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.accountSummaryAccountIdWitness (\referenceOwner -> (bindingToShape Bindings.accountSummaryBinding referenceOwner).accountId) owner) (NonEmpty.toList (fixtureCases Bindings.accountSummaryCases)))+  , ("projection witness agreement: conformance.mapped-readmodel.AccountSummary.v1/tenant/tenant_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.accountSummaryTenantTenantIdWitness (\referenceOwner -> ((bindingToShape Bindings.accountSummaryBinding referenceOwner).tenant).tenantId) owner) (NonEmpty.toList (fixtureCases Bindings.accountSummaryCases)))+  , ("projection witness agreement: conformance.mapped-readmodel.TenantKey.v1/tenant_id", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.tenantKeyTenantIdWitness (\referenceOwner -> (bindingToShape Bindings.tenantKeyBinding referenceOwner).tenantId) owner) (NonEmpty.toList (fixtureCases Bindings.tenantKeyCases)))+  , ("projection witness agreement: conformance.mapped-readmodel.UnusedFilter.v1/prefix", all (\(_, owner) -> fieldWitnessAgrees StructuralProjections.unusedFilterPrefixWitness (\referenceOwner -> (bindingToShape Bindings.unusedFilterBinding referenceOwner).prefix) owner) (NonEmpty.toList (fixtureCases Bindings.unusedFilterCases)))   ]

test/conformance-mapped-readmodel/Generated/MappedReadmodel/StructuralProjections.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from context mapped-readmodel mapped structural facade; do not edit.+-- @generated by keiro-dsl 0.15.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@@ -15,13 +15,13 @@ import Data.Text (Text) import Keiro.Codec.Structural (bindingToShape) import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)+import Generated.MappedReadmodel.Structural.Shape.AccountLookup (AccountLookupShape(accountId, tenant))+import Generated.MappedReadmodel.Structural.Shape.AccountProfile (AccountProfileShape(displayName))+import Generated.MappedReadmodel.Structural.Shape.AccountSummary (AccountSummaryShape(accountId, tenant))+import Generated.MappedReadmodel.Structural.Shape.TenantKey (TenantKeyShape(tenantId))+import Generated.MappedReadmodel.Structural.Shape.UnusedFilter (UnusedFilterShape(prefix)) 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 @@ -30,7 +30,7 @@   type FieldOwner AccountLookupAccountIdProjection = AccountLookup   type FieldResult AccountLookupAccountIdProjection = Text   fieldShapeId _ = "conformance.mapped-readmodel.AccountLookup.v1"-  projectFieldValue _ owner = ShapeAccountLookup.accountId (bindingToShape Bindings.accountLookupBinding owner)+  projectFieldValue _ owner = (bindingToShape Bindings.accountLookupBinding owner).accountId  accountLookupAccountIdWitness :: FieldWitness AccountLookupAccountIdProjection accountLookupAccountIdWitness = fieldWitness @AccountLookupAccountIdProjection@@ -42,7 +42,7 @@   type FieldOwner AccountLookupTenantTenantIdProjection = AccountLookup   type FieldResult AccountLookupTenantTenantIdProjection = Text   fieldShapeId _ = "conformance.mapped-readmodel.AccountLookup.v1"-  projectFieldValue _ owner = ShapeTenantKey.tenantId (ShapeAccountLookup.tenant (bindingToShape Bindings.accountLookupBinding owner))+  projectFieldValue _ owner = ((bindingToShape Bindings.accountLookupBinding owner).tenant).tenantId  accountLookupTenantTenantIdWitness :: FieldWitness AccountLookupTenantTenantIdProjection accountLookupTenantTenantIdWitness = fieldWitness @AccountLookupTenantTenantIdProjection@@ -54,7 +54,7 @@   type FieldOwner AccountProfileDisplayNameProjection = AccountProfile   type FieldResult AccountProfileDisplayNameProjection = Text   fieldShapeId _ = "conformance.mapped-readmodel.AccountProfile.v1"-  projectFieldValue _ owner = ShapeAccountProfile.displayName (bindingToShape Bindings.accountProfileBinding owner)+  projectFieldValue _ owner = (bindingToShape Bindings.accountProfileBinding owner).displayName  accountProfileDisplayNameWitness :: FieldWitness AccountProfileDisplayNameProjection accountProfileDisplayNameWitness = fieldWitness @AccountProfileDisplayNameProjection@@ -66,7 +66,7 @@   type FieldOwner AccountSummaryAccountIdProjection = AccountSummary   type FieldResult AccountSummaryAccountIdProjection = Text   fieldShapeId _ = "conformance.mapped-readmodel.AccountSummary.v1"-  projectFieldValue _ owner = ShapeAccountSummary.accountId (bindingToShape Bindings.accountSummaryBinding owner)+  projectFieldValue _ owner = (bindingToShape Bindings.accountSummaryBinding owner).accountId  accountSummaryAccountIdWitness :: FieldWitness AccountSummaryAccountIdProjection accountSummaryAccountIdWitness = fieldWitness @AccountSummaryAccountIdProjection@@ -78,7 +78,7 @@   type FieldOwner AccountSummaryTenantTenantIdProjection = AccountSummary   type FieldResult AccountSummaryTenantTenantIdProjection = Text   fieldShapeId _ = "conformance.mapped-readmodel.AccountSummary.v1"-  projectFieldValue _ owner = ShapeTenantKey.tenantId (ShapeAccountSummary.tenant (bindingToShape Bindings.accountSummaryBinding owner))+  projectFieldValue _ owner = ((bindingToShape Bindings.accountSummaryBinding owner).tenant).tenantId  accountSummaryTenantTenantIdWitness :: FieldWitness AccountSummaryTenantTenantIdProjection accountSummaryTenantTenantIdWitness = fieldWitness @AccountSummaryTenantTenantIdProjection@@ -90,7 +90,7 @@   type FieldOwner TenantKeyTenantIdProjection = TenantKey   type FieldResult TenantKeyTenantIdProjection = Text   fieldShapeId _ = "conformance.mapped-readmodel.TenantKey.v1"-  projectFieldValue _ owner = ShapeTenantKey.tenantId (bindingToShape Bindings.tenantKeyBinding owner)+  projectFieldValue _ owner = (bindingToShape Bindings.tenantKeyBinding owner).tenantId  tenantKeyTenantIdWitness :: FieldWitness TenantKeyTenantIdProjection tenantKeyTenantIdWitness = fieldWitness @TenantKeyTenantIdProjection@@ -102,7 +102,7 @@   type FieldOwner UnusedFilterPrefixProjection = UnusedFilter   type FieldResult UnusedFilterPrefixProjection = Text   fieldShapeId _ = "conformance.mapped-readmodel.UnusedFilter.v1"-  projectFieldValue _ owner = ShapeUnusedFilter.prefix (bindingToShape Bindings.unusedFilterBinding owner)+  projectFieldValue _ owner = (bindingToShape Bindings.unusedFilterBinding owner).prefix  unusedFilterPrefixWitness :: FieldWitness UnusedFilterPrefixProjection unusedFilterPrefixWitness = fieldWitness @UnusedFilterPrefixProjection

+ test/conformance-mapped-readmodel/keiro-dsl-cabal-fragment.context.mapped-readmodel.txt view

@@ -0,0 +1,44 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/mapped-readmodel.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    Conformance.MappedReadModel.Bindings+    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+    , effectful-core+    , hasql-transaction+    , keiro+    , keiro-dsl+    , kiroku-store+    , text++consumer-packages:+    keiro-dsl++consumer-modules:+    Conformance.MappedReadModel.Bindings+    Conformance.MappedReadModel.Domain

+ test/conformance-mapped-readmodel/keiro-dsl-ledger.context.mapped-readmodel.txt view

@@ -0,0 +1,67 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/mapped-readmodel.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":5,"effectiveLanguageVersion":5,"sourceForm":"declared"}+semantic-contract {"languageSupport":"stable","languageVersion":5,"runtimeSemantics":"keiro-dsl/runtime-semantics/4"}+naming-edition idiomatic-v2+module-role {"family":"StructuralConformance","kind":"generated","ownerKind":"context","ownerName":"context mapped-readmodel structural conformance","path":"Generated/MappedReadmodel/StructuralConformance.hs"}+module-role {"family":"AccountLookup","kind":"generated","ownerKind":"mapped","ownerName":"mapped structural AccountLookup (line 15)","path":"Generated/MappedReadmodel/Structural/Shape/AccountLookup.hs"}+module-role {"family":"AccountProfile","kind":"generated","ownerKind":"mapped","ownerName":"mapped structural AccountProfile (line 27)","path":"Generated/MappedReadmodel/Structural/Shape/AccountProfile.hs"}+module-role {"family":"AccountSummary","kind":"generated","ownerKind":"mapped","ownerName":"mapped structural AccountSummary (line 38)","path":"Generated/MappedReadmodel/Structural/Shape/AccountSummary.hs"}+module-role {"family":"TenantKey","kind":"generated","ownerKind":"mapped","ownerName":"mapped structural TenantKey (line 4)","path":"Generated/MappedReadmodel/Structural/Shape/TenantKey.hs"}+module-role {"family":"UnusedFilter","kind":"generated","ownerKind":"mapped","ownerName":"mapped structural UnusedFilter (line 51)","path":"Generated/MappedReadmodel/Structural/Shape/UnusedFilter.hs"}+module-role {"family":"StructuralProjections","kind":"generated","ownerKind":"context","ownerName":"context mapped-readmodel mapped structural facade","path":"Generated/MappedReadmodel/StructuralProjections.hs"}+module-role {"family":"Bindings","kind":"hole","ownerKind":"consumer","ownerName":"consumer binding skeleton Conformance.MappedReadModel.Bindings","path":"Conformance/MappedReadModel/Bindings.hs"}+module-role {"family":"ProjectionCatalog","kind":"generated","ownerKind":"projection-catalog","ownerName":"projection-catalog mapped-readmodel","path":"Generated/MappedReadmodel/ProjectionCatalog.hs"}+module-role {"family":"ProjectionCatalogHoles","kind":"hole","ownerKind":"projection-catalog","ownerName":"projection-catalog mapped-readmodel","path":"MappedReadmodel/ProjectionCatalog/ProjectionCatalogHoles.hs"}+module-role {"family":"ReadModelTable","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel account_summary (line 85)","path":"Generated/MappedReadmodel/AccountSummary/ReadModelTable.hs"}+module-role {"family":"QueryContract","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel account_summary (line 85)","path":"Generated/MappedReadmodel/AccountSummary/QueryContract.hs"}+module-role {"family":"ReadModel","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel account_summary (line 85)","path":"Generated/MappedReadmodel/AccountSummary/ReadModel.hs"}+module-role {"family":"ReadModelHoles","kind":"hole","ownerKind":"readmodel","ownerName":"readmodel account_summary (line 85)","path":"MappedReadmodel/AccountSummary/ReadModelHoles.hs"}+module-role {"family":"ReadModelHarness","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel account_summary (line 85)","path":"Generated/MappedReadmodel/AccountSummary/ReadModelHarness.hs"}+generated Generated/MappedReadmodel/StructuralConformance.hs+generated Generated/MappedReadmodel/Structural/Shape/AccountLookup.hs+generated Generated/MappedReadmodel/Structural/Shape/AccountProfile.hs+generated Generated/MappedReadmodel/Structural/Shape/AccountSummary.hs+generated Generated/MappedReadmodel/Structural/Shape/TenantKey.hs+generated Generated/MappedReadmodel/Structural/Shape/UnusedFilter.hs+generated Generated/MappedReadmodel/StructuralProjections.hs+hole Conformance/MappedReadModel/Bindings.hs+generated Generated/MappedReadmodel/ProjectionCatalog.hs+hole MappedReadmodel/ProjectionCatalog/ProjectionCatalogHoles.hs+generated Generated/MappedReadmodel/AccountSummary/ReadModelTable.hs+generated Generated/MappedReadmodel/AccountSummary/QueryContract.hs+generated Generated/MappedReadmodel/AccountSummary/ReadModel.hs+hole MappedReadmodel/AccountSummary/ReadModelHoles.hs+generated Generated/MappedReadmodel/AccountSummary/ReadModelHarness.hs+mapping {"bindingSymbol":"Conformance.MappedReadModel.Bindings.accountLookupBinding","bindingVersion":"1","canonicalType":"conformance.mapped-readmodel.AccountLookup.v1","mode":"structural","module":"Conformance.MappedReadModel.Domain","package":"keiro-dsl","schema":1,"specName":"AccountLookup","type":"AccountLookup"}+mapping {"bindingSymbol":"Conformance.MappedReadModel.Bindings.accountProfileBinding","bindingVersion":"1","canonicalType":"conformance.mapped-readmodel.AccountProfile.v1","mode":"structural","module":"Conformance.MappedReadModel.Domain","package":"keiro-dsl","schema":1,"specName":"AccountProfile","type":"AccountProfile"}+mapping {"bindingSymbol":"Conformance.MappedReadModel.Bindings.accountSummaryBinding","bindingVersion":"1","canonicalType":"conformance.mapped-readmodel.AccountSummary.v1","mode":"structural","module":"Conformance.MappedReadModel.Domain","package":"keiro-dsl","schema":1,"specName":"AccountSummary","type":"AccountSummary"}+mapping {"bindingSymbol":"Conformance.MappedReadModel.Bindings.tenantKeyBinding","bindingVersion":"1","canonicalType":"conformance.mapped-readmodel.TenantKey.v1","mode":"structural","module":"Conformance.MappedReadModel.Domain","package":"keiro-dsl","schema":1,"specName":"TenantKey","type":"TenantKey"}+mapping {"bindingSymbol":"Conformance.MappedReadModel.Bindings.unusedFilterBinding","bindingVersion":"1","canonicalType":"conformance.mapped-readmodel.UnusedFilter.v1","mode":"structural","module":"Conformance.MappedReadModel.Domain","package":"keiro-dsl","schema":1,"specName":"UnusedFilter","type":"UnusedFilter"}+binding {"kind":"binding","mappedName":"AccountLookup","module":"Conformance.MappedReadModel.Bindings","path":"accountId","schema":1,"signature":"accountLookupBinding.accountId :: Text","symbol":"accountLookupBinding"}+binding {"kind":"binding","mappedName":"AccountLookup","module":"Conformance.MappedReadModel.Bindings","path":"tenant","schema":1,"signature":"accountLookupBinding.tenant :: TenantKey","symbol":"accountLookupBinding"}+binding {"kind":"fixtures","mappedName":"AccountLookup","module":"Conformance.MappedReadModel.Bindings","path":null,"schema":1,"signature":"accountLookupCases :: FixtureCases Conformance.MappedReadModel.Domain.AccountLookup","symbol":"accountLookupCases"}+binding {"kind":"binding","mappedName":"AccountProfile","module":"Conformance.MappedReadModel.Bindings","path":"displayName","schema":1,"signature":"accountProfileBinding.displayName :: Text","symbol":"accountProfileBinding"}+binding {"kind":"fixtures","mappedName":"AccountProfile","module":"Conformance.MappedReadModel.Bindings","path":null,"schema":1,"signature":"accountProfileCases :: FixtureCases Conformance.MappedReadModel.Domain.AccountProfile","symbol":"accountProfileCases"}+binding {"kind":"binding","mappedName":"AccountSummary","module":"Conformance.MappedReadModel.Bindings","path":"accountId","schema":1,"signature":"accountSummaryBinding.accountId :: Text","symbol":"accountSummaryBinding"}+binding {"kind":"binding","mappedName":"AccountSummary","module":"Conformance.MappedReadModel.Bindings","path":"profile","schema":1,"signature":"accountSummaryBinding.profile :: Maybe (AccountProfile)","symbol":"accountSummaryBinding"}+binding {"kind":"binding","mappedName":"AccountSummary","module":"Conformance.MappedReadModel.Bindings","path":"tenant","schema":1,"signature":"accountSummaryBinding.tenant :: TenantKey","symbol":"accountSummaryBinding"}+binding {"kind":"fixtures","mappedName":"AccountSummary","module":"Conformance.MappedReadModel.Bindings","path":null,"schema":1,"signature":"accountSummaryCases :: FixtureCases Conformance.MappedReadModel.Domain.AccountSummary","symbol":"accountSummaryCases"}+binding {"kind":"binding","mappedName":"TenantKey","module":"Conformance.MappedReadModel.Bindings","path":"tenantId","schema":1,"signature":"tenantKeyBinding.tenantId :: Text","symbol":"tenantKeyBinding"}+binding {"kind":"fixtures","mappedName":"TenantKey","module":"Conformance.MappedReadModel.Bindings","path":null,"schema":1,"signature":"tenantKeyCases :: FixtureCases Conformance.MappedReadModel.Domain.TenantKey","symbol":"tenantKeyCases"}+binding {"kind":"binding","mappedName":"UnusedFilter","module":"Conformance.MappedReadModel.Bindings","path":"prefix","schema":1,"signature":"unusedFilterBinding.prefix :: Text","symbol":"unusedFilterBinding"}+binding {"kind":"fixtures","mappedName":"UnusedFilter","module":"Conformance.MappedReadModel.Bindings","path":null,"schema":1,"signature":"unusedFilterCases :: FixtureCases Conformance.MappedReadModel.Domain.UnusedFilter","symbol":"unusedFilterCases"}+projection-catalog-fact cursor|account_summary|mapped-readmodel-account-summary|85+projection-catalog-fact delivery|account_summary_writer|subscription|73+projection-catalog-fact freshness|account_summary|wait-for-head:entire-log|85+projection-catalog-fact group|reporting|account_summary_table|account_summary_table|68+projection-catalog-fact owner|account_summary_writer|all|reporting|account_summary_table|10|mapped-readmodel-account-summary|mapped-readmodel-account-summary-v1|from-beginning|explicit|73+projection-catalog-fact query|account_summary|reporting|account_summary_table|account_summary_table|85+projection-catalog-fact supply|account_summary|account_summary_writer|reporting|account_summary_table|85|73+projection-catalog-fact target|account_summary_table|public|account_summary|clear||62+query-contract-baseline v1+query-contract {"mappedDependencies":["AccountLookup","TenantKey"],"position":"input","readModel":"account_summary","typeExpression":"AccountLookup"}+query-contract {"mappedDependencies":["AccountProfile","AccountSummary","TenantKey"],"position":"result","readModel":"account_summary","typeExpression":"Optional AccountSummary"}+semantic-impact {"declarations":[{"consequences":[{"consumer":"read-model-query:account_summary:input","kind":"consumer-build"},{"kind":"query-api","position":"input","readModel":"account_summary"}],"consumerEvidence":[{"consumer":"read-model-query:account_summary:input","operation":null,"path":"readmodel account_summary query input : AccountLookup","surface":"read-model-query-input"}],"consumers":["read-model-query:account_summary:input"],"declaration":"AccountLookup","identity":"structural\u001fkeiro-dsl:Conformance.MappedReadModel.Domain:AccountLookup\u001fConformance.MappedReadModel.Bindings.accountLookupBinding\u001f1\u001fconformance.mapped-readmodel.AccountLookup.v1\u001fConformance.MappedReadModel.Bindings.accountLookupCases\u001f\u001fc9b15cdbe3466150\u001frecord:AccountLookup:accountId=account_id,tenant=tenant"},{"consequences":[{"consumer":"read-model-query:account_summary:result","kind":"consumer-build"},{"kind":"query-api","position":"result","readModel":"account_summary"}],"consumerEvidence":[{"consumer":"read-model-query:account_summary:result","operation":null,"path":"readmodel account_summary query result : AccountSummary optional .profile optional : AccountProfile","surface":"read-model-query-result"}],"consumers":["read-model-query:account_summary:result"],"declaration":"AccountProfile","identity":"structural\u001fkeiro-dsl:Conformance.MappedReadModel.Domain:AccountProfile\u001fConformance.MappedReadModel.Bindings.accountProfileBinding\u001f1\u001fconformance.mapped-readmodel.AccountProfile.v1\u001fConformance.MappedReadModel.Bindings.accountProfileCases\u001f\u001f122e7346f0a9851b\u001frecord:AccountProfile:displayName=display_name"},{"consequences":[{"consumer":"read-model-query:account_summary:result","kind":"consumer-build"},{"kind":"query-api","position":"result","readModel":"account_summary"}],"consumerEvidence":[{"consumer":"read-model-query:account_summary:result","operation":null,"path":"readmodel account_summary query result : AccountSummary optional","surface":"read-model-query-result"}],"consumers":["read-model-query:account_summary:result"],"declaration":"AccountSummary","identity":"structural\u001fkeiro-dsl:Conformance.MappedReadModel.Domain:AccountSummary\u001fConformance.MappedReadModel.Bindings.accountSummaryBinding\u001f1\u001fconformance.mapped-readmodel.AccountSummary.v1\u001fConformance.MappedReadModel.Bindings.accountSummaryCases\u001f\u001ff6029041cdfafd88\u001frecord:AccountSummary:accountId=account_id,profile=profile,tenant=tenant"},{"consequences":[{"consumer":"read-model-query:account_summary:input","kind":"consumer-build"},{"consumer":"read-model-query:account_summary:result","kind":"consumer-build"},{"kind":"query-api","position":"input","readModel":"account_summary"},{"kind":"query-api","position":"result","readModel":"account_summary"}],"consumerEvidence":[{"consumer":"read-model-query:account_summary:input","operation":null,"path":"readmodel account_summary query input : AccountLookup .tenant : TenantKey","surface":"read-model-query-input"},{"consumer":"read-model-query:account_summary:result","operation":null,"path":"readmodel account_summary query result : AccountSummary optional .tenant : TenantKey","surface":"read-model-query-result"}],"consumers":["read-model-query:account_summary:input","read-model-query:account_summary:result"],"declaration":"TenantKey","identity":"structural\u001fkeiro-dsl:Conformance.MappedReadModel.Domain:TenantKey\u001fConformance.MappedReadModel.Bindings.tenantKeyBinding\u001f1\u001fconformance.mapped-readmodel.TenantKey.v1\u001fConformance.MappedReadModel.Bindings.tenantKeyCases\u001f\u001f83221e47fa0b3237\u001frecord:TenantKey:tenantId=tenant_id"},{"consequences":[],"consumerEvidence":[],"consumers":[],"declaration":"UnusedFilter","identity":"structural\u001fkeiro-dsl:Conformance.MappedReadModel.Domain:UnusedFilter\u001fConformance.MappedReadModel.Bindings.unusedFilterBinding\u001f1\u001fconformance.mapped-readmodel.UnusedFilter.v1\u001fConformance.MappedReadModel.Bindings.unusedFilterCases\u001f\u001fc325e320de08f16b\u001frecord:UnusedFilter:prefix=prefix"}],"mappedSurfaceEvidenceVersion":1,"serviceInventory":["AccountLookup","AccountProfile","AccountSummary","TenantKey","UnusedFilter"]}

test/conformance-newsurface/Generated/TransferRouting/BehaviorSourceMap.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from context transfer-routing behavior source map; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from context transfer-routing behavior source map; do not edit. module Generated.TransferRouting.BehaviorSourceMap   ( BehaviorSourceLocation (..)   , behaviorSourceLocation@@ -9,9 +9,9 @@ import Data.Text qualified as T  data BehaviorSourceLocation = BehaviorSourceLocation-  { sourceFile :: !FilePath-  , sourceLine :: !Int-  , sourceColumn :: !Int+  { file :: !FilePath+  , line :: !Int+  , column :: !Int   }   deriving stock (Eq, Ord, Show) @@ -22,7 +22,7 @@  renderBehaviorSourceLocation :: Text -> Text renderBehaviorSourceLocation key = case behaviorSourceLocation key of-  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Just location -> T.pack location.file <> ":" <> tshow location.line <> ":" <> tshow location.column   Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"  tshow :: Show value => value -> Text

+ test/conformance-newsurface/Generated/TransferRouting/Hospital/BehaviorContract.hs view

@@ -0,0 +1,337 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.TransferRouting.Hospital.BehaviorContract+  ( BehaviorKey (..)+  , unBehaviorKey+  , 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)++unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value++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+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !HospitalVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef HospitalVertex))+  , target :: !(Maybe HospitalVertex)+  , eventKinds :: ![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+      { key :: BehaviorKey+      , history :: [HospitalEvent]+      , command :: HospitalCommand+      , expected :: LiveExpectation+      }+  | ReplayWitness+      { key :: BehaviorKey+      , historyPrefix :: [HospitalEvent]+      , observedChunk :: [HospitalEvent]+      }+  deriving stock (Eq, Show)++data BehaviorFailure = BehaviorFailure+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !Text+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorFailure where+  toJSON behaviorFailure = object+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail+    ]++data BehaviorConformanceReport = BehaviorConformanceReport+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![BehaviorKey]+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorConformanceReport where+  toJSON report = object+    [ "schema" .= ("keiro/behavior-conformance/1" :: Text)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified+    ]++behaviorRequirements :: [BehaviorRequirement]+behaviorRequirements =+  [ -- HospitalAccepting x RouteAcceptedTransferNeed: live transition+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-8c1612ae6464bb11"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = HospitalAccepting+      , commandName = "RouteAcceptedTransferNeed"+      , expectedEdge = (Just (K.EdgeRef HospitalAccepting 0))+      , target = Just HospitalAccepting+      , eventKinds = ["AcceptedTransferNeedRouted"]+      }+  ]++behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport+behaviorCoverageReport witnesses =+  BehaviorConformanceReport+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]+    }+ where+  requiredByKey = Map.fromList [(requirement.key, 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 report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)++renderBehaviorConformanceText :: BehaviorConformanceReport -> Text+renderBehaviorConformanceText report = T.unlines+  [ "behavior conformance: Hospital"+  , "schema: keiro/behavior-conformance/1"+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]++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 == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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 == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)+      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) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)++runReplay :: BehaviorRequirement -> [HospitalEvent] -> [HospitalEvent] -> Either BehaviorFailure ()+runReplay requirement prefix chunk = case requirement.kind of+  ReplayTransition -> do+    settled <- settleHistory requirement "history-prefix" prefix+    ensure requirement (K.replaySuccessState settled == requirement.source) "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) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)+    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) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)+    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 == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)+    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 (HospitalAccepting, 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 _ _ = True++proofStrength :: BehaviorRequirement -> Bool+proofStrength requirement =+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]++behaviorWitnessKey :: BehaviorWitness -> BehaviorKey+behaviorWitnessKey witness = case witness of+  Pending key -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = 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+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")+        code+        detail+    )+ where+  kindPhrase = case requirement.kind 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-newsurface/Generated/TransferRouting/Hospital/Codec.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.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,5 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.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,6 @@ {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.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,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from readmodel hospital_load; do not edit.+-- @generated by keiro-dsl 0.15.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,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from readmodel hospital_load; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from readmodel hospital_load; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from router HospitalTransferRouter; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from router HospitalTransferRouter; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from context transfer-routing replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.15.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-newsurface/TransferRouting/Hospital/BehaviorHoles.hs view

@@ -0,0 +1,9 @@+-- 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-8c1612ae6464bb11")+  ]

+ test/conformance-newsurface/keiro-dsl-cabal-fragment.context.transfer-routing.txt view

@@ -0,0 +1,41 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/transfer-routing.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    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.ReadModel+    Generated.TransferRouting.HospitalLoad.ReadModelHarness+    Generated.TransferRouting.HospitalLoad.ReadModelTable+    Generated.TransferRouting.HospitalTransferRouter.Router+    Generated.TransferRouting.HospitalTransferRouter.RouterHarness+    Generated.TransferRouting.ReplayAudit+    TransferRouting.Hospital.BehaviorHoles+    TransferRouting.HospitalLoad.ReadModelHoles+    TransferRouting.HospitalTransferRouter.RouterHoles++build-depends:+    , aeson+    , base+    , effectful-core+    , hasql-transaction+    , keiki+    , keiro+    , kiroku-store+    , shibuya-core+    , text

+ test/conformance-newsurface/keiro-dsl-ledger.context.transfer-routing.txt view

@@ -0,0 +1,44 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/transfer-routing.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":4,"effectiveLanguageVersion":4,"sourceForm":"declared"}+semantic-contract {"languageSupport":"compatibility-only","languageVersion":4,"runtimeSemantics":"keiro-dsl/runtime-semantics/3"}+naming-edition idiomatic-v2+module-role {"family":"BehaviorSourceMap","kind":"generated","ownerKind":"context","ownerName":"context transfer-routing behavior source map","path":"Generated/TransferRouting/BehaviorSourceMap.hs"}+module-role {"family":"ReplayAudit","kind":"generated","ownerKind":"context","ownerName":"context transfer-routing replay-audit assembly","path":"Generated/TransferRouting/ReplayAudit.hs"}+module-role {"family":"ReadModelTable","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel hospital_load (line 4)","path":"Generated/TransferRouting/HospitalLoad/ReadModelTable.hs"}+module-role {"family":"ReadModel","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel hospital_load (line 4)","path":"Generated/TransferRouting/HospitalLoad/ReadModel.hs"}+module-role {"family":"ReadModelHoles","kind":"hole","ownerKind":"readmodel","ownerName":"readmodel hospital_load (line 4)","path":"TransferRouting/HospitalLoad/ReadModelHoles.hs"}+module-role {"family":"ReadModelHarness","kind":"generated","ownerKind":"readmodel","ownerName":"readmodel hospital_load (line 4)","path":"Generated/TransferRouting/HospitalLoad/ReadModelHarness.hs"}+module-role {"family":"Router","kind":"generated","ownerKind":"router","ownerName":"router HospitalTransferRouter (line 19)","path":"Generated/TransferRouting/HospitalTransferRouter/Router.hs"}+module-role {"family":"RouterHoles","kind":"hole","ownerKind":"router","ownerName":"router HospitalTransferRouter (line 19)","path":"TransferRouting/HospitalTransferRouter/RouterHoles.hs"}+module-role {"family":"RouterHarness","kind":"generated","ownerKind":"router","ownerName":"router HospitalTransferRouter (line 19)","path":"Generated/TransferRouting/HospitalTransferRouter/RouterHarness.hs"}+module-role {"family":"Domain","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 32)","path":"Generated/TransferRouting/Hospital/Domain.hs"}+module-role {"family":"Codec","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 32)","path":"Generated/TransferRouting/Hospital/Codec.hs"}+module-role {"family":"Transducer","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 32)","path":"Generated/TransferRouting/Hospital/Transducer.hs"}+module-role {"family":"BehaviorContract","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 32)","path":"Generated/TransferRouting/Hospital/BehaviorContract.hs"}+module-role {"family":"BehaviorHoles","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate behavior witnesses Hospital (line 32)","path":"TransferRouting/Hospital/BehaviorHoles.hs"}+module-role {"family":"EventStream","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 32)","path":"Generated/TransferRouting/Hospital/EventStream.hs"}+module-role {"family":"Projection","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 32)","path":"Generated/TransferRouting/Hospital/Projection.hs"}+module-role {"family":"Harness","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 32)","path":"Generated/TransferRouting/Hospital/Harness.hs"}+generated Generated/TransferRouting/BehaviorSourceMap.hs+generated Generated/TransferRouting/ReplayAudit.hs+generated Generated/TransferRouting/HospitalLoad/ReadModelTable.hs+generated Generated/TransferRouting/HospitalLoad/ReadModel.hs+hole TransferRouting/HospitalLoad/ReadModelHoles.hs+generated Generated/TransferRouting/HospitalLoad/ReadModelHarness.hs+generated Generated/TransferRouting/HospitalTransferRouter/Router.hs+hole TransferRouting/HospitalTransferRouter/RouterHoles.hs+generated Generated/TransferRouting/HospitalTransferRouter/RouterHarness.hs+generated Generated/TransferRouting/Hospital/Domain.hs+generated Generated/TransferRouting/Hospital/Codec.hs+generated Generated/TransferRouting/Hospital/Transducer.hs+generated Generated/TransferRouting/Hospital/BehaviorContract.hs+hole TransferRouting/Hospital/BehaviorHoles.hs+generated Generated/TransferRouting/Hospital/EventStream.hs+generated Generated/TransferRouting/Hospital/Projection.hs+generated Generated/TransferRouting/Hospital/Harness.hs+behavior {"aggregate":"Hospital","command":"RouteAcceptedTransferNeed","evidence":"generated-authoritative","key":"behavior-v1-8c1612ae6464bb11","kind":"live-transition","outputs":[{"command":"RouteAcceptedTransferNeed","ownership":"generated-command-identity"}],"source":"Accepting"}+router-selection {"fingerprint":null,"identity":null,"router":"HospitalTransferRouter","verification":"custom-unverified","version":null}+semantic-impact {"declarations":[],"mappedSurfaceEvidenceVersion":1,"serviceInventory":[]}

test/conformance-nominal-scalars/Generated/NominalScalars/BehaviorSourceMap.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from context nominal-scalars behavior source map; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from context nominal-scalars behavior source map; do not edit. module Generated.NominalScalars.BehaviorSourceMap   ( BehaviorSourceLocation (..)   , behaviorSourceLocation@@ -9,9 +9,9 @@ import Data.Text qualified as T  data BehaviorSourceLocation = BehaviorSourceLocation-  { sourceFile :: !FilePath-  , sourceLine :: !Int-  , sourceColumn :: !Int+  { file :: !FilePath+  , line :: !Int+  , column :: !Int   }   deriving stock (Eq, Ord, Show) @@ -23,7 +23,7 @@  renderBehaviorSourceLocation :: Text -> Text renderBehaviorSourceLocation key = case behaviorSourceLocation key of-  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Just location -> T.pack location.file <> ":" <> tshow location.line <> ":" <> tshow location.column   Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"  tshow :: Show value => value -> Text

test/conformance-nominal-scalars/Generated/NominalScalars/Nominal/Shape/OrderStatus.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from bound nominal enum representation OrderStatus; do not edit.+-- @generated by keiro-dsl 0.15.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,7 +1,8 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit. module Generated.NominalScalars.NominalLedger.BehaviorContract   ( BehaviorKey (..)+  , unBehaviorKey   , ObligationKind (..)   , EvidenceLevel (..)   , GuardCoverage (..)@@ -35,6 +36,9 @@ newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }   deriving stock (Eq, Ord, Show) +unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value+ data ObligationKind = LiveTransition | RequiredRejection | ReplayTransition   deriving stock (Eq, Ord, Show) @@ -45,15 +49,15 @@   deriving stock (Eq, Ord, Show)  data BehaviorRequirement = BehaviorRequirement-  { requirementKey :: !BehaviorKey-  , requirementKind :: !ObligationKind-  , requirementEvidence :: !EvidenceLevel-  , requirementGuardCoverage :: !GuardCoverage-  , requirementSource :: !NominalLedgerVertex-  , requirementCommandName :: !Text-  , requirementExpectedEdge :: !(Maybe (K.EdgeRef NominalLedgerVertex))-  , requirementTarget :: !(Maybe NominalLedgerVertex)-  , requirementEventKinds :: ![Text]+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !NominalLedgerVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef NominalLedgerVertex))+  , target :: !(Maybe NominalLedgerVertex)+  , eventKinds :: ![Text]   }   deriving stock (Eq, Show) @@ -69,104 +73,104 @@ data BehaviorWitness   = Pending BehaviorKey   | LiveWitness-      { witnessKey :: BehaviorKey-      , witnessHistory :: [NominalLedgerEvent]-      , witnessCommand :: NominalLedgerCommand-      , witnessExpected :: LiveExpectation+      { key :: BehaviorKey+      , history :: [NominalLedgerEvent]+      , command :: NominalLedgerCommand+      , expected :: LiveExpectation       }   | ReplayWitness-      { witnessKey :: BehaviorKey-      , witnessHistoryPrefix :: [NominalLedgerEvent]-      , witnessObservedChunk :: [NominalLedgerEvent]+      { key :: BehaviorKey+      , historyPrefix :: [NominalLedgerEvent]+      , observedChunk :: [NominalLedgerEvent]       }   deriving stock (Eq, Show)  data BehaviorFailure = BehaviorFailure-  { failureKey :: !BehaviorKey-  , failureSubject :: !Text-  , failureCode :: !Text-  , failureDetail :: !Text+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !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+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail     ]  data BehaviorConformanceReport = BehaviorConformanceReport-  { reportRequired :: ![BehaviorKey]-  , reportFilled :: ![BehaviorKey]-  , reportPending :: ![BehaviorKey]-  , reportMissing :: ![BehaviorKey]-  , reportDuplicate :: ![BehaviorKey]-  , reportStale :: ![BehaviorKey]-  , reportFailed :: ![BehaviorFailure]-  , reportVerified :: ![BehaviorKey]-  , reportUnverified :: ![BehaviorKey]+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![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)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified     ]  behaviorRequirements :: [BehaviorRequirement] behaviorRequirements =   [ -- NominalLedgerEmpty x RecordNominals: live transition     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-274eaf83d346048a"-      , requirementKind = LiveTransition-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardUnknown-      , requirementSource = NominalLedgerEmpty-      , requirementCommandName = "RecordNominals"-      , requirementExpectedEdge = (Just (K.EdgeRef NominalLedgerEmpty 0))-      , requirementTarget = Just NominalLedgerRecorded-      , requirementEventKinds = ["NominalsRecorded"]+      { key = BehaviorKey "behavior-v1-274eaf83d346048a"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardUnknown+      , source = NominalLedgerEmpty+      , commandName = "RecordNominals"+      , expectedEdge = (Just (K.EdgeRef NominalLedgerEmpty 0))+      , target = Just NominalLedgerRecorded+      , eventKinds = ["NominalsRecorded"]       }   , -- NominalLedgerRecorded x RecordNominals: required rejection     BehaviorRequirement-      { requirementKey = BehaviorKey "behavior-v1-971c0c80ffdfe018"-      , requirementKind = RequiredRejection-      , requirementEvidence = GeneratedAuthoritative-      , requirementGuardCoverage = GuardNotApplicable-      , requirementSource = NominalLedgerRecorded-      , requirementCommandName = "RecordNominals"-      , requirementExpectedEdge = Nothing-      , requirementTarget = Nothing-      , requirementEventKinds = []+      { key = BehaviorKey "behavior-v1-971c0c80ffdfe018"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = NominalLedgerRecorded+      , commandName = "RecordNominals"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []       }   ]  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)]+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]     }  where-  requiredByKey = Map.fromList [(requirementKey requirement, requirement) | requirement <- behaviorRequirements]+  requiredByKey = Map.fromList [(requirement.key, requirement) | requirement <- behaviorRequirements]   witnessGroups = Map.fromListWith (flip (<>)) [(behaviorWitnessKey witness, [witness]) | witness <- witnesses]   executions =     [ (requirement, runWitness requirement witness)@@ -181,27 +185,27 @@  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))+  null report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)  renderBehaviorConformanceText :: BehaviorConformanceReport -> Text renderBehaviorConformanceText report = T.unlines   [ "behavior conformance: NominalLedger"   , "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]+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]  runWitness :: BehaviorRequirement -> BehaviorWitness -> Either BehaviorFailure () runWitness requirement witness = case witness of@@ -212,9 +216,9 @@ runLive :: BehaviorRequirement -> [NominalLedgerEvent] -> NominalLedgerCommand -> 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+  ensure requirement (K.replaySuccessState settled == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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@@ -246,7 +250,7 @@       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))+      ensure requirement (map eventKind actual == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)       decoded <- either (failure requirement "emitted-codec-decode") Right (decodeEvents actual)       replayed <- case K.applyEventsDetailedEither nominalLedgerTransducer seed decoded of         Left replayFailure -> failure requirement "emitted-replay-failed" (tshow replayFailure)@@ -258,30 +262,30 @@ checkAcceptedEnvelope :: BehaviorRequirement -> K.StepSuccess NominalLedgerRegs NominalLedgerVertex NominalLedgerEvent -> 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))+  ensure requirement (Just (K.stepSuccessEdge success) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)  runReplay :: BehaviorRequirement -> [NominalLedgerEvent] -> [NominalLedgerEvent] -> Either BehaviorFailure ()-runReplay requirement prefix chunk = case requirementKind requirement of+runReplay requirement prefix chunk = case requirement.kind 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 (K.replaySuccessState settled == requirement.source) "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 nominalLedgerTransducer (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))+    ensure requirement (Just (K.replaySuccessState replayed) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)     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 NominalLedgerVertex] -> 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 (Just (K.replayAttributionEdge attribution) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)     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.replayAttributionSource attribution == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)     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" @@ -307,14 +311,14 @@  proofStrength :: BehaviorRequirement -> Bool proofStrength requirement =-  requirementEvidence requirement == GeneratedAuthoritative-    && requirementGuardCoverage requirement `elem` [GuardTotal, GuardNotApplicable]+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]  behaviorWitnessKey :: BehaviorWitness -> BehaviorKey behaviorWitnessKey witness = case witness of   Pending key -> key-  LiveWitness { witnessKey = key } -> key-  ReplayWitness { witnessKey = key } -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = key } -> key  isPending :: BehaviorWitness -> Bool isPending Pending {} = True@@ -326,13 +330,13 @@ failure requirement code detail =   Left     ( BehaviorFailure-        (requirementKey requirement)-        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey requirement)) <> ")")+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")         code         detail     )  where-  kindPhrase = case requirementKind requirement of+  kindPhrase = case requirement.kind of     LiveTransition -> "live transition"     RequiredRejection -> "required rejection"     ReplayTransition -> "replay-only transition"

test/conformance-nominal-scalars/Generated/NominalScalars/NominalLedger/Codec.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit.+-- @generated by keiro-dsl 0.15.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,6 @@ {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit.+-- @generated by keiro-dsl 0.15.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

@@ -1,8 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate NominalLedger; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from context nominal-scalars nominal scalar projection facade; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from context nominal-scalars replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.15.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-nominal-scalars/NominalConformance/Domain.hs view

@@ -18,6 +18,9 @@     deriving stock (Eq, Generic, Show)     deriving newtype (FromJSON, ToJSON) +unOrderId :: OrderId -> KindID "ord"+unOrderId (OrderId value) = value+ instance CanonicalTypeName OrderId where     canonicalTypeName _ = "nominal.OrderId.v1" @@ -32,6 +35,9 @@     deriving stock (Eq, Generic, Ord, Show)     deriving newtype (FromJSON, ToJSON) +unAccountNumber :: AccountNumber -> Text+unAccountNumber (AccountNumber value) = value+ instance CanonicalTypeName AccountNumber where     canonicalTypeName _ = "nominal.AccountNumber.v1" @@ -39,6 +45,9 @@     deriving stock (Eq, Generic, Ord, Show)     deriving newtype (FromJSON, ToJSON) +unRiskScore :: RiskScore -> Int+unRiskScore (RiskScore value) = value+ instance CanonicalTypeName RiskScore where     canonicalTypeName _ = "nominal.RiskScore.v1" @@ -46,6 +55,9 @@     deriving stock (Eq, Generic, Ord, Show)     deriving newtype (FromJSON, ToJSON) +unSequenceNumber :: SequenceNumber -> Natural+unSequenceNumber (SequenceNumber value) = value+ instance CanonicalTypeName SequenceNumber where     canonicalTypeName _ = "nominal.SequenceNumber.v1" @@ -53,12 +65,18 @@     deriving stock (Eq, Generic, Ord, Show)     deriving newtype (FromJSON, ToJSON) +unFeatureFlag :: FeatureFlag -> Bool+unFeatureFlag (FeatureFlag value) = value+ instance CanonicalTypeName FeatureFlag where     canonicalTypeName _ = "nominal.FeatureFlag.v1"  newtype ObservedAt = ObservedAt {unObservedAt :: UTCTime}     deriving stock (Eq, Generic, Ord, Show)     deriving newtype (FromJSON, ToJSON)++unObservedAt :: ObservedAt -> UTCTime+unObservedAt (ObservedAt value) = value  instance CanonicalTypeName ObservedAt where     canonicalTypeName _ = "nominal.ObservedAt.v1"

+ test/conformance-nominal-scalars/compile-fail/PartialInverse.hs view

@@ -0,0 +1,12 @@+module PartialInverse where++import Keiro.Codec.Nominal (NominalBinding (..))++-- This file is expected not to type-check: a refined/partial inverse is not a+-- total NominalBinding. The compile-fail gate invokes GHC with -fno-code.+partialInverse :: NominalBinding Int Int+partialInverse =+    NominalBinding+        { nominalToRepresentation = id+        , nominalFromRepresentation = \value -> Left ("refined rejection", value)+        }

+ test/conformance-nominal-scalars/compile-fail/check-partial-inverse.sh view

@@ -0,0 +1,4 @@+#!/usr/bin/env bash+set -euo pipefail++cabal exec ghc -- -fno-code keiro-dsl/test/conformance-nominal-scalars/compile-fail/PartialInverse.hs

+ test/conformance-nominal-scalars/keiro-dsl-cabal-fragment.context.nominal-scalars.txt view

@@ -0,0 +1,42 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/nominal-scalars.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    Generated.NominalScalars.BehaviorSourceMap+    Generated.NominalScalars.Nominal.Shape.OrderStatus+    Generated.NominalScalars.NominalLedger.BehaviorContract+    Generated.NominalScalars.NominalLedger.Codec+    Generated.NominalScalars.NominalLedger.Domain+    Generated.NominalScalars.NominalLedger.EventStream+    Generated.NominalScalars.NominalLedger.Harness+    Generated.NominalScalars.NominalLedger.Projection+    Generated.NominalScalars.NominalLedger.Transducer+    Generated.NominalScalars.NominalProjections+    Generated.NominalScalars.ReplayAudit+    NominalConformance.Bindings+    NominalScalars.NominalLedger.BehaviorHoles++build-depends:+    , aeson+    , base+    , keiki+    , keiro+    , mmzk-typeid+    , nominal-conformance+    , text++consumer-packages:+    nominal-conformance++consumer-modules:+    NominalConformance.Bindings+    NominalConformance.Domain

+ test/conformance-nominal-scalars/keiro-dsl-ledger.context.nominal-scalars.txt view

@@ -0,0 +1,67 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/nominal-scalars.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":4,"effectiveLanguageVersion":4,"sourceForm":"declared"}+semantic-contract {"languageSupport":"compatibility-only","languageVersion":4,"runtimeSemantics":"keiro-dsl/runtime-semantics/3"}+naming-edition idiomatic-v2+module-role {"family":"BehaviorSourceMap","kind":"generated","ownerKind":"context","ownerName":"context nominal-scalars behavior source map","path":"Generated/NominalScalars/BehaviorSourceMap.hs"}+module-role {"family":"OrderStatus","kind":"generated","ownerKind":"bound","ownerName":"bound nominal enum representation OrderStatus (line 13)","path":"Generated/NominalScalars/Nominal/Shape/OrderStatus.hs"}+module-role {"family":"NominalProjections","kind":"generated","ownerKind":"context","ownerName":"context nominal-scalars nominal scalar projection facade","path":"Generated/NominalScalars/NominalProjections.hs"}+module-role {"family":"Bindings","kind":"hole","ownerKind":"consumer","ownerName":"consumer binding skeleton NominalConformance.Bindings","path":"NominalConformance/Bindings.hs"}+module-role {"family":"ReplayAudit","kind":"generated","ownerKind":"context","ownerName":"context nominal-scalars replay-audit assembly","path":"Generated/NominalScalars/ReplayAudit.hs"}+module-role {"family":"Domain","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate NominalLedger (line 67)","path":"Generated/NominalScalars/NominalLedger/Domain.hs"}+module-role {"family":"Codec","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate NominalLedger (line 67)","path":"Generated/NominalScalars/NominalLedger/Codec.hs"}+module-role {"family":"Transducer","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate NominalLedger (line 67)","path":"Generated/NominalScalars/NominalLedger/Transducer.hs"}+module-role {"family":"BehaviorContract","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate NominalLedger (line 67)","path":"Generated/NominalScalars/NominalLedger/BehaviorContract.hs"}+module-role {"family":"BehaviorHoles","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate behavior witnesses NominalLedger (line 67)","path":"NominalScalars/NominalLedger/BehaviorHoles.hs"}+module-role {"family":"EventStream","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate NominalLedger (line 67)","path":"Generated/NominalScalars/NominalLedger/EventStream.hs"}+module-role {"family":"Projection","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate NominalLedger (line 67)","path":"Generated/NominalScalars/NominalLedger/Projection.hs"}+module-role {"family":"Harness","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate NominalLedger (line 67)","path":"Generated/NominalScalars/NominalLedger/Harness.hs"}+generated Generated/NominalScalars/BehaviorSourceMap.hs+generated Generated/NominalScalars/Nominal/Shape/OrderStatus.hs+generated Generated/NominalScalars/NominalProjections.hs+hole NominalConformance/Bindings.hs+generated Generated/NominalScalars/ReplayAudit.hs+generated Generated/NominalScalars/NominalLedger/Domain.hs+generated Generated/NominalScalars/NominalLedger/Codec.hs+generated Generated/NominalScalars/NominalLedger/Transducer.hs+generated Generated/NominalScalars/NominalLedger/BehaviorContract.hs+hole NominalScalars/NominalLedger/BehaviorHoles.hs+generated Generated/NominalScalars/NominalLedger/EventStream.hs+generated Generated/NominalScalars/NominalLedger/Projection.hs+generated Generated/NominalScalars/NominalLedger/Harness.hs+nominal-mapping {"bindingSymbol":"NominalConformance.Bindings.accountNumberBinding","bindingVersion":"1","canonicalType":"nominal.AccountNumber.v1","category":"scalar","fixtureSymbol":"NominalConformance.Bindings.accountNumberFixtures","initialSymbol":"NominalConformance.Bindings.initialAccountNumber","mode":"nominal","module":"NominalConformance.Domain","package":"nominal-conformance","representation":"Text","schema":1,"specName":"AccountNumber","type":"AccountNumber"}+nominal-mapping {"bindingSymbol":"NominalConformance.Bindings.featureFlagBinding","bindingVersion":"1","canonicalType":"nominal.FeatureFlag.v1","category":"scalar","fixtureSymbol":"NominalConformance.Bindings.featureFlagFixtures","initialSymbol":"NominalConformance.Bindings.initialFeatureFlag","mode":"nominal","module":"NominalConformance.Domain","package":"nominal-conformance","representation":"Bool","schema":1,"specName":"FeatureFlag","type":"FeatureFlag"}+nominal-mapping {"bindingSymbol":"NominalConformance.Bindings.observedAtBinding","bindingVersion":"1","canonicalType":"nominal.ObservedAt.v1","category":"scalar","fixtureSymbol":"NominalConformance.Bindings.observedAtFixtures","initialSymbol":"NominalConformance.Bindings.initialObservedAt","mode":"nominal","module":"NominalConformance.Domain","package":"nominal-conformance","representation":"Time","schema":1,"specName":"ObservedAt","type":"ObservedAt"}+nominal-mapping {"bindingSymbol":"NominalConformance.Bindings.orderIdBinding","bindingVersion":"1","canonicalType":"nominal.OrderId.v1","category":"id","fixtureSymbol":"NominalConformance.Bindings.orderIdFixtures","initialSymbol":"NominalConformance.Bindings.initialOrderId","mode":"nominal","module":"NominalConformance.Domain","package":"nominal-conformance","representation":"KindID:ord","schema":1,"specName":"OrderId","type":"OrderId"}+nominal-mapping {"bindingSymbol":"NominalConformance.Bindings.orderStatusBinding","bindingVersion":"1","canonicalType":"nominal.OrderStatus.v1","category":"enum","fixtureSymbol":"NominalConformance.Bindings.orderStatusFixtures","initialSymbol":"NominalConformance.Bindings.initialOrderStatus","mode":"nominal","module":"NominalConformance.Domain","package":"nominal-conformance","representation":"enum:Draft=draft,Submitted=submitted","schema":1,"specName":"OrderStatus","type":"OrderStatus"}+nominal-mapping {"bindingSymbol":"NominalConformance.Bindings.riskScoreBinding","bindingVersion":"1","canonicalType":"nominal.RiskScore.v1","category":"scalar","fixtureSymbol":"NominalConformance.Bindings.riskScoreFixtures","initialSymbol":"NominalConformance.Bindings.initialRiskScore","mode":"nominal","module":"NominalConformance.Domain","package":"nominal-conformance","representation":"Int","schema":1,"specName":"RiskScore","type":"RiskScore"}+nominal-mapping {"bindingSymbol":"NominalConformance.Bindings.sequenceNumberBinding","bindingVersion":"1","canonicalType":"nominal.SequenceNumber.v1","category":"scalar","fixtureSymbol":"NominalConformance.Bindings.sequenceNumberFixtures","initialSymbol":"NominalConformance.Bindings.initialSequenceNumber","mode":"nominal","module":"NominalConformance.Domain","package":"nominal-conformance","representation":"Natural","schema":1,"specName":"SequenceNumber","type":"SequenceNumber"}+id-domain id-domain|name=OrderId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=ord|separator=_|json=canonical-json-text+nominal-equality nominal-equality|name=OrderId|contract=keiro-dsl/nominal-equality/2|key=Text|domain=typeid-v7-text:ord:keiro-dsl/id-domain/typeid-v7/1|owner=consumer;canonical=nominal.OrderId.v1;binding=NominalConformance.Bindings.orderIdBinding;binding-version=1+nominal-equality nominal-equality|name=OrderStatus|contract=keiro-dsl/nominal-equality/1|key=Text|domain=finite-text:draft,submitted|owner=consumer;canonical=nominal.OrderStatus.v1;binding=NominalConformance.Bindings.orderStatusBinding;binding-version=1+binding {"kind":"binding","mappedName":"AccountNumber","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"accountNumberBinding :: NominalBinding NominalConformance.Domain.AccountNumber Text","symbol":"accountNumberBinding"}+binding {"kind":"fixtures","mappedName":"AccountNumber","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"accountNumberFixtures :: NominalFixtureCases NominalConformance.Domain.AccountNumber","symbol":"accountNumberFixtures"}+binding {"kind":"initial-value","mappedName":"AccountNumber","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"initialAccountNumber :: NominalConformance.Domain.AccountNumber","symbol":"initialAccountNumber"}+binding {"kind":"binding","mappedName":"FeatureFlag","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"featureFlagBinding :: NominalBinding NominalConformance.Domain.FeatureFlag Bool","symbol":"featureFlagBinding"}+binding {"kind":"fixtures","mappedName":"FeatureFlag","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"featureFlagFixtures :: NominalFixtureCases NominalConformance.Domain.FeatureFlag","symbol":"featureFlagFixtures"}+binding {"kind":"initial-value","mappedName":"FeatureFlag","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"initialFeatureFlag :: NominalConformance.Domain.FeatureFlag","symbol":"initialFeatureFlag"}+binding {"kind":"binding","mappedName":"ObservedAt","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"observedAtBinding :: NominalBinding NominalConformance.Domain.ObservedAt UTCTime","symbol":"observedAtBinding"}+binding {"kind":"fixtures","mappedName":"ObservedAt","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"observedAtFixtures :: NominalFixtureCases NominalConformance.Domain.ObservedAt","symbol":"observedAtFixtures"}+binding {"kind":"initial-value","mappedName":"ObservedAt","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"initialObservedAt :: NominalConformance.Domain.ObservedAt","symbol":"initialObservedAt"}+binding {"kind":"binding","mappedName":"OrderId","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"orderIdBinding :: NominalBinding NominalConformance.Domain.OrderId (KindID \"ord\")","symbol":"orderIdBinding"}+binding {"kind":"fixtures","mappedName":"OrderId","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"orderIdFixtures :: NominalFixtureCases NominalConformance.Domain.OrderId","symbol":"orderIdFixtures"}+binding {"kind":"initial-value","mappedName":"OrderId","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"initialOrderId :: NominalConformance.Domain.OrderId","symbol":"initialOrderId"}+binding {"kind":"binding","mappedName":"OrderStatus","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"orderStatusBinding :: NominalBinding NominalConformance.Domain.OrderStatus Generated.NominalScalars.Nominal.Shape.OrderStatus.OrderStatusRepresentation","symbol":"orderStatusBinding"}+binding {"kind":"fixtures","mappedName":"OrderStatus","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"orderStatusFixtures :: NominalFixtureCases NominalConformance.Domain.OrderStatus","symbol":"orderStatusFixtures"}+binding {"kind":"initial-value","mappedName":"OrderStatus","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"initialOrderStatus :: NominalConformance.Domain.OrderStatus","symbol":"initialOrderStatus"}+binding {"kind":"binding","mappedName":"RiskScore","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"riskScoreBinding :: NominalBinding NominalConformance.Domain.RiskScore Int","symbol":"riskScoreBinding"}+binding {"kind":"fixtures","mappedName":"RiskScore","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"riskScoreFixtures :: NominalFixtureCases NominalConformance.Domain.RiskScore","symbol":"riskScoreFixtures"}+binding {"kind":"initial-value","mappedName":"RiskScore","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"initialRiskScore :: NominalConformance.Domain.RiskScore","symbol":"initialRiskScore"}+binding {"kind":"binding","mappedName":"SequenceNumber","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"sequenceNumberBinding :: NominalBinding NominalConformance.Domain.SequenceNumber Natural","symbol":"sequenceNumberBinding"}+binding {"kind":"fixtures","mappedName":"SequenceNumber","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"sequenceNumberFixtures :: NominalFixtureCases NominalConformance.Domain.SequenceNumber","symbol":"sequenceNumberFixtures"}+binding {"kind":"initial-value","mappedName":"SequenceNumber","module":"NominalConformance.Bindings","path":null,"schema":1,"signature":"initialSequenceNumber :: NominalConformance.Domain.SequenceNumber","symbol":"initialSequenceNumber"}+behavior {"aggregate":"NominalLedger","command":"RecordNominals","evidence":"generated-authoritative","key":"behavior-v1-274eaf83d346048a","kind":"live-transition","outputs":[{"command":"RecordNominals","ownership":"generated-command-identity"}],"source":"Empty"}+behavior {"aggregate":"NominalLedger","command":"RecordNominals","evidence":"generated-authoritative","key":"behavior-v1-971c0c80ffdfe018","kind":"required-rejection","outputs":[],"source":"Recorded"}+semantic-impact {"declarations":[],"mappedSurfaceEvidenceVersion":1,"serviceInventory":[]}

+ test/conformance-nominal-scalars/mutations/dishonest-exact.sh view

@@ -0,0 +1,4 @@+#!/usr/bin/env bash+set -euo pipefail++KEIRO_NOMINAL_MUTATION=dishonest-exact cabal test keiro-dsl-conformance-nominal-scalars

+ test/conformance-nominal-scalars/mutations/enum-transpose.sh view

@@ -0,0 +1,4 @@+#!/usr/bin/env bash+set -euo pipefail++KEIRO_NOMINAL_MUTATION=enum-transpose cabal test keiro-dsl-conformance-nominal-scalars

+ test/conformance-nominal-scalars/mutations/id-one-direction.sh view

@@ -0,0 +1,4 @@+#!/usr/bin/env bash+set -euo pipefail++KEIRO_NOMINAL_MUTATION=id-one-direction cabal test keiro-dsl-conformance-nominal-scalars

+ test/conformance-nominal-scalars/mutations/scalar-wire.sh view

@@ -0,0 +1,4 @@+#!/usr/bin/env bash+set -euo pipefail++KEIRO_NOMINAL_MUTATION=scalar-wire cabal test keiro-dsl-conformance-nominal-scalars

test/conformance-process-full/Generated/SurgeDemo/BehaviorSourceMap.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from context surge-demo behavior source map; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from context surge-demo behavior source map; do not edit. module Generated.SurgeDemo.BehaviorSourceMap   ( BehaviorSourceLocation (..)   , behaviorSourceLocation@@ -9,9 +9,9 @@ import Data.Text qualified as T  data BehaviorSourceLocation = BehaviorSourceLocation-  { sourceFile :: !FilePath-  , sourceLine :: !Int-  , sourceColumn :: !Int+  { file :: !FilePath+  , line :: !Int+  , column :: !Int   }   deriving stock (Eq, Ord, Show) @@ -29,7 +29,7 @@  renderBehaviorSourceLocation :: Text -> Text renderBehaviorSourceLocation key = case behaviorSourceLocation key of-  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Just location -> T.pack location.file <> ":" <> tshow location.line <> ":" <> tshow location.column   Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"  tshow :: Show value => value -> Text

+ test/conformance-process-full/Generated/SurgeDemo/Hospital/BehaviorContract.hs view

@@ -0,0 +1,349 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.SurgeDemo.Hospital.BehaviorContract+  ( BehaviorKey (..)+  , unBehaviorKey+  , ObligationKind (..)+  , EvidenceLevel (..)+  , GuardCoverage (..)+  , BehaviorRequirement (..)+  , RejectionClass (..)+  , LiveExpectation (..)+  , BehaviorWitness (..)+  , BehaviorFailure (..)+  , BehaviorConformanceReport (..)+  , behaviorRequirements+  , behaviorCoverageReport+  , behaviorConformancePassed+  , behaviorConformancePassedWith+  , renderBehaviorConformanceText+  ) where++import Generated.SurgeDemo.Hospital.Codec (encodeHospitalEvent, parseHospitalEvent, hospitalCodec)+import Generated.SurgeDemo.Hospital.Domain+import Generated.SurgeDemo.Hospital.Transducer (hospitalTransducer)+import Generated.SurgeDemo.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)++unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value++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+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !HospitalVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef HospitalVertex))+  , target :: !(Maybe HospitalVertex)+  , eventKinds :: ![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+      { key :: BehaviorKey+      , history :: [HospitalEvent]+      , command :: HospitalCommand+      , expected :: LiveExpectation+      }+  | ReplayWitness+      { key :: BehaviorKey+      , historyPrefix :: [HospitalEvent]+      , observedChunk :: [HospitalEvent]+      }+  deriving stock (Eq, Show)++data BehaviorFailure = BehaviorFailure+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !Text+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorFailure where+  toJSON behaviorFailure = object+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail+    ]++data BehaviorConformanceReport = BehaviorConformanceReport+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![BehaviorKey]+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorConformanceReport where+  toJSON report = object+    [ "schema" .= ("keiro/behavior-conformance/1" :: Text)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified+    ]++behaviorRequirements :: [BehaviorRequirement]+behaviorRequirements =+  [ -- HospitalIdle x ActivateSurge: live transition+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-4738b03b129c9778"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = HospitalIdle+      , commandName = "ActivateSurge"+      , expectedEdge = (Just (K.EdgeRef HospitalIdle 0))+      , target = Just HospitalSurging+      , eventKinds = ["SurgeActivated"]+      }+  , -- HospitalSurging x ActivateSurge: required rejection+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-8cc737e3759c26c7"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = HospitalSurging+      , commandName = "ActivateSurge"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []+      }+  ]++behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport+behaviorCoverageReport witnesses =+  BehaviorConformanceReport+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]+    }+ where+  requiredByKey = Map.fromList [(requirement.key, 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 report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)++renderBehaviorConformanceText :: BehaviorConformanceReport -> Text+renderBehaviorConformanceText report = T.unlines+  [ "behavior conformance: Hospital"+  , "schema: keiro/behavior-conformance/1"+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]++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 == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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 == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)+      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) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)++runReplay :: BehaviorRequirement -> [HospitalEvent] -> [HospitalEvent] -> Either BehaviorFailure ()+runReplay requirement prefix chunk = case requirement.kind of+  ReplayTransition -> do+    settled <- settleHistory requirement "history-prefix" prefix+    ensure requirement (K.replaySuccessState settled == requirement.source) "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) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)+    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) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)+    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 == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)+    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 (HospitalIdle, 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+  ActivateSurge _ -> "ActivateSurge"++eventKind :: HospitalEvent -> Text+eventKind event = case Codec.eventType hospitalCodec event of Codec.EventType tag -> tag++regsEqual :: K.RegFile HospitalRegs -> K.RegFile HospitalRegs -> Bool+regsEqual _ _ = True++proofStrength :: BehaviorRequirement -> Bool+proofStrength requirement =+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]++behaviorWitnessKey :: BehaviorWitness -> BehaviorKey+behaviorWitnessKey witness = case witness of+  Pending key -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = 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+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")+        code+        detail+    )+ where+  kindPhrase = case requirement.kind 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-process-full/Generated/SurgeDemo/Hospital/Codec.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.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,5 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.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/Harness.hs view

@@ -0,0 +1,57 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.SurgeDemo.Hospital.Harness (harnessAssertions) where++import Generated.SurgeDemo.Hospital.Domain+import Generated.SurgeDemo.Hospital.Codec (encodeHospitalEvent, parseHospitalEvent, hospitalCodec)+import Generated.SurgeDemo.Hospital.Transducer (hospitalTransducer)+import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer)+import Keiro.Codec (eventType)+import Generated.SurgeDemo.Nominals (HospitalId, parseHospitalId)++-- | (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: SurgeActivated", roundTrips sampleEventSurgeActivated)+  , ("accepts ActivateSurge from HospitalIdle", acceptActivateSurge)+  ]+  ++ forwardReplayActivateSurge++roundTrips :: HospitalEvent -> Bool+roundTrips e = parseHospitalEvent (eventType hospitalCodec e) (encodeHospitalEvent e) == Right e++sampleHospitalId :: HospitalId+sampleHospitalId =+  case parseHospitalId "hosp_01h455vb4pex5vsknk084sn02q" of+    Right parsed -> parsed+    Left problem -> error (show problem)++sampleEventSurgeActivated :: HospitalEvent+sampleEventSurgeActivated = SurgeActivated (SurgeActivatedData sampleHospitalId)++acceptActivateSurge :: Bool+acceptActivateSurge =+  case step hospitalTransducer (HospitalIdle, initialHospitalRegs) (ActivateSurge (ActivateSurgeData sampleHospitalId)) of+    Just (v, _, _) -> v == HospitalSurging+    Nothing -> False++-- forward/replay equality (plan 147): cross the persisted codec boundary,+-- replay the emitted chain, and compare the final vertex and every register.+forwardReplayActivateSurge :: [(String, Bool)]+forwardReplayActivateSurge =+  case step hospitalTransducer (HospitalIdle, initialHospitalRegs) (ActivateSurge (ActivateSurgeData sampleHospitalId)) 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 (HospitalIdle, initialHospitalRegs) decodedEvents of+            Left _ -> [(prefix <> "replay succeeds", False)]+            Right (replayVertex, _replayRegs) ->+              [ (prefix <> "final vertex", replayVertex == forwardVertex)+              ]+  where+    prefix = "forward/replay equality: ActivateSurge from HospitalIdle -- "

test/conformance-process-full/Generated/SurgeDemo/Hospital/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.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,6 @@ {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from context surge-demo generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from context surge-demo generated nominal ID internals; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from context surge-demo replay-audit assembly; do not edit.+-- @generated by keiro-dsl 0.15.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/BehaviorContract.hs view

@@ -0,0 +1,398 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+module Generated.SurgeDemo.Surge.BehaviorContract+  ( BehaviorKey (..)+  , unBehaviorKey+  , ObligationKind (..)+  , EvidenceLevel (..)+  , GuardCoverage (..)+  , BehaviorRequirement (..)+  , RejectionClass (..)+  , LiveExpectation (..)+  , BehaviorWitness (..)+  , BehaviorFailure (..)+  , BehaviorConformanceReport (..)+  , behaviorRequirements+  , behaviorCoverageReport+  , behaviorConformancePassed+  , behaviorConformancePassedWith+  , renderBehaviorConformanceText+  ) where++import Generated.SurgeDemo.Surge.Codec (encodeSurgeEvent, parseSurgeEvent, surgeCodec)+import Generated.SurgeDemo.Surge.Domain+import Generated.SurgeDemo.Surge.Transducer (surgeTransducer)+import Generated.SurgeDemo.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)++unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value++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+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !SurgeVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef SurgeVertex))+  , target :: !(Maybe SurgeVertex)+  , eventKinds :: ![Text]+  }+  deriving stock (Eq, Show)++data RejectionClass = RejectNoOutgoingEdges | RejectNoMatchingEdge+  deriving stock (Eq, Show)++data LiveExpectation+  = Emits (NonEmpty SurgeEvent)+  | Rejects RejectionClass+  | NoOp+  deriving stock (Eq, Show)++data BehaviorWitness+  = Pending BehaviorKey+  | LiveWitness+      { key :: BehaviorKey+      , history :: [SurgeEvent]+      , command :: SurgeCommand+      , expected :: LiveExpectation+      }+  | ReplayWitness+      { key :: BehaviorKey+      , historyPrefix :: [SurgeEvent]+      , observedChunk :: [SurgeEvent]+      }+  deriving stock (Eq, Show)++data BehaviorFailure = BehaviorFailure+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !Text+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorFailure where+  toJSON behaviorFailure = object+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail+    ]++data BehaviorConformanceReport = BehaviorConformanceReport+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![BehaviorKey]+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorConformanceReport where+  toJSON report = object+    [ "schema" .= ("keiro/behavior-conformance/1" :: Text)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified+    ]++behaviorRequirements :: [BehaviorRequirement]+behaviorRequirements =+  [ -- SurgeFired x MarkSurgeTimerFired: required rejection+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-364cc8c97a1dccd7"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = SurgeFired+      , commandName = "MarkSurgeTimerFired"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []+      }+  , -- SurgeWatching x NoteSurgeThreshold: live transition+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-7bd417bb60f14aea"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = SurgeWatching+      , commandName = "NoteSurgeThreshold"+      , expectedEdge = (Just (K.EdgeRef SurgeWatching 0))+      , target = Just SurgeNoted+      , eventKinds = ["SurgeThresholdNoted"]+      }+  , -- SurgeWatching x MarkSurgeTimerFired: required rejection+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-8303777877a78d98"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = SurgeWatching+      , commandName = "MarkSurgeTimerFired"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []+      }+  , -- SurgeFired x NoteSurgeThreshold: required rejection+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-9d1377f4e60cd45a"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = SurgeFired+      , commandName = "NoteSurgeThreshold"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []+      }+  , -- SurgeNoted x NoteSurgeThreshold: required rejection+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-c7783d8bb46678fe"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = SurgeNoted+      , commandName = "NoteSurgeThreshold"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []+      }+  , -- SurgeNoted x MarkSurgeTimerFired: live transition+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-db2fec76864e5867"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = SurgeNoted+      , commandName = "MarkSurgeTimerFired"+      , expectedEdge = (Just (K.EdgeRef SurgeNoted 0))+      , target = Just SurgeFired+      , eventKinds = ["SurgeTimerFired"]+      }+  ]++behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport+behaviorCoverageReport witnesses =+  BehaviorConformanceReport+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]+    }+ where+  requiredByKey = Map.fromList [(requirement.key, 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 report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)++renderBehaviorConformanceText :: BehaviorConformanceReport -> Text+renderBehaviorConformanceText report = T.unlines+  [ "behavior conformance: Surge"+  , "schema: keiro/behavior-conformance/1"+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]++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 -> [SurgeEvent] -> SurgeCommand -> LiveExpectation -> Either BehaviorFailure ()+runLive requirement history command expectation = do+  settled <- settleHistory requirement "history" history+  ensure requirement (K.replaySuccessState settled == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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 -> (SurgeVertex, K.RegFile SurgeRegs) -> SurgeCommand -> 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 surgeTransducer 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 -> (SurgeVertex, K.RegFile SurgeRegs) -> SurgeCommand -> 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 surgeTransducer 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 surgeTransducer 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 == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)+      decoded <- either (failure requirement "emitted-codec-decode") Right (decodeEvents actual)+      replayed <- case K.applyEventsDetailedEither surgeTransducer 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 SurgeRegs SurgeVertex SurgeEvent -> 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) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)++runReplay :: BehaviorRequirement -> [SurgeEvent] -> [SurgeEvent] -> Either BehaviorFailure ()+runReplay requirement prefix chunk = case requirement.kind of+  ReplayTransition -> do+    settled <- settleHistory requirement "history-prefix" prefix+    ensure requirement (K.replaySuccessState settled == requirement.source) "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 surgeTransducer (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) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)+    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 SurgeVertex] -> Either BehaviorFailure ()+checkSingleAttribution requirement expectedMode eventCount trace = case trace of+  [attribution] -> do+    ensure requirement (Just (K.replayAttributionEdge attribution) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)+    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 == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)+    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 -> [SurgeEvent] -> Either BehaviorFailure (K.ReplaySuccess SurgeRegs SurgeVertex)+settleHistory requirement label history = do+  decoded <- either (failure requirement (label <> "-codec-decode")) Right (decodeEvents history)+  case K.applyEventsDetailedEither surgeTransducer (SurgeWatching, initialSurgeRegs) decoded of+    Left replayFailure -> failure requirement (label <> "-replay-failed") (tshow replayFailure)+    Right replaySuccess -> Right replaySuccess++decodeEvents :: [SurgeEvent] -> Either Text [SurgeEvent]+decodeEvents = traverse (\event -> parseSurgeEvent (Codec.eventType surgeCodec event) (encodeSurgeEvent event))++commandKind :: SurgeCommand -> Text+commandKind command = case command of+  NoteSurgeThreshold _ -> "NoteSurgeThreshold"+  MarkSurgeTimerFired _ -> "MarkSurgeTimerFired"++eventKind :: SurgeEvent -> Text+eventKind event = case Codec.eventType surgeCodec event of Codec.EventType tag -> tag++regsEqual :: K.RegFile SurgeRegs -> K.RegFile SurgeRegs -> Bool+regsEqual _ _ = True++proofStrength :: BehaviorRequirement -> Bool+proofStrength requirement =+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]++behaviorWitnessKey :: BehaviorWitness -> BehaviorKey+behaviorWitnessKey witness = case witness of+  Pending key -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = 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+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")+        code+        detail+    )+ where+  kindPhrase = case requirement.kind 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-process-full/Generated/SurgeDemo/Surge/Codec.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.15.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,5 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.15.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/Harness.hs view

@@ -0,0 +1,61 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+module Generated.SurgeDemo.Surge.Harness (harnessAssertions) where++import Generated.SurgeDemo.Surge.Domain+import Generated.SurgeDemo.Surge.Codec (encodeSurgeEvent, parseSurgeEvent, surgeCodec)+import Generated.SurgeDemo.Surge.Transducer (surgeTransducer)+import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer)+import Keiro.Codec (eventType)+import Generated.SurgeDemo.Nominals (HospitalId, parseHospitalId)++-- | (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 surgeTransducer))+  -- clock-free: spec samples no wall clock (verified at scaffold time)+  , ("golden round-trip: SurgeThresholdNoted", roundTrips sampleEventSurgeThresholdNoted)+  , ("golden round-trip: SurgeTimerFired", roundTrips sampleEventSurgeTimerFired)+  , ("accepts NoteSurgeThreshold from SurgeWatching", acceptNoteSurgeThreshold)+  ]+  ++ forwardReplayNoteSurgeThreshold++roundTrips :: SurgeEvent -> Bool+roundTrips e = parseSurgeEvent (eventType surgeCodec e) (encodeSurgeEvent e) == Right e++sampleHospitalId :: HospitalId+sampleHospitalId =+  case parseHospitalId "hosp_01h455vb4pex5vsknk084sn02q" of+    Right parsed -> parsed+    Left problem -> error (show problem)++sampleEventSurgeThresholdNoted :: SurgeEvent+sampleEventSurgeThresholdNoted = SurgeThresholdNoted (SurgeThresholdNotedData sampleHospitalId)++sampleEventSurgeTimerFired :: SurgeEvent+sampleEventSurgeTimerFired = SurgeTimerFired (SurgeTimerFiredData sampleHospitalId)++acceptNoteSurgeThreshold :: Bool+acceptNoteSurgeThreshold =+  case step surgeTransducer (SurgeWatching, initialSurgeRegs) (NoteSurgeThreshold (NoteSurgeThresholdData sampleHospitalId)) of+    Just (v, _, _) -> v == SurgeNoted+    Nothing -> False++-- forward/replay equality (plan 147): cross the persisted codec boundary,+-- replay the emitted chain, and compare the final vertex and every register.+forwardReplayNoteSurgeThreshold :: [(String, Bool)]+forwardReplayNoteSurgeThreshold =+  case step surgeTransducer (SurgeWatching, initialSurgeRegs) (NoteSurgeThreshold (NoteSurgeThresholdData sampleHospitalId)) of+    Nothing -> [(prefix <> "forward step accepted", False)]+    Just (forwardVertex, _forwardRegs, emitted) ->+      case mapM (\event -> parseSurgeEvent (eventType surgeCodec event) (encodeSurgeEvent event)) emitted of+        Left _ -> [(prefix <> "emitted chain decodes", False)]+        Right decodedEvents ->+          case applyEventsEither surgeTransducer (SurgeWatching, initialSurgeRegs) decodedEvents of+            Left _ -> [(prefix <> "replay succeeds", False)]+            Right (replayVertex, _replayRegs) ->+              [ (prefix <> "final vertex", replayVertex == forwardVertex)+              ]+  where+    prefix = "forward/replay equality: NoteSurgeThreshold from SurgeWatching -- "

test/conformance-process-full/Generated/SurgeDemo/Surge/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.15.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,6 @@ {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from process SurgeFlow; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from process SurgeFlow; do not edit. module Generated.SurgeDemo.SurgeFlow.Process   ( surgeFlowProcessName   , surgeFlowCategory

+ test/conformance-process-full/Generated/SurgeDemo/SurgeFlow/ProcessHarness.hs view

@@ -0,0 +1,22 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from process SurgeFlow; do not edit.+module Generated.SurgeDemo.SurgeFlow.ProcessHarness (processHarnessValues) where++-- | (label, value): the spec's deterministic process/timer decisions,+-- lowered to plain values so a driver can assert them against a committed+-- expectation. The driver's expectation is hand-written (not generated), so a+-- spec change that alters a decision diverges from it and turns a specific+-- assertion red — the spec->behaviour pin. (Live-runtime behavioural+-- conformance of the filled ProcessManager is the M5 step.)+processHarnessValues :: [(String, String)]+processHarnessValues =+  [ ("fireAtField", "observedAt")+  , ("timerIdPrefix", "surge-timer:")+  , ("firedEventIdPrefix", "surge-fired:")+  , ("dispatchIdUserField", "none")+  , ("onReject", "Fired")+  , ("onAmbiguous", "Retry")+  , ("onFailed", "Retry")+  , ("rejectedPolicy", "halt")+  , ("poisonPolicy", "halt")+  , ("maxAttempts", "5")+  ]

+ test/conformance-process-full/SurgeDemo/Hospital/BehaviorHoles.hs view

@@ -0,0 +1,10 @@+-- Consumer-owned behavioral witnesses. Created once; never overwritten.+module SurgeDemo.Hospital.BehaviorHoles (behaviorWitnesses) where++import Generated.SurgeDemo.Hospital.BehaviorContract++behaviorWitnesses :: [BehaviorWitness]+behaviorWitnesses =+  [ Pending (BehaviorKey "behavior-v1-4738b03b129c9778")+  , Pending (BehaviorKey "behavior-v1-8cc737e3759c26c7")+  ]

+ test/conformance-process-full/SurgeDemo/Surge/BehaviorHoles.hs view

@@ -0,0 +1,14 @@+-- Consumer-owned behavioral witnesses. Created once; never overwritten.+module SurgeDemo.Surge.BehaviorHoles (behaviorWitnesses) where++import Generated.SurgeDemo.Surge.BehaviorContract++behaviorWitnesses :: [BehaviorWitness]+behaviorWitnesses =+  [ Pending (BehaviorKey "behavior-v1-364cc8c97a1dccd7")+  , Pending (BehaviorKey "behavior-v1-7bd417bb60f14aea")+  , Pending (BehaviorKey "behavior-v1-8303777877a78d98")+  , Pending (BehaviorKey "behavior-v1-9d1377f4e60cd45a")+  , Pending (BehaviorKey "behavior-v1-c7783d8bb46678fe")+  , Pending (BehaviorKey "behavior-v1-db2fec76864e5867")+  ]

test/conformance-process-full/SurgeDemo/SurgeFlow/Manager.hs view

@@ -49,23 +49,23 @@ surgeManager =     ProcessManager         { name = "surge-demo"-        , correlate = \i -> hospitalId (i :: SurgeInput)+        , correlate = \i -> (i :: SurgeInput).hospitalId         , eventStream = surgeEventStream         , streamFor = entityStream surgeFlowCategory         , targetEventStream = hospitalEventStream         , targetProjections = const []         , handle = \i ->-            let checkedId = checkedHospitalId (hospitalId i)+            let checkedId = checkedHospitalId i.hospitalId              in             ProcessManagerAction                 { command = S.NoteSurgeThreshold (S.NoteSurgeThresholdData checkedId)                 , commands =                     [ PMCommand-                        { target = entityStream hospitalCommandCategory (hospitalId i)+                        { target = entityStream hospitalCommandCategory i.hospitalId                             , command = H.ActivateSurge (H.ActivateSurgeData checkedId)                         }                     ]-                , timers = [surgeFlowTimerRequest (hospitalId i) (observedAt i)]+                , timers = [surgeFlowTimerRequest i.hospitalId i.observedAt]                 }         }

+ test/conformance-process-full/SurgeDemo/SurgeFlow/ProcessHoles.hs view

@@ -0,0 +1,11 @@+-- HAND-OWNED hole module for the process manager's behaviour-bearing bodies.+-- keiro-dsl creates it once and never overwrites it.+module SurgeDemo.SurgeFlow.ProcessHoles () where++-- HOLE handle: build the ProcessManagerAction (the self-advance+--   'NoteSurgeThreshold', the dispatch(es), and the timer) from the input.+-- HOLE window: the deadline policy, e.g. surgeWindow :: NominalDiffTime;+--   surgeDeadline observedAt = addUTCTime surgeWindow observedAt  (TIME INJECTED).+-- HOLE fire command: construct MarkSurgeTimerFired for the timer fire,+--   keyed by correlationId; the fired-event-id is the deterministic uuidv5 of+--   "surge-fired:" <> correlationId.

+ test/conformance-process-full/keiro-dsl-cabal-fragment.context.surge-demo.txt view

@@ -0,0 +1,48 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/surge-service.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    Generated.SurgeDemo.BehaviorSourceMap+    Generated.SurgeDemo.Hospital.BehaviorContract+    Generated.SurgeDemo.Hospital.Codec+    Generated.SurgeDemo.Hospital.Domain+    Generated.SurgeDemo.Hospital.EventStream+    Generated.SurgeDemo.Hospital.Harness+    Generated.SurgeDemo.Hospital.Projection+    Generated.SurgeDemo.Hospital.Transducer+    Generated.SurgeDemo.Nominals+    Generated.SurgeDemo.Nominals.Internal+    Generated.SurgeDemo.ReplayAudit+    Generated.SurgeDemo.Surge.BehaviorContract+    Generated.SurgeDemo.Surge.Codec+    Generated.SurgeDemo.Surge.Domain+    Generated.SurgeDemo.Surge.EventStream+    Generated.SurgeDemo.Surge.Harness+    Generated.SurgeDemo.Surge.Projection+    Generated.SurgeDemo.Surge.Transducer+    Generated.SurgeDemo.SurgeFlow.Process+    Generated.SurgeDemo.SurgeFlow.ProcessHarness+    SurgeDemo.Hospital.BehaviorHoles+    SurgeDemo.Hospital.Holes+    SurgeDemo.Surge.BehaviorHoles+    SurgeDemo.Surge.Holes+    SurgeDemo.SurgeFlow.ProcessHoles++build-depends:+    , aeson+    , base+    , keiki+    , keiro+    , shibuya-core+    , text+    , time+    , uuid

+ test/conformance-process-full/keiro-dsl-ledger.context.surge-demo.txt view

@@ -0,0 +1,68 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/surge-service.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":4,"effectiveLanguageVersion":4,"sourceForm":"declared"}+semantic-contract {"languageSupport":"compatibility-only","languageVersion":4,"runtimeSemantics":"keiro-dsl/runtime-semantics/3"}+naming-edition idiomatic-v2+module-role {"family":"BehaviorSourceMap","kind":"generated","ownerKind":"context","ownerName":"context surge-demo behavior source map","path":"Generated/SurgeDemo/BehaviorSourceMap.hs"}+module-role {"family":"Nominals","kind":"generated","ownerKind":"context","ownerName":"context surge-demo generated nominal declarations","path":"Generated/SurgeDemo/Nominals.hs"}+module-role {"family":"Internal","kind":"generated","ownerKind":"context","ownerName":"context surge-demo generated nominal ID internals","path":"Generated/SurgeDemo/Nominals/Internal.hs"}+module-role {"family":"ReplayAudit","kind":"generated","ownerKind":"context","ownerName":"context surge-demo replay-audit assembly","path":"Generated/SurgeDemo/ReplayAudit.hs"}+module-role {"family":"Process","kind":"generated","ownerKind":"process","ownerName":"process SurgeFlow (line 6)","path":"Generated/SurgeDemo/SurgeFlow/Process.hs"}+module-role {"family":"ProcessHoles","kind":"hole","ownerKind":"process","ownerName":"process SurgeFlow (line 6)","path":"SurgeDemo/SurgeFlow/ProcessHoles.hs"}+module-role {"family":"ProcessHarness","kind":"generated","ownerKind":"process","ownerName":"process SurgeFlow (line 6)","path":"Generated/SurgeDemo/SurgeFlow/ProcessHarness.hs"}+module-role {"family":"Domain","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 34)","path":"Generated/SurgeDemo/Surge/Domain.hs"}+module-role {"family":"Codec","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 34)","path":"Generated/SurgeDemo/Surge/Codec.hs"}+module-role {"family":"Transducer","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 34)","path":"Generated/SurgeDemo/Surge/Transducer.hs"}+module-role {"family":"BehaviorContract","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 34)","path":"Generated/SurgeDemo/Surge/BehaviorContract.hs"}+module-role {"family":"BehaviorHoles","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate behavior witnesses Surge (line 34)","path":"SurgeDemo/Surge/BehaviorHoles.hs"}+module-role {"family":"EventStream","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 34)","path":"Generated/SurgeDemo/Surge/EventStream.hs"}+module-role {"family":"Projection","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 34)","path":"Generated/SurgeDemo/Surge/Projection.hs"}+module-role {"family":"Holes","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate Surge (line 34)","path":"SurgeDemo/Surge/Holes.hs"}+module-role {"family":"Harness","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 34)","path":"Generated/SurgeDemo/Surge/Harness.hs"}+module-role {"family":"Domain","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 50)","path":"Generated/SurgeDemo/Hospital/Domain.hs"}+module-role {"family":"Codec","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 50)","path":"Generated/SurgeDemo/Hospital/Codec.hs"}+module-role {"family":"Transducer","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 50)","path":"Generated/SurgeDemo/Hospital/Transducer.hs"}+module-role {"family":"BehaviorContract","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 50)","path":"Generated/SurgeDemo/Hospital/BehaviorContract.hs"}+module-role {"family":"BehaviorHoles","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate behavior witnesses Hospital (line 50)","path":"SurgeDemo/Hospital/BehaviorHoles.hs"}+module-role {"family":"EventStream","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 50)","path":"Generated/SurgeDemo/Hospital/EventStream.hs"}+module-role {"family":"Projection","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 50)","path":"Generated/SurgeDemo/Hospital/Projection.hs"}+module-role {"family":"Holes","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 50)","path":"SurgeDemo/Hospital/Holes.hs"}+module-role {"family":"Harness","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 50)","path":"Generated/SurgeDemo/Hospital/Harness.hs"}+generated Generated/SurgeDemo/BehaviorSourceMap.hs+generated Generated/SurgeDemo/Nominals.hs+generated Generated/SurgeDemo/Nominals/Internal.hs+generated Generated/SurgeDemo/ReplayAudit.hs+generated Generated/SurgeDemo/SurgeFlow/Process.hs+hole SurgeDemo/SurgeFlow/ProcessHoles.hs+generated Generated/SurgeDemo/SurgeFlow/ProcessHarness.hs+generated Generated/SurgeDemo/Surge/Domain.hs+generated Generated/SurgeDemo/Surge/Codec.hs+generated Generated/SurgeDemo/Surge/Transducer.hs+generated Generated/SurgeDemo/Surge/BehaviorContract.hs+hole SurgeDemo/Surge/BehaviorHoles.hs+generated Generated/SurgeDemo/Surge/EventStream.hs+generated Generated/SurgeDemo/Surge/Projection.hs+hole SurgeDemo/Surge/Holes.hs+generated Generated/SurgeDemo/Surge/Harness.hs+generated Generated/SurgeDemo/Hospital/Domain.hs+generated Generated/SurgeDemo/Hospital/Codec.hs+generated Generated/SurgeDemo/Hospital/Transducer.hs+generated Generated/SurgeDemo/Hospital/BehaviorContract.hs+hole SurgeDemo/Hospital/BehaviorHoles.hs+generated Generated/SurgeDemo/Hospital/EventStream.hs+generated Generated/SurgeDemo/Hospital/Projection.hs+hole SurgeDemo/Hospital/Holes.hs+generated Generated/SurgeDemo/Hospital/Harness.hs+id-domain id-domain|name=HospitalId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=hosp|separator=_|json=canonical-json-text+nominal-equality nominal-equality|name=HospitalId|contract=keiro-dsl/nominal-equality/2|key=Text|domain=typeid-v7-text:hosp:keiro-dsl/id-domain/typeid-v7/1|owner=generated+behavior {"aggregate":"Surge","command":"MarkSurgeTimerFired","evidence":"generated-authoritative","key":"behavior-v1-364cc8c97a1dccd7","kind":"required-rejection","outputs":[],"source":"Fired"}+behavior {"aggregate":"Hospital","command":"ActivateSurge","evidence":"generated-authoritative","key":"behavior-v1-4738b03b129c9778","kind":"live-transition","outputs":[{"command":"ActivateSurge","ownership":"generated-command-identity"}],"source":"Idle"}+behavior {"aggregate":"Surge","command":"NoteSurgeThreshold","evidence":"generated-authoritative","key":"behavior-v1-7bd417bb60f14aea","kind":"live-transition","outputs":[{"command":"NoteSurgeThreshold","ownership":"generated-command-identity"}],"source":"Watching"}+behavior {"aggregate":"Surge","command":"MarkSurgeTimerFired","evidence":"generated-authoritative","key":"behavior-v1-8303777877a78d98","kind":"required-rejection","outputs":[],"source":"Watching"}+behavior {"aggregate":"Hospital","command":"ActivateSurge","evidence":"generated-authoritative","key":"behavior-v1-8cc737e3759c26c7","kind":"required-rejection","outputs":[],"source":"Surging"}+behavior {"aggregate":"Surge","command":"NoteSurgeThreshold","evidence":"generated-authoritative","key":"behavior-v1-9d1377f4e60cd45a","kind":"required-rejection","outputs":[],"source":"Fired"}+behavior {"aggregate":"Surge","command":"NoteSurgeThreshold","evidence":"generated-authoritative","key":"behavior-v1-c7783d8bb46678fe","kind":"required-rejection","outputs":[],"source":"Noted"}+behavior {"aggregate":"Surge","command":"MarkSurgeTimerFired","evidence":"generated-authoritative","key":"behavior-v1-db2fec76864e5867","kind":"live-transition","outputs":[{"command":"MarkSurgeTimerFired","ownership":"generated-command-identity"}],"source":"Noted"}+semantic-impact {"declarations":[],"mappedSurfaceEvidenceVersion":1,"serviceInventory":[]}

test/conformance-process-runtime/Generated/HospitalCapacity/BehaviorSourceMap.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from context hospital-capacity behavior source map; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from context hospital-capacity behavior source map; do not edit. module Generated.HospitalCapacity.BehaviorSourceMap   ( BehaviorSourceLocation (..)   , behaviorSourceLocation@@ -9,9 +9,9 @@ import Data.Text qualified as T  data BehaviorSourceLocation = BehaviorSourceLocation-  { sourceFile :: !FilePath-  , sourceLine :: !Int-  , sourceColumn :: !Int+  { file :: !FilePath+  , line :: !Int+  , column :: !Int   }   deriving stock (Eq, Ord, Show) @@ -24,7 +24,7 @@  renderBehaviorSourceLocation :: Text -> Text renderBehaviorSourceLocation key = case behaviorSourceLocation key of-  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Just location -> T.pack location.file <> ":" <> tshow location.line <> ":" <> tshow location.column   Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"  tshow :: Show value => value -> Text

+ test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/BehaviorContract.hs view

@@ -0,0 +1,337 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.HospitalCapacity.Hospital.BehaviorContract+  ( BehaviorKey (..)+  , unBehaviorKey+  , ObligationKind (..)+  , EvidenceLevel (..)+  , GuardCoverage (..)+  , BehaviorRequirement (..)+  , RejectionClass (..)+  , LiveExpectation (..)+  , BehaviorWitness (..)+  , BehaviorFailure (..)+  , BehaviorConformanceReport (..)+  , behaviorRequirements+  , behaviorCoverageReport+  , behaviorConformancePassed+  , behaviorConformancePassedWith+  , renderBehaviorConformanceText+  ) where++import Generated.HospitalCapacity.Hospital.Codec (encodeHospitalEvent, parseHospitalEvent, hospitalCodec)+import Generated.HospitalCapacity.Hospital.Domain+import Generated.HospitalCapacity.Hospital.Transducer (hospitalTransducer)+import Generated.HospitalCapacity.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)++unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value++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+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !HospitalVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef HospitalVertex))+  , target :: !(Maybe HospitalVertex)+  , eventKinds :: ![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+      { key :: BehaviorKey+      , history :: [HospitalEvent]+      , command :: HospitalCommand+      , expected :: LiveExpectation+      }+  | ReplayWitness+      { key :: BehaviorKey+      , historyPrefix :: [HospitalEvent]+      , observedChunk :: [HospitalEvent]+      }+  deriving stock (Eq, Show)++data BehaviorFailure = BehaviorFailure+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !Text+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorFailure where+  toJSON behaviorFailure = object+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail+    ]++data BehaviorConformanceReport = BehaviorConformanceReport+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![BehaviorKey]+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorConformanceReport where+  toJSON report = object+    [ "schema" .= ("keiro/behavior-conformance/1" :: Text)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified+    ]++behaviorRequirements :: [BehaviorRequirement]+behaviorRequirements =+  [ -- HospitalOperational x ActivateSurge: live transition+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-69ac3daa8569d350"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = HospitalOperational+      , commandName = "ActivateSurge"+      , expectedEdge = (Just (K.EdgeRef HospitalOperational 0))+      , target = Just HospitalOperational+      , eventKinds = ["SurgeActivated"]+      }+  ]++behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport+behaviorCoverageReport witnesses =+  BehaviorConformanceReport+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]+    }+ where+  requiredByKey = Map.fromList [(requirement.key, 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 report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)++renderBehaviorConformanceText :: BehaviorConformanceReport -> Text+renderBehaviorConformanceText report = T.unlines+  [ "behavior conformance: Hospital"+  , "schema: keiro/behavior-conformance/1"+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]++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 == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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 == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)+      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) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)++runReplay :: BehaviorRequirement -> [HospitalEvent] -> [HospitalEvent] -> Either BehaviorFailure ()+runReplay requirement prefix chunk = case requirement.kind of+  ReplayTransition -> do+    settled <- settleHistory requirement "history-prefix" prefix+    ensure requirement (K.replaySuccessState settled == requirement.source) "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) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)+    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) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)+    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 == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)+    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 (HospitalOperational, 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+  ActivateSurge _ -> "ActivateSurge"++eventKind :: HospitalEvent -> Text+eventKind event = case Codec.eventType hospitalCodec event of Codec.EventType tag -> tag++regsEqual :: K.RegFile HospitalRegs -> K.RegFile HospitalRegs -> Bool+regsEqual _ _ = True++proofStrength :: BehaviorRequirement -> Bool+proofStrength requirement =+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]++behaviorWitnessKey :: BehaviorWitness -> BehaviorKey+behaviorWitnessKey witness = case witness of+  Pending key -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = 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+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")+        code+        detail+    )+ where+  kindPhrase = case requirement.kind 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-process-runtime/Generated/HospitalCapacity/Hospital/Codec.hs view

@@ -0,0 +1,66 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.HospitalCapacity.Hospital.Codec (+    hospitalCodec,+    parseHospitalEvent,+    encodeHospitalEvent,+) where++import Generated.HospitalCapacity.Hospital.Domain+import Generated.HospitalCapacity.Nominals (hospitalIdText)+import Generated.HospitalCapacity.Nominals.Internal (unsafeHospitalIdFromLegacyText)+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 "SurgeActivated" :| []++hospitalCodec :: Codec HospitalEvent+hospitalCodec =+  Codec+    { eventTypes = hospitalEventTypes+    , eventType = \case+        SurgeActivated{} -> EventType "SurgeActivated"+    , schemaVersion = 1+    , encode = encodeHospitalEvent+    , decode = parseHospitalEvent+    , upcasters = []+    }++encodeHospitalEvent :: HospitalEvent -> Value+encodeHospitalEvent = \case+  SurgeActivated payload ->+    object+      [ "kind" .= ("SurgeActivated" :: Text)+      , "hospitalId" .= hospitalIdText payload.hospitalId+      ]++parseHospitalEvent :: EventType -> Value -> Either Text HospitalEvent+parseHospitalEvent (EventType tag) = mapLeftText . parseEither (withObject "HospitalEvent" go)+  where+    go o = do+      case tag of+        "SurgeActivated" ->+          SurgeActivated+            <$> ( SurgeActivatedData+                    <$> (unsafeHospitalIdFromLegacyText <$> 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-process-runtime/Generated/HospitalCapacity/Hospital/Domain.hs view

@@ -0,0 +1,40 @@+{-# LANGUAGE TemplateHaskell #-}+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.HospitalCapacity.Hospital.Domain where++import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Generated.HospitalCapacity.Nominals (HospitalId)+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++data HospitalVertex = HospitalOperational+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data ActivateSurgeData = ActivateSurgeData+  { hospitalId :: !HospitalId+  }+  deriving stock (Generic, Eq, Show)++data HospitalCommand = ActivateSurge !ActivateSurgeData+  deriving stock (Generic, Eq, Show)++data SurgeActivatedData = SurgeActivatedData+  { hospitalId :: !HospitalId+  }+  deriving stock (Generic, Eq, Show)++data HospitalEvent = SurgeActivated !SurgeActivatedData+  deriving stock (Generic, Eq, Show)++type HospitalRegs =+  '[]++initialHospitalRegs :: RegFile HospitalRegs+initialHospitalRegs =+  RNil++$(deriveAggregateCtorsAll ''HospitalCommand ''HospitalRegs)++++$(deriveWireCtorsAll ''HospitalEvent)

+ test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/EventStream.hs view

@@ -0,0 +1,49 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.HospitalCapacity.Hospital.EventStream+  ( hospitalCategory+  , hospitalCommandCategory+  , hospitalEventStream+  , hospitalEventStreamDef+  , HospitalEventStream+  , HospitalEventStreamDef+  ) where++import Generated.HospitalCapacity.Hospital.Domain+import Generated.HospitalCapacity.Hospital.Codec (hospitalCodec)+import Generated.HospitalCapacity.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 = HospitalOperational,+      initialRegisters = initialHospitalRegs,+      eventCodec = hospitalCodec,+      resolveStreamName = Stream.streamName,+      snapshotPolicy = Never,+      stateCodec = Nothing+    }++hospitalEventStream :: HospitalEventStream+hospitalEventStream =+  mkEventStreamOrThrow "Hospital" hospitalEventStreamDef

+ test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/Harness.hs view

@@ -0,0 +1,57 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.HospitalCapacity.Hospital.Harness (harnessAssertions) where++import Generated.HospitalCapacity.Hospital.Domain+import Generated.HospitalCapacity.Hospital.Codec (encodeHospitalEvent, parseHospitalEvent, hospitalCodec)+import Generated.HospitalCapacity.Hospital.Transducer (hospitalTransducer)+import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer)+import Keiro.Codec (eventType)+import Generated.HospitalCapacity.Nominals (HospitalId, parseHospitalId)++-- | (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: SurgeActivated", roundTrips sampleEventSurgeActivated)+  , ("accepts ActivateSurge from HospitalOperational", acceptActivateSurge)+  ]+  ++ forwardReplayActivateSurge++roundTrips :: HospitalEvent -> Bool+roundTrips e = parseHospitalEvent (eventType hospitalCodec e) (encodeHospitalEvent e) == Right e++sampleHospitalId :: HospitalId+sampleHospitalId =+  case parseHospitalId "hosp_01h455vb4pex5vsknk084sn02q" of+    Right parsed -> parsed+    Left problem -> error (show problem)++sampleEventSurgeActivated :: HospitalEvent+sampleEventSurgeActivated = SurgeActivated (SurgeActivatedData sampleHospitalId)++acceptActivateSurge :: Bool+acceptActivateSurge =+  case step hospitalTransducer (HospitalOperational, initialHospitalRegs) (ActivateSurge (ActivateSurgeData sampleHospitalId)) of+    Just (v, _, _) -> v == HospitalOperational+    Nothing -> False++-- forward/replay equality (plan 147): cross the persisted codec boundary,+-- replay the emitted chain, and compare the final vertex and every register.+forwardReplayActivateSurge :: [(String, Bool)]+forwardReplayActivateSurge =+  case step hospitalTransducer (HospitalOperational, initialHospitalRegs) (ActivateSurge (ActivateSurgeData sampleHospitalId)) 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 (HospitalOperational, initialHospitalRegs) decodedEvents of+            Left _ -> [(prefix <> "replay succeeds", False)]+            Right (replayVertex, _replayRegs) ->+              [ (prefix <> "final vertex", replayVertex == forwardVertex)+              ]+  where+    prefix = "forward/replay equality: ActivateSurge from HospitalOperational -- "

+ test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/Projection.hs view

@@ -0,0 +1,4 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.HospitalCapacity.Hospital.Projection () where++-- No projection declarations are present; this module keeps the generated manifest inventory total.

+ test/conformance-process-runtime/Generated/HospitalCapacity/Hospital/Transducer.hs view

@@ -0,0 +1,54 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE QualifiedDo #-}+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.HospitalCapacity.Hospital.Transducer+  ( hospitalTransducer+  , hospitalFoldFingerprint+  , BehaviorOwnership (..)+  , hospitalPredicateVerifications+  ) where++import Generated.HospitalCapacity.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++hospitalTransducer+  :: SymTransducer+       (HsPred HospitalRegs HospitalCommand)+       HospitalRegs+       HospitalVertex+       HospitalCommand+       HospitalEvent+hospitalTransducer =+  B.buildTransducer HospitalOperational initialHospitalRegs isTerminal do+    B.from HospitalOperational do+      B.onCmd inCtorActivateSurge $ \d -> B.do+        B.emit wireSurgeActivated (SurgeActivatedTermFields+          { hospitalId = d.hospitalId+          })+        B.goto HospitalOperational+ where+  isTerminal = \case++    _ -> False++hospitalFoldFingerprint :: Text+hospitalFoldFingerprint = "06c89896e94c1e76773dd30acb13f802"++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 "transition1OperationalActivateSurge" GeneratedOwned HospitalOperational 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-process-runtime/Generated/HospitalCapacity/HospitalSurge/Process.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from process HospitalSurge; do not edit.+-- @generated by keiro-dsl 0.15.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/HospitalSurge/ProcessHarness.hs view

@@ -0,0 +1,22 @@+-- @generated by keiro-dsl 0.15.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,+-- lowered to plain values so a driver can assert them against a committed+-- expectation. The driver's expectation is hand-written (not generated), so a+-- spec change that alters a decision diverges from it and turns a specific+-- assertion red — the spec->behaviour pin. (Live-runtime behavioural+-- conformance of the filled ProcessManager is the M5 step.)+processHarnessValues :: [(String, String)]+processHarnessValues =+  [ ("fireAtField", "observedAt")+  , ("timerIdPrefix", "hospital-surge-timer:")+  , ("firedEventIdPrefix", "hospital-surge-fired:")+  , ("dispatchIdUserField", "none")+  , ("onReject", "Fired")+  , ("onAmbiguous", "Retry")+  , ("onFailed", "Retry")+  , ("rejectedPolicy", "halt")+  , ("poisonPolicy", "halt")+  , ("maxAttempts", "5")+  ]

test/conformance-process-runtime/Generated/HospitalCapacity/Nominals.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal declarations; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal ID internals; do not edit.+-- @generated by keiro-dsl 0.15.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/ReplayAudit.hs view

@@ -0,0 +1,30 @@+-- @generated by keiro-dsl 0.15.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;+--   * 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.HospitalCapacity.ReplayAudit (auditTargets) where++import Generated.HospitalCapacity.Surge.EventStream qualified as Surge+import Generated.HospitalCapacity.Hospital.EventStream qualified as Hospital+import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory)+import Keiro.Stream qualified as Stream++auditTargets :: [SomeAuditTarget]+auditTargets =+  [ SomeAuditTarget+      AuditTarget+        { eventStream = Surge.surgeEventStream+        , category = Stream.categoryText Surge.surgeCategory+        , mkStream = streamInCategory (Stream.categoryText Surge.surgeCategory)+        }+  , SomeAuditTarget+      AuditTarget+        { eventStream = Hospital.hospitalEventStream+        , category = Stream.categoryText Hospital.hospitalCategory+        , mkStream = streamInCategory (Stream.categoryText Hospital.hospitalCategory)+        }+  ]

+ test/conformance-process-runtime/Generated/HospitalCapacity/Surge/BehaviorContract.hs view

@@ -0,0 +1,350 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+module Generated.HospitalCapacity.Surge.BehaviorContract+  ( BehaviorKey (..)+  , unBehaviorKey+  , ObligationKind (..)+  , EvidenceLevel (..)+  , GuardCoverage (..)+  , BehaviorRequirement (..)+  , RejectionClass (..)+  , LiveExpectation (..)+  , BehaviorWitness (..)+  , BehaviorFailure (..)+  , BehaviorConformanceReport (..)+  , behaviorRequirements+  , behaviorCoverageReport+  , behaviorConformancePassed+  , behaviorConformancePassedWith+  , renderBehaviorConformanceText+  ) where++import Generated.HospitalCapacity.Surge.Codec (encodeSurgeEvent, parseSurgeEvent, surgeCodec)+import Generated.HospitalCapacity.Surge.Domain+import Generated.HospitalCapacity.Surge.Transducer (surgeTransducer)+import Generated.HospitalCapacity.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)++unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value++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+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !SurgeVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef SurgeVertex))+  , target :: !(Maybe SurgeVertex)+  , eventKinds :: ![Text]+  }+  deriving stock (Eq, Show)++data RejectionClass = RejectNoOutgoingEdges | RejectNoMatchingEdge+  deriving stock (Eq, Show)++data LiveExpectation+  = Emits (NonEmpty SurgeEvent)+  | Rejects RejectionClass+  | NoOp+  deriving stock (Eq, Show)++data BehaviorWitness+  = Pending BehaviorKey+  | LiveWitness+      { key :: BehaviorKey+      , history :: [SurgeEvent]+      , command :: SurgeCommand+      , expected :: LiveExpectation+      }+  | ReplayWitness+      { key :: BehaviorKey+      , historyPrefix :: [SurgeEvent]+      , observedChunk :: [SurgeEvent]+      }+  deriving stock (Eq, Show)++data BehaviorFailure = BehaviorFailure+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !Text+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorFailure where+  toJSON behaviorFailure = object+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail+    ]++data BehaviorConformanceReport = BehaviorConformanceReport+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![BehaviorKey]+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorConformanceReport where+  toJSON report = object+    [ "schema" .= ("keiro/behavior-conformance/1" :: Text)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified+    ]++behaviorRequirements :: [BehaviorRequirement]+behaviorRequirements =+  [ -- SurgeIdle x NoteSurgeThreshold: live transition+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-5198a253324042e6"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = SurgeIdle+      , commandName = "NoteSurgeThreshold"+      , expectedEdge = (Just (K.EdgeRef SurgeIdle 0))+      , target = Just SurgeIdle+      , eventKinds = ["SurgeThresholdNoted"]+      }+  , -- SurgeIdle x MarkSurgeTimerFired: live transition+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-6721e0b61aa38780"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = SurgeIdle+      , commandName = "MarkSurgeTimerFired"+      , expectedEdge = (Just (K.EdgeRef SurgeIdle 1))+      , target = Just SurgeIdle+      , eventKinds = ["SurgeTimerMarked"]+      }+  ]++behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport+behaviorCoverageReport witnesses =+  BehaviorConformanceReport+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]+    }+ where+  requiredByKey = Map.fromList [(requirement.key, 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 report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)++renderBehaviorConformanceText :: BehaviorConformanceReport -> Text+renderBehaviorConformanceText report = T.unlines+  [ "behavior conformance: Surge"+  , "schema: keiro/behavior-conformance/1"+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]++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 -> [SurgeEvent] -> SurgeCommand -> LiveExpectation -> Either BehaviorFailure ()+runLive requirement history command expectation = do+  settled <- settleHistory requirement "history" history+  ensure requirement (K.replaySuccessState settled == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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 -> (SurgeVertex, K.RegFile SurgeRegs) -> SurgeCommand -> 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 surgeTransducer 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 -> (SurgeVertex, K.RegFile SurgeRegs) -> SurgeCommand -> 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 surgeTransducer 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 surgeTransducer 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 == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)+      decoded <- either (failure requirement "emitted-codec-decode") Right (decodeEvents actual)+      replayed <- case K.applyEventsDetailedEither surgeTransducer 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 SurgeRegs SurgeVertex SurgeEvent -> 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) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)++runReplay :: BehaviorRequirement -> [SurgeEvent] -> [SurgeEvent] -> Either BehaviorFailure ()+runReplay requirement prefix chunk = case requirement.kind of+  ReplayTransition -> do+    settled <- settleHistory requirement "history-prefix" prefix+    ensure requirement (K.replaySuccessState settled == requirement.source) "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 surgeTransducer (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) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)+    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 SurgeVertex] -> Either BehaviorFailure ()+checkSingleAttribution requirement expectedMode eventCount trace = case trace of+  [attribution] -> do+    ensure requirement (Just (K.replayAttributionEdge attribution) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)+    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 == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)+    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 -> [SurgeEvent] -> Either BehaviorFailure (K.ReplaySuccess SurgeRegs SurgeVertex)+settleHistory requirement label history = do+  decoded <- either (failure requirement (label <> "-codec-decode")) Right (decodeEvents history)+  case K.applyEventsDetailedEither surgeTransducer (SurgeIdle, initialSurgeRegs) decoded of+    Left replayFailure -> failure requirement (label <> "-replay-failed") (tshow replayFailure)+    Right replaySuccess -> Right replaySuccess++decodeEvents :: [SurgeEvent] -> Either Text [SurgeEvent]+decodeEvents = traverse (\event -> parseSurgeEvent (Codec.eventType surgeCodec event) (encodeSurgeEvent event))++commandKind :: SurgeCommand -> Text+commandKind command = case command of+  NoteSurgeThreshold _ -> "NoteSurgeThreshold"+  MarkSurgeTimerFired _ -> "MarkSurgeTimerFired"++eventKind :: SurgeEvent -> Text+eventKind event = case Codec.eventType surgeCodec event of Codec.EventType tag -> tag++regsEqual :: K.RegFile SurgeRegs -> K.RegFile SurgeRegs -> Bool+regsEqual _ _ = True++proofStrength :: BehaviorRequirement -> Bool+proofStrength requirement =+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]++behaviorWitnessKey :: BehaviorWitness -> BehaviorKey+behaviorWitnessKey witness = case witness of+  Pending key -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = 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+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")+        code+        detail+    )+ where+  kindPhrase = case requirement.kind 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-process-runtime/Generated/HospitalCapacity/Surge/Codec.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.15.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,5 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.15.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.14.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.15.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/Harness.hs view

@@ -0,0 +1,87 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+module Generated.HospitalCapacity.Surge.Harness (harnessAssertions) where++import Generated.HospitalCapacity.Surge.Domain+import Generated.HospitalCapacity.Surge.Codec (encodeSurgeEvent, parseSurgeEvent, surgeCodec)+import Generated.HospitalCapacity.Surge.Transducer (surgeTransducer)+import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer)+import Keiro.Codec (eventType)+import Generated.HospitalCapacity.Nominals (HospitalId, parseHospitalId)++-- | (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 surgeTransducer))+  -- clock-free: spec samples no wall clock (verified at scaffold time)+  , ("golden round-trip: SurgeThresholdNoted", roundTrips sampleEventSurgeThresholdNoted)+  , ("golden round-trip: SurgeTimerMarked", roundTrips sampleEventSurgeTimerMarked)+  , ("accepts NoteSurgeThreshold from SurgeIdle", acceptNoteSurgeThreshold)+  , ("accepts MarkSurgeTimerFired from SurgeIdle", acceptMarkSurgeTimerFired)+  ]+  ++ forwardReplayNoteSurgeThreshold+  ++ forwardReplayMarkSurgeTimerFired++roundTrips :: SurgeEvent -> Bool+roundTrips e = parseSurgeEvent (eventType surgeCodec e) (encodeSurgeEvent e) == Right e++sampleHospitalId :: HospitalId+sampleHospitalId =+  case parseHospitalId "hosp_01h455vb4pex5vsknk084sn02q" of+    Right parsed -> parsed+    Left problem -> error (show problem)++sampleEventSurgeThresholdNoted :: SurgeEvent+sampleEventSurgeThresholdNoted = SurgeThresholdNoted (SurgeThresholdNotedData sampleHospitalId 0 0 "sample-timerId")++sampleEventSurgeTimerMarked :: SurgeEvent+sampleEventSurgeTimerMarked = SurgeTimerMarked (SurgeTimerMarkedData sampleHospitalId "sample-timerId")++acceptNoteSurgeThreshold :: Bool+acceptNoteSurgeThreshold =+  case step surgeTransducer (SurgeIdle, initialSurgeRegs) (NoteSurgeThreshold (NoteSurgeThresholdData sampleHospitalId 0 0 "sample-timerId")) of+    Just (v, _, _) -> v == SurgeIdle+    Nothing -> False++acceptMarkSurgeTimerFired :: Bool+acceptMarkSurgeTimerFired =+  case step surgeTransducer (SurgeIdle, initialSurgeRegs) (MarkSurgeTimerFired (MarkSurgeTimerFiredData sampleHospitalId "sample-timerId")) of+    Just (v, _, _) -> v == SurgeIdle+    Nothing -> False++-- forward/replay equality (plan 147): cross the persisted codec boundary,+-- replay the emitted chain, and compare the final vertex and every register.+forwardReplayNoteSurgeThreshold :: [(String, Bool)]+forwardReplayNoteSurgeThreshold =+  case step surgeTransducer (SurgeIdle, initialSurgeRegs) (NoteSurgeThreshold (NoteSurgeThresholdData sampleHospitalId 0 0 "sample-timerId")) of+    Nothing -> [(prefix <> "forward step accepted", False)]+    Just (forwardVertex, _forwardRegs, emitted) ->+      case mapM (\event -> parseSurgeEvent (eventType surgeCodec event) (encodeSurgeEvent event)) emitted of+        Left _ -> [(prefix <> "emitted chain decodes", False)]+        Right decodedEvents ->+          case applyEventsEither surgeTransducer (SurgeIdle, initialSurgeRegs) decodedEvents of+            Left _ -> [(prefix <> "replay succeeds", False)]+            Right (replayVertex, _replayRegs) ->+              [ (prefix <> "final vertex", replayVertex == forwardVertex)+              ]+  where+    prefix = "forward/replay equality: NoteSurgeThreshold from SurgeIdle -- "++-- forward/replay equality (plan 147): cross the persisted codec boundary,+-- replay the emitted chain, and compare the final vertex and every register.+forwardReplayMarkSurgeTimerFired :: [(String, Bool)]+forwardReplayMarkSurgeTimerFired =+  case step surgeTransducer (SurgeIdle, initialSurgeRegs) (MarkSurgeTimerFired (MarkSurgeTimerFiredData sampleHospitalId "sample-timerId")) of+    Nothing -> [(prefix <> "forward step accepted", False)]+    Just (forwardVertex, _forwardRegs, emitted) ->+      case mapM (\event -> parseSurgeEvent (eventType surgeCodec event) (encodeSurgeEvent event)) emitted of+        Left _ -> [(prefix <> "emitted chain decodes", False)]+        Right decodedEvents ->+          case applyEventsEither surgeTransducer (SurgeIdle, initialSurgeRegs) decodedEvents of+            Left _ -> [(prefix <> "replay succeeds", False)]+            Right (replayVertex, _replayRegs) ->+              [ (prefix <> "final vertex", replayVertex == forwardVertex)+              ]+  where+    prefix = "forward/replay equality: MarkSurgeTimerFired from SurgeIdle -- "

+ test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Projection.hs view

@@ -0,0 +1,4 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+module Generated.HospitalCapacity.Surge.Projection () where++-- No projection declarations are present; this module keeps the generated manifest inventory total.

test/conformance-process-runtime/Generated/HospitalCapacity/Surge/Transducer.hs view

@@ -1,7 +1,6 @@ {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit. module Generated.HospitalCapacity.Surge.Transducer   ( surgeTransducer   , surgeFoldFingerprint

+ test/conformance-process-runtime/HospitalCapacity/Hospital/BehaviorHoles.hs view

@@ -0,0 +1,9 @@+-- Consumer-owned behavioral witnesses. Created once; never overwritten.+module HospitalCapacity.Hospital.BehaviorHoles (behaviorWitnesses) where++import Generated.HospitalCapacity.Hospital.BehaviorContract++behaviorWitnesses :: [BehaviorWitness]+behaviorWitnesses =+  [ Pending (BehaviorKey "behavior-v1-69ac3daa8569d350")+  ]

+ test/conformance-process-runtime/HospitalCapacity/Hospital/Holes.hs view

@@ -0,0 +1,33 @@+{-# 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 HospitalCapacity.Hospital.Holes (+    hospitalTransducer,+    -- (no projection)+) where++import Generated.HospitalCapacity.Hospital.Domain+import Keiki.Builder ((=:))+import qualified Keiki.Builder as B+import Keiki.Core (HsPred, RegFile, SymTransducer, lit, (./=), (.==), (.||))++-- HOLE: the transducer body. Reproduce the structure below, replacing each+-- `-- HOLE` line with the keiki symbolic operators it describes.+hospitalTransducer ::+    SymTransducer+        (HsPred HospitalRegs HospitalCommand)+        HospitalRegs+        HospitalVertex+        HospitalCommand+        HospitalEvent+hospitalTransducer =+    B.buildTransducer HospitalOperational initialHospitalRegs isTerminal do+  where+    isTerminal = \case+        _ -> False

+ test/conformance-process-runtime/HospitalCapacity/HospitalSurge/ProcessHoles.hs view

@@ -0,0 +1,11 @@+-- HAND-OWNED hole module for the process manager's behaviour-bearing bodies.+-- keiro-dsl creates it once and never overwrites it.+module HospitalCapacity.HospitalSurge.ProcessHoles () where++-- HOLE handle: build the ProcessManagerAction (the self-advance+--   'NoteSurgeThreshold', the dispatch(es), and the timer) from the input.+-- HOLE window: the deadline policy, e.g. surgeWindow :: NominalDiffTime;+--   surgeDeadline observedAt = addUTCTime surgeWindow observedAt  (TIME INJECTED).+-- HOLE fire command: construct MarkSurgeTimerFired for the timer fire,+--   keyed by correlationId; the fired-event-id is the deterministic uuidv5 of+--   "hospital-surge-fired:" <> correlationId.

+ test/conformance-process-runtime/HospitalCapacity/Surge/BehaviorHoles.hs view

@@ -0,0 +1,10 @@+-- Consumer-owned behavioral witnesses. Created once; never overwritten.+module HospitalCapacity.Surge.BehaviorHoles (behaviorWitnesses) where++import Generated.HospitalCapacity.Surge.BehaviorContract++behaviorWitnesses :: [BehaviorWitness]+behaviorWitnesses =+  [ Pending (BehaviorKey "behavior-v1-5198a253324042e6")+  , Pending (BehaviorKey "behavior-v1-6721e0b61aa38780")+  ]

+ test/conformance-process-runtime/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

@@ -0,0 +1,46 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/hospital-surge.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    Generated.HospitalCapacity.BehaviorSourceMap+    Generated.HospitalCapacity.Hospital.BehaviorContract+    Generated.HospitalCapacity.Hospital.Codec+    Generated.HospitalCapacity.Hospital.Domain+    Generated.HospitalCapacity.Hospital.EventStream+    Generated.HospitalCapacity.Hospital.Harness+    Generated.HospitalCapacity.Hospital.Projection+    Generated.HospitalCapacity.Hospital.Transducer+    Generated.HospitalCapacity.HospitalSurge.Process+    Generated.HospitalCapacity.HospitalSurge.ProcessHarness+    Generated.HospitalCapacity.Nominals+    Generated.HospitalCapacity.Nominals.Internal+    Generated.HospitalCapacity.ReplayAudit+    Generated.HospitalCapacity.Surge.BehaviorContract+    Generated.HospitalCapacity.Surge.Codec+    Generated.HospitalCapacity.Surge.Domain+    Generated.HospitalCapacity.Surge.EventStream+    Generated.HospitalCapacity.Surge.Harness+    Generated.HospitalCapacity.Surge.Projection+    Generated.HospitalCapacity.Surge.Transducer+    HospitalCapacity.Hospital.BehaviorHoles+    HospitalCapacity.HospitalSurge.ProcessHoles+    HospitalCapacity.Surge.BehaviorHoles++build-depends:+    , aeson+    , base+    , keiki+    , keiro+    , shibuya-core+    , text+    , time+    , uuid

+ test/conformance-process-runtime/keiro-dsl-ledger.context.hospital-capacity.txt view

@@ -0,0 +1,61 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/hospital-surge.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":4,"effectiveLanguageVersion":4,"sourceForm":"declared"}+semantic-contract {"languageSupport":"compatibility-only","languageVersion":4,"runtimeSemantics":"keiro-dsl/runtime-semantics/3"}+naming-edition idiomatic-v2+module-role {"family":"BehaviorSourceMap","kind":"generated","ownerKind":"context","ownerName":"context hospital-capacity behavior source map","path":"Generated/HospitalCapacity/BehaviorSourceMap.hs"}+module-role {"family":"Nominals","kind":"generated","ownerKind":"context","ownerName":"context hospital-capacity generated nominal declarations","path":"Generated/HospitalCapacity/Nominals.hs"}+module-role {"family":"Internal","kind":"generated","ownerKind":"context","ownerName":"context hospital-capacity generated nominal ID internals","path":"Generated/HospitalCapacity/Nominals/Internal.hs"}+module-role {"family":"ReplayAudit","kind":"generated","ownerKind":"context","ownerName":"context hospital-capacity replay-audit assembly","path":"Generated/HospitalCapacity/ReplayAudit.hs"}+module-role {"family":"Process","kind":"generated","ownerKind":"process","ownerName":"process HospitalSurge (line 7)","path":"Generated/HospitalCapacity/HospitalSurge/Process.hs"}+module-role {"family":"ProcessHoles","kind":"hole","ownerKind":"process","ownerName":"process HospitalSurge (line 7)","path":"HospitalCapacity/HospitalSurge/ProcessHoles.hs"}+module-role {"family":"ProcessHarness","kind":"generated","ownerKind":"process","ownerName":"process HospitalSurge (line 7)","path":"Generated/HospitalCapacity/HospitalSurge/ProcessHarness.hs"}+module-role {"family":"Domain","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 35)","path":"Generated/HospitalCapacity/Surge/Domain.hs"}+module-role {"family":"Codec","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 35)","path":"Generated/HospitalCapacity/Surge/Codec.hs"}+module-role {"family":"Transducer","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 35)","path":"Generated/HospitalCapacity/Surge/Transducer.hs"}+module-role {"family":"BehaviorContract","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 35)","path":"Generated/HospitalCapacity/Surge/BehaviorContract.hs"}+module-role {"family":"BehaviorHoles","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate behavior witnesses Surge (line 35)","path":"HospitalCapacity/Surge/BehaviorHoles.hs"}+module-role {"family":"EventStream","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 35)","path":"Generated/HospitalCapacity/Surge/EventStream.hs"}+module-role {"family":"Projection","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 35)","path":"Generated/HospitalCapacity/Surge/Projection.hs"}+module-role {"family":"Harness","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 35)","path":"Generated/HospitalCapacity/Surge/Harness.hs"}+module-role {"family":"Domain","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 47)","path":"Generated/HospitalCapacity/Hospital/Domain.hs"}+module-role {"family":"Codec","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 47)","path":"Generated/HospitalCapacity/Hospital/Codec.hs"}+module-role {"family":"Transducer","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 47)","path":"Generated/HospitalCapacity/Hospital/Transducer.hs"}+module-role {"family":"BehaviorContract","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 47)","path":"Generated/HospitalCapacity/Hospital/BehaviorContract.hs"}+module-role {"family":"BehaviorHoles","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate behavior witnesses Hospital (line 47)","path":"HospitalCapacity/Hospital/BehaviorHoles.hs"}+module-role {"family":"EventStream","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 47)","path":"Generated/HospitalCapacity/Hospital/EventStream.hs"}+module-role {"family":"Projection","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 47)","path":"Generated/HospitalCapacity/Hospital/Projection.hs"}+module-role {"family":"Harness","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 47)","path":"Generated/HospitalCapacity/Hospital/Harness.hs"}+generated Generated/HospitalCapacity/BehaviorSourceMap.hs+generated Generated/HospitalCapacity/Nominals.hs+generated Generated/HospitalCapacity/Nominals/Internal.hs+generated Generated/HospitalCapacity/ReplayAudit.hs+generated Generated/HospitalCapacity/HospitalSurge/Process.hs+hole HospitalCapacity/HospitalSurge/ProcessHoles.hs+generated Generated/HospitalCapacity/HospitalSurge/ProcessHarness.hs+generated Generated/HospitalCapacity/Surge/Domain.hs+generated Generated/HospitalCapacity/Surge/Codec.hs+generated Generated/HospitalCapacity/Surge/Transducer.hs+generated Generated/HospitalCapacity/Surge/BehaviorContract.hs+hole HospitalCapacity/Surge/BehaviorHoles.hs+generated Generated/HospitalCapacity/Surge/EventStream.hs+generated Generated/HospitalCapacity/Surge/Projection.hs+generated Generated/HospitalCapacity/Surge/Harness.hs+generated Generated/HospitalCapacity/Hospital/Domain.hs+generated Generated/HospitalCapacity/Hospital/Codec.hs+generated Generated/HospitalCapacity/Hospital/Transducer.hs+generated Generated/HospitalCapacity/Hospital/BehaviorContract.hs+hole HospitalCapacity/Hospital/BehaviorHoles.hs+generated Generated/HospitalCapacity/Hospital/EventStream.hs+generated Generated/HospitalCapacity/Hospital/Projection.hs+generated Generated/HospitalCapacity/Hospital/Harness.hs+id-domain id-domain|name=HospitalId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=hosp|separator=_|json=canonical-json-text+id-domain id-domain|name=CommandId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=cmd|separator=_|json=canonical-json-text+nominal-equality nominal-equality|name=CommandId|contract=keiro-dsl/nominal-equality/2|key=Text|domain=typeid-v7-text:cmd:keiro-dsl/id-domain/typeid-v7/1|owner=generated+nominal-equality nominal-equality|name=HospitalId|contract=keiro-dsl/nominal-equality/2|key=Text|domain=typeid-v7-text:hosp:keiro-dsl/id-domain/typeid-v7/1|owner=generated+behavior {"aggregate":"Surge","command":"NoteSurgeThreshold","evidence":"generated-authoritative","key":"behavior-v1-5198a253324042e6","kind":"live-transition","outputs":[{"command":"NoteSurgeThreshold","ownership":"generated-command-identity"}],"source":"Idle"}+behavior {"aggregate":"Surge","command":"MarkSurgeTimerFired","evidence":"generated-authoritative","key":"behavior-v1-6721e0b61aa38780","kind":"live-transition","outputs":[{"command":"MarkSurgeTimerFired","ownership":"generated-command-identity"}],"source":"Idle"}+behavior {"aggregate":"Hospital","command":"ActivateSurge","evidence":"generated-authoritative","key":"behavior-v1-69ac3daa8569d350","kind":"live-transition","outputs":[{"command":"ActivateSurge","ownership":"generated-command-identity"}],"source":"Operational"}+semantic-impact {"declarations":[],"mappedSurfaceEvidenceVersion":1,"serviceInventory":[]}

test/conformance-process/Generated/HospitalCapacity/BehaviorSourceMap.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from context hospital-capacity behavior source map; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from context hospital-capacity behavior source map; do not edit. module Generated.HospitalCapacity.BehaviorSourceMap   ( BehaviorSourceLocation (..)   , behaviorSourceLocation@@ -9,9 +9,9 @@ import Data.Text qualified as T  data BehaviorSourceLocation = BehaviorSourceLocation-  { sourceFile :: !FilePath-  , sourceLine :: !Int-  , sourceColumn :: !Int+  { file :: !FilePath+  , line :: !Int+  , column :: !Int   }   deriving stock (Eq, Ord, Show) @@ -24,7 +24,7 @@  renderBehaviorSourceLocation :: Text -> Text renderBehaviorSourceLocation key = case behaviorSourceLocation key of-  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Just location -> T.pack location.file <> ":" <> tshow location.line <> ":" <> tshow location.column   Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"  tshow :: Show value => value -> Text

+ test/conformance-process/Generated/HospitalCapacity/Hospital/BehaviorContract.hs view

@@ -0,0 +1,337 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.HospitalCapacity.Hospital.BehaviorContract+  ( BehaviorKey (..)+  , unBehaviorKey+  , ObligationKind (..)+  , EvidenceLevel (..)+  , GuardCoverage (..)+  , BehaviorRequirement (..)+  , RejectionClass (..)+  , LiveExpectation (..)+  , BehaviorWitness (..)+  , BehaviorFailure (..)+  , BehaviorConformanceReport (..)+  , behaviorRequirements+  , behaviorCoverageReport+  , behaviorConformancePassed+  , behaviorConformancePassedWith+  , renderBehaviorConformanceText+  ) where++import Generated.HospitalCapacity.Hospital.Codec (encodeHospitalEvent, parseHospitalEvent, hospitalCodec)+import Generated.HospitalCapacity.Hospital.Domain+import Generated.HospitalCapacity.Hospital.Transducer (hospitalTransducer)+import Generated.HospitalCapacity.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)++unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value++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+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !HospitalVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef HospitalVertex))+  , target :: !(Maybe HospitalVertex)+  , eventKinds :: ![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+      { key :: BehaviorKey+      , history :: [HospitalEvent]+      , command :: HospitalCommand+      , expected :: LiveExpectation+      }+  | ReplayWitness+      { key :: BehaviorKey+      , historyPrefix :: [HospitalEvent]+      , observedChunk :: [HospitalEvent]+      }+  deriving stock (Eq, Show)++data BehaviorFailure = BehaviorFailure+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !Text+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorFailure where+  toJSON behaviorFailure = object+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail+    ]++data BehaviorConformanceReport = BehaviorConformanceReport+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![BehaviorKey]+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorConformanceReport where+  toJSON report = object+    [ "schema" .= ("keiro/behavior-conformance/1" :: Text)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified+    ]++behaviorRequirements :: [BehaviorRequirement]+behaviorRequirements =+  [ -- HospitalOperational x ActivateSurge: live transition+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-69ac3daa8569d350"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = HospitalOperational+      , commandName = "ActivateSurge"+      , expectedEdge = (Just (K.EdgeRef HospitalOperational 0))+      , target = Just HospitalOperational+      , eventKinds = ["SurgeActivated"]+      }+  ]++behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport+behaviorCoverageReport witnesses =+  BehaviorConformanceReport+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]+    }+ where+  requiredByKey = Map.fromList [(requirement.key, 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 report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)++renderBehaviorConformanceText :: BehaviorConformanceReport -> Text+renderBehaviorConformanceText report = T.unlines+  [ "behavior conformance: Hospital"+  , "schema: keiro/behavior-conformance/1"+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]++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 == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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 == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)+      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) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)++runReplay :: BehaviorRequirement -> [HospitalEvent] -> [HospitalEvent] -> Either BehaviorFailure ()+runReplay requirement prefix chunk = case requirement.kind of+  ReplayTransition -> do+    settled <- settleHistory requirement "history-prefix" prefix+    ensure requirement (K.replaySuccessState settled == requirement.source) "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) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)+    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) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)+    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 == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)+    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 (HospitalOperational, 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+  ActivateSurge _ -> "ActivateSurge"++eventKind :: HospitalEvent -> Text+eventKind event = case Codec.eventType hospitalCodec event of Codec.EventType tag -> tag++regsEqual :: K.RegFile HospitalRegs -> K.RegFile HospitalRegs -> Bool+regsEqual _ _ = True++proofStrength :: BehaviorRequirement -> Bool+proofStrength requirement =+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]++behaviorWitnessKey :: BehaviorWitness -> BehaviorKey+behaviorWitnessKey witness = case witness of+  Pending key -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = 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+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")+        code+        detail+    )+ where+  kindPhrase = case requirement.kind 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-process/Generated/HospitalCapacity/Hospital/Codec.hs view

@@ -0,0 +1,66 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.HospitalCapacity.Hospital.Codec (+    hospitalCodec,+    parseHospitalEvent,+    encodeHospitalEvent,+) where++import Generated.HospitalCapacity.Hospital.Domain+import Generated.HospitalCapacity.Nominals (hospitalIdText)+import Generated.HospitalCapacity.Nominals.Internal (unsafeHospitalIdFromLegacyText)+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 "SurgeActivated" :| []++hospitalCodec :: Codec HospitalEvent+hospitalCodec =+  Codec+    { eventTypes = hospitalEventTypes+    , eventType = \case+        SurgeActivated{} -> EventType "SurgeActivated"+    , schemaVersion = 1+    , encode = encodeHospitalEvent+    , decode = parseHospitalEvent+    , upcasters = []+    }++encodeHospitalEvent :: HospitalEvent -> Value+encodeHospitalEvent = \case+  SurgeActivated payload ->+    object+      [ "kind" .= ("SurgeActivated" :: Text)+      , "hospitalId" .= hospitalIdText payload.hospitalId+      ]++parseHospitalEvent :: EventType -> Value -> Either Text HospitalEvent+parseHospitalEvent (EventType tag) = mapLeftText . parseEither (withObject "HospitalEvent" go)+  where+    go o = do+      case tag of+        "SurgeActivated" ->+          SurgeActivated+            <$> ( SurgeActivatedData+                    <$> (unsafeHospitalIdFromLegacyText <$> 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-process/Generated/HospitalCapacity/Hospital/Domain.hs view

@@ -0,0 +1,40 @@+{-# LANGUAGE TemplateHaskell #-}+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.HospitalCapacity.Hospital.Domain where++import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Generated.HospitalCapacity.Nominals (HospitalId)+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++data HospitalVertex = HospitalOperational+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data ActivateSurgeData = ActivateSurgeData+  { hospitalId :: !HospitalId+  }+  deriving stock (Generic, Eq, Show)++data HospitalCommand = ActivateSurge !ActivateSurgeData+  deriving stock (Generic, Eq, Show)++data SurgeActivatedData = SurgeActivatedData+  { hospitalId :: !HospitalId+  }+  deriving stock (Generic, Eq, Show)++data HospitalEvent = SurgeActivated !SurgeActivatedData+  deriving stock (Generic, Eq, Show)++type HospitalRegs =+  '[]++initialHospitalRegs :: RegFile HospitalRegs+initialHospitalRegs =+  RNil++$(deriveAggregateCtorsAll ''HospitalCommand ''HospitalRegs)++++$(deriveWireCtorsAll ''HospitalEvent)

+ test/conformance-process/Generated/HospitalCapacity/Hospital/EventStream.hs view

@@ -0,0 +1,49 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.HospitalCapacity.Hospital.EventStream+  ( hospitalCategory+  , hospitalCommandCategory+  , hospitalEventStream+  , hospitalEventStreamDef+  , HospitalEventStream+  , HospitalEventStreamDef+  ) where++import Generated.HospitalCapacity.Hospital.Domain+import Generated.HospitalCapacity.Hospital.Codec (hospitalCodec)+import Generated.HospitalCapacity.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 = HospitalOperational,+      initialRegisters = initialHospitalRegs,+      eventCodec = hospitalCodec,+      resolveStreamName = Stream.streamName,+      snapshotPolicy = Never,+      stateCodec = Nothing+    }++hospitalEventStream :: HospitalEventStream+hospitalEventStream =+  mkEventStreamOrThrow "Hospital" hospitalEventStreamDef

+ test/conformance-process/Generated/HospitalCapacity/Hospital/Harness.hs view

@@ -0,0 +1,57 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.HospitalCapacity.Hospital.Harness (harnessAssertions) where++import Generated.HospitalCapacity.Hospital.Domain+import Generated.HospitalCapacity.Hospital.Codec (encodeHospitalEvent, parseHospitalEvent, hospitalCodec)+import Generated.HospitalCapacity.Hospital.Transducer (hospitalTransducer)+import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer)+import Keiro.Codec (eventType)+import Generated.HospitalCapacity.Nominals (HospitalId, parseHospitalId)++-- | (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: SurgeActivated", roundTrips sampleEventSurgeActivated)+  , ("accepts ActivateSurge from HospitalOperational", acceptActivateSurge)+  ]+  ++ forwardReplayActivateSurge++roundTrips :: HospitalEvent -> Bool+roundTrips e = parseHospitalEvent (eventType hospitalCodec e) (encodeHospitalEvent e) == Right e++sampleHospitalId :: HospitalId+sampleHospitalId =+  case parseHospitalId "hosp_01h455vb4pex5vsknk084sn02q" of+    Right parsed -> parsed+    Left problem -> error (show problem)++sampleEventSurgeActivated :: HospitalEvent+sampleEventSurgeActivated = SurgeActivated (SurgeActivatedData sampleHospitalId)++acceptActivateSurge :: Bool+acceptActivateSurge =+  case step hospitalTransducer (HospitalOperational, initialHospitalRegs) (ActivateSurge (ActivateSurgeData sampleHospitalId)) of+    Just (v, _, _) -> v == HospitalOperational+    Nothing -> False++-- forward/replay equality (plan 147): cross the persisted codec boundary,+-- replay the emitted chain, and compare the final vertex and every register.+forwardReplayActivateSurge :: [(String, Bool)]+forwardReplayActivateSurge =+  case step hospitalTransducer (HospitalOperational, initialHospitalRegs) (ActivateSurge (ActivateSurgeData sampleHospitalId)) 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 (HospitalOperational, initialHospitalRegs) decodedEvents of+            Left _ -> [(prefix <> "replay succeeds", False)]+            Right (replayVertex, _replayRegs) ->+              [ (prefix <> "final vertex", replayVertex == forwardVertex)+              ]+  where+    prefix = "forward/replay equality: ActivateSurge from HospitalOperational -- "

+ test/conformance-process/Generated/HospitalCapacity/Hospital/Projection.hs view

@@ -0,0 +1,4 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.HospitalCapacity.Hospital.Projection () where++-- No projection declarations are present; this module keeps the generated manifest inventory total.

+ test/conformance-process/Generated/HospitalCapacity/Hospital/Transducer.hs view

@@ -0,0 +1,54 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE QualifiedDo #-}+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Hospital; do not edit.+module Generated.HospitalCapacity.Hospital.Transducer+  ( hospitalTransducer+  , hospitalFoldFingerprint+  , BehaviorOwnership (..)+  , hospitalPredicateVerifications+  ) where++import Generated.HospitalCapacity.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++hospitalTransducer+  :: SymTransducer+       (HsPred HospitalRegs HospitalCommand)+       HospitalRegs+       HospitalVertex+       HospitalCommand+       HospitalEvent+hospitalTransducer =+  B.buildTransducer HospitalOperational initialHospitalRegs isTerminal do+    B.from HospitalOperational do+      B.onCmd inCtorActivateSurge $ \d -> B.do+        B.emit wireSurgeActivated (SurgeActivatedTermFields+          { hospitalId = d.hospitalId+          })+        B.goto HospitalOperational+ where+  isTerminal = \case++    _ -> False++hospitalFoldFingerprint :: Text+hospitalFoldFingerprint = "06c89896e94c1e76773dd30acb13f802"++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 "transition1OperationalActivateSurge" GeneratedOwned HospitalOperational 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-process/Generated/HospitalCapacity/HospitalSurge/Process.hs view

@@ -0,0 +1,76 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from process HospitalSurge; do not edit.+module Generated.HospitalCapacity.HospitalSurge.Process+  ( hospitalSurgeProcessName+  , hospitalSurgeCategory+  , hospitalSurgeProcessWorkerOptions+  , hospitalSurgeTimerRequest+  , hospitalSurgeFireOutcome+  ) 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 Generated.HospitalCapacity.Surge.EventStream (SurgeEventStreamDef)+import Keiro.Command (CommandError (..))+import Keiro.Stream qualified as Stream+import Keiro.Timer (TimerId (..), TimerRequest (..))+import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))+import Shibuya.Core.Ack (RetryDelay (..))++-- The define-once ProcessManager name (hole-kind 5: referenced, never retyped).+hospitalSurgeProcessName :: Text+hospitalSurgeProcessName = "hospital-surge"++-- 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.+hospitalSurgeCategory :: Stream.StreamCategory SurgeEventStreamDef+hospitalSurgeCategory = Stream.categoryUnsafe "hospitalSurge"++-- Node-level worker policy lowered from the spec. Pass this value to+-- Keiro.ProcessManager.runProcessManagerWorkerWith.+hospitalSurgeProcessWorkerOptions :: WorkerOptions es msg+hospitalSurgeProcessWorkerOptions =+  WorkerOptions+    { poisonPolicy = PoisonHalt,+      rejectedCommandPolicy = RejectedHalt,+      transientRetryDelay = RetryDelay 5, -- matches defaultWorkerOptions; runtime tuning+      metrics = Nothing -- runtime configuration; install at call site+    }++-- 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 "hospital-surge-timer:" <> correlationId)+hospitalSurgeTimerRequest :: Text -> UTCTime -> TimerRequest+hospitalSurgeTimerRequest correlationId fireAtTime =+  TimerRequest+    { timerId = TimerId (namedUuid ("hospital-surge-timer:" <> correlationId))+    , processManagerName = hospitalSurgeProcessName+    , correlationId = correlationId+    , fireAt = fireAtTime+    , payload = object [ "kind" .= ("hospital-surge-follow-up" :: Value) ]+    }++-- The timer-fire disposition table (hole-kind 2), derived from the spec.+-- on-reject => Fired 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.+hospitalSurgeFireOutcome :: Either CommandError a -> Maybe ()+hospitalSurgeFireOutcome result = case result of+  Right{} -> Just ()  -- Fired+  Left CommandRejected -> Just ()  -- Fired+  Left (CommandAmbiguous _) -> Nothing  -- Retry  -- explicit definition-bug arm+  Left{} -> Nothing  -- Retry++-- max-attempts = 5, dead-letter = "surge timer exceeded ceiling"+-- (the timer worker must pass Just 5 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))

test/conformance-process/Generated/HospitalCapacity/HospitalSurge/ProcessHarness.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 4) from process HospitalSurge; do not edit.+-- @generated by keiro-dsl 0.15.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-process/Generated/HospitalCapacity/Nominals.hs view

@@ -0,0 +1,13 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal declarations; do not edit.+module Generated.HospitalCapacity.Nominals+  ( CommandId+  , parseCommandId+  , mkCommandId+  , commandIdText+  , HospitalId+  , parseHospitalId+  , mkHospitalId+  , hospitalIdText+  ) where++import Generated.HospitalCapacity.Nominals.Internal (CommandId, mkCommandId, parseCommandId, commandIdText, HospitalId, mkHospitalId, parseHospitalId, hospitalIdText)

+ test/conformance-process/Generated/HospitalCapacity/Nominals/Internal.hs view

@@ -0,0 +1,70 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from context hospital-capacity generated nominal ID internals; do not edit.+module Generated.HospitalCapacity.Nominals.Internal+  ( CommandId+  , parseCommandId+  , mkCommandId+  , commandIdText+  , unsafeCommandIdFromLegacyText+  , HospitalId+  , parseHospitalId+  , mkHospitalId+  , hospitalIdText+  , unsafeHospitalIdFromLegacyText+  ) 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)++newtype CommandId = CommandId Text+  deriving stock (Generic, Eq, Ord, Show)++instance CanonicalTypeName CommandId++instance ToJSON CommandId where+  toJSON = toJSON . commandIdText++instance FromJSON CommandId where+  parseJSON = withText "CommandId" (either (fail . T.unpack) pure . parseCommandId)++parseCommandId :: Text -> Either Text CommandId+parseCommandId input = case validateIdDomainText (typeIdV7Domain "cmd") input of+  Left reason -> Left (T.pack (show reason))+  Right () -> Right (CommandId input)++mkCommandId :: Text -> Either Text CommandId+mkCommandId = parseCommandId++commandIdText :: CommandId -> Text+commandIdText (CommandId value) = value++unsafeCommandIdFromLegacyText :: Text -> CommandId+unsafeCommandIdFromLegacyText = CommandId++newtype HospitalId = HospitalId Text+  deriving stock (Generic, Eq, Ord, Show)++instance CanonicalTypeName HospitalId++instance ToJSON HospitalId where+  toJSON = toJSON . hospitalIdText++instance FromJSON HospitalId where+  parseJSON = withText "HospitalId" (either (fail . T.unpack) pure . parseHospitalId)++parseHospitalId :: Text -> Either Text HospitalId+parseHospitalId input = case validateIdDomainText (typeIdV7Domain "hosp") input of+  Left reason -> Left (T.pack (show reason))+  Right () -> Right (HospitalId input)++mkHospitalId :: Text -> Either Text HospitalId+mkHospitalId = parseHospitalId++hospitalIdText :: HospitalId -> Text+hospitalIdText (HospitalId value) = value++unsafeHospitalIdFromLegacyText :: Text -> HospitalId+unsafeHospitalIdFromLegacyText = HospitalId

+ test/conformance-process/Generated/HospitalCapacity/ReplayAudit.hs view

@@ -0,0 +1,30 @@+-- @generated by keiro-dsl 0.15.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;+--   * 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.HospitalCapacity.ReplayAudit (auditTargets) where++import Generated.HospitalCapacity.Surge.EventStream qualified as Surge+import Generated.HospitalCapacity.Hospital.EventStream qualified as Hospital+import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory)+import Keiro.Stream qualified as Stream++auditTargets :: [SomeAuditTarget]+auditTargets =+  [ SomeAuditTarget+      AuditTarget+        { eventStream = Surge.surgeEventStream+        , category = Stream.categoryText Surge.surgeCategory+        , mkStream = streamInCategory (Stream.categoryText Surge.surgeCategory)+        }+  , SomeAuditTarget+      AuditTarget+        { eventStream = Hospital.hospitalEventStream+        , category = Stream.categoryText Hospital.hospitalCategory+        , mkStream = streamInCategory (Stream.categoryText Hospital.hospitalCategory)+        }+  ]

+ test/conformance-process/Generated/HospitalCapacity/Surge/BehaviorContract.hs view

@@ -0,0 +1,350 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+module Generated.HospitalCapacity.Surge.BehaviorContract+  ( BehaviorKey (..)+  , unBehaviorKey+  , ObligationKind (..)+  , EvidenceLevel (..)+  , GuardCoverage (..)+  , BehaviorRequirement (..)+  , RejectionClass (..)+  , LiveExpectation (..)+  , BehaviorWitness (..)+  , BehaviorFailure (..)+  , BehaviorConformanceReport (..)+  , behaviorRequirements+  , behaviorCoverageReport+  , behaviorConformancePassed+  , behaviorConformancePassedWith+  , renderBehaviorConformanceText+  ) where++import Generated.HospitalCapacity.Surge.Codec (encodeSurgeEvent, parseSurgeEvent, surgeCodec)+import Generated.HospitalCapacity.Surge.Domain+import Generated.HospitalCapacity.Surge.Transducer (surgeTransducer)+import Generated.HospitalCapacity.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)++unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value++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+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !SurgeVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef SurgeVertex))+  , target :: !(Maybe SurgeVertex)+  , eventKinds :: ![Text]+  }+  deriving stock (Eq, Show)++data RejectionClass = RejectNoOutgoingEdges | RejectNoMatchingEdge+  deriving stock (Eq, Show)++data LiveExpectation+  = Emits (NonEmpty SurgeEvent)+  | Rejects RejectionClass+  | NoOp+  deriving stock (Eq, Show)++data BehaviorWitness+  = Pending BehaviorKey+  | LiveWitness+      { key :: BehaviorKey+      , history :: [SurgeEvent]+      , command :: SurgeCommand+      , expected :: LiveExpectation+      }+  | ReplayWitness+      { key :: BehaviorKey+      , historyPrefix :: [SurgeEvent]+      , observedChunk :: [SurgeEvent]+      }+  deriving stock (Eq, Show)++data BehaviorFailure = BehaviorFailure+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !Text+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorFailure where+  toJSON behaviorFailure = object+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail+    ]++data BehaviorConformanceReport = BehaviorConformanceReport+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![BehaviorKey]+  }+  deriving stock (Eq, Show)++instance ToJSON BehaviorConformanceReport where+  toJSON report = object+    [ "schema" .= ("keiro/behavior-conformance/1" :: Text)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified+    ]++behaviorRequirements :: [BehaviorRequirement]+behaviorRequirements =+  [ -- SurgeIdle x NoteSurgeThreshold: live transition+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-5198a253324042e6"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = SurgeIdle+      , commandName = "NoteSurgeThreshold"+      , expectedEdge = (Just (K.EdgeRef SurgeIdle 0))+      , target = Just SurgeIdle+      , eventKinds = ["SurgeThresholdNoted"]+      }+  , -- SurgeIdle x MarkSurgeTimerFired: live transition+    BehaviorRequirement+      { key = BehaviorKey "behavior-v1-6721e0b61aa38780"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = SurgeIdle+      , commandName = "MarkSurgeTimerFired"+      , expectedEdge = (Just (K.EdgeRef SurgeIdle 1))+      , target = Just SurgeIdle+      , eventKinds = ["SurgeTimerMarked"]+      }+  ]++behaviorCoverageReport :: [BehaviorWitness] -> BehaviorConformanceReport+behaviorCoverageReport witnesses =+  BehaviorConformanceReport+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]+    }+ where+  requiredByKey = Map.fromList [(requirement.key, 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 report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)++renderBehaviorConformanceText :: BehaviorConformanceReport -> Text+renderBehaviorConformanceText report = T.unlines+  [ "behavior conformance: Surge"+  , "schema: keiro/behavior-conformance/1"+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]++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 -> [SurgeEvent] -> SurgeCommand -> LiveExpectation -> Either BehaviorFailure ()+runLive requirement history command expectation = do+  settled <- settleHistory requirement "history" history+  ensure requirement (K.replaySuccessState settled == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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 -> (SurgeVertex, K.RegFile SurgeRegs) -> SurgeCommand -> 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 surgeTransducer 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 -> (SurgeVertex, K.RegFile SurgeRegs) -> SurgeCommand -> 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 surgeTransducer 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 surgeTransducer 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 == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)+      decoded <- either (failure requirement "emitted-codec-decode") Right (decodeEvents actual)+      replayed <- case K.applyEventsDetailedEither surgeTransducer 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 SurgeRegs SurgeVertex SurgeEvent -> 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) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)++runReplay :: BehaviorRequirement -> [SurgeEvent] -> [SurgeEvent] -> Either BehaviorFailure ()+runReplay requirement prefix chunk = case requirement.kind of+  ReplayTransition -> do+    settled <- settleHistory requirement "history-prefix" prefix+    ensure requirement (K.replaySuccessState settled == requirement.source) "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 surgeTransducer (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) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)+    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 SurgeVertex] -> Either BehaviorFailure ()+checkSingleAttribution requirement expectedMode eventCount trace = case trace of+  [attribution] -> do+    ensure requirement (Just (K.replayAttributionEdge attribution) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)+    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 == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)+    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 -> [SurgeEvent] -> Either BehaviorFailure (K.ReplaySuccess SurgeRegs SurgeVertex)+settleHistory requirement label history = do+  decoded <- either (failure requirement (label <> "-codec-decode")) Right (decodeEvents history)+  case K.applyEventsDetailedEither surgeTransducer (SurgeIdle, initialSurgeRegs) decoded of+    Left replayFailure -> failure requirement (label <> "-replay-failed") (tshow replayFailure)+    Right replaySuccess -> Right replaySuccess++decodeEvents :: [SurgeEvent] -> Either Text [SurgeEvent]+decodeEvents = traverse (\event -> parseSurgeEvent (Codec.eventType surgeCodec event) (encodeSurgeEvent event))++commandKind :: SurgeCommand -> Text+commandKind command = case command of+  NoteSurgeThreshold _ -> "NoteSurgeThreshold"+  MarkSurgeTimerFired _ -> "MarkSurgeTimerFired"++eventKind :: SurgeEvent -> Text+eventKind event = case Codec.eventType surgeCodec event of Codec.EventType tag -> tag++regsEqual :: K.RegFile SurgeRegs -> K.RegFile SurgeRegs -> Bool+regsEqual _ _ = True++proofStrength :: BehaviorRequirement -> Bool+proofStrength requirement =+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]++behaviorWitnessKey :: BehaviorWitness -> BehaviorKey+behaviorWitnessKey witness = case witness of+  Pending key -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = 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+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")+        code+        detail+    )+ where+  kindPhrase = case requirement.kind 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-process/Generated/HospitalCapacity/Surge/Codec.hs view

@@ -0,0 +1,85 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+module Generated.HospitalCapacity.Surge.Codec (+    surgeCodec,+    parseSurgeEvent,+    encodeSurgeEvent,+) where++import Generated.HospitalCapacity.Surge.Domain+import Generated.HospitalCapacity.Nominals (hospitalIdText)+import Generated.HospitalCapacity.Nominals.Internal (unsafeHospitalIdFromLegacyText)+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 (..))++++++surgeEventTypes :: NonEmpty EventType+surgeEventTypes = EventType "SurgeThresholdNoted" :| [EventType "SurgeTimerMarked"]++surgeCodec :: Codec SurgeEvent+surgeCodec =+  Codec+    { eventTypes = surgeEventTypes+    , eventType = \case+        SurgeThresholdNoted{} -> EventType "SurgeThresholdNoted"+        SurgeTimerMarked{} -> EventType "SurgeTimerMarked"+    , schemaVersion = 1+    , encode = encodeSurgeEvent+    , decode = parseSurgeEvent+    , upcasters = []+    }++encodeSurgeEvent :: SurgeEvent -> Value+encodeSurgeEvent = \case+  SurgeThresholdNoted payload ->+    object+      [ "kind" .= ("SurgeThresholdNoted" :: Text)+      , "hospitalId" .= hospitalIdText payload.hospitalId+      , "availableIcuBeds" .= payload.availableIcuBeds+      , "redDemand" .= payload.redDemand+      , "timerId" .= payload.timerId+      ]+  SurgeTimerMarked payload ->+    object+      [ "kind" .= ("SurgeTimerMarked" :: Text)+      , "hospitalId" .= hospitalIdText payload.hospitalId+      , "timerId" .= payload.timerId+      ]++parseSurgeEvent :: EventType -> Value -> Either Text SurgeEvent+parseSurgeEvent (EventType tag) = mapLeftText . parseEither (withObject "SurgeEvent" go)+  where+    go o = do+      case tag of+        "SurgeThresholdNoted" ->+          SurgeThresholdNoted+            <$> ( SurgeThresholdNotedData+                    <$> (unsafeHospitalIdFromLegacyText <$> o .: "hospitalId")+                    <*> o .: "availableIcuBeds"+                    <*> o .: "redDemand"+                    <*> o .: "timerId"+                )+        "SurgeTimerMarked" ->+          SurgeTimerMarked+            <$> ( SurgeTimerMarkedData+                    <$> (unsafeHospitalIdFromLegacyText <$> o .: "hospitalId")+                    <*> o .: "timerId"+                )+        _ -> fail ("unknown event type " <> show tag <> "; expected one of: " <> renderExpectedEventTypes surgeEventTypes)++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-process/Generated/HospitalCapacity/Surge/Domain.hs view

@@ -0,0 +1,61 @@+{-# LANGUAGE TemplateHaskell #-}+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+module Generated.HospitalCapacity.Surge.Domain where++import Data.Text (Text)+import GHC.Generics (Generic)+import Keiki.Core (RegFile (..))+import Generated.HospitalCapacity.Nominals (HospitalId)+import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)++data SurgeVertex = SurgeIdle+  deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)++data NoteSurgeThresholdData = NoteSurgeThresholdData+  { hospitalId :: !HospitalId+  , availableIcuBeds :: !Int+  , redDemand :: !Int+  , timerId :: !Text+  }+  deriving stock (Generic, Eq, Show)++data MarkSurgeTimerFiredData = MarkSurgeTimerFiredData+  { hospitalId :: !HospitalId+  , timerId :: !Text+  }+  deriving stock (Generic, Eq, Show)++data SurgeCommand = NoteSurgeThreshold !NoteSurgeThresholdData+  | MarkSurgeTimerFired !MarkSurgeTimerFiredData+  deriving stock (Generic, Eq, Show)++data SurgeThresholdNotedData = SurgeThresholdNotedData+  { hospitalId :: !HospitalId+  , availableIcuBeds :: !Int+  , redDemand :: !Int+  , timerId :: !Text+  }+  deriving stock (Generic, Eq, Show)++data SurgeTimerMarkedData = SurgeTimerMarkedData+  { hospitalId :: !HospitalId+  , timerId :: !Text+  }+  deriving stock (Generic, Eq, Show)++data SurgeEvent = SurgeThresholdNoted !SurgeThresholdNotedData+  | SurgeTimerMarked !SurgeTimerMarkedData+  deriving stock (Generic, Eq, Show)++type SurgeRegs =+  '[]++initialSurgeRegs :: RegFile SurgeRegs+initialSurgeRegs =+  RNil++$(deriveAggregateCtorsAll ''SurgeCommand ''SurgeRegs)++++$(deriveWireCtorsAll ''SurgeEvent)

+ test/conformance-process/Generated/HospitalCapacity/Surge/EventStream.hs view

@@ -0,0 +1,49 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+module Generated.HospitalCapacity.Surge.EventStream+  ( surgeCategory+  , surgeCommandCategory+  , surgeEventStream+  , surgeEventStreamDef+  , SurgeEventStream+  , SurgeEventStreamDef+  ) where++import Generated.HospitalCapacity.Surge.Domain+import Generated.HospitalCapacity.Surge.Codec (surgeCodec)+import Generated.HospitalCapacity.Surge.Transducer (surgeTransducer)+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.+surgeCategory :: Stream.StreamCategory SurgeEventStreamDef+surgeCategory = Stream.categoryUnsafe "surge"++-- The same category text, typed for command envelopes such as PMCommand.+surgeCommandCategory :: Stream.StreamCategory SurgeCommand+surgeCommandCategory = Stream.categoryUnsafe "surge"++type SurgeEventStreamDef =+  EventStream (HsPred SurgeRegs SurgeCommand) SurgeRegs SurgeVertex SurgeCommand SurgeEvent++type SurgeEventStream =+  ValidatedEventStream (HsPred SurgeRegs SurgeCommand) SurgeRegs SurgeVertex SurgeCommand SurgeEvent++surgeEventStreamDef :: SurgeEventStreamDef+surgeEventStreamDef =+  EventStream+    { transducer = surgeTransducer,+      initialState = SurgeIdle,+      initialRegisters = initialSurgeRegs,+      eventCodec = surgeCodec,+      resolveStreamName = Stream.streamName,+      snapshotPolicy = Never,+      stateCodec = Nothing+    }++surgeEventStream :: SurgeEventStream+surgeEventStream =+  mkEventStreamOrThrow "Surge" surgeEventStreamDef

+ test/conformance-process/Generated/HospitalCapacity/Surge/Harness.hs view

@@ -0,0 +1,87 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+module Generated.HospitalCapacity.Surge.Harness (harnessAssertions) where++import Generated.HospitalCapacity.Surge.Domain+import Generated.HospitalCapacity.Surge.Codec (encodeSurgeEvent, parseSurgeEvent, surgeCodec)+import Generated.HospitalCapacity.Surge.Transducer (surgeTransducer)+import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer)+import Keiro.Codec (eventType)+import Generated.HospitalCapacity.Nominals (HospitalId, parseHospitalId)++-- | (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 surgeTransducer))+  -- clock-free: spec samples no wall clock (verified at scaffold time)+  , ("golden round-trip: SurgeThresholdNoted", roundTrips sampleEventSurgeThresholdNoted)+  , ("golden round-trip: SurgeTimerMarked", roundTrips sampleEventSurgeTimerMarked)+  , ("accepts NoteSurgeThreshold from SurgeIdle", acceptNoteSurgeThreshold)+  , ("accepts MarkSurgeTimerFired from SurgeIdle", acceptMarkSurgeTimerFired)+  ]+  ++ forwardReplayNoteSurgeThreshold+  ++ forwardReplayMarkSurgeTimerFired++roundTrips :: SurgeEvent -> Bool+roundTrips e = parseSurgeEvent (eventType surgeCodec e) (encodeSurgeEvent e) == Right e++sampleHospitalId :: HospitalId+sampleHospitalId =+  case parseHospitalId "hosp_01h455vb4pex5vsknk084sn02q" of+    Right parsed -> parsed+    Left problem -> error (show problem)++sampleEventSurgeThresholdNoted :: SurgeEvent+sampleEventSurgeThresholdNoted = SurgeThresholdNoted (SurgeThresholdNotedData sampleHospitalId 0 0 "sample-timerId")++sampleEventSurgeTimerMarked :: SurgeEvent+sampleEventSurgeTimerMarked = SurgeTimerMarked (SurgeTimerMarkedData sampleHospitalId "sample-timerId")++acceptNoteSurgeThreshold :: Bool+acceptNoteSurgeThreshold =+  case step surgeTransducer (SurgeIdle, initialSurgeRegs) (NoteSurgeThreshold (NoteSurgeThresholdData sampleHospitalId 0 0 "sample-timerId")) of+    Just (v, _, _) -> v == SurgeIdle+    Nothing -> False++acceptMarkSurgeTimerFired :: Bool+acceptMarkSurgeTimerFired =+  case step surgeTransducer (SurgeIdle, initialSurgeRegs) (MarkSurgeTimerFired (MarkSurgeTimerFiredData sampleHospitalId "sample-timerId")) of+    Just (v, _, _) -> v == SurgeIdle+    Nothing -> False++-- forward/replay equality (plan 147): cross the persisted codec boundary,+-- replay the emitted chain, and compare the final vertex and every register.+forwardReplayNoteSurgeThreshold :: [(String, Bool)]+forwardReplayNoteSurgeThreshold =+  case step surgeTransducer (SurgeIdle, initialSurgeRegs) (NoteSurgeThreshold (NoteSurgeThresholdData sampleHospitalId 0 0 "sample-timerId")) of+    Nothing -> [(prefix <> "forward step accepted", False)]+    Just (forwardVertex, _forwardRegs, emitted) ->+      case mapM (\event -> parseSurgeEvent (eventType surgeCodec event) (encodeSurgeEvent event)) emitted of+        Left _ -> [(prefix <> "emitted chain decodes", False)]+        Right decodedEvents ->+          case applyEventsEither surgeTransducer (SurgeIdle, initialSurgeRegs) decodedEvents of+            Left _ -> [(prefix <> "replay succeeds", False)]+            Right (replayVertex, _replayRegs) ->+              [ (prefix <> "final vertex", replayVertex == forwardVertex)+              ]+  where+    prefix = "forward/replay equality: NoteSurgeThreshold from SurgeIdle -- "++-- forward/replay equality (plan 147): cross the persisted codec boundary,+-- replay the emitted chain, and compare the final vertex and every register.+forwardReplayMarkSurgeTimerFired :: [(String, Bool)]+forwardReplayMarkSurgeTimerFired =+  case step surgeTransducer (SurgeIdle, initialSurgeRegs) (MarkSurgeTimerFired (MarkSurgeTimerFiredData sampleHospitalId "sample-timerId")) of+    Nothing -> [(prefix <> "forward step accepted", False)]+    Just (forwardVertex, _forwardRegs, emitted) ->+      case mapM (\event -> parseSurgeEvent (eventType surgeCodec event) (encodeSurgeEvent event)) emitted of+        Left _ -> [(prefix <> "emitted chain decodes", False)]+        Right decodedEvents ->+          case applyEventsEither surgeTransducer (SurgeIdle, initialSurgeRegs) decodedEvents of+            Left _ -> [(prefix <> "replay succeeds", False)]+            Right (replayVertex, _replayRegs) ->+              [ (prefix <> "final vertex", replayVertex == forwardVertex)+              ]+  where+    prefix = "forward/replay equality: MarkSurgeTimerFired from SurgeIdle -- "

+ test/conformance-process/Generated/HospitalCapacity/Surge/Projection.hs view

@@ -0,0 +1,4 @@+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+module Generated.HospitalCapacity.Surge.Projection () where++-- No projection declarations are present; this module keeps the generated manifest inventory total.

+ test/conformance-process/Generated/HospitalCapacity/Surge/Transducer.hs view

@@ -0,0 +1,64 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE QualifiedDo #-}+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 4) from aggregate Surge; do not edit.+module Generated.HospitalCapacity.Surge.Transducer+  ( surgeTransducer+  , surgeFoldFingerprint+  , BehaviorOwnership (..)+  , surgePredicateVerifications+  ) where++import Generated.HospitalCapacity.Surge.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++surgeTransducer+  :: SymTransducer+       (HsPred SurgeRegs SurgeCommand)+       SurgeRegs+       SurgeVertex+       SurgeCommand+       SurgeEvent+surgeTransducer =+  B.buildTransducer SurgeIdle initialSurgeRegs isTerminal do+    B.from SurgeIdle do+      B.onCmd inCtorNoteSurgeThreshold $ \d -> B.do+        B.emit wireSurgeThresholdNoted (SurgeThresholdNotedTermFields+          { hospitalId = d.hospitalId+          , availableIcuBeds = d.availableIcuBeds+          , redDemand = d.redDemand+          , timerId = d.timerId+          })+        B.goto SurgeIdle+      B.onCmd inCtorMarkSurgeTimerFired $ \d -> B.do+        B.emit wireSurgeTimerMarked (SurgeTimerMarkedTermFields+          { hospitalId = d.hospitalId+          , timerId = d.timerId+          })+        B.goto SurgeIdle+ where+  isTerminal = \case++    _ -> False++surgeFoldFingerprint :: Text+surgeFoldFingerprint = "f5cf8e2b3a7ba5deee7b74834492edd1"++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.+surgePredicateVerifications :: IO [(Text, BehaviorOwnership, S.PredicateVerification)]+surgePredicateVerifications = sequence+  [ verifyTransition "transition1IdleNoteSurgeThreshold" GeneratedOwned SurgeIdle 0+  , verifyTransition "transition2IdleMarkSurgeTimerFired" GeneratedOwned SurgeIdle 1+  ]+ where+  verifyTransition label owner source edgeIndex =+    case drop edgeIndex (K.edgesOut surgeTransducer source) of+      K.Edge predicate _ _ _ _ : _ -> (\result -> (label, owner, result)) <$> S.verifyPredicate predicate+      [] -> pure (label, owner, S.UnverifiedSolverFailure "generated transition edge missing")

+ test/conformance-process/HospitalCapacity/Hospital/BehaviorHoles.hs view

@@ -0,0 +1,9 @@+-- Consumer-owned behavioral witnesses. Created once; never overwritten.+module HospitalCapacity.Hospital.BehaviorHoles (behaviorWitnesses) where++import Generated.HospitalCapacity.Hospital.BehaviorContract++behaviorWitnesses :: [BehaviorWitness]+behaviorWitnesses =+  [ Pending (BehaviorKey "behavior-v1-69ac3daa8569d350")+  ]

+ test/conformance-process/HospitalCapacity/Hospital/Holes.hs view

@@ -0,0 +1,37 @@+{-# 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 HospitalCapacity.Hospital.Holes+  ( hospitalTransducer+  -- (no projection)++  ) where++import Generated.HospitalCapacity.Hospital.Domain+import Keiki.Builder ((=:))+import qualified Keiki.Builder as B+import Keiki.Core (HsPred, RegFile, SymTransducer, lit, (.==), (./=), (.||))+++-- HOLE: the transducer body. Reproduce the structure below, replacing each+-- `-- HOLE` line with the keiki symbolic operators it describes.+hospitalTransducer+  :: SymTransducer+       (HsPred HospitalRegs HospitalCommand)+       HospitalRegs+       HospitalVertex+       HospitalCommand+       HospitalEvent+hospitalTransducer =+  B.buildTransducer HospitalOperational initialHospitalRegs isTerminal do++ where+  isTerminal = \case++    _ -> False+

+ test/conformance-process/HospitalCapacity/HospitalSurge/ProcessHoles.hs view

@@ -0,0 +1,11 @@+-- HAND-OWNED hole module for the process manager's behaviour-bearing bodies.+-- keiro-dsl creates it once and never overwrites it.+module HospitalCapacity.HospitalSurge.ProcessHoles () where++-- HOLE handle: build the ProcessManagerAction (the self-advance +--   'NoteSurgeThreshold', the dispatch(es), and the timer) from the input.+-- HOLE window: the deadline policy, e.g. surgeWindow :: NominalDiffTime; +--   surgeDeadline observedAt = addUTCTime surgeWindow observedAt  (TIME INJECTED).+-- HOLE fire command: construct MarkSurgeTimerFired for the timer fire,+--   keyed by correlationId; the fired-event-id is the deterministic uuidv5 of+--   "hospital-surge-fired:" <> correlationId.

+ test/conformance-process/HospitalCapacity/Surge/BehaviorHoles.hs view

@@ -0,0 +1,10 @@+-- Consumer-owned behavioral witnesses. Created once; never overwritten.+module HospitalCapacity.Surge.BehaviorHoles (behaviorWitnesses) where++import Generated.HospitalCapacity.Surge.BehaviorContract++behaviorWitnesses :: [BehaviorWitness]+behaviorWitnesses =+  [ Pending (BehaviorKey "behavior-v1-5198a253324042e6")+  , Pending (BehaviorKey "behavior-v1-6721e0b61aa38780")+  ]

+ test/conformance-process/HospitalCapacity/Surge/Holes.hs view

@@ -0,0 +1,37 @@+{-# 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 HospitalCapacity.Surge.Holes+  ( surgeTransducer+  -- (no projection)++  ) where++import Generated.HospitalCapacity.Surge.Domain+import Keiki.Builder ((=:))+import qualified Keiki.Builder as B+import Keiki.Core (HsPred, RegFile, SymTransducer, lit, (.==), (./=), (.||))+++-- HOLE: the transducer body. Reproduce the structure below, replacing each+-- `-- HOLE` line with the keiki symbolic operators it describes.+surgeTransducer+  :: SymTransducer+       (HsPred SurgeRegs SurgeCommand)+       SurgeRegs+       SurgeVertex+       SurgeCommand+       SurgeEvent+surgeTransducer =+  B.buildTransducer SurgeIdle initialSurgeRegs isTerminal do++ where+  isTerminal = \case++    _ -> False+

+ test/conformance-process/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

@@ -0,0 +1,46 @@+-- keiro-dsl build manifest for keiro-dsl/test/fixtures/hospital-surge.keiro+-- Paste the complete fragment below into the consuming Cabal stanza.+-- The generated layer is overwritten on every scaffold; hole modules are+-- create-if-absent (filled by hand).++default-language: GHC2024+default-extensions:+    DuplicateRecordFields+    NoFieldSelectors+    OverloadedRecordDot+    OverloadedStrings++other-modules:+    Generated.HospitalCapacity.BehaviorSourceMap+    Generated.HospitalCapacity.Hospital.BehaviorContract+    Generated.HospitalCapacity.Hospital.Codec+    Generated.HospitalCapacity.Hospital.Domain+    Generated.HospitalCapacity.Hospital.EventStream+    Generated.HospitalCapacity.Hospital.Harness+    Generated.HospitalCapacity.Hospital.Projection+    Generated.HospitalCapacity.Hospital.Transducer+    Generated.HospitalCapacity.HospitalSurge.Process+    Generated.HospitalCapacity.HospitalSurge.ProcessHarness+    Generated.HospitalCapacity.Nominals+    Generated.HospitalCapacity.Nominals.Internal+    Generated.HospitalCapacity.ReplayAudit+    Generated.HospitalCapacity.Surge.BehaviorContract+    Generated.HospitalCapacity.Surge.Codec+    Generated.HospitalCapacity.Surge.Domain+    Generated.HospitalCapacity.Surge.EventStream+    Generated.HospitalCapacity.Surge.Harness+    Generated.HospitalCapacity.Surge.Projection+    Generated.HospitalCapacity.Surge.Transducer+    HospitalCapacity.Hospital.BehaviorHoles+    HospitalCapacity.HospitalSurge.ProcessHoles+    HospitalCapacity.Surge.BehaviorHoles++build-depends:+    , aeson+    , base+    , keiki+    , keiro+    , shibuya-core+    , text+    , time+    , uuid

+ test/conformance-process/keiro-dsl-ledger.context.hospital-capacity.txt view

@@ -0,0 +1,61 @@+keiro-dsl scaffold record v1+spec: keiro-dsl/test/fixtures/hospital-surge.keiro+module-root: (none)+layout: prefixed+source-language {"declaredLanguageVersion":4,"effectiveLanguageVersion":4,"sourceForm":"declared"}+semantic-contract {"languageSupport":"compatibility-only","languageVersion":4,"runtimeSemantics":"keiro-dsl/runtime-semantics/3"}+naming-edition idiomatic-v2+module-role {"family":"BehaviorSourceMap","kind":"generated","ownerKind":"context","ownerName":"context hospital-capacity behavior source map","path":"Generated/HospitalCapacity/BehaviorSourceMap.hs"}+module-role {"family":"Nominals","kind":"generated","ownerKind":"context","ownerName":"context hospital-capacity generated nominal declarations","path":"Generated/HospitalCapacity/Nominals.hs"}+module-role {"family":"Internal","kind":"generated","ownerKind":"context","ownerName":"context hospital-capacity generated nominal ID internals","path":"Generated/HospitalCapacity/Nominals/Internal.hs"}+module-role {"family":"ReplayAudit","kind":"generated","ownerKind":"context","ownerName":"context hospital-capacity replay-audit assembly","path":"Generated/HospitalCapacity/ReplayAudit.hs"}+module-role {"family":"Process","kind":"generated","ownerKind":"process","ownerName":"process HospitalSurge (line 7)","path":"Generated/HospitalCapacity/HospitalSurge/Process.hs"}+module-role {"family":"ProcessHoles","kind":"hole","ownerKind":"process","ownerName":"process HospitalSurge (line 7)","path":"HospitalCapacity/HospitalSurge/ProcessHoles.hs"}+module-role {"family":"ProcessHarness","kind":"generated","ownerKind":"process","ownerName":"process HospitalSurge (line 7)","path":"Generated/HospitalCapacity/HospitalSurge/ProcessHarness.hs"}+module-role {"family":"Domain","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 35)","path":"Generated/HospitalCapacity/Surge/Domain.hs"}+module-role {"family":"Codec","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 35)","path":"Generated/HospitalCapacity/Surge/Codec.hs"}+module-role {"family":"Transducer","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 35)","path":"Generated/HospitalCapacity/Surge/Transducer.hs"}+module-role {"family":"BehaviorContract","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 35)","path":"Generated/HospitalCapacity/Surge/BehaviorContract.hs"}+module-role {"family":"BehaviorHoles","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate behavior witnesses Surge (line 35)","path":"HospitalCapacity/Surge/BehaviorHoles.hs"}+module-role {"family":"EventStream","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 35)","path":"Generated/HospitalCapacity/Surge/EventStream.hs"}+module-role {"family":"Projection","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 35)","path":"Generated/HospitalCapacity/Surge/Projection.hs"}+module-role {"family":"Harness","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Surge (line 35)","path":"Generated/HospitalCapacity/Surge/Harness.hs"}+module-role {"family":"Domain","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 47)","path":"Generated/HospitalCapacity/Hospital/Domain.hs"}+module-role {"family":"Codec","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 47)","path":"Generated/HospitalCapacity/Hospital/Codec.hs"}+module-role {"family":"Transducer","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 47)","path":"Generated/HospitalCapacity/Hospital/Transducer.hs"}+module-role {"family":"BehaviorContract","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 47)","path":"Generated/HospitalCapacity/Hospital/BehaviorContract.hs"}+module-role {"family":"BehaviorHoles","kind":"hole","ownerKind":"aggregate","ownerName":"aggregate behavior witnesses Hospital (line 47)","path":"HospitalCapacity/Hospital/BehaviorHoles.hs"}+module-role {"family":"EventStream","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 47)","path":"Generated/HospitalCapacity/Hospital/EventStream.hs"}+module-role {"family":"Projection","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 47)","path":"Generated/HospitalCapacity/Hospital/Projection.hs"}+module-role {"family":"Harness","kind":"generated","ownerKind":"aggregate","ownerName":"aggregate Hospital (line 47)","path":"Generated/HospitalCapacity/Hospital/Harness.hs"}+generated Generated/HospitalCapacity/BehaviorSourceMap.hs+generated Generated/HospitalCapacity/Nominals.hs+generated Generated/HospitalCapacity/Nominals/Internal.hs+generated Generated/HospitalCapacity/ReplayAudit.hs+generated Generated/HospitalCapacity/HospitalSurge/Process.hs+hole HospitalCapacity/HospitalSurge/ProcessHoles.hs+generated Generated/HospitalCapacity/HospitalSurge/ProcessHarness.hs+generated Generated/HospitalCapacity/Surge/Domain.hs+generated Generated/HospitalCapacity/Surge/Codec.hs+generated Generated/HospitalCapacity/Surge/Transducer.hs+generated Generated/HospitalCapacity/Surge/BehaviorContract.hs+hole HospitalCapacity/Surge/BehaviorHoles.hs+generated Generated/HospitalCapacity/Surge/EventStream.hs+generated Generated/HospitalCapacity/Surge/Projection.hs+generated Generated/HospitalCapacity/Surge/Harness.hs+generated Generated/HospitalCapacity/Hospital/Domain.hs+generated Generated/HospitalCapacity/Hospital/Codec.hs+generated Generated/HospitalCapacity/Hospital/Transducer.hs+generated Generated/HospitalCapacity/Hospital/BehaviorContract.hs+hole HospitalCapacity/Hospital/BehaviorHoles.hs+generated Generated/HospitalCapacity/Hospital/EventStream.hs+generated Generated/HospitalCapacity/Hospital/Projection.hs+generated Generated/HospitalCapacity/Hospital/Harness.hs+id-domain id-domain|name=HospitalId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=hosp|separator=_|json=canonical-json-text+id-domain id-domain|name=CommandId|contract=keiro-dsl/id-domain/typeid-v7/1|prefix=cmd|separator=_|json=canonical-json-text+nominal-equality nominal-equality|name=CommandId|contract=keiro-dsl/nominal-equality/2|key=Text|domain=typeid-v7-text:cmd:keiro-dsl/id-domain/typeid-v7/1|owner=generated+nominal-equality nominal-equality|name=HospitalId|contract=keiro-dsl/nominal-equality/2|key=Text|domain=typeid-v7-text:hosp:keiro-dsl/id-domain/typeid-v7/1|owner=generated+behavior {"aggregate":"Surge","command":"NoteSurgeThreshold","evidence":"generated-authoritative","key":"behavior-v1-5198a253324042e6","kind":"live-transition","outputs":[{"command":"NoteSurgeThreshold","ownership":"generated-command-identity"}],"source":"Idle"}+behavior {"aggregate":"Surge","command":"MarkSurgeTimerFired","evidence":"generated-authoritative","key":"behavior-v1-6721e0b61aa38780","kind":"live-transition","outputs":[{"command":"MarkSurgeTimerFired","ownership":"generated-command-identity"}],"source":"Idle"}+behavior {"aggregate":"Hospital","command":"ActivateSurge","evidence":"generated-authoritative","key":"behavior-v1-69ac3daa8569d350","kind":"live-transition","outputs":[{"command":"ActivateSurge","ownership":"generated-command-identity"}],"source":"Operational"}+semantic-impact {"declarations":[],"mappedSurfaceEvidenceVersion":1,"serviceInventory":[]}

test/conformance-projection-catalog/Generated/CatalogDemo/BehaviorSourceMap.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from context catalog-demo behavior source map; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from context catalog-demo behavior source map; do not edit. module Generated.CatalogDemo.BehaviorSourceMap   ( BehaviorSourceLocation (..)   , behaviorSourceLocation@@ -9,9 +9,9 @@ import Data.Text qualified as T  data BehaviorSourceLocation = BehaviorSourceLocation-  { sourceFile :: !FilePath-  , sourceLine :: !Int-  , sourceColumn :: !Int+  { file :: !FilePath+  , line :: !Int+  , column :: !Int   }   deriving stock (Eq, Ord, Show) @@ -25,7 +25,7 @@  renderBehaviorSourceLocation :: Text -> Text renderBehaviorSourceLocation key = case behaviorSourceLocation key of-  Just location -> T.pack (sourceFile location) <> ":" <> tshow (sourceLine location) <> ":" <> tshow (sourceColumn location)+  Just location -> T.pack location.file <> ":" <> tshow location.line <> ":" <> tshow location.column   Nothing -> "<internal invariant: missing behavior source for " <> key <> ">"  tshow :: Show value => value -> Text

test/conformance-projection-catalog/Generated/CatalogDemo/CatalogAudit/ReadModel.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel catalogAudit; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from readmodel catalogAudit; do not edit. module Generated.CatalogDemo.CatalogAudit.ReadModel   ( catalogAuditReadModel   , catalogAuditQualifiedTable

test/conformance-projection-catalog/Generated/CatalogDemo/CatalogAudit/ReadModelHarness.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel catalogAudit; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-projection-catalog/Generated/CatalogDemo/CatalogAudit/ReadModelTable.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel catalogAudit; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from readmodel catalogAudit; do not edit. module Generated.CatalogDemo.CatalogAudit.ReadModelTable (catalogAuditQualifiedTable) where  import Data.Text (Text)

test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/QueryContract.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel order_inline; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from readmodel order_inline; do not edit. module Generated.CatalogDemo.OrderInline.QueryContract   ( OrderInlineQueryInput   , OrderInlineQueryResult

test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/ReadModel.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel order_inline; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from readmodel order_inline; do not edit. module Generated.CatalogDemo.OrderInline.ReadModel   ( orderInlineReadModel   , orderInlineQualifiedTable

test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/ReadModelHarness.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel order_inline; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-projection-catalog/Generated/CatalogDemo/OrderInline/ReadModelTable.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel order_inline; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from readmodel order_inline; do not edit. module Generated.CatalogDemo.OrderInline.ReadModelTable (orderInlineQualifiedTable) where  import Data.Text (Text)

test/conformance-projection-catalog/Generated/CatalogDemo/OrderTotalsLookup/ReadModel.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel order_totals_lookup; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from readmodel order_totals_lookup; do not edit. module Generated.CatalogDemo.OrderTotalsLookup.ReadModel   ( orderTotalsLookupReadModel   , orderTotalsLookupQualifiedTable

test/conformance-projection-catalog/Generated/CatalogDemo/OrderTotalsLookup/ReadModelHarness.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel order_totals_lookup; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-projection-catalog/Generated/CatalogDemo/OrderTotalsLookup/ReadModelTable.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from readmodel order_totals_lookup; do not edit.+-- @generated by keiro-dsl 0.15.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)

test/conformance-projection-catalog/Generated/CatalogDemo/Orders/BehaviorContract.hs view

@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit. module Generated.CatalogDemo.Orders.BehaviorContract   ( BehaviorKey (..)+  , unBehaviorKey   , ObligationKind (..)   , EvidenceLevel (..)   , GuardCoverage (..)@@ -35,6 +36,9 @@ newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }   deriving stock (Eq, Ord, Show) +unBehaviorKey :: BehaviorKey -> Text+unBehaviorKey (BehaviorKey value) = value+ data ObligationKind = LiveTransition | RequiredRejection | ReplayTransition   deriving stock (Eq, Ord, Show) @@ -45,15 +49,15 @@   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]+  { key :: !BehaviorKey+  , kind :: !ObligationKind+  , evidence :: !EvidenceLevel+  , guardCoverage :: !GuardCoverage+  , source :: !OrdersVertex+  , commandName :: !Text+  , expectedEdge :: !(Maybe (K.EdgeRef OrdersVertex))+  , target :: !(Maybe OrdersVertex)+  , eventKinds :: ![Text]   }   deriving stock (Eq, Show) @@ -69,104 +73,104 @@ data BehaviorWitness   = Pending BehaviorKey   | LiveWitness-      { witnessKey :: BehaviorKey-      , witnessHistory :: [OrdersEvent]-      , witnessCommand :: OrdersCommand-      , witnessExpected :: LiveExpectation+      { key :: BehaviorKey+      , history :: [OrdersEvent]+      , command :: OrdersCommand+      , expected :: LiveExpectation       }   | ReplayWitness-      { witnessKey :: BehaviorKey-      , witnessHistoryPrefix :: [OrdersEvent]-      , witnessObservedChunk :: [OrdersEvent]+      { key :: BehaviorKey+      , historyPrefix :: [OrdersEvent]+      , observedChunk :: [OrdersEvent]       }   deriving stock (Eq, Show)  data BehaviorFailure = BehaviorFailure-  { failureKey :: !BehaviorKey-  , failureSubject :: !Text-  , failureCode :: !Text-  , failureDetail :: !Text+  { key :: !BehaviorKey+  , subject :: !Text+  , code :: !Text+  , detail :: !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+    [ "key" .= unBehaviorKey behaviorFailure.key+    , "subject" .= behaviorFailure.subject+    , "code" .= behaviorFailure.code+    , "detail" .= behaviorFailure.detail     ]  data BehaviorConformanceReport = BehaviorConformanceReport-  { reportRequired :: ![BehaviorKey]-  , reportFilled :: ![BehaviorKey]-  , reportPending :: ![BehaviorKey]-  , reportMissing :: ![BehaviorKey]-  , reportDuplicate :: ![BehaviorKey]-  , reportStale :: ![BehaviorKey]-  , reportFailed :: ![BehaviorFailure]-  , reportVerified :: ![BehaviorKey]-  , reportUnverified :: ![BehaviorKey]+  { required :: ![BehaviorKey]+  , filled :: ![BehaviorKey]+  , pending :: ![BehaviorKey]+  , missing :: ![BehaviorKey]+  , duplicate :: ![BehaviorKey]+  , stale :: ![BehaviorKey]+  , failed :: ![BehaviorFailure]+  , verified :: ![BehaviorKey]+  , unverified :: ![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)+    , "required" .= keyTexts report.required+    , "filled" .= keyTexts report.filled+    , "pending" .= keyTexts report.pending+    , "missing" .= keyTexts report.missing+    , "duplicate" .= keyTexts report.duplicate+    , "stale" .= keyTexts report.stale+    , "failed" .= report.failed+    , "verified" .= keyTexts report.verified+    , "unverified" .= keyTexts report.unverified     ]  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"]+      { key = BehaviorKey "behavior-v1-8861ebe94ff5f68a"+      , kind = LiveTransition+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardTotal+      , source = OrdersEmpty+      , commandName = "RecordOrder"+      , expectedEdge = (Just (K.EdgeRef OrdersEmpty 0))+      , target = Just OrdersRecorded+      , eventKinds = ["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 = []+      { key = BehaviorKey "behavior-v1-badd7ebab3a3a844"+      , kind = RequiredRejection+      , evidence = GeneratedAuthoritative+      , guardCoverage = GuardNotApplicable+      , source = OrdersRecorded+      , commandName = "RecordOrder"+      , expectedEdge = Nothing+      , target = Nothing+      , eventKinds = []       }   ]  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)]+    { required = sortedKeys (Map.keys requiredByKey)+    , filled = sortedKeys [key | (key, [witness]) <- Map.toList witnessGroups, Map.member key requiredByKey, not (isPending witness)]+    , pending = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, Map.member key requiredByKey, any isPending rows]+    , missing = sortedKeys [key | key <- Map.keys requiredByKey, Map.notMember key witnessGroups]+    , duplicate = sortedKeys [key | (key, rows) <- Map.toList witnessGroups, length rows > 1]+    , stale = sortedKeys [key | key <- Map.keys witnessGroups, Map.notMember key requiredByKey]+    , failed = sortOn (unBehaviorKey . (.key)) failures+    , verified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, proofStrength requirement]+    , unverified = sortedKeys [requirement.key | (requirement, Right ()) <- executions, not (proofStrength requirement)]     }  where-  requiredByKey = Map.fromList [(requirementKey requirement, requirement) | requirement <- behaviorRequirements]+  requiredByKey = Map.fromList [(requirement.key, requirement) | requirement <- behaviorRequirements]   witnessGroups = Map.fromListWith (flip (<>)) [(behaviorWitnessKey witness, [witness]) | witness <- witnesses]   executions =     [ (requirement, runWitness requirement witness)@@ -181,27 +185,27 @@  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))+  null report.pending+    && null report.missing+    && null report.duplicate+    && null report.stale+    && null report.failed+    && (not failOnUnverified || null report.unverified)  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]+  , countLine "required" report.required+  , countLine "filled" report.filled+  , countLine "pending" report.pending+  , countLine "missing" report.missing+  , countLine "duplicate" report.duplicate+  , countLine "stale" report.stale+  , "failed: " <> tshow (length report.failed)+  , countLine "verified" report.verified+  , countLine "unverified" report.unverified+  ] <> T.unlines ["FAIL " <> unBehaviorKey behaviorFailure.key <> " " <> behaviorFailure.subject <> " [" <> behaviorFailure.code <> "] " <> behaviorFailure.detail | behaviorFailure <- report.failed]  runWitness :: BehaviorRequirement -> BehaviorWitness -> Either BehaviorFailure () runWitness requirement witness = case witness of@@ -212,9 +216,9 @@ 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+  ensure requirement (K.replaySuccessState settled == requirement.source) "history-wrong-source" "history does not settle at the required source vertex"+  ensure requirement (commandKind command == requirement.commandName) "command-mismatch" "witness command constructor does not match the required state/command cell"+  case requirement.kind 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@@ -246,7 +250,7 @@       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))+      ensure requirement (map eventKind actual == requirement.eventKinds) "event-envelope-mismatch" ("runtime event kinds differ from the declared ordered envelope; actual=" <> tshow (map eventKind actual) <> " expected=" <> tshow requirement.eventKinds)       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)@@ -258,30 +262,30 @@ 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))+  ensure requirement (Just (K.stepSuccessEdge success) == requirement.expectedEdge) "edge-attribution" ("runtime selected a different guarded sibling; actual=" <> tshow (Just (K.stepSuccessEdge success)) <> " expected=" <> tshow requirement.expectedEdge)+  ensure requirement (Just (K.stepSuccessState success) == requirement.target) "target-mismatch" ("runtime reached a different target vertex; actual=" <> tshow (Just (K.stepSuccessState success)) <> " expected=" <> tshow requirement.target)  runReplay :: BehaviorRequirement -> [OrdersEvent] -> [OrdersEvent] -> Either BehaviorFailure ()-runReplay requirement prefix chunk = case requirementKind requirement of+runReplay requirement prefix chunk = case requirement.kind 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 (K.replaySuccessState settled == requirement.source) "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))+    ensure requirement (Just (K.replaySuccessState replayed) == requirement.target) "target-mismatch" ("replay chunk reached a different target vertex; actual=" <> tshow (Just (K.replaySuccessState replayed)) <> " expected=" <> tshow requirement.target)     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 (Just (K.replayAttributionEdge attribution) == requirement.expectedEdge) "replay-edge-attribution" ("replay selected a different edge; actual=" <> tshow (Just (K.replayAttributionEdge attribution)) <> " expected=" <> tshow requirement.expectedEdge)     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.replayAttributionSource attribution == requirement.source) "replay-source-attribution" ("replay attribution starts at the wrong source; actual=" <> tshow (K.replayAttributionSource attribution) <> " expected=" <> tshow requirement.source)+    ensure requirement (Just (K.replayAttributionTarget attribution) == requirement.target) "replay-target-attribution" ("replay attribution ends at the wrong target; actual=" <> tshow (Just (K.replayAttributionTarget attribution)) <> " expected=" <> tshow requirement.target)     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" @@ -307,14 +311,14 @@  proofStrength :: BehaviorRequirement -> Bool proofStrength requirement =-  requirementEvidence requirement == GeneratedAuthoritative-    && requirementGuardCoverage requirement `elem` [GuardTotal, GuardNotApplicable]+  requirement.evidence == GeneratedAuthoritative+    && requirement.guardCoverage `elem` [GuardTotal, GuardNotApplicable]  behaviorWitnessKey :: BehaviorWitness -> BehaviorKey behaviorWitnessKey witness = case witness of   Pending key -> key-  LiveWitness { witnessKey = key } -> key-  ReplayWitness { witnessKey = key } -> key+  LiveWitness { key = key } -> key+  ReplayWitness { key = key } -> key  isPending :: BehaviorWitness -> Bool isPending Pending {} = True@@ -326,13 +330,13 @@ failure requirement code detail =   Left     ( BehaviorFailure-        (requirementKey requirement)-        (tshow (requirementSource requirement) <> " x " <> requirementCommandName requirement <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey (requirementKey requirement)) <> ")")+        requirement.key+        (tshow requirement.source <> " x " <> requirement.commandName <> ": " <> kindPhrase <> " (" <> BehaviorSourceMap.renderBehaviorSourceLocation (unBehaviorKey requirement.key) <> ")")         code         detail     )  where-  kindPhrase = case requirementKind requirement of+  kindPhrase = case requirement.kind of     LiveTransition -> "live transition"     RequiredRejection -> "required rejection"     ReplayTransition -> "replay-only transition"

test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Codec.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedRecordDot #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit. module Generated.CatalogDemo.Orders.Codec (     ordersCodec,     parseOrdersEvent,

test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Domain.hs view

@@ -1,6 +1,5 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit. module Generated.CatalogDemo.Orders.Domain where  import Data.Proxy (Proxy (..))

test/conformance-projection-catalog/Generated/CatalogDemo/Orders/EventStream.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit. module Generated.CatalogDemo.Orders.EventStream   ( ordersCategory   , ordersCommandCategory

test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Harness.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedLabels #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit. module Generated.CatalogDemo.Orders.Harness (harnessAssertions) where  import Generated.CatalogDemo.Orders.Domain

test/conformance-projection-catalog/Generated/CatalogDemo/Orders/Projection.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit.+-- @generated by keiro-dsl 0.15.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

@@ -1,7 +1,6 @@ {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-}--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from aggregate Orders; do not edit. module Generated.CatalogDemo.Orders.Transducer   ( ordersTransducer   , ordersFoldFingerprint

test/conformance-projection-catalog/Generated/CatalogDemo/ProjectionCatalog.hs view

@@ -1,4 +1,4 @@--- @generated by keiro-dsl 0.14.0.0 (language keiro-dsl 5) from projection-catalog catalog-demo; do not edit.+-- @generated by keiro-dsl 0.15.0.0 (language keiro-dsl 5) from projection-catalog catalog-demo; do not edit. {-# LANGUAGE OverloadedStrings #-} module Generated.CatalogDemo.ProjectionCatalog   ( projectionCatalog

test/conformance-projection-catalog/Generated/CatalogDemo/QualificationJobs/Queue.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/QualificationJobs/QueueCodec.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/QualificationJobs/QueuePolicy.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/ReplayAudit.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/ShipmentLookup/ReadModel.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/ShipmentLookup/ReadModelHarness.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/ShipmentLookup/ReadModelTable.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/BehaviorContract.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Codec.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Domain.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/EventStream.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Harness.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Projection.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/Shipments/Transducer.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/Structural/Shape/QualificationPayload.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/StructuralConformance.hs view

file too large to diff

test/conformance-projection-catalog/Generated/CatalogDemo/StructuralProjections.hs view

file too large to diff

test/conformance-projection-catalog/Main.hs view

file too large to diff

+ test/conformance-projection-catalog/keiro-dsl-cabal-fragment.context.catalog-demo.txt view

file too large to diff

+ test/conformance-projection-catalog/keiro-dsl-ledger.context.catalog-demo.txt view

file too large to diff

+ test/conformance-publisher-runtime/Generated/HospitalCapacity/Emergency/Contract.hs view

file too large to diff

test/conformance-publisher-runtime/Generated/HospitalCapacity/HospitalPublisher/Publisher.hs view

file too large to diff

+ test/conformance-publisher-runtime/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

file too large to diff

+ test/conformance-publisher-runtime/keiro-dsl-ledger.context.hospital-capacity.txt view

file too large to diff

+ test/conformance-queue-runtime/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModel.hs view

file too large to diff

+ test/conformance-queue-runtime/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelHarness.hs view

file too large to diff

+ test/conformance-queue-runtime/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelTable.hs view

file too large to diff

test/conformance-queue-runtime/Generated/HospitalCapacity/ReservationWork/Queue.hs view

file too large to diff

test/conformance-queue-runtime/Generated/HospitalCapacity/ReservationWork/QueueCodec.hs view

file too large to diff

test/conformance-queue-runtime/Generated/HospitalCapacity/ReservationWork/QueuePolicy.hs view

file too large to diff

+ test/conformance-queue-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModel.hs view

file too large to diff

+ test/conformance-queue-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs view

file too large to diff

+ test/conformance-queue-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs view

file too large to diff

+ test/conformance-queue-runtime/HospitalCapacity/AcceptedTransferNeeds/ReadModelHoles.hs view

file too large to diff

+ test/conformance-queue-runtime/HospitalCapacity/TransferDecisions/ReadModelHoles.hs view

file too large to diff

+ test/conformance-queue-runtime/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

file too large to diff

+ test/conformance-queue-runtime/keiro-dsl-ledger.context.hospital-capacity.txt view

file too large to diff

+ test/conformance-queue/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModel.hs view

file too large to diff

+ test/conformance-queue/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelHarness.hs view

file too large to diff

+ test/conformance-queue/Generated/HospitalCapacity/AcceptedTransferNeeds/ReadModelTable.hs view

file too large to diff

test/conformance-queue/Generated/HospitalCapacity/ReservationWork/Queue.hs view

file too large to diff

test/conformance-queue/Generated/HospitalCapacity/ReservationWork/QueueCodec.hs view

file too large to diff

+ test/conformance-queue/Generated/HospitalCapacity/ReservationWork/QueuePolicy.hs view

file too large to diff

+ test/conformance-queue/Generated/HospitalCapacity/TransferDecisions/ReadModel.hs view

file too large to diff

+ test/conformance-queue/Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs view

file too large to diff

+ test/conformance-queue/Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs view

file too large to diff

+ test/conformance-queue/HospitalCapacity/AcceptedTransferNeeds/ReadModelHoles.hs view

file too large to diff

+ test/conformance-queue/HospitalCapacity/TransferDecisions/ReadModelHoles.hs view

file too large to diff

+ test/conformance-queue/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

file too large to diff

+ test/conformance-queue/keiro-dsl-ledger.context.hospital-capacity.txt view

file too large to diff

test/conformance-readmodel-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModel.hs view

file too large to diff

test/conformance-readmodel-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelHarness.hs view

file too large to diff

test/conformance-readmodel-runtime/Generated/HospitalCapacity/TransferDecisions/ReadModelTable.hs view

file too large to diff

+ test/conformance-readmodel-runtime/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

file too large to diff

+ test/conformance-readmodel-runtime/keiro-dsl-ledger.context.hospital-capacity.txt view

file too large to diff

test/conformance-replay/Generated/ReplayDivergence/BehaviorSourceMap.hs view

file too large to diff

+ test/conformance-replay/Generated/ReplayDivergence/Note/BehaviorContract.hs view

file too large to diff

test/conformance-replay/Generated/ReplayDivergence/Note/Codec.hs view

file too large to diff

test/conformance-replay/Generated/ReplayDivergence/Note/Domain.hs view

file too large to diff

test/conformance-replay/Generated/ReplayDivergence/Note/EventStream.hs view

file too large to diff

test/conformance-replay/Generated/ReplayDivergence/Note/Harness.hs view

file too large to diff

test/conformance-replay/Generated/ReplayDivergence/Note/Projection.hs view

file too large to diff

test/conformance-replay/Generated/ReplayDivergence/Note/Transducer.hs view

file too large to diff

test/conformance-replay/Generated/ReplayDivergence/ReplayAudit.hs view

file too large to diff

+ test/conformance-replay/ReplayDivergence/Note/BehaviorHoles.hs view

file too large to diff

+ test/conformance-replay/keiro-dsl-cabal-fragment.context.replay-divergence.txt view

file too large to diff

+ test/conformance-replay/keiro-dsl-ledger.context.replay-divergence.txt view

file too large to diff

test/conformance-router-full/Generated/IncidentPaging/BehaviorSourceMap.hs view

file too large to diff

+ test/conformance-router-full/Generated/IncidentPaging/Page/BehaviorContract.hs view

file too large to diff

test/conformance-router-full/Generated/IncidentPaging/Page/Codec.hs view

file too large to diff

test/conformance-router-full/Generated/IncidentPaging/Page/Domain.hs view

file too large to diff

test/conformance-router-full/Generated/IncidentPaging/Page/EventStream.hs view

file too large to diff

+ test/conformance-router-full/Generated/IncidentPaging/Page/Harness.hs view

file too large to diff

+ test/conformance-router-full/Generated/IncidentPaging/Page/Projection.hs view

file too large to diff

test/conformance-router-full/Generated/IncidentPaging/Page/Transducer.hs view

file too large to diff

test/conformance-router-full/Generated/IncidentPaging/PagingRouter/Router.hs view

file too large to diff

test/conformance-router-full/Generated/IncidentPaging/PagingRouter/RouterHarness.hs view

file too large to diff

test/conformance-router-full/Generated/IncidentPaging/ReplayAudit.hs view

file too large to diff

+ test/conformance-router-full/Generated/IncidentPaging/ServiceOncall/ReadModel.hs view

file too large to diff

+ test/conformance-router-full/Generated/IncidentPaging/ServiceOncall/ReadModelHarness.hs view

file too large to diff

+ test/conformance-router-full/Generated/IncidentPaging/ServiceOncall/ReadModelTable.hs view

file too large to diff

+ test/conformance-router-full/IncidentPaging/Page/BehaviorHoles.hs view

file too large to diff

+ test/conformance-router-full/IncidentPaging/PagingRouter/RouterHoles.hs view

file too large to diff

+ test/conformance-router-full/IncidentPaging/ServiceOncall/ReadModelHoles.hs view

file too large to diff

+ test/conformance-router-full/keiro-dsl-cabal-fragment.context.incident-paging.txt view

file too large to diff

+ test/conformance-router-full/keiro-dsl-ledger.context.incident-paging.txt view

file too large to diff

test/conformance-router-runtime/Generated/IncidentPaging/BehaviorSourceMap.hs view

file too large to diff

+ test/conformance-router-runtime/Generated/IncidentPaging/Page/BehaviorContract.hs view

file too large to diff

+ test/conformance-router-runtime/Generated/IncidentPaging/Page/Codec.hs view

file too large to diff

+ test/conformance-router-runtime/Generated/IncidentPaging/Page/Domain.hs view

file too large to diff

+ test/conformance-router-runtime/Generated/IncidentPaging/Page/EventStream.hs view

file too large to diff

+ test/conformance-router-runtime/Generated/IncidentPaging/Page/Harness.hs view

file too large to diff

+ test/conformance-router-runtime/Generated/IncidentPaging/Page/Projection.hs view

file too large to diff

+ test/conformance-router-runtime/Generated/IncidentPaging/Page/Transducer.hs view

file too large to diff

test/conformance-router-runtime/Generated/IncidentPaging/PagingRouter/Router.hs view

file too large to diff

test/conformance-router-runtime/Generated/IncidentPaging/PagingRouter/RouterHarness.hs view

file too large to diff

+ test/conformance-router-runtime/Generated/IncidentPaging/ReplayAudit.hs view

file too large to diff

+ test/conformance-router-runtime/Generated/IncidentPaging/ServiceOncall/ReadModel.hs view

file too large to diff

+ test/conformance-router-runtime/Generated/IncidentPaging/ServiceOncall/ReadModelHarness.hs view

file too large to diff

+ test/conformance-router-runtime/Generated/IncidentPaging/ServiceOncall/ReadModelTable.hs view

file too large to diff

+ test/conformance-router-runtime/IncidentPaging/Page/BehaviorHoles.hs view

file too large to diff

+ test/conformance-router-runtime/IncidentPaging/Page/Holes.hs view

file too large to diff

+ test/conformance-router-runtime/IncidentPaging/PagingRouter/RouterHoles.hs view

file too large to diff

+ test/conformance-router-runtime/IncidentPaging/ServiceOncall/ReadModelHoles.hs view

file too large to diff

+ test/conformance-router-runtime/keiro-dsl-cabal-fragment.context.incident-paging.txt view

file too large to diff

+ test/conformance-router-runtime/keiro-dsl-ledger.context.incident-paging.txt view

file too large to diff

test/conformance-router/Generated/IncidentPaging/BehaviorSourceMap.hs view

file too large to diff

+ test/conformance-router/Generated/IncidentPaging/Page/BehaviorContract.hs view

file too large to diff

+ test/conformance-router/Generated/IncidentPaging/Page/Codec.hs view

file too large to diff

+ test/conformance-router/Generated/IncidentPaging/Page/Domain.hs view

file too large to diff

+ test/conformance-router/Generated/IncidentPaging/Page/EventStream.hs view

file too large to diff

+ test/conformance-router/Generated/IncidentPaging/Page/Harness.hs view

file too large to diff

+ test/conformance-router/Generated/IncidentPaging/Page/Projection.hs view

file too large to diff

+ test/conformance-router/Generated/IncidentPaging/Page/Transducer.hs view

file too large to diff

+ test/conformance-router/Generated/IncidentPaging/PagingRouter/Router.hs view

file too large to diff

test/conformance-router/Generated/IncidentPaging/PagingRouter/RouterHarness.hs view

file too large to diff

+ test/conformance-router/Generated/IncidentPaging/ReplayAudit.hs view

file too large to diff

+ test/conformance-router/Generated/IncidentPaging/ServiceOncall/ReadModel.hs view

file too large to diff

+ test/conformance-router/Generated/IncidentPaging/ServiceOncall/ReadModelHarness.hs view

file too large to diff

+ test/conformance-router/Generated/IncidentPaging/ServiceOncall/ReadModelTable.hs view

file too large to diff

+ test/conformance-router/IncidentPaging/Page/BehaviorHoles.hs view

file too large to diff

+ test/conformance-router/IncidentPaging/Page/Holes.hs view

file too large to diff

+ test/conformance-router/IncidentPaging/PagingRouter/RouterHoles.hs view

file too large to diff

+ test/conformance-router/IncidentPaging/ServiceOncall/ReadModelHoles.hs view

file too large to diff

+ test/conformance-router/keiro-dsl-cabal-fragment.context.incident-paging.txt view

file too large to diff

+ test/conformance-router/keiro-dsl-ledger.context.incident-paging.txt view

file too large to diff

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/BehaviorSourceMap.hs view

file too large to diff

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Nominals.hs view

file too large to diff

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Nominals/Internal.hs view

file too large to diff

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ReplayAudit.hs view

file too large to diff

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/BehaviorContract.hs view

file too large to diff

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Codec.hs view

file too large to diff

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Domain.hs view

file too large to diff

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/EventStream.hs view

file too large to diff

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Harness.hs view

file too large to diff

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Projection.hs view

file too large to diff

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/ScalarAccount/Transducer.hs view

file too large to diff

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/Structural/Shape/Limits.hs view

file too large to diff

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/StructuralConformance.hs view

file too large to diff

test/conformance-scalar-expressions/Generated/AggregateScalarExpressions/StructuralProjections.hs view

file too large to diff

test/conformance-scalar-expressions/Main.hs view

file too large to diff

+ test/conformance-scalar-expressions/keiro-dsl-cabal-fragment.context.aggregate-scalar-expressions.txt view

file too large to diff

+ test/conformance-scalar-expressions/keiro-dsl-ledger.context.aggregate-scalar-expressions.txt view

file too large to diff

+ test/conformance-service-package/domain/alpha.keiro view

file too large to diff

+ test/conformance-service-package/domain/beta.keiro view

file too large to diff

+ test/conformance-service-package/domain/evidence.keiro view

file too large to diff

+ test/conformance-service-package/domain/shared.keiro view

file too large to diff

+ test/conformance-service-package/runtime/keiro-dsl-conformance-service-runtime.cabal view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/BehaviorHoles.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/Generated/BehaviorContract.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/Generated/Codec.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/Generated/Domain.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/Generated/EventStream.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/Generated/Harness.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/Generated/Projection.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Alpha/Generated/Transducer.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/AlphaView/Generated/ReadModel.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/AlphaView/Generated/ReadModelHarness.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/AlphaView/Generated/ReadModelTable.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/AlphaView/ReadModelHoles.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/BehaviorHoles.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/Generated/BehaviorContract.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/Generated/Codec.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/Generated/Domain.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/Generated/EventStream.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/Generated/Harness.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/Generated/Projection.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Beta/Generated/Transducer.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/BetaView/Generated/ReadModel.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/BetaView/Generated/ReadModelHarness.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/BetaView/Generated/ReadModelTable.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/BetaView/ReadModelHoles.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Generated/BehaviorSourceMap.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Generated/Conformance.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Generated/Nominals.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Generated/Nominals/Internal.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/Generated/ReplayAudit.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/WorkspaceProofWorkflow/Generated/WorkflowFacts.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/Proof/WorkspaceProof/WorkspaceProofWorkflow/Generated/WorkflowRuntime.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/keiro-dsl-cabal-fragment.workspace.workspace-proof.txt view

file too large to diff

+ test/conformance-service-package/runtime/src/keiro-dsl-conformance.workspace.workspace-proof/keiro-dsl-conformance-ledger.txt view

file too large to diff

+ test/conformance-service-package/runtime/src/keiro-dsl-conformance.workspace.workspace-proof/keiro-workspace-proof-conformance.cabal view

file too large to diff

+ test/conformance-service-package/runtime/src/keiro-dsl-conformance.workspace.workspace-proof/src/KeiroConformance/Expectations.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/keiro-dsl-conformance.workspace.workspace-proof/src/Main.hs view

file too large to diff

+ test/conformance-service-package/runtime/src/keiro-dsl-ledger.workspace.workspace-proof.txt view

file too large to diff

+ test/conformance-service-package/service.keiro-workspace view

file too large to diff

test/conformance-skeletons/Main.hs view

file too large to diff

test/conformance-skeletons/SkelAggregate/Generated/MyService/Thing/BehaviorContract.hs view

file too large to diff

+ test/conformance-skeletons/SkelAggregate/keiro-dsl-manifest.my-service.txt view

file too large to diff

+ test/conformance-skeletons/SkelAggregate/keiro-dsl-scaffold-record.my-service.txt view

file too large to diff

test/conformance-skeletons/SkelIntake/Generated/MyService/ThingInbox/Inbox.hs view

file too large to diff

+ test/conformance-skeletons/SkelProcess/Generated/MyService/Hospital/BehaviorContract.hs view

file too large to diff

+ test/conformance-skeletons/SkelProcess/Generated/MyService/Surge/BehaviorContract.hs view

file too large to diff

+ test/conformance-skeletons/SkelProcess/MyService/Hospital/BehaviorHoles.hs view

file too large to diff

+ test/conformance-skeletons/SkelProcess/MyService/Surge/BehaviorHoles.hs view

file too large to diff

+ test/conformance-skeletons/SkelRouter/Generated/MyService/Page/BehaviorContract.hs view

file too large to diff

+ test/conformance-skeletons/SkelRouter/MyService/Page/BehaviorHoles.hs view

file too large to diff

test/conformance-skeletons/SkelWorkflow/Generated/MyService/HospitalTransferReservation/WorkflowFacts.hs view

file too large to diff

+ test/conformance-skeletons/keiro-dsl-cabal-fragment.context.my-service.txt view

file too large to diff

+ test/conformance-skeletons/keiro-dsl-ledger.context.my-service.txt view

file too large to diff

test/conformance-snapshot/Generated/HospitalCapacity/BehaviorSourceMap.hs view

file too large to diff

test/conformance-snapshot/Generated/HospitalCapacity/Nominals.hs view

file too large to diff

test/conformance-snapshot/Generated/HospitalCapacity/Nominals/Internal.hs view

file too large to diff

test/conformance-snapshot/Generated/HospitalCapacity/ReplayAudit.hs view

file too large to diff

+ test/conformance-snapshot/Generated/HospitalCapacity/Reservation/BehaviorContract.hs view

file too large to diff

test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Codec.hs view

file too large to diff

test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Domain.hs view

file too large to diff

test/conformance-snapshot/Generated/HospitalCapacity/Reservation/EventStream.hs view

file too large to diff

+ test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Harness.hs view

file too large to diff

+ test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Projection.hs view

file too large to diff

test/conformance-snapshot/Generated/HospitalCapacity/Reservation/Transducer.hs view

file too large to diff

+ test/conformance-snapshot/HospitalCapacity/Reservation/BehaviorHoles.hs view

file too large to diff

+ test/conformance-snapshot/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

file too large to diff

+ test/conformance-snapshot/keiro-dsl-ledger.context.hospital-capacity.txt view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/BehaviorContract.hs view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Codec.hs view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Domain.hs view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/EventStream.hs view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Harness.hs view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Projection.hs view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/ArtifactCatalog/Transducer.hs view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/BehaviorSourceMap.hs view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/ReplayAudit.hs view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/Structural/CodecCompare/ArtifactInfo.hs view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactInfo.hs view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactKind.hs view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactLocation.hs view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/Structural/Shape/ArtifactMetadata.hs view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/StructuralConformance.hs view

file too large to diff

test/conformance-structural/Generated/StructuralConformance/StructuralProjections.hs view

file too large to diff

+ test/conformance-structural/StructuralConformance/ArtifactCatalog/BehaviorHoles.hs view

file too large to diff

+ test/conformance-structural/keiro-dsl-cabal-fragment.context.structural-conformance.txt view

file too large to diff

+ test/conformance-structural/keiro-dsl-ledger.context.structural-conformance.txt view

file too large to diff

test/conformance-v2/Generated/HospitalCapacity/BehaviorSourceMap.hs view

file too large to diff

test/conformance-v2/Generated/HospitalCapacity/Nominals.hs view

file too large to diff

test/conformance-v2/Generated/HospitalCapacity/Nominals/Internal.hs view

file too large to diff

test/conformance-v2/Generated/HospitalCapacity/ReplayAudit.hs view

file too large to diff

+ test/conformance-v2/Generated/HospitalCapacity/Reservation/BehaviorContract.hs view

file too large to diff

test/conformance-v2/Generated/HospitalCapacity/Reservation/Codec.hs view

file too large to diff

test/conformance-v2/Generated/HospitalCapacity/Reservation/Domain.hs view

file too large to diff

test/conformance-v2/Generated/HospitalCapacity/Reservation/EventStream.hs view

file too large to diff

test/conformance-v2/Generated/HospitalCapacity/Reservation/Harness.hs view

file too large to diff

test/conformance-v2/Generated/HospitalCapacity/Reservation/Projection.hs view

file too large to diff

test/conformance-v2/Generated/HospitalCapacity/Reservation/Transducer.hs view

file too large to diff

+ test/conformance-v2/HospitalCapacity/Reservation/BehaviorHoles.hs view

file too large to diff

+ test/conformance-v2/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

file too large to diff

+ test/conformance-v2/keiro-dsl-ledger.context.hospital-capacity.txt view

file too large to diff

+ test/conformance-workflow-full/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowFacts.hs view

file too large to diff

test/conformance-workflow-full/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs view

file too large to diff

+ test/conformance-workflow-full/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

file too large to diff

+ test/conformance-workflow-full/keiro-dsl-ledger.context.hospital-capacity.txt view

file too large to diff

+ test/conformance-workflow-runtime/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowFacts.hs view

file too large to diff

test/conformance-workflow-runtime/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs view

file too large to diff

+ test/conformance-workflow-runtime/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

file too large to diff

+ test/conformance-workflow-runtime/keiro-dsl-ledger.context.hospital-capacity.txt view

file too large to diff

test/conformance-workflow/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowFacts.hs view

file too large to diff

+ test/conformance-workflow/Generated/HospitalCapacity/HospitalTransferReservation/WorkflowRuntime.hs view

file too large to diff

test/conformance-workflow/Main.hs view

file too large to diff

+ test/conformance-workflow/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

file too large to diff

+ test/conformance-workflow/keiro-dsl-ledger.context.hospital-capacity.txt view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/BehaviorSourceMap.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Nominals.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Nominals/Internal.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/BehaviorContract.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Codec.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Domain.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/EventStream.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Harness.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Projection.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/Project/Transducer.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/BehaviorContract.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Codec.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Domain.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/EventStream.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Harness.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Projection.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ProjectArtifact/Transducer.hs view

file too large to diff

test/conformance-workspace-nominals/Generated/WorkspaceNominalProof/ReplayAudit.hs view

file too large to diff

+ test/conformance-workspace-nominals/keiro-dsl-cabal-fragment.workspace.workspace-nominal-proof.txt view

file too large to diff

+ test/conformance-workspace-nominals/keiro-dsl-ledger.workspace.workspace-nominal-proof.txt view

file too large to diff

test/conformance/Generated/HospitalCapacity/BehaviorSourceMap.hs view

file too large to diff

test/conformance/Generated/HospitalCapacity/Nominals.hs view

file too large to diff

test/conformance/Generated/HospitalCapacity/Nominals/Internal.hs view

file too large to diff

test/conformance/Generated/HospitalCapacity/ReplayAudit.hs view

file too large to diff

+ test/conformance/Generated/HospitalCapacity/Reservation/BehaviorContract.hs view

file too large to diff

test/conformance/Generated/HospitalCapacity/Reservation/Codec.hs view

file too large to diff

test/conformance/Generated/HospitalCapacity/Reservation/Domain.hs view

file too large to diff

test/conformance/Generated/HospitalCapacity/Reservation/EventStream.hs view

file too large to diff

test/conformance/Generated/HospitalCapacity/Reservation/Harness.hs view

file too large to diff

test/conformance/Generated/HospitalCapacity/Reservation/Projection.hs view

file too large to diff

test/conformance/Generated/HospitalCapacity/Reservation/Transducer.hs view

file too large to diff

+ test/conformance/HospitalCapacity/Reservation/BehaviorHoles.hs view

file too large to diff

+ test/conformance/keiro-dsl-cabal-fragment.context.hospital-capacity.txt view

file too large to diff

+ test/conformance/keiro-dsl-ledger.context.hospital-capacity.txt view

file too large to diff

+ test/diff-test.sh view

file too large to diff

+ test/domain-command-outcome-mutation-test.sh view

file too large to diff

+ test/fixtures/aggregate-bad-refs.keiro view

file too large to diff

+ test/fixtures/aggregate-collection-expressions-v2-rejects.keiro view

file too large to diff

+ test/fixtures/aggregate-field-alias.keiro view

file too large to diff

+ test/fixtures/aggregate-scalar-expressions-v1-rejects.keiro view

file too large to diff

+ test/fixtures/aggregate-scalar-expressions-v2.keiro view

file too large to diff

+ test/fixtures/aggregate-scalars-arithmetic.keiro view

file too large to diff

+ test/fixtures/aggregate-scalars-invalid-capabilities.keiro view

file too large to diff

+ test/fixtures/aggregate-scalars-unsupported.keiro view

file too large to diff

+ test/fixtures/aggregate-scalars-workspace/domain/scalars.keiro view

file too large to diff

+ test/fixtures/aggregate-scalars-workspace/service.keiro-workspace view

file too large to diff

+ test/fixtures/aggregate-scalars.keiro view

file too large to diff

+ test/fixtures/behavior-complete-workspace/declarations.keiro view

file too large to diff

+ test/fixtures/behavior-complete-workspace/journey.keiro view

file too large to diff

+ test/fixtures/behavior-complete-workspace/service.keiro-workspace view

file too large to diff

+ test/fixtures/behavior-complete.keiro view

file too large to diff

+ test/fixtures/catalog-readmodel-backing-required.keiro view

file too large to diff

+ test/fixtures/catalog-readmodel-backing-unobserved.keiro view

file too large to diff

+ test/fixtures/catalog-readmodel-physical-override.keiro view

file too large to diff

+ test/fixtures/catalog-readmodel-reorder-a.keiro view

file too large to diff

+ test/fixtures/catalog-readmodel-reorder-b.keiro view

file too large to diff

+ test/fixtures/check-report/legacy-min-language.golden.json view

file too large to diff

+ test/fixtures/compatibility-vector-new.keiro view

file too large to diff

+ test/fixtures/compatibility-vector-old.keiro view

file too large to diff

+ test/fixtures/compatibility-vector.diff.golden view

file too large to diff

+ test/fixtures/consumer-types-armadd.keiro view

file too large to diff

+ test/fixtures/consumer-types-binding-change.keiro view

file too large to diff

+ test/fixtures/consumer-types-encoding.keiro view

file too large to diff

+ test/fixtures/consumer-types-enumadd.keiro view

file too large to diff

+ test/fixtures/consumer-types-enumremove.keiro view

file too large to diff

+ test/fixtures/consumer-types-enumspelling.keiro view

file too large to diff

+ test/fixtures/consumer-types-fieldadd-default.keiro view

file too large to diff

+ test/fixtures/consumer-types-fieldadd-nodefault.keiro view

file too large to diff

+ test/fixtures/consumer-types-fieldremove.keiro view

file too large to diff

+ test/fixtures/consumer-types-fixtures-change.keiro view

file too large to diff

+ test/fixtures/consumer-types-haskell-rename.keiro view

file too large to diff

+ test/fixtures/consumer-types-initial-change.keiro view

file too large to diff

+ test/fixtures/consumer-types-mode-cross.keiro view

file too large to diff

+ test/fixtures/consumer-types-nested-propagation.keiro view

file too large to diff

+ test/fixtures/consumer-types-opaque-version.keiro view

file too large to diff

+ test/fixtures/consumer-types-tagchange.keiro view

file too large to diff

+ test/fixtures/consumer-types-v2.keiro view

file too large to diff

+ test/fixtures/consumer-types-wirekey.keiro view

file too large to diff

+ test/fixtures/consumer-types.keiro view

file too large to diff

+ test/fixtures/contract-bump-fieldadd.keiro view

file too large to diff

+ test/fixtures/contract-discriminator.keiro view

file too large to diff

+ test/fixtures/contract-eventadd.keiro view

file too large to diff

+ test/fixtures/contract-eventdrop.keiro view

file too large to diff

+ test/fixtures/contract-fieldadd.keiro view

file too large to diff

+ test/fixtures/contract-fieldtype.keiro view

file too large to diff

+ test/fixtures/contract-reserved-family.keiro view

file too large to diff

+ test/fixtures/contract-topic.keiro view

file too large to diff

+ test/fixtures/contract-typeid-domain.diff.golden view

file too large to diff

+ test/fixtures/contract-typeid-domain.diff.json.golden view

file too large to diff

+ test/fixtures/contract-v1-compat.keiro view

file too large to diff

+ test/fixtures/contract-v4.keiro view

file too large to diff

+ test/fixtures/contract.keiro view

file too large to diff

+ test/fixtures/declarative-router/README.md view

file too large to diff

+ test/fixtures/declarative-router/unbounded.keiro view

file too large to diff

+ test/fixtures/declarative-router/valid.keiro view

file too large to diff

+ test/fixtures/deny-unlogged.keiro view

file too large to diff

+ test/fixtures/dispatch-dedup-bad-field.keiro view

file too large to diff

+ test/fixtures/dispatch-dedup-ghost-queue.keiro view

file too large to diff

+ test/fixtures/domain-command-outcomes.keiro view

file too large to diff

+ test/fixtures/duplicate-names.keiro view

file too large to diff

+ test/fixtures/emit-badevent.keiro view

file too large to diff

+ test/fixtures/emit-derive.keiro view

file too large to diff

+ test/fixtures/emit-mapchange.keiro view

file too large to diff

+ test/fixtures/emit-noskip.keiro view

file too large to diff

+ test/fixtures/emit-ordering.keiro view

file too large to diff

+ test/fixtures/emit-outboxfield.keiro view

file too large to diff

+ test/fixtures/emit-topic-mismatch.keiro view

file too large to diff

+ test/fixtures/emit.keiro view

file too large to diff

+ test/fixtures/fold-identity-baseline.golden view

file too large to diff

+ test/fixtures/fold-identity-diff-replay.golden view

file too large to diff

+ test/fixtures/hospital-surge-badref.keiro view

file too large to diff

+ test/fixtures/hospital-surge-clock.keiro view

file too large to diff

+ test/fixtures/hospital-surge-dispatchid.keiro view

file too large to diff

+ test/fixtures/hospital-surge-handle.keiro view

file too large to diff

+ test/fixtures/hospital-surge-inputtype.keiro view

file too large to diff

+ test/fixtures/hospital-surge-payload.keiro view

file too large to diff

+ test/fixtures/hospital-surge-procname.keiro view

file too large to diff

+ test/fixtures/hospital-surge-timerid.keiro view

file too large to diff

+ test/fixtures/hospital-surge-window.keiro view

file too large to diff

+ test/fixtures/hospital-surge.keiro view

file too large to diff

+ test/fixtures/id-domain-migration-v3.keiro view

file too large to diff

+ test/fixtures/import-planning-collisions.keiro view

file too large to diff

+ test/fixtures/incident-paging/incident-paging-dispatch.keiro view

file too large to diff

+ test/fixtures/incident-paging/incident-paging.keiro view

file too large to diff

+ test/fixtures/intake-decode.keiro view

file too large to diff

+ test/fixtures/intake-dedupekey.keiro view

file too large to diff

+ test/fixtures/intake-dedupepolicy.keiro view

file too large to diff

+ test/fixtures/intake-dup-retry.keiro view

file too large to diff

+ test/fixtures/intake-dup-row.keiro view

file too large to diff

+ test/fixtures/intake-incomplete.keiro view

file too large to diff

+ test/fixtures/intake-pf-retry.keiro view

file too large to diff

+ test/fixtures/intake-topic-mismatch.keiro view

file too large to diff

+ test/fixtures/intake.keiro view

file too large to diff

+ test/fixtures/language-duplicate.keiro view

file too large to diff

+ test/fixtures/language-identifier-v1.keiro view

file too large to diff

+ test/fixtures/language-identifier-v2.keiro view

file too large to diff

+ test/fixtures/language-legacy.keiro view

file too large to diff

+ test/fixtures/language-malformed.keiro view

file too large to diff

+ test/fixtures/language-misplaced.keiro view

file too large to diff

+ test/fixtures/language-v1.keiro view

file too large to diff

+ test/fixtures/language-zero.keiro view

file too large to diff

+ test/fixtures/mapped-ambiguous.keiro view

file too large to diff

+ test/fixtures/mapped-bad-encoding.keiro view

file too large to diff

+ test/fixtures/mapped-bad-haskell-name.keiro view

file too large to diff

+ test/fixtures/mapped-dup-armname.keiro view

file too large to diff

+ test/fixtures/mapped-dup-fieldname.keiro view

file too large to diff

+ test/fixtures/mapped-dup-tag.keiro view

file too large to diff

+ test/fixtures/mapped-dup-wirekey.keiro view

file too large to diff

+ test/fixtures/mapped-empty-identity.keiro view

file too large to diff

+ test/fixtures/mapped-guard-natural.keiro view

file too large to diff

+ test/fixtures/mapped-guard-time.keiro view

file too large to diff

+ test/fixtures/mapped-guard.keiro view

file too large to diff

+ test/fixtures/mapped-illtyped-default.keiro view

file too large to diff

+ test/fixtures/mapped-import-conflict.keiro view

file too large to diff

+ test/fixtures/mapped-missing-binding-version.keiro view

file too large to diff

+ test/fixtures/mapped-missing-binding.keiro view

file too large to diff

+ test/fixtures/mapped-missing-canonical.keiro view

file too large to diff

+ test/fixtures/mapped-missing-fixture.keiro view

file too large to diff

+ test/fixtures/mapped-missing-initial.keiro view

file too large to diff

+ test/fixtures/mapped-optional-json.keiro view

file too large to diff

+ test/fixtures/mapped-optional-opaque.keiro view

file too large to diff

+ test/fixtures/mapped-optional-optional.keiro view

file too large to diff

+ test/fixtures/mapped-readmodel-workspace/readmodel.keiro view

file too large to diff

+ test/fixtures/mapped-readmodel-workspace/service.keiro-workspace view

file too large to diff

+ test/fixtures/mapped-readmodel-workspace/types.keiro view

file too large to diff

+ test/fixtures/mapped-readmodel.keiro view

file too large to diff

+ test/fixtures/mapped-recursive-mutual.keiro view

file too large to diff

+ test/fixtures/mapped-recursive.keiro view

file too large to diff

+ test/fixtures/mapped-union-key-collision.keiro view

file too large to diff

+ test/fixtures/mapped-unresolved.keiro view

file too large to diff

+ test/fixtures/mapped-workqueue.keiro view

file too large to diff

+ test/fixtures/nominal-bad-qualified.keiro view

file too large to diff

+ test/fixtures/nominal-invalid-prefix.keiro view

file too large to diff

+ test/fixtures/nominal-missing-facts.keiro view

file too large to diff

+ test/fixtures/nominal-missing-initial.keiro view

file too large to diff

+ test/fixtures/nominal-name-collision.keiro view

file too large to diff

+ test/fixtures/nominal-scalars.keiro view

file too large to diff

+ test/fixtures/nominal-unsupported-representation.keiro view

file too large to diff

+ test/fixtures/nominal-v1.keiro view

file too large to diff

+ test/fixtures/operation-ghost-aggregate.keiro view

file too large to diff

+ test/fixtures/operation-signal-value.keiro view

file too large to diff

+ test/fixtures/order.keiro view

file too large to diff

+ test/fixtures/outcome-identifier-legacy.keiro view

file too large to diff

+ test/fixtures/outcome-identifier-positions.keiro view

file too large to diff

+ test/fixtures/outcome-identifier-v5.keiro view

file too large to diff

+ test/fixtures/outcome-identifier.keiro view

file too large to diff

+ test/fixtures/process-bad-timer.keiro view

file too large to diff

+ test/fixtures/process-ghost-refs.keiro view

file too large to diff

+ test/fixtures/projection-catalog-grown.keiro-workspace view

file too large to diff

+ test/fixtures/projection-catalog-unrelated.keiro view

file too large to diff

+ test/fixtures/projection-catalog.keiro view

file too large to diff

+ test/fixtures/projection-catalog.keiro-workspace view

file too large to diff

+ test/fixtures/projection-owner-multi-query.keiro view

file too large to diff

+ test/fixtures/readmodel-consistency-conflict.keiro view

file too large to diff

+ test/fixtures/readmodel-dispatch-unresolved.keiro view

file too large to diff

+ test/fixtures/readmodel-inline-unreferenced.keiro view

file too large to diff

+ test/fixtures/readmodel-migration-l4.keiro view

file too large to diff

+ test/fixtures/readmodel-query-unresolved.keiro view

file too large to diff

+ test/fixtures/readmodel-runtime.keiro view

file too large to diff

+ test/fixtures/readmodel-scope-eventual.keiro view

file too large to diff

+ test/fixtures/readmodel-shape-drift.keiro view

file too large to diff

+ test/fixtures/readmodel-strong-inline.keiro view

file too large to diff

+ test/fixtures/readmodel-strong-standalone.keiro view

file too large to diff

+ test/fixtures/readmodel.keiro view

file too large to diff

+ test/fixtures/record-migration/behavior-obligations.exact.json.golden view

file too large to diff

+ test/fixtures/record-migration/single-file-scaffold-record.ledger.golden view

file too large to diff

+ test/fixtures/record-migration/workspace-scaffold-record.ledger.golden view

file too large to diff

+ test/fixtures/replay-divergence.keiro view

file too large to diff

+ test/fixtures/reservation-bad-command.keiro view

file too large to diff

+ test/fixtures/reservation-chain-gap.keiro view

file too large to diff

+ test/fixtures/reservation-clock.keiro view

file too large to diff

+ test/fixtures/reservation-cmdfieldtype.keiro view

file too large to diff

+ test/fixtures/reservation-deprecated-replay-only.keiro view

file too large to diff

+ test/fixtures/reservation-deprecated.keiro view

file too large to diff

+ test/fixtures/reservation-dup-upcast-source.keiro view

file too large to diff

+ test/fixtures/reservation-enumadd.keiro view

file too large to diff

+ test/fixtures/reservation-enumdrop.keiro view

file too large to diff

+ test/fixtures/reservation-enumwire.keiro view

file too large to diff

+ test/fixtures/reservation-fieldadd.keiro view

file too large to diff

+ test/fixtures/reservation-fieldremove.keiro view

file too large to diff

+ test/fixtures/reservation-fieldtype.keiro view

file too large to diff

+ test/fixtures/reservation-foldchange.keiro view

file too large to diff

+ test/fixtures/reservation-guard-tightened-twin.keiro view

file too large to diff

+ test/fixtures/reservation-guard-tightened.keiro view

file too large to diff

+ test/fixtures/reservation-idprefix.keiro view

file too large to diff

+ test/fixtures/reservation-no-statusmap.keiro view

file too large to diff

+ test/fixtures/reservation-projection.keiro view

file too large to diff

+ test/fixtures/reservation-retiring.keiro view

file too large to diff

+ test/fixtures/reservation-snapshot.keiro view

file too large to diff

+ test/fixtures/reservation-v2-noupcast.keiro view

file too large to diff

+ test/fixtures/reservation-v2.keiro view

file too large to diff

+ test/fixtures/reservation-v3-dangling.keiro view

file too large to diff

+ test/fixtures/reservation-wire.keiro view

file too large to diff

+ test/fixtures/reservation-work-dedupkey.keiro view

file too large to diff

+ test/fixtures/reservation-work-df-retry.keiro view

file too large to diff

+ test/fixtures/reservation-work-divergent.keiro view

file too large to diff

+ test/fixtures/reservation-work-fieldtype.keiro view

file too large to diff

+ test/fixtures/reservation-work-fifo-nokey.keiro view

file too large to diff

+ test/fixtures/reservation-work-key-unordered.keiro view

file too large to diff

+ test/fixtures/reservation-work-optfield.keiro view

file too large to diff

+ test/fixtures/reservation-work-partitioned-empty.keiro view

file too large to diff

+ test/fixtures/reservation-work-rename.keiro view

file too large to diff

+ test/fixtures/reservation-work-reqfield.keiro view

file too large to diff

+ test/fixtures/reservation-work-retarget.keiro view

file too large to diff

+ test/fixtures/reservation-work-sf-deadletter.keiro view

file too large to diff

+ test/fixtures/reservation-work-unlogged.keiro view

file too large to diff

+ test/fixtures/reservation-work-wirename.keiro view

file too large to diff

+ test/fixtures/reservation-work.keiro view

file too large to diff

+ test/fixtures/reservation.keiro view

file too large to diff

+ test/fixtures/rule-bad-domain.keiro view

file too large to diff

+ test/fixtures/rule-not-total.keiro view

file too large to diff

+ test/fixtures/semantic-impact.keiro view

file too large to diff

+ test/fixtures/semantic-locality/domain/alpha.keiro view

file too large to diff

+ test/fixtures/semantic-locality/domain/beta.keiro view

file too large to diff

+ test/fixtures/semantic-locality/service.keiro-workspace view

file too large to diff

+ test/fixtures/statusmap-dangling.keiro view

file too large to diff

+ test/fixtures/statusmap-dup-key.keiro view

file too large to diff

+ test/fixtures/structural-conformance.keiro view

file too large to diff

+ test/fixtures/structural-locality.keiro view

file too large to diff

+ test/fixtures/structural-locality.keiro-workspace view

file too large to diff

+ test/fixtures/subscription.keiro view

file too large to diff

+ test/fixtures/surge-service.keiro view

file too large to diff

+ test/fixtures/transfer-routing.keiro view

file too large to diff

+ test/fixtures/workflow-body.keiro view

file too large to diff

+ test/fixtures/workflow-can-mid.keiro view

file too large to diff

+ test/fixtures/workflow-continue-seed-v2.keiro view

file too large to diff

+ test/fixtures/workflow-continue.keiro view

file too large to diff

+ test/fixtures/workflow-dup-label.keiro view

file too large to diff

+ test/fixtures/workflow-evolution-diff.keiro view

file too large to diff

+ test/fixtures/workflow-evolution.keiro view

file too large to diff

+ test/fixtures/workflow-idfield.keiro view

file too large to diff

+ test/fixtures/workflow-inputfield.keiro view

file too large to diff

+ test/fixtures/workflow-output.keiro view

file too large to diff

+ test/fixtures/workflow-patch-colon.keiro view

file too large to diff

+ test/fixtures/workflow-patch-dup.keiro view

file too large to diff

+ test/fixtures/workflow-rename.keiro view

file too large to diff

+ test/fixtures/workflow-signal-mismatch.keiro view

file too large to diff

+ test/fixtures/workflow-stepadd.keiro view

file too large to diff

+ test/fixtures/workflow-unresolved-fields.keiro view

file too large to diff

+ test/fixtures/workflow.keiro view

file too large to diff

+ test/fixtures/workqueue-dlq-divergent.keiro view

file too large to diff

+ test/fixtures/workqueue-dup-row.keiro view

file too large to diff

+ test/fixtures/workqueue-group-key-change.keiro view

file too large to diff

+ test/fixtures/workqueue-hashed-logical.keiro view

file too large to diff

+ test/fixtures/workqueue-incomplete.keiro view

file too large to diff

+ test/fixtures/workqueue-ordering-change.keiro view

file too large to diff

+ test/fixtures/workqueue-policy-base.keiro view

file too large to diff

+ test/fixtures/workqueue-provision-change.keiro view

file too large to diff

+ test/fixtures/workqueue-table-divergent.keiro view

file too large to diff

+ test/fixtures/workqueue-uppercase-logical.keiro view

file too large to diff

+ test/fixtures/workspace-authority-conflict/domain/a.keiro view

file too large to diff

+ test/fixtures/workspace-authority-conflict/domain/b.keiro view

file too large to diff

+ test/fixtures/workspace-authority-conflict/service.keiro-workspace view

file too large to diff

+ test/fixtures/workspace-context-mismatch/domain/a.keiro view

file too large to diff

+ test/fixtures/workspace-context-mismatch/domain/b.keiro view

file too large to diff

+ test/fixtures/workspace-context-mismatch/service.keiro-workspace view

file too large to diff

+ test/fixtures/workspace-diff-moved/domain/order.keiro view

file too large to diff

+ test/fixtures/workspace-diff-moved/domain/shared.keiro view

file too large to diff

+ test/fixtures/workspace-diff-moved/service.keiro-workspace view

file too large to diff

+ test/fixtures/workspace-diff-new/domain/order.keiro view

file too large to diff

+ test/fixtures/workspace-diff-new/domain/shared.keiro view

file too large to diff

+ test/fixtures/workspace-diff-new/domain/shipment.keiro view

file too large to diff

+ test/fixtures/workspace-diff-new/service.keiro-workspace view

file too large to diff

+ test/fixtures/workspace-diff-new/workspace.diff.golden view

file too large to diff

+ test/fixtures/workspace-diff-old/domain/order.keiro view

file too large to diff

+ test/fixtures/workspace-diff-old/domain/shared.keiro view

file too large to diff

+ test/fixtures/workspace-diff-old/domain/shipment.keiro view

file too large to diff

+ test/fixtures/workspace-diff-old/service.keiro-workspace view

file too large to diff

+ test/fixtures/workspace-dup-decl/domain/project.keiro view

file too large to diff

+ test/fixtures/workspace-dup-decl/domain/shared.keiro view

file too large to diff

+ test/fixtures/workspace-dup-decl/service.keiro-workspace view

file too large to diff

+ test/fixtures/workspace-dup-member/domain/a.keiro view

file too large to diff

+ test/fixtures/workspace-dup-member/service.keiro-workspace view

file too large to diff

+ test/fixtures/workspace-dup-node/domain/a.keiro view

file too large to diff

+ test/fixtures/workspace-dup-node/domain/b.keiro view

file too large to diff

+ test/fixtures/workspace-dup-node/service.keiro-workspace view

file too large to diff

+ test/fixtures/workspace-invalid-member-path/service.keiro-workspace view

file too large to diff

+ test/fixtures/workspace-member-parse-failed/domain/a.keiro view

file too large to diff

+ test/fixtures/workspace-member-parse-failed/domain/b.keiro view

file too large to diff

+ test/fixtures/workspace-member-parse-failed/service.keiro-workspace view

file too large to diff

+ test/fixtures/workspace-missing-member/domain/a.keiro view

file too large to diff

+ test/fixtures/workspace-missing-member/service.keiro-workspace view

file too large to diff

+ test/fixtures/workspace-nominals/domain/project-artifact.keiro view

file too large to diff

+ test/fixtures/workspace-nominals/domain/project.keiro view

file too large to diff

+ test/fixtures/workspace-nominals/domain/shared.keiro view

file too large to diff

+ test/fixtures/workspace-nominals/service.keiro-workspace view

file too large to diff

+ test/fixtures/workspace-path-collision/domain/a.keiro view

file too large to diff

+ test/fixtures/workspace-path-collision/domain/b.keiro view

file too large to diff

+ test/fixtures/workspace-path-collision/service.keiro-workspace view

file too large to diff

+ test/fixtures/workspace-unresolved/domain/project.keiro view

file too large to diff

+ test/fixtures/workspace-unresolved/domain/shared.keiro view

file too large to diff

+ test/fixtures/workspace-unresolved/service.keiro-workspace view

file too large to diff

+ test/fixtures/workspace/domain/project-artifact.keiro view

file too large to diff

+ test/fixtures/workspace/domain/project.keiro view

file too large to diff

+ test/fixtures/workspace/domain/shared.keiro view

file too large to diff

+ test/fixtures/workspace/service-reordered.keiro-workspace view

file too large to diff

+ test/fixtures/workspace/service.keiro-workspace view

file too large to diff

+ test/frontend-0.7/diagnostics/duplicate-clause.txt view

file too large to diff

+ test/frontend-0.7/diagnostics/duplicate-preamble.txt view

file too large to diff

+ test/frontend-0.7/diagnostics/escaped-string.txt view

file too large to diff

+ test/frontend-0.7/diagnostics/expression-error.txt view

file too large to diff

+ test/frontend-0.7/diagnostics/feature-explicit-implementation-v1.txt view

file too large to diff

+ test/frontend-0.7/diagnostics/feature-integer-v1.txt view

file too large to diff

+ test/frontend-0.7/diagnostics/feature-nominal-binding-v1.txt view

file too large to diff

+ test/frontend-0.7/diagnostics/feature-typed-expression-v1.txt view

file too large to diff

+ test/frontend-0.7/diagnostics/invalid-preamble.txt view

file too large to diff

+ test/frontend-0.7/diagnostics/misplaced-preamble.txt view

file too large to diff

+ test/frontend-0.7/diagnostics/numeric-overflow.txt view

file too large to diff

+ test/frontend-0.7/diagnostics/semantic-error.txt view

file too large to diff

+ test/frontend-0.7/diagnostics/workspace-member-parse-failure.txt view

file too large to diff

+ test/frontend-0.7/manifest.json view

file too large to diff

+ test/frontend-0.7/sources/body-grammar-invalid.keiro view

file too large to diff

+ test/frontend-0.7/sources/feature-explicit-implementation-v1.keiro view

file too large to diff

+ test/frontend-0.7/sources/feature-integer-v1.keiro view

file too large to diff

+ test/frontend-0.7/sources/feature-nominal-binding-v1.keiro view

file too large to diff

+ test/frontend-0.7/sources/feature-typed-expression-v1.keiro view

file too large to diff

+ test/frontend-0.7/sources/language-duplicate.keiro view

file too large to diff

+ test/frontend-0.7/sources/language-legacy.keiro view

file too large to diff

+ test/frontend-0.7/sources/language-malformed.keiro view

file too large to diff

+ test/frontend-0.7/sources/language-misplaced.keiro view

file too large to diff

+ test/frontend-0.7/sources/language-v1.keiro view

file too large to diff

+ test/frontend-0.7/sources/language-v2.keiro view

file too large to diff

+ test/frontend-0.7/sources/language-v3.keiro view

file too large to diff

+ test/frontend-0.7/sources/language-zero.keiro view

file too large to diff

+ test/frontend-0.7/sources/semantic-invalid.keiro view

file too large to diff

+ test/frontend-0.7/workspaces/member-parse-failed/domain/a.keiro view

file too large to diff

+ test/frontend-0.7/workspaces/member-parse-failed/domain/b.keiro view

file too large to diff

+ test/frontend-0.7/workspaces/member-parse-failed/service.keiro-workspace view

file too large to diff

+ test/frontend-0.7/workspaces/valid/domain/project-artifact.keiro view

file too large to diff

+ test/frontend-0.7/workspaces/valid/domain/project.keiro view

file too large to diff

+ test/frontend-0.7/workspaces/valid/domain/shared.keiro view

file too large to diff

+ test/frontend-0.7/workspaces/valid/service.keiro-workspace view

file too large to diff

+ test/golden-payloads/hospital-capacity/Reservation/TransferReservationCreated.v1.json view

file too large to diff

+ test/golden-payloads/structural-conformance/ArtifactCatalog/ArtifactRecorded.v1.json view

file too large to diff

test/haskell-name/Main.hs view

file too large to diff

+ test/id-domain-migration-mutation-test.sh view

file too large to diff

test/import-planning/Main.hs view

file too large to diff

+ test/keiro-dsl-codec-compare-artifact-info.cabal view

file too large to diff

+ test/mapped-queue-mutation-test.sh view

file too large to diff

+ test/mapped-readmodel-mutation-test.sh view

file too large to diff

+ test/mapped-surface-locality-test.sh view

file too large to diff

+ test/mapped-surface-mutation-test.sh view

file too large to diff

+ test/mutation-test.sh view

file too large to diff

+ test/process-mutation-test.sh view

file too large to diff

+ test/projection-supply-mutation-test.sh view

file too large to diff

+ test/replay-mutation-test.sh view

file too large to diff

+ test/router-mutation-test.sh view

file too large to diff

+ test/source-anchor-mutation-test.sh view

file too large to diff

+ test/structural-mutation-test.sh view

file too large to diff

+ test/workflow-mutation-test.sh view

file too large to diff