diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,113 @@ ## [Unreleased] +## 0.9.0.0 — 2026-08-02 + +### Breaking Changes + +- Requires `keiki >=0.8 && <0.9`, replacing the previous `>=0.7 && <0.8` bound, + in lockstep with `keiro-core` and `keiro`. +- Aggregate fold fingerprints widen from 16-hex-digit FNV-1a-64 to + 32-lowercase-hex-digit FNV-1a-128. This intentionally invalidates snapshots + produced with the old fold discriminator; re-scaffold generated transducers + before deploying `0.9.0.0`. Read-model shape, mapped-wire, and behavior-key + 64-bit identities are unchanged. +- Aggregate fold, diff, replay-impact, and workspace-diff service APIs now + return `Either FoldSurfaceError`; scaffold planning refuses the same error + before module generation. Removes the misleading legacy/version-1 + `Spec`-only wrappers `aggregateFoldFingerprint`, `aggregateFoldSurface`, + `diffSpecs`, `replayImpact`, `nominalEqualityContract`, + `nominalEqualityIdentity`, and `nominalEqualityIdentities`. Retain and pass a + `CheckedService`, or explicitly use `legacyCheckedService` at a deliberate + compatibility boundary. +- `DiagnosticCode` gains append-only constructors for contract TypeID + admission and for closed policy, numeric, duplicate, identity, external-name, + intake-coupling, topic-alias, and wire-clause validation. Exhaustive matches + over `DiagnosticCode` must be extended. `RolloutConstraint` also gains + `RolloutProducerFirst`. +- Removes the unreachable exported grammar types `Derivation`, + `DerivStrategy`, `Disposition`, `DispAction`, `EnvelopeBinding`, and + `EnvelopeLayer`. No parser, renderer, validator, or generator constructed + them; use the live node-specific derivation, disposition, and intake binding + types instead. +- Workqueue `jobOutcomeFor` functions now accept a generated queue-named closed + outcome sum instead of `Text`; inbox generation exposes closed outcome and + detailed disposition sums carrying retry delays, dead-letter reasons, and + runtime failure detail. Replace string literals and bare acknowledgement + matches with the generated constructors. +- Structural projection witnesses are renamed from hex-mangled identifiers to + deterministic owner-and-JSON-pointer names, with a stable suffix only for + normalized-name collisions. Re-scaffold and update hand-owned imports and + uses; witness values and projection semantics are unchanged. +- Aggregate stream categories are fixed to their generated event-stream + definition phantom. `PMCommand` and router consumers must use the new + `CommandCategory`, fixed to the command phantom; generated process + categories are fixed to the saga event-stream definition. +- `workflowFacts` changes from packed `[(String, String)]` values to the + generated `WorkflowFacts` record with separate body, await-label, and + patch-identifier lists. Honest zero-constructor command/event declarations + are now empty datatypes rather than a synthetic `()` constructor. + +### New Features + +- Runtime semantics now uses private monotone capability profiles rather than + consumer-maintained identifier-string lists. Aggregate fold identity and + replay transition comparison use a total frozen canonical encoder independent + of presentation pretty-printing, and replay pairing of guard-disambiguated + sibling transitions is declaration-order invariant. Fold identity applies the + standard FNV-1a-128 octet fold to that frozen UTF-8 surface. +- Adds `language keiro-dsl 4`, selecting syntax profile 2 and + `keiro-dsl/runtime-semantics/3`. Relative to language 3, aggregate ID + admission, fold fingerprints, and replay classification remain unchanged; + versions 1 through 3 retain their released semantics. +- Designates language 4 as the sole stable authoring contract. `inspect` now + reports language 4 as `stable` and versions 1 through 3 as + `compatibility-only`; every `new ` skeleton starts at language 4. + Historical and unversioned sources remain accepted with their released + semantics and are never silently upgraded. +- Moves the primary conformance baseline to language 4: 226 stable fixtures and + 30 stable-primary compiled suites are enforced against 14 named source + exceptions, two compatibility suites, and one version-independent suite. + `keiro-dsl-conformance-contract` now owns the typed TypeID contract proof; + the former permissive target is explicitly + `keiro-dsl-conformance-contract-v1-compat`, and the redundant + `keiro-dsl-conformance-contract-typeid` target is removed. +- Closes accepted-but-unenforced service surfaces. Values that cannot lower to + working generated code are rejected under every language version; language 4 + additionally enforces numeric floors, duplicate/shadowing rules, stable + runtime identity uniqueness, Kafka and PostgreSQL naming, intake envelope + and schema coupling, contract topic aliases, and the aggregate wire + convention. Emit source/key/discriminant names remain explicitly + descriptive-only. +- Language-4 public contract fields declared as `typeid "inc"` now scaffold as + `KindID "inc"`. Generated encoders keep canonical JSON strings, while + field-path-aware decoders reject malformed text, the wrong prefix, + non-canonical spelling, and non-v7 UUIDs through Keiro's frozen admission + policy. Their manifests add `keiro-core` and `mmzk-typeid`; single-file and + workspace records persist stable per-field ID-domain identities. +- Adds service-aware `scaffoldContractForService`, + `manifestDependenciesForService`, and `renderManifestForService` entry points. + Existing `Spec`-only functions remain legacy/version-1 wrappers, and CLI and + workspace semantic routes use the checked service. +- Diffing an unchanged contract TypeID field from language 3 to language 4 now + emits `ContractTypeIdDomainChanged`: public consumers and consumer builds are + breaking, with producer-first and drain-required rollout. Producers must emit + the frozen TypeID-v7 domain, legacy-invalid in-flight messages must drain or + be remediated, and consumers must then be re-scaffolded, recompiled, and run + through contract conformance. +- Generated contract topic constants are exported. Generated contract, + aggregate, mapped-enum, nominal, and union decoders now report the rejected + value, complete expected set, and Aeson field path without changing accepted + wire bytes. +- Generated files carry the package version, effective language version, and a + stable node origin in their provenance banner. Overwrite, stale, and + workspace-adoption checks accept both this frozen stamped shape and the + historical banner, but reject unrelated marker comments. +- Regenerated committed fixtures pass the repository Fourmolu configuration; + event decode arms render one field per line, contract topics no longer need + private-binding warning suppression, and generated workflow facts expose + typed list structure. + ## 0.8.0.0 — 2026-08-01 ### Breaking Changes diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -17,6 +17,7 @@ import Keiro.Dsl.Diff (Change (..), CompatibilitySurface, diffSources, gateWith, gatedBreaking) import Keiro.Dsl.DiffReport (diffReport, parseSurfaceName, renderExplainBlock, renderFinding) import Keiro.Dsl.ExplainBindings (bindingObligationsForService, renderBindingObligations) +import Keiro.Dsl.FoldFingerprint (renderFoldSurfaceError) import Keiro.Dsl.Goldens (emitGoldenPayloads, loadGoldenPayloads) import Keiro.Dsl.Grammar (Placement (..), Spec (..)) import Keiro.Dsl.LanguageVersion (ParsedSource (..), SourceLanguage, declaredLanguageVersionMaybe, effectiveLanguageVersion, sourceFormText) @@ -319,19 +320,20 @@ newService = checkedSource newSource oldSpec = checkedSpec oldService newSpec = checkedSpec newService - written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) emitGoldensRoot - mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written - let changes = diffSources oldSource newSource - impact = replayImpactServices oldService newService - effectiveGate = gateWith gatedSurfaces - mapM_ (TIO.putStrLn . renderFinding) changes - when explain $ - mapM_ (TIO.putStrLn . renderExplainBlock) (filter shouldExplain changes) - TIO.putStrLn (renderReplayImpact impact) - mapM_ (`Aeson.encodeFile` impact) replayImpactOut - mapM_ (\path -> Aeson.encodeFile path (diffReport effectiveGate changes)) reportOut - coverageOk <- runDiffCoverage fp (T.pack ref) oldSpec newSpec coverageOptions - if any (gatedBreaking effectiveGate) changes || not coverageOk then exitFailure else pure () + case (,) <$> diffSources oldSource newSource <*> replayImpactServices oldService newService of + Left surfaceError -> TIO.hPutStrLn stderr (renderFoldSurfaceError surfaceError) >> exitFailure + Right (changes, impact) -> do + written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) emitGoldensRoot + mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written + let effectiveGate = gateWith gatedSurfaces + mapM_ (TIO.putStrLn . renderFinding) changes + when explain $ + mapM_ (TIO.putStrLn . renderExplainBlock) (filter shouldExplain changes) + TIO.putStrLn (renderReplayImpact impact) + mapM_ (`Aeson.encodeFile` impact) replayImpactOut + mapM_ (\path -> Aeson.encodeFile path (diffReport effectiveGate changes)) reportOut + coverageOk <- runDiffCoverage fp (T.pack ref) oldSpec newSpec coverageOptions + if any (gatedBreaking effectiveGate) changes || not coverageOk then exitFailure else pure () -- | @parse@ on a workspace manifest: read it, parse it, and print it back in -- canonical form (clauses in order, members codepoint-sorted). @@ -589,29 +591,30 @@ oldSpec = checkedSpec oldService newSpec = checkedSpec newService goldenRoot = fmap (workspaceGoldenRoot fp) emitGoldensRoot - written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) goldenRoot - mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written - let workspaceChanges = diffWorkspaces oldWorkspace newWorkspace - changes = map wcChange workspaceChanges - impact = replayImpactServices oldService newService - effectiveGate = gateWith gatedSurfaces - reportMeta = - WorkspaceMeta - { wmIdentity = wsService newWorkspace, - wmManifest = fp, - wmSince = T.pack ref, - wmMembersOld = map wmPath (wsMembers oldWorkspace), - wmMembersNew = map wmPath (wsMembers newWorkspace), - wmAdoptionBaseline = adoptionBaseline - } - mapM_ (TIO.putStrLn . renderWorkspaceFinding) workspaceChanges - when explain $ - mapM_ (TIO.putStrLn . renderExplainBlock) (filter shouldExplain changes) - TIO.putStrLn (renderReplayImpact impact) - mapM_ (`Aeson.encodeFile` impact) replayImpactOut - mapM_ (\path -> Aeson.encodeFile path (workspaceDiffReport reportMeta effectiveGate workspaceChanges)) reportOut - coverageOk <- runDiffCoverage fp (T.pack ref) oldSpec newSpec coverageOptions - if any (gatedBreaking effectiveGate) changes || not coverageOk then exitFailure else pure () + case (,) <$> diffWorkspaces oldWorkspace newWorkspace <*> replayImpactServices oldService newService of + Left surfaceError -> TIO.hPutStrLn stderr (renderFoldSurfaceError surfaceError) >> exitFailure + 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 + effectiveGate = gateWith gatedSurfaces + reportMeta = + WorkspaceMeta + { wmIdentity = wsService newWorkspace, + wmManifest = fp, + wmSince = T.pack ref, + wmMembersOld = map wmPath (wsMembers oldWorkspace), + wmMembersNew = map wmPath (wsMembers newWorkspace), + wmAdoptionBaseline = adoptionBaseline + } + mapM_ (TIO.putStrLn . renderWorkspaceFinding) workspaceChanges + when explain $ + mapM_ (TIO.putStrLn . renderExplainBlock) (filter shouldExplain changes) + TIO.putStrLn (renderReplayImpact impact) + mapM_ (`Aeson.encodeFile` impact) replayImpactOut + mapM_ (\path -> Aeson.encodeFile path (workspaceDiffReport reportMeta effectiveGate workspaceChanges)) reportOut + coverageOk <- runDiffCoverage fp (T.pack ref) oldSpec newSpec coverageOptions + if any (gatedBreaking effectiveGate) changes || not coverageOk then exitFailure else pure () -- | A @git show@ backed source rooted at a workspace manifest directory. gitContentSource :: FilePath -> String -> FilePath -> ContentSource diff --git a/keiro-dsl.cabal b/keiro-dsl.cabal --- a/keiro-dsl.cabal +++ b/keiro-dsl.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: keiro-dsl -version: 0.8.0.0 +version: 0.9.0.0 synopsis: Typed specification toolchain for keiro services description: keiro-dsl is the toolchain over a typed `.keiro` specification of a keiro @@ -26,14 +26,17 @@ DuplicateRecordFields ImportQualifiedPost LambdaCase + OverloadedLabels OverloadedStrings library import: warnings, shared hs-source-dirs: src + autogen-modules: Paths_keiro_dsl exposed-modules: Keiro.Dsl.AggregateType Keiro.Dsl.BehaviorCoverage + Keiro.Dsl.CanonicalEncoding Keiro.Dsl.CodecCompare Keiro.Dsl.Coverage Keiro.Dsl.Diff @@ -85,6 +88,7 @@ Keiro.Dsl.Parser.Queue Keiro.Dsl.Parser.ReadModel Keiro.Dsl.Parser.Workflow + Paths_keiro_dsl build-depends: , aeson >=2.2.1 && <2.3 @@ -93,8 +97,8 @@ , containers >=0.6 && <0.8 , directory >=1.3 && <1.4 , filepath >=1.4 && <1.6 - , keiki >=0.7 && <0.8 - , keiro-core ^>=0.8.0.0 + , keiki >=0.8 && <0.9 + , keiro-core ^>=0.9.0.0 , megaparsec >=9.6 && <9.9 , mmzk-typeid >=0.7 && <0.8 , parser-combinators >=1.3 && <1.4 @@ -117,29 +121,33 @@ , text >=2.1 && <2.2 test-suite keiro-dsl-test - import: warnings, shared - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + autogen-modules: Paths_keiro_dsl other-modules: + Keiro.Dsl.ConformanceBaseline Keiro.Dsl.FrontendCompatibility Keiro.Dsl.FrontendProfiles Keiro.Dsl.FrontendPublicApiProbe Keiro.Dsl.FrontendSurface + 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.7 && <0.8 + , 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.8 && <0.9 , keiro-core , keiro-dsl - , process >=1.6 && <1.7 - , QuickCheck >=2.14 - , text >=2.1 && <2.2 + , mmzk-typeid >=0.7 && <0.8 + , process >=1.6 && <1.7 + , QuickCheck >=2.14 + , text >=2.1 && <2.2 -- Conformance: proves the scaffolded Generated modules plus a hand-filled -- Holes.hs compile against keiki/keiro and that the filled transducer passes @@ -153,20 +161,23 @@ main-is: Main.hs other-modules: Generated.HospitalCapacity.Nominals + Generated.HospitalCapacity.Nominals.Internal Generated.HospitalCapacity.ReplayAudit Generated.HospitalCapacity.Reservation.Codec Generated.HospitalCapacity.Reservation.Domain Generated.HospitalCapacity.Reservation.EventStream Generated.HospitalCapacity.Reservation.Harness Generated.HospitalCapacity.Reservation.Projection + Generated.HospitalCapacity.Reservation.Transducer HospitalCapacity.Reservation.Holes build-depends: - , aeson >=2.2 && <2.3 - , base >=4.21 && <5 - , keiki >=0.7 && <0.8 + , aeson >=2.2 && <2.3 + , base >=4.21 && <5 + , bytestring >=0.12 && <0.13 + , keiki >=0.8 && <0.9 , keiro - , text >=2.1 && <2.2 + , text >=2.1 && <2.2 -- Plan 157: compiled direct Time/Natural aggregate fields and registers, -- symbolic equality/ordering, codecs, snapshots, forward/replay equality, @@ -184,11 +195,12 @@ Generated.AggregateScalars.ScalarLedger.EventStream Generated.AggregateScalars.ScalarLedger.Harness Generated.AggregateScalars.ScalarLedger.Projection + Generated.AggregateScalars.ScalarLedger.Transducer build-depends: , aeson >=2.2 && <2.3 , base >=4.21 && <5 - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , text >=2.1 && <2.2 , time >=1.12 && <1.15 @@ -205,12 +217,12 @@ AggregateScalarExpressions.ScalarAccount.BehaviorHoles AggregateScalarExpressions.ScalarAccount.Holes Generated.AggregateScalarExpressions.Nominals + Generated.AggregateScalarExpressions.Nominals.Internal Generated.AggregateScalarExpressions.ReplayAudit Generated.AggregateScalarExpressions.ScalarAccount.BehaviorContract Generated.AggregateScalarExpressions.ScalarAccount.Codec Generated.AggregateScalarExpressions.ScalarAccount.Domain Generated.AggregateScalarExpressions.ScalarAccount.EventStream - Generated.AggregateScalarExpressions.ScalarAccount.Expressions Generated.AggregateScalarExpressions.ScalarAccount.Harness Generated.AggregateScalarExpressions.ScalarAccount.Projection Generated.AggregateScalarExpressions.ScalarAccount.Transducer @@ -223,7 +235,7 @@ , aeson >=2.2 && <2.3 , base >=4.21 && <5 , containers >=0.6 && <0.8 - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , keiro-dsl , text >=2.1 && <2.2 @@ -243,10 +255,11 @@ Generated.BehaviorComplete.Journey.Codec Generated.BehaviorComplete.Journey.Domain Generated.BehaviorComplete.Journey.EventStream - Generated.BehaviorComplete.Journey.Expressions 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.StructuralProjections @@ -256,7 +269,7 @@ , base >=4.21 && <5 , bytestring >=0.12 && <0.13 , containers >=0.6 && <0.8 - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , text >=2.1 && <2.2 , time >=1.12 && <1.15 @@ -274,7 +287,6 @@ Generated.NominalScalars.NominalLedger.Codec Generated.NominalScalars.NominalLedger.Domain Generated.NominalScalars.NominalLedger.EventStream - Generated.NominalScalars.NominalLedger.Expressions Generated.NominalScalars.NominalLedger.Harness Generated.NominalScalars.NominalLedger.Projection Generated.NominalScalars.NominalLedger.Transducer @@ -288,7 +300,7 @@ , aeson >=2.2 && <2.3 , base >=4.21 && <5 , containers >=0.6 && <0.8 - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , mmzk-typeid >=0.7 && <0.8 , text >=2.1 && <2.2 @@ -305,11 +317,11 @@ main-is: Main.hs other-modules: Generated.WorkspaceNominalProof.Nominals + Generated.WorkspaceNominalProof.Nominals.Internal Generated.WorkspaceNominalProof.Project.BehaviorContract Generated.WorkspaceNominalProof.Project.Codec Generated.WorkspaceNominalProof.Project.Domain Generated.WorkspaceNominalProof.Project.EventStream - Generated.WorkspaceNominalProof.Project.Expressions Generated.WorkspaceNominalProof.Project.Harness Generated.WorkspaceNominalProof.Project.Projection Generated.WorkspaceNominalProof.Project.Transducer @@ -317,7 +329,6 @@ Generated.WorkspaceNominalProof.ProjectArtifact.Codec Generated.WorkspaceNominalProof.ProjectArtifact.Domain Generated.WorkspaceNominalProof.ProjectArtifact.EventStream - Generated.WorkspaceNominalProof.ProjectArtifact.Expressions Generated.WorkspaceNominalProof.ProjectArtifact.Harness Generated.WorkspaceNominalProof.ProjectArtifact.Projection Generated.WorkspaceNominalProof.ProjectArtifact.Transducer @@ -329,7 +340,7 @@ , aeson >=2.2 && <2.3 , base >=4.21 && <5 , containers >=0.6 && <0.8 - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , text >=2.1 && <2.2 @@ -349,6 +360,7 @@ Generated.StructuralConformance.ArtifactCatalog.EventStream Generated.StructuralConformance.ArtifactCatalog.Harness Generated.StructuralConformance.ArtifactCatalog.Projection + Generated.StructuralConformance.ArtifactCatalog.Transducer Generated.StructuralConformance.ReplayAudit Generated.StructuralConformance.Structural.Shape.ArtifactInfo Generated.StructuralConformance.Structural.Shape.ArtifactKind @@ -363,7 +375,7 @@ , bytestring >=0.12 && <0.13 , containers >=0.6 && <0.8 , deepseq >=1.5 && <1.6 - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , text >=2.1 && <2.2 , time >=1.12 && <1.15 @@ -397,7 +409,7 @@ , deepseq >=1.5 && <1.6 , directory >=1.3 && <1.4 , filepath >=1.4 && <1.6 - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , keiro-dsl , text >=2.1 && <2.2 @@ -417,13 +429,14 @@ Generated.ReplayDivergence.Note.EventStream Generated.ReplayDivergence.Note.Harness Generated.ReplayDivergence.Note.Projection + Generated.ReplayDivergence.Note.Transducer Generated.ReplayDivergence.ReplayAudit ReplayDivergence.Note.Holes build-depends: , aeson >=2.2 && <2.3 , base >=4.21 && <5 - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , text >=2.1 && <2.2 @@ -447,7 +460,7 @@ , base >=4.21 && <5 , containers >=0.6 && <0.8 , deepseq >=1.5 && <1.6 - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , tasty-bench >=0.5 && <0.6 , text >=2.1 && <2.2 @@ -462,16 +475,19 @@ hs-source-dirs: test/conformance-snapshot main-is: Main.hs other-modules: + Generated.HospitalCapacity.Nominals + Generated.HospitalCapacity.Nominals.Internal Generated.HospitalCapacity.ReplayAudit Generated.HospitalCapacity.Reservation.Codec Generated.HospitalCapacity.Reservation.Domain Generated.HospitalCapacity.Reservation.EventStream + Generated.HospitalCapacity.Reservation.Transducer HospitalCapacity.Reservation.Holes build-depends: , aeson >=2.2 && <2.3 , base >=4.21 && <5 - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , text >=2.1 && <2.2 @@ -485,12 +501,16 @@ main-is: Main.hs other-modules: SkelAggregate.Generated.MyService.Nominals + SkelAggregate.Generated.MyService.Nominals.Internal SkelAggregate.Generated.MyService.ReplayAudit + SkelAggregate.Generated.MyService.Thing.BehaviorContract SkelAggregate.Generated.MyService.Thing.Codec SkelAggregate.Generated.MyService.Thing.Domain SkelAggregate.Generated.MyService.Thing.EventStream SkelAggregate.Generated.MyService.Thing.Harness SkelAggregate.Generated.MyService.Thing.Projection + SkelAggregate.Generated.MyService.Thing.Transducer + SkelAggregate.MyService.Thing.BehaviorHoles SkelAggregate.MyService.Thing.Holes SkelContract.Generated.MyService.MyContract.Contract SkelEmit.Generated.MyService.MyContract.Contract @@ -502,15 +522,18 @@ SkelProcess.Generated.MyService.Hospital.EventStream SkelProcess.Generated.MyService.Hospital.Harness SkelProcess.Generated.MyService.Hospital.Projection + SkelProcess.Generated.MyService.Hospital.Transducer SkelProcess.Generated.MyService.HospitalSurge.Process SkelProcess.Generated.MyService.HospitalSurge.ProcessHarness SkelProcess.Generated.MyService.Nominals + SkelProcess.Generated.MyService.Nominals.Internal SkelProcess.Generated.MyService.ReplayAudit SkelProcess.Generated.MyService.Surge.Codec SkelProcess.Generated.MyService.Surge.Domain SkelProcess.Generated.MyService.Surge.EventStream SkelProcess.Generated.MyService.Surge.Harness SkelProcess.Generated.MyService.Surge.Projection + SkelProcess.Generated.MyService.Surge.Transducer SkelProcess.MyService.Hospital.Holes SkelProcess.MyService.HospitalSurge.ProcessHoles SkelProcess.MyService.Surge.Holes @@ -530,6 +553,7 @@ SkelRouter.Generated.MyService.Page.EventStream SkelRouter.Generated.MyService.Page.Harness SkelRouter.Generated.MyService.Page.Projection + SkelRouter.Generated.MyService.Page.Transducer SkelRouter.Generated.MyService.PagingRouter.Router SkelRouter.Generated.MyService.PagingRouter.RouterHarness SkelRouter.Generated.MyService.ReplayAudit @@ -544,11 +568,12 @@ , containers , effectful-core , hasql-transaction - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , keiro-core , keiro-pgmq , kiroku-store + , mmzk-typeid >=0.7 && <0.8 , shibuya-core , text >=2.1 && <2.2 , time @@ -564,22 +589,26 @@ main-is: Main.hs other-modules: Billing.Subscription.Holes + Generated.Billing.Nominals + Generated.Billing.Nominals.Internal Generated.Billing.ReplayAudit 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 >=2.2 && <2.3 , base >=4.21 && <5 - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , text >=2.1 && <2.2 --- Contract codec conformance (EP-4): the scaffolded self-contained contract --- payload ADT + codec, compiled + round-tripped per event type. +-- Stable language-4 contract conformance: prefix-indexed KindID fields, +-- canonical text JSON, field-path-aware rejection, and the complete generated +-- dependency set. test-suite keiro-dsl-conformance-contract import: warnings, shared type: exitcode-stdio-1.0 @@ -587,10 +616,26 @@ main-is: Main.hs other-modules: Generated.HospitalCapacity.Emergency.Contract build-depends: - , aeson >=2.2 && <2.3 - , base >=4.21 && <5 - , text >=2.1 && <2.2 + , aeson >=2.2 && <2.3 + , base >=4.21 && <5 + , keiro-core + , mmzk-typeid >=0.7 && <0.8 + , text >=2.1 && <2.2 +-- Language-1 compatibility proof: the historical permissive Text contract DTO +-- still accepts pre-TypeID-v7 samples and retains its released JSON image. +test-suite keiro-dsl-conformance-contract-v1-compat + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-contract-v1-compat + main-is: Main.hs + other-modules: Generated.HospitalCapacity.Emergency.Contract + build-depends: + , aeson >=2.2 && <2.3 + , base >=4.21 && <5 + , bytestring >=0.12 && <0.13 + , text >=2.1 && <2.2 + -- EP-4 intake runtime conformance: the scaffolded Inbox disposition + dedupe -- policy compiled against the LIVE Keiro.Inbox.Types (InboxResult / dedupe). test-suite keiro-dsl-conformance-intake-runtime @@ -602,6 +647,7 @@ build-depends: , base >=4.21 && <5 , keiro + , text >=2.1 && <2.2 -- EP-4 M5 full-service conformance: a complete integration service — scaffolded -- inbox dedupe + a filled inbox transaction runner and outbox IntegrationProducer @@ -621,6 +667,7 @@ , hasql-transaction , keiro , kiroku-store >=0.3 && <0.4 + , text >=2.1 && <2.2 -- EP-4 publisher runtime conformance: the scaffolded Publisher config compiled -- against the LIVE Keiro.Outbox.Types (OrderingPolicy / BackoffSchedule). @@ -667,6 +714,7 @@ build-depends: , aeson >=2.2 && <2.3 , base >=4.21 && <5 + , bytestring >=0.12 && <0.13 , keiro-core , keiro-dsl , keiro-pgmq @@ -760,11 +808,15 @@ Generated.SurgeDemo.Hospital.Domain Generated.SurgeDemo.Hospital.EventStream Generated.SurgeDemo.Hospital.Projection + Generated.SurgeDemo.Hospital.Transducer + Generated.SurgeDemo.Nominals + Generated.SurgeDemo.Nominals.Internal Generated.SurgeDemo.ReplayAudit Generated.SurgeDemo.Surge.Codec Generated.SurgeDemo.Surge.Domain Generated.SurgeDemo.Surge.EventStream Generated.SurgeDemo.Surge.Projection + Generated.SurgeDemo.Surge.Transducer Generated.SurgeDemo.SurgeFlow.Process SurgeDemo.Hospital.Holes SurgeDemo.Surge.Holes @@ -773,7 +825,7 @@ build-depends: , aeson >=2.2 && <2.3 , base >=4.21 && <5 - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , shibuya-core , text >=2.1 && <2.2 @@ -808,10 +860,20 @@ type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-process-runtime main-is: Main.hs - other-modules: Generated.HospitalCapacity.HospitalSurge.Process + other-modules: + Generated.HospitalCapacity.HospitalSurge.Process + Generated.HospitalCapacity.Nominals + Generated.HospitalCapacity.Nominals.Internal + Generated.HospitalCapacity.Surge.Codec + Generated.HospitalCapacity.Surge.Domain + Generated.HospitalCapacity.Surge.EventStream + Generated.HospitalCapacity.Surge.Transducer + HospitalCapacity.Surge.Holes + build-depends: , aeson >=2.2 && <2.3 , base >=4.21 && <5 + , keiki >=0.8 && <0.9 , keiro , keiro-dsl , shibuya-core @@ -858,6 +920,7 @@ Generated.IncidentPaging.Page.Codec Generated.IncidentPaging.Page.Domain Generated.IncidentPaging.Page.EventStream + Generated.IncidentPaging.Page.Transducer Generated.IncidentPaging.PagingRouter.Router Generated.IncidentPaging.PagingRouter.RouterHarness Generated.IncidentPaging.ReplayAudit @@ -868,7 +931,7 @@ , aeson >=2.2 && <2.3 , base >=4.21 && <5 , effectful-core - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , shibuya-core , text >=2.1 && <2.2 @@ -888,6 +951,7 @@ Generated.TransferRouting.Hospital.EventStream Generated.TransferRouting.Hospital.Harness Generated.TransferRouting.Hospital.Projection + Generated.TransferRouting.Hospital.Transducer Generated.TransferRouting.Hospital_load.ReadModel Generated.TransferRouting.Hospital_load.ReadModelHarness Generated.TransferRouting.Hospital_load.ReadModelTable @@ -904,7 +968,7 @@ , base >=4.21 && <5 , effectful-core , hasql-transaction - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , kiroku-store , shibuya-core @@ -936,19 +1000,22 @@ hs-source-dirs: test/conformance-v2 main-is: Main.hs other-modules: + Generated.HospitalCapacity.Nominals + Generated.HospitalCapacity.Nominals.Internal Generated.HospitalCapacity.ReplayAudit Generated.HospitalCapacity.Reservation.Codec Generated.HospitalCapacity.Reservation.Domain Generated.HospitalCapacity.Reservation.EventStream Generated.HospitalCapacity.Reservation.Harness Generated.HospitalCapacity.Reservation.Projection + Generated.HospitalCapacity.Reservation.Transducer HospitalCapacity.Reservation.Holes build-depends: , aeson >=2.2 && <2.3 , base >=4.21 && <5 , directory >=1.3 && <1.4 - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro , text >=2.1 && <2.2 @@ -969,6 +1036,6 @@ build-depends: , aeson >=2.2 && <2.3 , base >=4.21 && <5 - , keiki >=0.7 && <0.8 + , keiki >=0.8 && <0.9 , keiro-core , text >=2.1 && <2.2 diff --git a/src/Keiro/Dsl/AggregateType.hs b/src/Keiro/Dsl/AggregateType.hs --- a/src/Keiro/Dsl/AggregateType.hs +++ b/src/Keiro/Dsl/AggregateType.hs @@ -154,9 +154,8 @@ AggregateMapped {} -> Unsupported AggregateNominal nominal -> case resolvedNominalRepresentation nominal of ScalarRepresentation {} -> SolverVisible - _ -> case nominalEqualityContract nominal of - Just _ -> SolverVisible - Nothing -> OpaqueOnly + IdRepresentation {} -> SolverVisible + EnumRepresentation {} -> SolverVisible _ -> solverVisibility resolved OrderingGuardUse -> case resolved of AggregateInt -> SolverVisible diff --git a/src/Keiro/Dsl/CanonicalEncoding.hs b/src/Keiro/Dsl/CanonicalEncoding.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/CanonicalEncoding.hs @@ -0,0 +1,168 @@ +-- | Frozen canonical encoding for persisted aggregate-fold identity. +-- +-- The bytes produced here feed snapshot compatibility decisions. They may +-- change only as part of an explicit, ADR-recorded identity migration with +-- updated golden fixtures. Keep this implementation independent from the +-- presentation-oriented pretty printer so readability changes cannot move +-- persisted identity accidentally. +module Keiro.Dsl.CanonicalEncoding + ( canonicalExpr, + canonicalTransition, + foldFingerprint128, + ) +where + +import Data.Bits (shiftR, xor, (.&.), (.|.)) +import Data.Text (Text) +import Data.Text qualified as T +import Keiro.Dsl.Grammar +import Numeric (showHex) +import Prettyprinter +import Prettyprinter.Render.Text (renderStrict) + +-- | Canonical concrete encoding of one expression. +canonicalExpr :: Expr -> Text +canonicalExpr = + renderStrict + . layoutPretty LayoutOptions {layoutPageWidth = Unbounded} + . docExpr 0 + +-- | Canonical concrete encoding of one transition. +canonicalTransition :: Transition -> Text +canonicalTransition = + renderStrict + . layoutPretty LayoutOptions {layoutPageWidth = Unbounded} + . docTransition + +-- | A fixed-width FNV-1a-128 digest over the frozen fold surface's UTF-8 +-- bytes. The constants and octet fold are the standard values from RFC 9923; +-- multiplication is reduced modulo 2^128 explicitly so the result does not +-- depend on a machine integer width. +foldFingerprint128 :: Text -> Text +foldFingerprint128 input = + T.justifyRight 32 '0' (T.pack (showHex digest "")) + where + digest = foldl' step fnvOffsetBasis128 (concatMap utf8Bytes (T.unpack input)) + step hash octet = ((hash `xor` octet) * fnvPrime128) `mod` fnvModulus128 + +fnvOffsetBasis128 :: Integer +fnvOffsetBasis128 = 0x6c62272e07bb014262b821756295c58d + +fnvPrime128 :: Integer +fnvPrime128 = 0x0000000001000000000000000000013b + +fnvModulus128 :: Integer +fnvModulus128 = 2 ^ (128 :: Int) + +-- | Encode one Unicode scalar value as UTF-8 octets without coupling the +-- persisted identity implementation to a text or bytestring encoder version. +utf8Bytes :: Char -> [Integer] +utf8Bytes character + | codePoint <= 0x7f = [byte codePoint] + | codePoint <= 0x7ff = + [ byte (0xc0 .|. (codePoint `shiftR` 6)), + continuation codePoint + ] + | codePoint <= 0xffff = + [ byte (0xe0 .|. (codePoint `shiftR` 12)), + continuation (codePoint `shiftR` 6), + continuation codePoint + ] + | otherwise = + [ byte (0xf0 .|. (codePoint `shiftR` 18)), + continuation (codePoint `shiftR` 12), + continuation (codePoint `shiftR` 6), + continuation codePoint + ] + where + codePoint = fromEnum character + byte = toInteger + continuation value = byte (0x80 .|. (value .&. 0x3f)) + +docTransition :: Transition -> Doc ann +docTransition transition = + vsep $ + [modePrefix <> pretty (tSource transition) <+> "--" <+> pretty (tCommand transition) <+> "-->"] + ++ map (indent 2) clauses + where + modePrefix = case tMode 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)] + +-- | @showsPrec@-style frozen expression encoding. Precedence levels are +-- @||@ = 1, @&&@ = 2, comparisons = 3, addition/subtraction = 4, +-- multiplication = 5, and atoms = 6. +docExpr :: Int -> Expr -> Doc ann +docExpr context expression = parensIf (precedence expression < context) (body expression) + where + body (EOr left right) = docExpr 1 left <+> "||" <+> docExpr 2 right + body (EAnd left right) = docExpr 2 left <+> "&&" <+> docExpr 3 right + body (ECmp operator left right) = docExpr 4 left <+> docCmp operator <+> docExpr 4 right + body (EAdd _ left right) = docExpr 4 left <+> "+" <+> docExpr 5 right + body (ESubtract _ left right) = docExpr 4 left <+> "-" <+> docExpr 5 right + body (EMultiply _ left right) = docExpr 5 left <+> "*" <+> docExpr 6 right + body (EPath _ root path) = docPath root path + body (ELiteral _ literal) = docLiteral literal + body (EAtom atom) = docAtom atom + +precedence :: Expr -> Int +precedence EOr {} = 1 +precedence EAnd {} = 2 +precedence ECmp {} = 3 +precedence EAdd {} = 4 +precedence ESubtract {} = 4 +precedence EMultiply {} = 5 +precedence EPath {} = 6 +precedence ELiteral {} = 6 +precedence EAtom {} = 6 + +docPath :: ExprRoot -> [Name] -> Doc ann +docPath UnqualifiedRoot [] = mempty +docPath UnqualifiedRoot (first : rest) = pretty first <> hcat (map (("." <>) . pretty) rest) +docPath root path = docRoot root <> hcat (map (("." <>) . pretty) path) + +docRoot :: ExprRoot -> Doc ann +docRoot UnqualifiedRoot = mempty +docRoot RegisterRoot = "reg" +docRoot CommandRoot = "cmd" + +docLiteral :: ScalarLiteral -> Doc ann +docLiteral (LiteralText value) = dquoted value +docLiteral (LiteralIntegral value) = pretty value +docLiteral (LiteralBool True) = "true" +docLiteral (LiteralBool False) = "false" +docLiteral (LiteralQualified typeName constructorName) = pretty typeName <> "." <> pretty constructorName +docLiteral (LiteralId typeName value) = pretty typeName <> "(" <> dquoted value <> ")" + +dquoted :: Text -> Doc ann +dquoted value = "\"" <> pretty (T.concatMap escapeCharacter value) <> "\"" + where + escapeCharacter '"' = "\\\"" + escapeCharacter '\\' = "\\\\" + escapeCharacter '\n' = "\\n" + escapeCharacter '\t' = "\\t" + escapeCharacter '\r' = "\\r" + escapeCharacter character = T.singleton character + +docCmp :: CmpOp -> Doc ann +docCmp OpEq = "==" +docCmp OpNeq = "!=" +docCmp OpLt = "<" +docCmp OpLe = "<=" +docCmp OpGt = ">" +docCmp OpGe = ">=" + +docAtom :: Atom -> Doc ann +docAtom (AName name) = pretty name +docAtom (ABool True) = "true" +docAtom (ABool False) = "false" + +parensIf :: Bool -> Doc ann -> Doc ann +parensIf True document = "(" <> document <> ")" +parensIf False document = document diff --git a/src/Keiro/Dsl/Diff.hs b/src/Keiro/Dsl/Diff.hs --- a/src/Keiro/Dsl/Diff.hs +++ b/src/Keiro/Dsl/Diff.hs @@ -1,4 +1,4 @@ --- | The spec evolution differ. 'diffSpecs' compares an /old/ and a /new/ 'Spec' +-- | The service evolution differ compares an /old/ and a /new/ checked graph -- and classifies changes over the persisted decode and identity surfaces. -- -- Changes are __ADDITIVE__ when they preserve stored data, __WARNING__ when they @@ -41,7 +41,6 @@ diffSources, sourceLanguageChange, diffServices, - diffSpecs, DiffEnv (..), NodeFamily (..), familyOf, @@ -55,6 +54,7 @@ where import Data.Char (toUpper) +import Data.Foldable (traverse_) import Data.List (find, (\\)) import Data.Maybe (isJust, isNothing, mapMaybe) import Data.Set (Set) @@ -62,9 +62,9 @@ import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.AggregateType (typeExprCanonicalName) -import Keiro.Dsl.FoldFingerprint (aggregateFoldSurface, aggregateFoldSurfaceForService) +import Keiro.Dsl.FoldFingerprint (FoldSurfaceError, aggregateFoldSurfaceForService) import Keiro.Dsl.Grammar -import Keiro.Dsl.IdDomain (IdDomainContract (..), idDomainContractFor) +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 @@ -75,7 +75,7 @@ renderTransition, ) import Keiro.Dsl.ReadModelShape (registryNameFor, subscriptionNameFor) -import Keiro.Dsl.SemanticContract (CheckedService (..), checkedSource, effectiveLanguageContract, effectiveRuntimeSemantics, legacyCheckedService) +import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, checkedSource, effectiveLanguageContract, effectiveRuntimeSemantics, legacyCheckedService) import Keiro.Dsl.TypeGraph (UsePath (..), UseSite (..)) import Keiro.Dsl.Validate (DiagnosticCode (..)) @@ -110,6 +110,7 @@ | RolloutWorkersFirst | RolloutDrainRequired | RolloutProducerLast + | RolloutProducerFirst deriving stock (Eq, Ord, Show) -- | The explicit, compile-forcing compatibility result for one finding. @@ -279,6 +280,7 @@ | 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 @@ -377,6 +379,18 @@ 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, @@ -633,13 +647,15 @@ (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. Current --- released contracts share runtime semantics, so the selected policy delegates --- to the graph differ; successor semantics extend this boundary rather than --- teaching CLI callers to recover versions from provenance. -diffServices :: CheckedService -> CheckedService -> [Change] -diffServices oldService newService = - diffCheckedSpecs oldSpec newSpec <> idDomainContractChanges <> semanticContractFoldChanges +-- | 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 @@ -663,30 +679,78 @@ let newContract = idDomainContractFor (checkedLanguageContract newService) (idPrefix newDeclaration), oldContract /= newContract ] - semanticContractFoldChanges = - [ 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" - | (name, oldAggregate) <- oldAggregates, - Just newAggregate <- [lookup name newAggregates], - aggregateFoldSurface oldSpec oldAggregate == aggregateFoldSurface newSpec newAggregate, - aggregateFoldSurfaceForService oldService oldAggregate /= aggregateFoldSurfaceForService newService newAggregate + 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 <> ")" --- | Compatibility wrapper for graph-only callers, explicitly using --- legacy/version-1 semantics on both sides. -diffSpecs :: Spec -> Spec -> [Change] -diffSpecs old new = - diffServices (legacyCheckedService old) (legacyCheckedService new) +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 @@ -694,15 +758,18 @@ where env = DiffEnv old new --- | Compare provenance first, then delegate semantic graphs to 'diffSpecs'. -diffSources :: ParsedSource -> ParsedSource -> [Change] -diffSources old new = - sourceLanguageChange - (specContext (parsedSpec new)) - "declaration" - (parsedSourceLanguage old) - (parsedSourceLanguage new) - <> diffServices (checkedSource old) (checkedSource 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] @@ -1017,7 +1084,7 @@ -- fingerprint and invalidates old snapshots, so this remains advisory. transitionSurfaceDiff :: Spec -> Spec -> Aggregate -> Aggregate -> [Change] transitionSurfaceDiff oldSpec newSpec oldAgg newAgg - | aggregateFoldSurface oldSpec oldAgg == aggregateFoldSurface newSpec newAgg = [] + | aggregateFoldSurfaceForService (legacyCheckedService oldSpec) oldAgg == aggregateFoldSurfaceForService (legacyCheckedService newSpec) newAgg = [] | otherwise = [ advisory (aggName newAgg) @@ -2197,6 +2264,7 @@ publicCodes = [ ContractEventRemoved, ContractFieldChanged, + ContractTypeIdDomainChanged, ContractDiscriminatorChanged, ContractTopicChanged, ContractSchemaVersionDecreased, diff --git a/src/Keiro/Dsl/DiffReport.hs b/src/Keiro/Dsl/DiffReport.hs --- a/src/Keiro/Dsl/DiffReport.hs +++ b/src/Keiro/Dsl/DiffReport.hs @@ -50,6 +50,10 @@ | RemedyRunConformance | RemedyNoSemanticAction | RemedyDoNotDeploy Text + | RemedyEmitContractTypeIdDomain + | RemedyDrainLegacyInvalidContractMessages + | RemedyRescaffoldContractConsumers + | RemedyRunContractConformance deriving stock (Eq, Show) data DiffReport = DiffReport @@ -184,6 +188,12 @@ | code == AggFoldSurfaceChanged = RemedyStateCodecBump :| [RemedyRunConformance] | code == IdDomainContractChanged = RemedyDeploymentOrder RolloutProducerLast :| [RemedyStateCodecBump, RemedyRecompileConsumers, RemedyRunConformance] + | code == ContractTypeIdDomainChanged = + RemedyEmitContractTypeIdDomain + :| [ RemedyDrainLegacyInvalidContractMessages, + RemedyRescaffoldContractConsumers, + RemedyRunContractConformance + ] | code `elem` mappedWireCodes = mappedWireRemedy | code `elem` [MappedFieldAddedWithDefault, MappedArmAdded, MappedEnumValueAdded] = mappedAdditionRemedy | code `elem` [MappedHaskellSourceChanged, MappedRecordConstructorChanged] = @@ -304,6 +314,10 @@ RemedyRunConformance -> "run the generated conformance and historical fixture suites" RemedyNoSemanticAction -> "no semantic action is required; only source-language provenance changed" RemedyDoNotDeploy detail -> detail + RemedyEmitContractTypeIdDomain -> "make all producers emit the frozen TypeID-v7 domain" + RemedyDrainLegacyInvalidContractMessages -> "drain or remediate legacy-invalid in-flight messages" + RemedyRescaffoldContractConsumers -> "re-scaffold and recompile every affected consumer against the generated interface" + RemedyRunContractConformance -> "run contract conformance" renderFinding :: Change -> Text renderFinding change = @@ -389,6 +403,7 @@ RolloutWorkersFirst -> "workers-first" RolloutDrainRequired -> "drain-required" RolloutProducerLast -> "producer-last" + RolloutProducerFirst -> "producer-first" labelName :: Label -> Text labelName label = case label of diff --git a/src/Keiro/Dsl/FoldFingerprint.hs b/src/Keiro/Dsl/FoldFingerprint.hs --- a/src/Keiro/Dsl/FoldFingerprint.hs +++ b/src/Keiro/Dsl/FoldFingerprint.hs @@ -3,10 +3,10 @@ -- projections, snapshot policy, and source locations: those inputs do not change -- how an existing event log becomes aggregate state. module Keiro.Dsl.FoldFingerprint - ( aggregateFoldFingerprintForService, + ( FoldSurfaceError (..), + renderFoldSurfaceError, + aggregateFoldFingerprintForService, aggregateFoldSurfaceForService, - aggregateFoldFingerprint, - aggregateFoldSurface, ) where @@ -18,48 +18,74 @@ import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.AggregateType +import Keiro.Dsl.CanonicalEncoding (canonicalExpr, foldFingerprint128) import Keiro.Dsl.EventOutput import Keiro.Dsl.Expression import Keiro.Dsl.Grammar +import Keiro.Dsl.LanguageVersion (RuntimeCapability (NominalEqualityV2), runtimeProfileHasCapability) import Keiro.Dsl.NominalType -import Keiro.Dsl.PrettyPrint (renderExpr) -import Keiro.Dsl.ReadModelShape (fnv1a64) -import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, legacyCheckedService, runtimeSemanticsFingerprintSegment) +import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveRuntimeProfile, runtimeSemanticsFingerprintSegments) import Keiro.Dsl.TypeGraph --- | The sixteen-hex-digit identity of an aggregate's replay fold under the --- service's effective runtime semantics. -aggregateFoldFingerprintForService :: CheckedService -> Aggregate -> Text -aggregateFoldFingerprintForService service = fnv1a64 . aggregateFoldSurfaceForService service +-- | A checked service can retain language provenance before semantic +-- validation succeeds. Fold identity therefore reports every resolution +-- failure instead of silently omitting or inventing canonical segments. +data FoldSurfaceError + = FoldTypeGraphResolutionFailed !Text + | FoldNominalResolutionFailed !Text + | FoldRegisterTypeResolutionFailed !Name !Text + | FoldRegisterInitialResolutionFailed !Name !Text + | FoldGuardResolutionFailed !Name !Name !Text + | FoldEventOutputResolutionFailed !Name !Name !Name !Text + deriving stock (Eq, Show) --- | The sixteen-hex-digit identity of an aggregate's replay fold. --- This compatibility wrapper selects legacy/version-1 runtime semantics. -aggregateFoldFingerprint :: Spec -> Aggregate -> Text -aggregateFoldFingerprint spec = aggregateFoldFingerprintForService (legacyCheckedService spec) +renderFoldSurfaceError :: FoldSurfaceError -> Text +renderFoldSurfaceError = \case + FoldTypeGraphResolutionFailed detail -> "aggregate fold type-graph resolution failed: " <> detail + FoldNominalResolutionFailed detail -> "aggregate fold nominal resolution failed: " <> detail + FoldRegisterTypeResolutionFailed registerName detail -> + "aggregate fold register '" <> registerName <> "' type resolution failed: " <> detail + FoldRegisterInitialResolutionFailed registerName detail -> + "aggregate fold register '" <> registerName <> "' initial resolution failed: " <> detail + FoldGuardResolutionFailed aggregateName commandName detail -> + "aggregate fold guard resolution failed for '" <> aggregateName <> "." <> commandName <> "': " <> detail + FoldEventOutputResolutionFailed aggregateName commandName eventName detail -> + "aggregate fold output resolution failed for '" + <> aggregateName + <> "." + <> commandName + <> "' emitting '" + <> eventName + <> "': " + <> detail --- | Canonical pre-hash text for an aggregate's replay fold. --- --- Rules are declarations on 'Spec', not children of 'Aggregate', so the complete --- spec is required. Only rules reached from transition guards and writes are --- included, transitively, in declaration order. -aggregateFoldSurface :: Spec -> Aggregate -> Text -aggregateFoldSurface spec = aggregateFoldSurfaceForService (legacyCheckedService spec) +-- | The thirty-two-hex-digit identity of an aggregate's replay fold under the +-- service's effective runtime semantics. +aggregateFoldFingerprintForService :: CheckedService -> Aggregate -> Either FoldSurfaceError Text +aggregateFoldFingerprintForService service = fmap foldFingerprint128 . aggregateFoldSurfaceForService service -- | Canonical pre-hash text under a checked semantic contract. A runtime -- discriminator is included only for a contract that can change fold behavior; -- source declaration provenance and grammar-only versions never enter it. -aggregateFoldSurfaceForService :: CheckedService -> Aggregate -> Text -aggregateFoldSurfaceForService service aggregate = - T.intercalate - "\n" - ( maybe [] pure (runtimeSemanticsFingerprintSegment (checkedLanguageContract service)) - ++ map stateSegment (aggStates aggregate) - ++ map (registerSegment symbols) (aggRegs aggregate) - ++ mappedRegisterSegments - ++ nominalSegments - ++ nominalEqualitySegments - ++ map (transitionSegment spec aggregate) (aggTransitions aggregate) - ++ map ruleSegment referencedRules +aggregateFoldSurfaceForService :: CheckedService -> Aggregate -> Either FoldSurfaceError Text +aggregateFoldSurfaceForService service aggregate = do + graph <- mapLeft (FoldTypeGraphResolutionFailed . showText) (resolveTypeGraph spec) + nominalRegistry <- mapLeft (FoldNominalResolutionFailed . showText) (resolveNominalTypes spec) + registerSegments <- traverse (registerSegment symbols) (aggRegs aggregate) + equalityUses <- nominalEqualityUses service aggregate + transitionSegments <- traverse (transitionSegment spec aggregate) (aggTransitions aggregate) + pure + ( T.intercalate + "\n" + ( runtimeSemanticsFingerprintSegments (checkedLanguageContract service) + ++ map stateSegment (aggStates aggregate) + ++ registerSegments + ++ mappedRegisterSegments graph + ++ nominalSegments nominalRegistry + ++ ["nominal-equality-use:" <> identity | identity <- Set.toAscList equalityUses] + ++ transitionSegments + ++ map ruleSegment referencedRules + ) ) where spec = checkedSpec service @@ -69,42 +95,47 @@ | rule <- specRules spec, ruleName rule `Set.member` referencedRuleNames spec aggregate ] - mappedRegisterSegments = case resolveTypeGraph spec of - Left _ -> [] - Right graph -> - [ mappedRegisterSegment graph declaration - | register <- aggRegs aggregate, - TRef typeName <- [regType register], - Just declaration <- [Map.lookup (MappedKey typeName) (tgDeclarations graph)] - ] - nominalSegments = case resolveNominalTypes spec of - Left _ -> [] - Right registry -> - [ nominalUseSegment useSite nominal binding - | (useSite, typeName) <- nominalUseNames aggregate, - Just nominal <- [lookupNominalType typeName registry], - ConsumerNominal binding <- [resolvedNominalOwnership nominal] - ] - nominalEqualitySegments = - [ "nominal-equality-use:" <> identity - | identity <- Set.toAscList (nominalEqualityUses service aggregate) + mappedRegisterSegments graph = + [ mappedRegisterSegment graph declaration + | register <- aggRegs aggregate, + TRef typeName <- [regType register], + Just declaration <- [Map.lookup (MappedKey typeName) (tgDeclarations graph)] ] + nominalSegments registry = + [ nominalUseSegment useSite nominal binding + | (useSite, typeName) <- nominalUseNames aggregate, + Just nominal <- [lookupNominalType typeName registry], + ConsumerNominal binding <- [resolvedNominalOwnership nominal] + ] -- | Equality representation belongs in the fold identity only when a guard -- actually compares that declaration. This keeps unrelated binding metadata out -- of replay compatibility while ensuring a witness/domain change cannot silently -- retain the old fold fingerprint. -nominalEqualityUses :: CheckedService -> Aggregate -> Set Text +nominalEqualityUses :: CheckedService -> Aggregate -> Either FoldSurfaceError (Set Text) nominalEqualityUses service aggregate = - Set.fromList - [ identity - | transition <- aggTransitions aggregate, - guardSyntax <- maybeToList (tGuard transition), - Right guardExpression <- [resolveGuardExpr (expressionEnvironment spec aggregate transition) guardSyntax], - identity <- equalityIdentities (checkedLanguageContract service) guardExpression - ] + if runtimeProfileHasCapability (effectiveRuntimeProfile (checkedLanguageContract service)) NominalEqualityV2 + then fmap (Set.fromList . concat) (traverse transitionIdentities (aggTransitions aggregate)) + else + Right + ( Set.fromList + [ identity + | transition <- aggTransitions aggregate, + guardSyntax <- maybeToList (tGuard transition), + Right guardExpression <- [resolveGuardExpr (expressionEnvironment spec aggregate transition) guardSyntax], + identity <- equalityIdentities (checkedLanguageContract service) guardExpression + ] + ) where spec = checkedSpec service + transitionIdentities transition = case tGuard transition of + Nothing -> Right [] + Just guardSyntax -> do + guardExpression <- + mapLeft + (FoldGuardResolutionFailed (aggName aggregate) (tCommand transition) . showText) + (resolveGuardExpr (expressionEnvironment spec aggregate transition) guardSyntax) + pure (equalityIdentities (checkedLanguageContract service) guardExpression) equalityIdentities :: EffectiveLanguageContract -> TypedScalarExpr -> [Text] equalityIdentities languageContract expression = @@ -198,59 +229,56 @@ <> "|terminal=" <> if stTerminal state then "true" else "false" -registerSegment :: AggregateSymbols -> RegDecl -> Text -registerSegment symbols register = - "reg:" - <> regName register - <> ":" - <> typeExprCanonicalName (regType register) - <> "=" - <> canonicalInitial - where - canonicalInitial = case resolveAggregateType symbols (regLoc register) RegisterUse (regType register) of - Left _ -> renderInitial (regInitial register) - Right resolvedType -> case resolveRegisterInitial symbols (regLoc register) resolvedType (regInitial register) of - Left _ -> renderInitial (regInitial register) - Right resolvedInitial -> registerInitialCanonicalName resolvedInitial - -renderInitial :: RegInitial -> Text -renderInitial (RegInitBare value) = value -renderInitial (RegInitText value) = "\"" <> escapeText value <> "\"" - -escapeText :: Text -> Text -escapeText = T.concatMap $ \case - '"' -> "\\\"" - '\\' -> "\\\\" - '\n' -> "\\n" - '\t' -> "\\t" - '\r' -> "\\r" - character -> T.singleton character +registerSegment :: AggregateSymbols -> RegDecl -> Either FoldSurfaceError Text +registerSegment symbols register = do + resolvedType <- + mapLeft + (FoldRegisterTypeResolutionFailed (regName register) . showText) + (resolveAggregateType symbols (regLoc register) RegisterUse (regType register)) + resolvedInitial <- + mapLeft + (FoldRegisterInitialResolutionFailed (regName register) . showText) + (resolveRegisterInitial symbols (regLoc register) resolvedType (regInitial register)) + pure + ( "reg:" + <> regName register + <> ":" + <> typeExprCanonicalName (regType register) + <> "=" + <> registerInitialCanonicalName resolvedInitial + ) -transitionSegment :: Spec -> Aggregate -> Transition -> Text -transitionSegment spec aggregate transition = - T.intercalate - "|" - ( [ "transition:" <> renderMode (tMode transition), - tSource transition, - tCommand transition - ] - ++ implementationSegment - ++ [ "guard=" <> maybe "" renderExpr (tGuard transition), - "writes=" <> T.intercalate ";" (map renderWrite (tWrites transition)), - "emits=" <> T.intercalate "," (tEmits transition) - ] - ++ outputOwnershipSegment - ++ ["goto=" <> tGoto transition] +transitionSegment :: Spec -> Aggregate -> Transition -> Either FoldSurfaceError Text +transitionSegment spec aggregate transition = do + outputOwnershipSegment <- case tImplementation 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 + ] + ++ implementationSegment + ++ [ "guard=" <> maybe "" canonicalExpr (tGuard transition), + "writes=" <> T.intercalate ";" (map renderWrite (tWrites transition)), + "emits=" <> T.intercalate "," (tEmits transition) + ] + ++ outputOwnershipSegment + ++ ["goto=" <> tGoto transition] + ) ) where - renderWrite (registerName, expression) = registerName <> ":=" <> renderExpr expression - outputSegment emitIndex eventName = case eventOutputMapping spec aggregate transition emitIndex eventName of - Right mapping -> eventName <> "=" <> eventOutputCanonical mapping - Left problem -> eventName <> "=invalid:" <> T.pack (show problem) - outputOwnershipSegment = case tImplementation transition of - LegacyHoleImplementation -> [] - GeneratedImplementation -> ["outputs=" <> T.intercalate "," [outputSegment emitIndex eventName | (emitIndex, eventName) <- zip [1 ..] (tEmits transition)]] - HoleImplementation -> ["outputs=" <> T.intercalate "," [outputSegment emitIndex eventName | (emitIndex, eventName) <- zip [1 ..] (tEmits transition)]] + renderWrite (registerName, expression) = registerName <> ":=" <> canonicalExpr expression + outputSegments = traverse (uncurry outputSegment) (zip [1 ..] (tEmits transition)) + outputSegment emitIndex eventName = do + mapping <- + mapLeft + (FoldEventOutputResolutionFailed (aggName aggregate) (tCommand transition) eventName . showText) + (eventOutputMapping spec aggregate transition emitIndex eventName) + pure (eventName <> "=" <> eventOutputCanonical mapping) implementationSegment = case tImplementation transition of LegacyHoleImplementation -> [] GeneratedImplementation -> ["implementation=generated"] @@ -270,7 +298,7 @@ "cases=" <> T.intercalate ";" (map renderCase (ruleCases rule)) ] where - renderCase (constructorName, expression) = constructorName <> "=>" <> renderExpr expression + renderCase (constructorName, expression) = constructorName <> "=>" <> canonicalExpr expression referencedRuleNames :: Spec -> Aggregate -> Set Name referencedRuleNames spec aggregate = close directNames @@ -310,3 +338,9 @@ maybeToList :: Maybe a -> [a] maybeToList Nothing = [] maybeToList (Just value) = [value] + +mapLeft :: (errorValue -> otherError) -> Either errorValue value -> Either otherError value +mapLeft convert = either (Left . convert) Right + +showText :: (Show value) => value -> Text +showText = T.pack . show diff --git a/src/Keiro/Dsl/Frontend/Internal.hs b/src/Keiro/Dsl/Frontend/Internal.hs --- a/src/Keiro/Dsl/Frontend/Internal.hs +++ b/src/Keiro/Dsl/Frontend/Internal.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NoFieldSelectors #-} -- | Shared implementation behind the public frontend and parser compatibility diff --git a/src/Keiro/Dsl/Grammar.hs b/src/Keiro/Dsl/Grammar.hs --- a/src/Keiro/Dsl/Grammar.hs +++ b/src/Keiro/Dsl/Grammar.hs @@ -30,14 +30,8 @@ NominalScalarDecl (..), MappedDecl (..), - -- * The eight hole-kind types - Derivation (..), - DerivStrategy (..), - Disposition (..), - DispAction (..), + -- * Shared mapping type Mapping (..), - EnvelopeBinding (..), - EnvelopeLayer (..), -- * The Expr sublanguage Expr (..), @@ -332,33 +326,6 @@ } deriving stock (Eq, Show, Generic) --- The eight hole-kind types. EP-1 only exercises hole-kinds 1–3 against the --- aggregate vertical; the rest exist so EP-3…EP-6 reuse the same types. - --- | Hole-kind 1: a deterministic id/string derivation. Opaque strategies must --- carry a captured @fixture@ (not a prose rule) so two agents re-derive them --- identically. -data Derivation = Derivation - { derivStrategy :: !DerivStrategy, - derivFixture :: !(Maybe Text) - } - deriving stock (Eq, Show, Generic) - -data DerivStrategy = UuidV5 | SuffixSplice - deriving stock (Eq, Show, Generic) - --- | Hole-kind 2: a failure→action table. Carries the two dangerous inversions a --- @duplicate@/@rejected replay@ being treated as success and a --- @previously-failed@ being dead-lettered rather than retried (enforced by --- EP-4's validator rules). -newtype Disposition = Disposition - { dispCases :: [(Name, DispAction)] - } - deriving stock (Eq, Show, Generic) - -data DispAction = AckOk | Retry !Int | DeadLetter !Text - deriving stock (Eq, Show, Generic) - -- | Hole-kind 3: an explicit value→value table that is not an identity echo -- (e.g. an event name → projection status). @mapPartial@ records whether the -- spec author explicitly marked the table partial over its domain. @@ -368,18 +335,6 @@ } deriving stock (Eq, Show, Generic) --- | Hole-kind 4: which layer carries each envelope field, and whether the two --- are cross-checked. Defined here for reuse; exercised by EP-4. -data EnvelopeBinding = EnvelopeBinding - { envField :: !Name, - envLayer :: !EnvelopeLayer, - envCrossChecked :: !Bool - } - deriving stock (Eq, Show, Generic) - -data EnvelopeLayer = KafkaHeader | JsonBody - deriving stock (Eq, Show, Generic) - -- | The @Expr@ sublanguage used by @guard@ clauses and the right-hand side of -- @write@ clauses. An infix expression over 'Atom's; operators in precedence -- order are @||@ (lowest), @&&@, then the relational comparisons. @@ -694,8 +649,7 @@ deriving stock (Eq, Show, Generic) -- | The complete dispatch disposition table (every arm mandatory; the --- @on-duplicate AckOk@ benign inversion is explicit). Named to avoid clashing --- with the hole-kind 'Disposition'. +-- @on-duplicate AckOk@ benign inversion is explicit). data DispatchDisposition = DispatchDisposition { onAppended :: !Disp, onDuplicate :: !Disp, diff --git a/src/Keiro/Dsl/Harness.hs b/src/Keiro/Dsl/Harness.hs --- a/src/Keiro/Dsl/Harness.hs +++ b/src/Keiro/Dsl/Harness.hs @@ -219,13 +219,12 @@ [ generatedBanner, "module " <> genPrefix <> ".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.)", - "-}", + "-- | (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\", " <> hs (faField (tmFireAt timer)) <> ")", @@ -269,7 +268,7 @@ -- pinning the spec's deterministic decisions: the stable name, the WorkflowId -- derivation, the ordered body (step/await/sleep/child by label), and the await -- labels (whose ids the signal operations must match). Exposes --- @workflowFacts :: [(String, String)]@ so a driver asserts them against a +-- a typed @WorkflowFacts@ record so a driver asserts it against a -- hand-written expectation — a spec change (e.g. renaming an await label) diverges -- and reddens a specific assertion. Workflows intentionally have no domain scaffold -- or hole stub: their behaviour-bearing body remains hand-written, while these facts @@ -301,24 +300,35 @@ emitWorkflowFacts genPrefix w = nl [ generatedBanner, - "module " <> genPrefix <> ".WorkflowFacts (workflowFacts) where", + "module " <> genPrefix <> ".WorkflowFacts (WorkflowFacts (..), workflowFacts) where", "", - "{- | (label, value): the workflow's deterministic decisions, pinned as pure", - "facts. A driver asserts them against a hand-written expectation, so a spec", - "change (e.g. renaming an await) reddens a specific assertion.", - "-}", - "workflowFacts :: [(String, String)]", + "-- | The workflow's deterministic decisions, pinned as typed pure facts.", + "-- A driver asserts them against a hand-written expectation, so a spec", + "-- change (e.g. renaming an await) reddens a specific assertion.", + "data WorkflowFacts = WorkflowFacts", + " { workflowFactName :: !String", + " , workflowFactIdVia :: !String", + " , workflowFactIdField :: !String", + " , workflowFactBody :: ![String]", + " , workflowFactAwaitLabels :: ![String]", + " , workflowFactPatchIds :: ![String]", + " }", + " deriving stock (Eq, Show)", + "", + "workflowFacts :: WorkflowFacts", "workflowFacts =", - " [ (\"name\", " <> hs (wfStable w) <> ")", - " , (\"idVia\", " <> hs (wfIdVia w) <> ")", - " , (\"idField\", " <> hs (maybe "input" id (wfIdField w)) <> ")", - " , (\"body\", " <> hs (T.intercalate "," (map bodyTag (wfBody w))) <> ")", - " , (\"awaits\", " <> hs (T.intercalate "," (workflowAwaitLabels (wfBody w))) <> ")", - " , (\"patches\", " <> hs (T.intercalate "," (workflowPatchIds (wfBody w))) <> ")", - " ]" + " 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)), + " }" ] where hs = tshow + stringList values = "[" <> T.intercalate ", " (map hs values) <> "]" bodyTag (WfStep l _ _) = "step:" <> l bodyTag (WfAwait l _ _) = "await:" <> l bodyTag (WfSleep l _ _) = "sleep:" <> l @@ -410,10 +420,9 @@ ++ aggregateHarnessImports a ++ goldenImports ++ [ "", - "{- | (label, passed). A driver runs these and exits non-zero on any False,", - "naming the failing assertion. Filling a hole wrongly turns a specific", - "entry False; the scaffold cannot.", - "-}", + "-- | (label, passed). A driver runs these and exits non-zero on any False,", + "-- naming the failing assertion. Filling a hole wrongly turns a specific", + "-- entry False; the scaffold cannot.", "harnessAssertions :: [(String, Bool)]", "harnessAssertions =", " [ (\"validateTransducer is empty\", null (validateTransducer defaultValidationOptions " <> lowerFirst nm <> "Transducer))", @@ -602,7 +611,7 @@ ] where cmdSample = case [c | c <- aCommands a, rcName c == tCommand t] of - (c : _) -> "(" <> commandCtorExpr a c <> ")" + (c : _) -> "(" <> commandCtorExpr a t c <> ")" [] -> "(error \"no command\")" forwardReplayDecl :: Agg -> Transition -> [Text] @@ -640,7 +649,7 @@ forwardRegsName = if null (aRegs a) then "_forwardRegs" else "forwardRegs" replayRegsName = if null (aRegs a) then "_replayRegs" else "replayRegs" cmdSample = case [c | c <- aCommands a, rcName c == tCommand t] of - (c : _) -> "(" <> commandCtorExpr a c <> ")" + (c : _) -> "(" <> commandCtorExpr a t c <> ")" [] -> "(error \"no command\")" -- | @( (Data v1 v2 …))@ with positional sample field values. @@ -651,19 +660,19 @@ args = T.concat [" " <> sampleValue a fieldName ty | (fieldName, ty) <- rcFields rc] -- | A transition command sample prefers the initial value of a same-named, --- same-typed register. This makes the generated acceptance/replay probes honest --- for declaration-exact @cmd.field == reg.field@ guards while retaining the --- field-distinct samples used by standalone event codec probes. -commandCtorExpr :: Agg -> ResolvedCtor -> Text -commandCtorExpr a rc = +-- same-typed register only when the guard explicitly equates those two paths. +-- Inequality guards retain the ordinary sample so an enum such as @Paid@ does +-- not accidentally inherit a forbidden @Free@ register initial value. +commandCtorExpr :: Agg -> Transition -> ResolvedCtor -> Text +commandCtorExpr a transition rc = "(" <> rcName rc <> " (" <> rcName rc <> "Data" <> args <> "))" where - args = T.concat [" " <> commandSampleValue a fieldName ty | (fieldName, ty) <- rcFields rc] + args = T.concat [" " <> commandSampleValue a transition fieldName ty | (fieldName, ty) <- rcFields rc] -commandSampleValue :: Agg -> Text -> ResolvedAggregateType -> Text -commandSampleValue aggregate fieldName fieldType = case fieldType of - AggregateNominal nominal - | nominalEqualityUsedInGeneratedExpressions nominal aggregate -> case find matchesRegister (aRegs aggregate) of +commandSampleValue :: Agg -> Transition -> Text -> ResolvedAggregateType -> Text +commandSampleValue aggregate transition fieldName fieldType = case fieldType of + AggregateNominal _ + | guardEquatesCommandAndRegister transition fieldName -> case find matchesRegister (aRegs aggregate) of Just register -> regInitialValueForHarness aggregate register Nothing -> fallback _ -> fallback @@ -671,8 +680,22 @@ fallback = sampleValue aggregate fieldName fieldType matchesRegister register = rrName register == fieldName && rrType register == fieldType regInitialValueForHarness owner register = case rrType register of - AggregateNominal nominal -> fromMaybe (renderRegisterInitial (rrInitial register)) (generatedIdSampleHaskell owner nominal) + AggregateNominal nominal -> case resolvedNominalOwnership nominal of + ConsumerNominal {} -> renderRegisterInitial (rrInitial register) + GeneratedNominal -> fromMaybe (renderRegisterInitial (rrInitial register)) (generatedIdSampleHaskell owner nominal) _ -> renderRegisterInitial (rrInitial register) + +guardEquatesCommandAndRegister :: Transition -> Text -> Bool +guardEquatesCommandAndRegister transition fieldName = maybe False containsEquality (tGuard transition) + where + containsEquality = \case + EOr left right -> containsEquality left || containsEquality right + EAnd left right -> containsEquality left || containsEquality right + ECmp OpEq left right -> matchingPaths left right || matchingPaths right left + _ -> False + matchingPaths (EPath _ CommandRoot [commandField]) (EPath _ RegisterRoot [registerField]) = + commandField == fieldName && registerField == fieldName + matchingPaths _ _ = False sampleValue :: Agg -> Text -> ResolvedAggregateType -> Text sampleValue a fieldName ty = case ty of diff --git a/src/Keiro/Dsl/IdDomain.hs b/src/Keiro/Dsl/IdDomain.hs --- a/src/Keiro/Dsl/IdDomain.hs +++ b/src/Keiro/Dsl/IdDomain.hs @@ -5,6 +5,7 @@ IdDomainFailure (..), enforcedIdDomainVersion, idDomainContractFor, + contractIdDomainContractFor, idDomainIdentity, idDomainIdentitiesForService, idDomainAcceptsText, @@ -17,17 +18,26 @@ import Data.Text (Text) import Data.Text qualified as T import Keiro.Codec.IdDomain -import Keiro.Dsl.Grammar (IdDecl (..), Spec (..)) -import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveRuntimeSemantics) +import Keiro.Dsl.Grammar (ContractEvent (..), ContractField (..), ContractNode (..), ContractType (..), IdDecl (..), Node (..), Spec (..)) +import Keiro.Dsl.LanguageVersion (RuntimeCapability (..), runtimeProfileHasCapability) +import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveRuntimeProfile) -- | 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 - | effectiveRuntimeSemantics languageContract /= "keiro-dsl/runtime-semantics/2" = Nothing - | otherwise = Just (typeIdV7Domain prefix) + | runtimeProfileHasCapability (effectiveRuntimeProfile languageContract) GeneratedIdDomainTypeIdV7 = + Just (typeIdV7Domain prefix) + | otherwise = Nothing +-- | Public contract DTOs adopt the frozen TypeID-v7 admission contract only +-- 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) + | otherwise = Nothing + -- | Durable identity for the runtime admission domain of one declaration. -- This is deliberately separate from nominal equality: IDs without equality -- expressions still have a construction and codec contract. @@ -45,7 +55,20 @@ idDomainIdentitiesForService :: CheckedService -> [Text] idDomainIdentitiesForService service = - [ idDomainIdentity (idName declaration) contract - | declaration <- specIds (checkedSpec service), - Just contract <- [idDomainContractFor (checkedLanguageContract service) (idPrefix declaration)] - ] + aggregateIdentities <> contractIdentities + where + spec = checkedSpec service + languageContract = checkedLanguageContract service + aggregateIdentities = + [ idDomainIdentity (idName declaration) contract + | declaration <- specIds spec, + Just contract <- [idDomainContractFor languageContract (idPrefix 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], + Just contract <- [contractIdDomainContractFor languageContract prefix] + ] diff --git a/src/Keiro/Dsl/LanguageVersion.hs b/src/Keiro/Dsl/LanguageVersion.hs --- a/src/Keiro/Dsl/LanguageVersion.hs +++ b/src/Keiro/Dsl/LanguageVersion.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Werror=incomplete-patterns #-} + -- | The released-language contract selected by a @.keiro@ source. -- -- Source-language provenance deliberately wraps the semantic 'Spec' rather than @@ -17,9 +19,20 @@ SyntaxProfile, syntaxProfileIdentifier, syntaxProfileSupportsFeature, + RuntimeSemanticsProfile, + runtimeProfileIdentifier, + runtimeProfileHasCapability, + runtimeProfileFoldSegments, + RuntimeCapability (..), + capabilityFoldSegment, + LanguageSupport (..), + languageSupportText, LanguageDefinition (..), + definitionRuntimeSemantics, languageRegistry, supportedLanguageVersions, + currentStableLanguageVersion, + languageSupportForVersion, lookupLanguageDefinition, LanguageFeature (..), languageFeatureMinimumVersion, @@ -113,6 +126,63 @@ syntaxProfileSupportsFeature :: SyntaxProfile -> LanguageFeature -> Bool syntaxProfileSupportsFeature SyntaxProfile {profileFeatures} feature = Set.member feature profileFeatures +-- | One independently selectable runtime behavior in a released language +-- contract. Constructors are append-only: registry profiles are monotone, and +-- 'capabilityFoldSegment' must make an explicit fingerprint decision for every +-- new constructor. +data RuntimeCapability + = GeneratedIdDomainTypeIdV7 + | NominalEqualityV2 + | ContractIdDomainTypeIdV7 + | StrictSpecSurfaceValidation + deriving stock (Eq, Ord, Show, Enum, Bounded) + +-- | An immutable, explicitly named set of runtime capabilities. The +-- 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) + } + deriving stock (Eq, Ord, Show, Generic) + +runtimeProfileIdentifier :: RuntimeSemanticsProfile -> Text +runtimeProfileIdentifier RuntimeSemanticsProfile {runtimeSemanticsIdentifier} = runtimeSemanticsIdentifier + +runtimeProfileHasCapability :: RuntimeSemanticsProfile -> RuntimeCapability -> Bool +runtimeProfileHasCapability RuntimeSemanticsProfile {runtimeSemanticsCapabilities} capability = + Set.member capability runtimeSemanticsCapabilities + +-- | Optional replay-fold identity contributed by one capability. Duplicate +-- tokens intentionally collapse at the profile boundary so the two coupled +-- language-3 behaviors preserve their historical single segment. +capabilityFoldSegment :: RuntimeCapability -> Maybe Text +capabilityFoldSegment GeneratedIdDomainTypeIdV7 = Just "semantic-contract:keiro-dsl/runtime-semantics/2" +capabilityFoldSegment NominalEqualityV2 = Just "semantic-contract:keiro-dsl/runtime-semantics/2" +capabilityFoldSegment ContractIdDomainTypeIdV7 = Nothing +capabilityFoldSegment StrictSpecSurfaceValidation = Nothing + +runtimeProfileFoldSegments :: RuntimeSemanticsProfile -> [Text] +runtimeProfileFoldSegments RuntimeSemanticsProfile {runtimeSemanticsCapabilities} = + Set.toAscList + ( Set.fromList + [ segment + | capability <- Set.toAscList runtimeSemanticsCapabilities, + Just segment <- [capabilityFoldSegment capability] + ] + ) + +-- | Whether a released language is recommended for new authoring or retained +-- only so historical sources keep their released meaning. +data LanguageSupport + = CompatibilityOnly + | Stable + deriving stock (Eq, Ord, Show, Enum, Bounded) + +languageSupportText :: LanguageSupport -> Text +languageSupportText CompatibilityOnly = "compatibility-only" +languageSupportText Stable = "stable" + -- | One append-only released-language registry entry. data LanguageDefinition = LanguageDefinition { definitionVersion :: !LanguageVersion, @@ -121,10 +191,16 @@ -- dispatch uses 'definitionSyntaxProfile', never this historical tag. definitionBodyParser :: !LanguageBodyParser, definitionSyntaxProfile :: !SyntaxProfile, - definitionRuntimeSemantics :: !Text + definitionRuntimeSemanticsProfile :: !RuntimeSemanticsProfile, + definitionSupport :: !LanguageSupport } 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 + version1 :: LanguageVersion version1 = LanguageVersion 1 @@ -134,12 +210,16 @@ version3 :: LanguageVersion version3 = LanguageVersion 3 +version4 :: LanguageVersion +version4 = LanguageVersion 4 + -- | The authoritative, append-only registry of released language contracts. languageRegistry :: NonEmpty LanguageDefinition languageRegistry = - LanguageDefinition version1 Nothing LanguageBodyParserV1 profileV1 "keiro-dsl/runtime-semantics/1" - :| [ LanguageDefinition version2 (Just version1) LanguageBodyParserV2 profileV2 "keiro-dsl/runtime-semantics/1", - LanguageDefinition version3 (Just version2) LanguageBodyParserV2 profileV2 "keiro-dsl/runtime-semantics/2" + LanguageDefinition version1 Nothing LanguageBodyParserV1 profileV1 runtimeProfileV1 CompatibilityOnly + :| [ LanguageDefinition version2 (Just version1) LanguageBodyParserV2 profileV2 runtimeProfileV1 CompatibilityOnly, + LanguageDefinition version3 (Just version2) LanguageBodyParserV2 profileV2 runtimeProfileV2 CompatibilityOnly, + LanguageDefinition version4 (Just version3) LanguageBodyParserV2 profileV2 runtimeProfileV3 Stable ] profileV1 :: SyntaxProfile @@ -157,9 +237,43 @@ ] ) +runtimeProfileV1 :: RuntimeSemanticsProfile +runtimeProfileV1 = + RuntimeSemanticsProfile + "keiro-dsl/runtime-semantics/1" + Set.empty + +runtimeProfileV2 :: RuntimeSemanticsProfile +runtimeProfileV2 = + RuntimeSemanticsProfile + "keiro-dsl/runtime-semantics/2" + (Set.fromList [GeneratedIdDomainTypeIdV7, NominalEqualityV2]) + +runtimeProfileV3 :: RuntimeSemanticsProfile +runtimeProfileV3 = + RuntimeSemanticsProfile + "keiro-dsl/runtime-semantics/3" + ( Set.fromList + [ GeneratedIdDomainTypeIdV7, + NominalEqualityV2, + ContractIdDomainTypeIdV7, + StrictSpecSurfaceValidation + ] + ) + -- | Supported versions, derived from 'languageRegistry'. supportedLanguageVersions :: NonEmpty LanguageVersion supportedLanguageVersions = definitionVersion <$> languageRegistry + +-- | The one registry entry recommended for newly-authored sources. +currentStableLanguageVersion :: LanguageVersion +currentStableLanguageVersion = + case [definitionVersion definition | definition <- NE.toList languageRegistry, definitionSupport definition == Stable] of + [version] -> version + _ -> error "keiro-dsl internal invariant: language registry must contain exactly one stable version" + +languageSupportForVersion :: LanguageVersion -> Maybe LanguageSupport +languageSupportForVersion version = definitionSupport <$> lookupLanguageDefinition version lookupLanguageDefinition :: LanguageVersion -> Maybe LanguageDefinition lookupLanguageDefinition version = diff --git a/src/Keiro/Dsl/Manifest.hs b/src/Keiro/Dsl/Manifest.hs --- a/src/Keiro/Dsl/Manifest.hs +++ b/src/Keiro/Dsl/Manifest.hs @@ -28,7 +28,9 @@ -- @base@ is always present. module Keiro.Dsl.Manifest ( renderManifest, + renderManifestForService, manifestDependencies, + manifestDependenciesForService, moduleNameOf, ) where @@ -39,15 +41,23 @@ import Data.Text qualified as T import Keiro.Dsl.AggregateType import Keiro.Dsl.Grammar +import Keiro.Dsl.IdDomain (contractIdDomainContractFor) import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), consumerPlan) import Keiro.Dsl.NominalType import Keiro.Dsl.Scaffold (ScaffoldModule (..)) +import Keiro.Dsl.SemanticContract (CheckedService (..), legacyCheckedService) -- | Render a Cabal-pasteable manifest from the modules a scaffold run produced -- plus the node kinds present (which imply the dependency set). The first argument -- names the source spec (for the header comment). renderManifest :: Text -> [ScaffoldModule] -> Spec -> Text -renderManifest specName mods spec = +renderManifest specName mods = renderManifestForService specName mods . legacyCheckedService + +-- | Service-aware manifest renderer. Semantic CLI and workspace routes use +-- this entry point so language-4 typed contract imports are represented in the +-- consuming Cabal dependencies. +renderManifestForService :: Text -> [ScaffoldModule] -> CheckedService -> Text +renderManifestForService specName mods service = T.unlines $ [ "-- keiro-dsl build manifest for " <> specName, "-- Paste the two blocks below into the consuming Cabal stanza.", @@ -60,9 +70,10 @@ ++ [ "", "build-depends:" ] - ++ map (" , " <>) (manifestDependencies spec) + ++ map (" , " <>) (manifestDependenciesForService service) ++ consumerBlocks where + spec = checkedSpec service plan = consumerPlan spec consumerBlocks | null (consumerMappings plan) = [] @@ -84,16 +95,21 @@ -- | The sorted, deduplicated dependency set implied by the node kinds present -- in the spec. @base@ is always included. manifestDependencies :: Spec -> [Text] -manifestDependencies spec = - sort (nub ("base" : consumerPackages (consumerPlan spec) <> concatMap (depsForNode spec) (specNodes spec))) +manifestDependencies = manifestDependenciesForService . legacyCheckedService +manifestDependenciesForService :: CheckedService -> [Text] +manifestDependenciesForService service = + sort (nub ("base" : consumerPackages (consumerPlan spec) <> concatMap (depsForNode service spec) (specNodes spec))) + where + spec = checkedSpec service + -- | The dependencies a single node kind implies (see the module header table). -depsForNode :: Spec -> Node -> [Text] -depsForNode spec n = case n of +depsForNode :: CheckedService -> Spec -> Node -> [Text] +depsForNode service spec n = case n of NAggregate aggregate -> ["aeson", "keiki", "keiro", "text"] <> aggregateDependencies spec aggregate NProcess {} -> ["aeson", "keiki", "keiro", "shibuya-core", "text", "time", "uuid"] NRouter {} -> ["effectful-core", "keiro", "shibuya-core", "text"] - NContract {} -> ["aeson", "text"] + NContract contract -> ["aeson", "text"] <> [dependency | hasTypedContractId contract, dependency <- ["keiro-core", "mmzk-typeid"]] NIntake {} -> integration NEmit {} -> integration NPublisher {} -> integration @@ -104,6 +120,13 @@ NOperation {} -> ["effectful-core", "keiro", "text"] where integration = ["effectful-core", "hasql-transaction", "keiro", "kiroku-store"] + hasTypedContractId contract = + or + [ contractIdDomainContractFor (checkedLanguageContract service) prefix /= Nothing + | event <- ctrEvents contract, + field <- ceFields event, + CTypeId prefix <- [cfType field] + ] aggregateDependencies :: Spec -> Aggregate -> [Text] aggregateDependencies spec aggregate = diff --git a/src/Keiro/Dsl/NominalType.hs b/src/Keiro/Dsl/NominalType.hs --- a/src/Keiro/Dsl/NominalType.hs +++ b/src/Keiro/Dsl/NominalType.hs @@ -19,11 +19,8 @@ NominalTypeRegistry, nominalTypes, lookupNominalType, - nominalEqualityContract, nominalEqualityContractForService, - nominalEqualityIdentity, nominalEqualityIdentityForService, - nominalEqualityIdentities, nominalEqualityIdentitiesForService, NominalTypeError (..), resolveNominalTypes, @@ -41,9 +38,9 @@ import Data.TypeID qualified as TypeID import GHC.Generics (Generic) import Keiro.Dsl.Grammar -import Keiro.Dsl.IdDomain (idDomainContractFor, idDomainVersion) -import Keiro.Dsl.LanguageVersion (SourceLanguage (..)) -import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveLanguageContract) +import Keiro.Dsl.IdDomain (enforcedIdDomainVersion) +import Keiro.Dsl.LanguageVersion (RuntimeCapability (..), runtimeProfileHasCapability) +import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveRuntimeProfile) import Keiro.Dsl.TypeGraph data NominalScalarRepresentation @@ -123,26 +120,22 @@ lookupNominalType :: Name -> NominalTypeRegistry -> Maybe ResolvedNominalType lookupNominalType name = Map.lookup name . nominalTypes --- | Resolve the declaration-scoped equality contract. Nominal scalar wrappers --- keep their existing scalar projection behavior; this contract is the new --- authority only for IDs and enums. -nominalEqualityContract :: ResolvedNominalType -> Maybe CheckedNominalEquality -nominalEqualityContract = nominalEqualityContractForService (effectiveLanguageContract LegacyUnversioned) - nominalEqualityContractForService :: EffectiveLanguageContract -> ResolvedNominalType -> Maybe CheckedNominalEquality nominalEqualityContractForService languageContract nominal = case resolvedNominalRepresentation nominal of IdRepresentation prefix -> Just CheckedNominalEquality { equalityKeyRepresentation = NominalTextEqualityKey, - equalityDomain = case idDomainContractFor languageContract prefix of - Just contract -> EnforcedTypeIdV7TextDomain prefix (idDomainVersion contract) - Nothing -> case resolvedNominalOwnership nominal of - GeneratedNominal -> LegacyUnrestrictedTextDomain - ConsumerNominal {} -> TypeIdTextDomain prefix, - equalityContractVersion = case idDomainContractFor languageContract prefix of - Just _ -> "keiro-dsl/nominal-equality/2" - Nothing -> nominalEqualityContractVersion + equalityDomain = + if enforcesNominalEqualityV2 + then EnforcedTypeIdV7TextDomain prefix enforcedIdDomainVersion + else case resolvedNominalOwnership nominal of + GeneratedNominal -> LegacyUnrestrictedTextDomain + ConsumerNominal {} -> TypeIdTextDomain prefix, + equalityContractVersion = + if enforcesNominalEqualityV2 + then "keiro-dsl/nominal-equality/2" + else nominalEqualityContractVersion } EnumRepresentation constructors -> Just @@ -152,13 +145,13 @@ equalityContractVersion = nominalEqualityContractVersion } ScalarRepresentation {} -> Nothing + where + enforcesNominalEqualityV2 = + runtimeProfileHasCapability (effectiveRuntimeProfile languageContract) NominalEqualityV2 -- | Stable, checked identity used by generated projection tags, fingerprints, -- scaffold history, and explain output. It includes the existing binding -- authority rather than introducing a second consumer equality function. -nominalEqualityIdentity :: ResolvedNominalType -> Maybe Text -nominalEqualityIdentity = nominalEqualityIdentityForService (effectiveLanguageContract LegacyUnversioned) - nominalEqualityIdentityForService :: EffectiveLanguageContract -> ResolvedNominalType -> Maybe Text nominalEqualityIdentityForService languageContract nominal = do equality <- nominalEqualityContractForService languageContract nominal @@ -186,9 +179,6 @@ "binding=" <> unQualifiedValueName (consumerNominalBinding binding), "binding-version=" <> unBindingVersion (consumerNominalBindingVersion binding) ] - -nominalEqualityIdentities :: Spec -> [Text] -nominalEqualityIdentities spec = nominalEqualityIdentitiesForService (CheckedService (effectiveLanguageContract LegacyUnversioned) spec) nominalEqualityIdentitiesForService :: CheckedService -> [Text] nominalEqualityIdentitiesForService service = case resolveNominalTypes spec of diff --git a/src/Keiro/Dsl/Parser/Aggregate.hs b/src/Keiro/Dsl/Parser/Aggregate.hs --- a/src/Keiro/Dsl/Parser/Aggregate.hs +++ b/src/Keiro/Dsl/Parser/Aggregate.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ImportQualifiedPost #-} - -- | Aggregate declarations, clauses, transitions, and expression ownership. module Keiro.Dsl.Parser.Aggregate ( pAggregate, diff --git a/src/Keiro/Dsl/Parser/Coordination.hs b/src/Keiro/Dsl/Parser/Coordination.hs --- a/src/Keiro/Dsl/Parser/Coordination.hs +++ b/src/Keiro/Dsl/Parser/Coordination.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ImportQualifiedPost #-} - -- | Process-manager, router, timer, dispatch, and correlation syntax. module Keiro.Dsl.Parser.Coordination ( pProcess, diff --git a/src/Keiro/Dsl/Parser/Core.hs b/src/Keiro/Dsl/Parser/Core.hs --- a/src/Keiro/Dsl/Parser/Core.hs +++ b/src/Keiro/Dsl/Parser/Core.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ImportQualifiedPost #-} -- EP-4 integration: structural keywords never used as identifiers, so a -- list like @accept A B C@ stops at the next block keyword. -- EP-5 pgmq structural keywords. @@ -12,7 +11,6 @@ -------------------------------------------------------------------------------- -- Helpers -------------------------------------------------------------------------------- -{-# LANGUAGE ImportQualifiedPost #-} -- | Parser primitives shared by every internal grammar concern. module Keiro.Dsl.Parser.Core diff --git a/src/Keiro/Dsl/Parser/Document.hs b/src/Keiro/Dsl/Parser/Document.hs --- a/src/Keiro/Dsl/Parser/Document.hs +++ b/src/Keiro/Dsl/Parser/Document.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ImportQualifiedPost #-} - -- | Released-language dispatch and complete document composition. module Keiro.Dsl.Parser.Document ( parseSurfaceSource, diff --git a/src/Keiro/Dsl/Parser/Expression.hs b/src/Keiro/Dsl/Parser/Expression.hs --- a/src/Keiro/Dsl/Parser/Expression.hs +++ b/src/Keiro/Dsl/Parser/Expression.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ImportQualifiedPost #-} - -- | Legacy and typed scalar expression syntax. module Keiro.Dsl.Parser.Expression ( pExpr, diff --git a/src/Keiro/Dsl/Parser/Mapped.hs b/src/Keiro/Dsl/Parser/Mapped.hs --- a/src/Keiro/Dsl/Parser/Mapped.hs +++ b/src/Keiro/Dsl/Parser/Mapped.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ImportQualifiedPost #-} - -- | Consumer-owned mapped and nominal type syntax. module Keiro.Dsl.Parser.Mapped ( pMappedTopItem, diff --git a/src/Keiro/Dsl/Parser/Preamble.hs b/src/Keiro/Dsl/Parser/Preamble.hs --- a/src/Keiro/Dsl/Parser/Preamble.hs +++ b/src/Keiro/Dsl/Parser/Preamble.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ImportQualifiedPost #-} - -- | Released-language preamble recognition and source selection. module Keiro.Dsl.Parser.Preamble ( contextualDiagnostic, diff --git a/src/Keiro/Dsl/Parser/Workflow.hs b/src/Keiro/Dsl/Parser/Workflow.hs --- a/src/Keiro/Dsl/Parser/Workflow.hs +++ b/src/Keiro/Dsl/Parser/Workflow.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ImportQualifiedPost #-} - -- | Durable workflow and operation syntax. module Keiro.Dsl.Parser.Workflow ( pWorkflow, diff --git a/src/Keiro/Dsl/ReplayImpact.hs b/src/Keiro/Dsl/ReplayImpact.hs --- a/src/Keiro/Dsl/ReplayImpact.hs +++ b/src/Keiro/Dsl/ReplayImpact.hs @@ -13,13 +13,13 @@ ( AggregateImpact (..), ReplayImpact (..), replayImpactServices, - replayImpact, renderReplayImpact, ) where import Data.Aeson (ToJSON (..), object, (.=)) -import Data.List (delete, find) +import Data.Foldable (traverse_) +import Data.List (delete, sortOn) import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map @@ -28,11 +28,11 @@ import Data.Text (Text) import Data.Text qualified as Text import Keiro.Dsl.AggregateType -import Keiro.Dsl.FoldFingerprint (aggregateFoldSurfaceForService) +import Keiro.Dsl.CanonicalEncoding (canonicalExpr, canonicalTransition) +import Keiro.Dsl.FoldFingerprint (FoldSurfaceError, aggregateFoldSurfaceForService) import Keiro.Dsl.Grammar import Keiro.Dsl.NominalType -import Keiro.Dsl.PrettyPrint (renderTransition) -import Keiro.Dsl.SemanticContract (CheckedService (..), legacyCheckedService) +import Keiro.Dsl.SemanticContract (CheckedService (..)) import Keiro.Dsl.TypeGraph (BindingVersion (..), CanonicalTypeId (..), MappedKey (..), QualifiedValueName (..), TypeGraph (..), resolveTypeGraph, wireFingerprint) -- | The smallest conservative audit input for one aggregate. @@ -65,9 +65,15 @@ -- | Compute replay impact for every aggregate that existed under the old -- effective semantic contract. -replayImpactServices :: CheckedService -> CheckedService -> ReplayImpact -replayImpactServices oldService newService = - case Map.filter hasImpact impacts of +replayImpactServices :: CheckedService -> CheckedService -> Either FoldSurfaceError ReplayImpact +replayImpactServices oldService newService = do + traverse_ (aggregateFoldSurfaceForService oldService . snd) oldAggregates + traverse_ (aggregateFoldSurfaceForService newService . snd) (Map.toList newAggregates) + resolvedImpacts <- + traverse + (\(name, oldAggregate) -> fmap ((,) name) (maybe (pure (removedAggregateImpact oldAggregate)) (matchedAggregateImpact oldService newService oldAggregate) (Map.lookup name newAggregates))) + oldAggregates + pure $ case Map.filter hasImpact (Map.fromList resolvedImpacts) of filtered | Map.null filtered -> ReplayNeutral | otherwise -> ReplayAffected filtered @@ -76,18 +82,7 @@ newSpec = checkedSpec newService oldAggregates = [(aggName aggregate, aggregate) | NAggregate aggregate <- specNodes oldSpec] newAggregates = Map.fromList [(aggName aggregate, aggregate) | NAggregate aggregate <- specNodes newSpec] - impacts = - Map.fromList - [ (name, maybe (removedAggregateImpact oldAggregate) (matchedAggregateImpact oldService newService oldAggregate) (Map.lookup name newAggregates)) - | (name, oldAggregate) <- oldAggregates - ] --- | Compatibility wrapper for graph-only callers. It explicitly compares both --- sides under legacy/version-1 runtime semantics. -replayImpact :: Spec -> Spec -> ReplayImpact -replayImpact oldSpec newSpec = - replayImpactServices (legacyCheckedService oldSpec) (legacyCheckedService newSpec) - hasImpact :: AggregateImpact -> Bool hasImpact impact = not (Set.null (eventTypes impact)) @@ -100,15 +95,22 @@ includeSnapshotStreams = True } -matchedAggregateImpact :: CheckedService -> CheckedService -> Aggregate -> Aggregate -> AggregateImpact -matchedAggregateImpact oldService newService oldAggregate newAggregate = - AggregateImpact - { eventTypes = - decodeAffected - <> transitionAffected - <> if nonTransitionFoldChanged then oldEventTypes else Set.empty, - includeSnapshotStreams = transitionFoldChanged || nonTransitionFoldChanged || mappedRegisterChanged - } +matchedAggregateImpact :: CheckedService -> CheckedService -> Aggregate -> Aggregate -> Either FoldSurfaceError AggregateImpact +matchedAggregateImpact oldService newService oldAggregate newAggregate = do + oldSurface <- aggregateFoldSurfaceForService oldService oldAggregate + newNonTransitionSurface <- + aggregateFoldSurfaceForService + newService + newAggregate {aggTransitions = aggTransitions oldAggregate} + let nonTransitionFoldChanged = oldSurface /= newNonTransitionSurface + pure + AggregateImpact + { eventTypes = + decodeAffected + <> transitionAffected + <> if nonTransitionFoldChanged then oldEventTypes else Set.empty, + includeSnapshotStreams = transitionFoldChanged || nonTransitionFoldChanged || mappedRegisterChanged + } where oldSpec = checkedSpec oldService newSpec = checkedSpec newService @@ -119,13 +121,6 @@ /= mappedRegisterSurface newSpec newAggregate (transitionAffected, transitionFoldChanged) = changedTransitionEvents (aggTransitions oldAggregate) (aggTransitions newAggregate) - nonTransitionFoldChanged = - aggregateFoldSurfaceForService oldService oldAggregate - /= aggregateFoldSurfaceForService - newService - newAggregate - { aggTransitions = aggTransitions oldAggregate - } decodeSurfaceAffected :: Spec -> Spec -> Aggregate -> Aggregate -> Set Name decodeSurfaceAffected oldSpec newSpec oldAggregate newAggregate = @@ -222,37 +217,77 @@ changedTransitionEvents :: [Transition] -> [Transition] -> (Set Name, Bool) changedTransitionEvents oldTransitions newTransitions = - go oldTransitions newTransitions Set.empty False + foldl' + (\(affected, changed) key -> let (groupAffected, groupChanged) = compareGroup key in (affected <> groupAffected, changed || groupChanged)) + (Set.empty, False) + (Set.toAscList allKeys) where - go [] _ affected changed = (affected, changed) - go (oldTransition : remainingOld) remainingNew affected changed = - case find (sameSurface oldTransition) remainingNew of - Just exact -> - go remainingOld (delete exact remainingNew) affected changed - Nothing -> - case find (sameIdentity oldTransition) remainingNew of - Just candidate - | guardOnlyLoosening oldTransition candidate -> - go remainingOld (delete candidate remainingNew) affected changed - | otherwise -> - go - remainingOld - (delete candidate remainingNew) - (affected <> emittedBy oldTransition <> emittedBy candidate) - True - Nothing -> - go - remainingOld - remainingNew - (affected <> emittedBy oldTransition) - True + oldGroups = transitionGroups oldTransitions + newGroups = transitionGroups newTransitions + allKeys = Map.keysSet oldGroups <> Map.keysSet newGroups + compareGroup key = + let (afterExactOld, afterExactNew) = cancelExact (Map.findWithDefault [] key oldGroups) (Map.findWithDefault [] key newGroups) + (remainingOld, remainingNew) = cancelLoosenings afterExactOld afterExactNew + sortedOld = sortOn transitionSortKey remainingOld + sortedNew = sortOn transitionSortKey remainingNew + (pairedOld, unpairedOld) = splitAt (length sortedNew) sortedOld + pairedNew = take (length pairedOld) sortedNew + pairedEvents = Set.unions [emittedBy old <> emittedBy new | (old, new) <- zip pairedOld pairedNew] + removedEvents = Set.unions (map emittedBy unpairedOld) + changed = not (null pairedOld) || not (null unpairedOld) + in (pairedEvents <> removedEvents, changed) - sameSurface left right = renderTransition left == renderTransition right - sameIdentity left right = - tMode left == tMode right - && tSource left == tSource right - && tCommand left == tCommand right + transitionGroups = + Map.fromListWith (<>) + . map (\transition -> (transitionIdentity transition, [transition])) + transitionIdentity transition = + ( modeKey (tMode transition), + tSource transition, + tCommand transition + ) + modeKey TmLive = "live" :: Text + modeKey TmReplayOnly = "replay-only" + transitionSortKey transition = + (maybe "" canonicalExpr (tGuard transition), canonicalTransition transition) emittedBy = Set.fromList . tEmits + +-- | Remove byte-identical transitions as a multiset. Sorting makes duplicate +-- cancellation independent of declaration order. +cancelExact :: [Transition] -> [Transition] -> ([Transition], [Transition]) +cancelExact oldTransitions newTransitions = go sortedOld sortedNew [] [] + where + sortedOld = sortOn canonicalTransition oldTransitions + sortedNew = sortOn canonicalTransition newTransitions + go [] remainingNew unmatchedOld unmatchedNew = (reverse unmatchedOld, reverse unmatchedNew <> remainingNew) + go remainingOld [] unmatchedOld unmatchedNew = (reverse unmatchedOld <> remainingOld, reverse unmatchedNew) + go old@(oldTransition : remainingOld) new@(newTransition : remainingNew) unmatchedOld unmatchedNew = + case compare (canonicalTransition oldTransition) (canonicalTransition newTransition) of + LT -> go remainingOld new (oldTransition : unmatchedOld) unmatchedNew + EQ -> go remainingOld remainingNew unmatchedOld unmatchedNew + GT -> go old remainingNew unmatchedOld (newTransition : unmatchedNew) + +-- | Deterministically cancel every provable guard-only loosening. At each step +-- the lexicographically smallest canonical pair wins, so ambiguous siblings do +-- not inherit declaration-order semantics. +cancelLoosenings :: [Transition] -> [Transition] -> ([Transition], [Transition]) +cancelLoosenings oldTransitions newTransitions = + case sortOn looseningPairKey candidates of + [] -> (oldTransitions, newTransitions) + (oldTransition, newTransition) : _ -> + cancelLoosenings (delete oldTransition oldTransitions) (delete newTransition newTransitions) + where + candidates = + [ (oldTransition, newTransition) + | oldTransition <- oldTransitions, + newTransition <- newTransitions, + guardOnlyLoosening oldTransition newTransition + ] + looseningPairKey (oldTransition, newTransition) = + ( maybe "" canonicalExpr (tGuard oldTransition), + canonicalTransition oldTransition, + maybe "" canonicalExpr (tGuard newTransition), + canonicalTransition newTransition + ) -- | A syntactically provable loosening preserves every old transition match. -- diff --git a/src/Keiro/Dsl/Scaffold.hs b/src/Keiro/Dsl/Scaffold.hs --- a/src/Keiro/Dsl/Scaffold.hs +++ b/src/Keiro/Dsl/Scaffold.hs @@ -1,5479 +1,5915 @@ -- | The scaffold engine. Given an 'Aggregate' (and a 'Context' naming the --- service and output module-namespace root), it emits the __symbol-free --- deterministic layer__ as @-- \@generated@ modules plus a single create-if-absent --- @Holes.hs@ holding the typed holes a human or coding agent must fill. --- --- The load-bearing invariant of this module is the __firewall__: no @Generated@ --- module ever contains a keiki symbolic operator (@./=@, @.==@, @.||@, @lit@, --- @B.slot@, @B.requireGuard@). Those live only in the hand-owned @Holes.hs@. A --- test ('Generated' text scan) enforces it. --- --- Scope (EP-1, recorded in the plan's Decision Log): the scaffolder does /not/ --- emit the symbolic transducer body — that is the @buildTransducer@ hole in --- @Holes.hs@, pinned by the harness. It also does not emit the read-model SQL --- (the projection @apply@), which is a DB-coupled hole delegated to @codd@/the --- agent; the @Generated@ Projection module emits only the deterministic --- @InlineProjection@ wiring and the pure event→status mapping. The decode emitted --- here is /strict/ (every field required); lenient\/optional decode is EP-4's --- concern. -module Keiro.Dsl.Scaffold - ( ScaffoldModule (..), - ModuleKind (..), - Context (..), - Placement (..), - defaultContext, - genPrefixFor, - holePrefixFor, - generatedNominalModule, - NominalUseSite (..), - NominalGenerationOwner (..), - planNominalGeneration, - planNominalGenerationForService, - generatedNominalsInTypes, - generatedNominalTypeImports, - generatedNominalTypeImportsForService, - generatedIdSampleHaskell, - scaffoldReplayAudit, - scaffoldStructural, - scaffoldStructuralForService, - scaffoldStructuralOwners, - scaffoldStructuralOwnersForService, - codecComparisonModule, - codecComparisonBanner, - bindingSkeletonModules, - bindingSkeletonOwners, - scaffoldAggregateForService, - scaffoldAggregate, - obsoleteGeneratedOutputHooks, - scaffoldProcess, - scaffoldRouter, - scaffoldContract, - scaffoldIntake, - scaffoldPublisher, - scaffoldWorkqueue, - scaffoldReadModel, - scaffoldRefusals, - windowSeconds, - - -- * Firewall self-check (M3) - FirewallSurface (..), - firewallSurface, - firewallBreaches, - - -- * Internal resolution, shared with "Keiro.Dsl.Harness" - Agg (..), - aggregateCheckedService, - ResolvedRegister (..), - ResolvedCtor (..), - StructuralProjection (..), - resolveAggForService, - resolveAgg, - nominalEqualityUsedInGeneratedExpressions, - projectionSpecs, - resolveProjectionModules, - nominalProjectionModule, - codecMappedDeclarations, - FieldCat (..), - fieldCat, - vertexCtor, - initialVertex, - firstEnumCtor, - lowerFirst, - pascal, - pascalFromKebab, - generatedBanner, - ) -where - -import Data.Char (isAlpha, isAlphaNum, isUpper, ord, toLower, toUpper) -import Data.List (find, findIndex, groupBy, isSuffixOf, nub, sort, sortOn) -import Data.List.NonEmpty (NonEmpty) -import Data.List.NonEmpty qualified as NE -import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe, isJust, mapMaybe) -import Data.Set qualified as Set -import Data.Text (Text) -import Data.Text qualified as T -import Keiro.Dsl.AggregateType -import Keiro.Dsl.BehaviorCoverage qualified as Behavior -import Keiro.Dsl.CodecCompare (BranchArm (..), BranchField (..), BranchSchema (..)) -import Keiro.Dsl.EventOutput -import Keiro.Dsl.ExplainBindings (BindingObligation (..), BindingObligationKind (..), bindingObligations) -import Keiro.Dsl.Expression -import Keiro.Dsl.FoldFingerprint (aggregateFoldFingerprintForService) -import Keiro.Dsl.Grammar -import Keiro.Dsl.IdDomain (IdDomainContract, idDomainContractFor, idDomainPrefix, idDomainSampleText) -import Keiro.Dsl.NominalType -import Keiro.Dsl.PrettyPrint (renderExpr) -import Keiro.Dsl.ReadModelShape (registryNameFor, subscriptionNameFor) -import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, legacyCheckedService) -import Keiro.Dsl.TypeGraph -import Keiro.Dsl.Validate (sagaCategoryError) -import Numeric (showHex) -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) - -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 --- @\.Generated.\.\@ (identical to the historical layout); for --- 'CollocatedLeaf' it is @\.\.\.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 hand-owned (hole) namespace for a 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 = case placement ctx of - GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".Nominals" - CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.Nominals" - --- | The root namespace prefix, dot-terminated, or @""@ when no root is set. -rootPrefix :: Context -> Text -rootPrefix ctx = case moduleRoot ctx of r | T.null r -> ""; r -> r <> "." - --- | The context name in PascalCase, e.g. @hospital-capacity@ -> @HospitalCapacity@. -ctxPascalOf :: Context -> Text -ctxPascalOf = pascalFromKebab . contextName - --------------------------------------------------------------------------------- --- Firewall self-check (M3) --------------------------------------------------------------------------------- - --- | The canonical keiki surface forbidden in generated modules. Symbolic --- operators are matched as maximal Haskell symbol tokens, identifiers as complete --- tokens, qualifiers by their leading module alias, and imports structurally. -data FirewallSurface = FirewallSurface - { forbiddenSymbolic :: ![Text], - forbiddenIdents :: ![Text], - forbiddenQualifiers :: ![Text], - forbiddenImports :: ![Text], - restrictedImports :: ![(Text, [Text])] - } - deriving stock (Eq, Show) - -firewallSurface :: FirewallSurface -firewallSurface = - FirewallSurface - { forbiddenSymbolic = [".==", "./=", ".<", ".<=", ".>", ".>=", ".&&", ".||", ".+", ".-", ".*", "=:", "*:"], - forbiddenIdents = ["lit", "pnot", "tadd", "tsub", "tmul"], - forbiddenQualifiers = ["B"], - forbiddenImports = ["Keiki.Builder", "Keiki.Operators", "Keiki.Symbolic"], - -- Generated aggregate modules use the first two names; generated - -- harnesses validate, step, and replay filled holes register by register. - restrictedImports = - [ ( "Keiki.Core", - [ "RegFile", - "HsPred", - "FieldProjection", - "ExactFieldProjection", - "FieldWitness", - "fieldWitness", - "exactFieldWitness", - "fieldWitnessAgrees", - "applyEventsEither", - "defaultValidationOptions", - "step", - "validateTransducer", - "EdgeMode", - "EdgeRef", - "StepSuccess", - "StepFailure", - "ReplayEventSpan", - "ReplayAttribution", - "ReplaySuccess", - "applyEventsDetailedEither", - "stepDetailedEither", - "!" - ] - ) - ] - } - --- | Scan generated modules for firewall breaches, returning every offending --- @(module path, token, 1-based line number)@. Only modules whose 'kind' is --- 'Generated' are scanned. Strings and comments are skipped, symbol runs use --- maximal munch, and keiki imports are checked independently of token spelling. -firewallBreaches :: [ScaffoldModule] -> [(FilePath, Text, Int)] -firewallBreaches mods = - [ (modulePath m, breach, n) - | m <- mods, - kind m == Generated, - not (authoritativeScalarModule (modulePath m)), - (n, line) <- zip [1 ..] (T.lines (moduleText m)), - breach <- lineBreaches line - ] - --- Version-2 aggregate expression and transducer modules are the narrow, --- intentional exception to the generated symbolic-operator firewall: they --- are precisely the generated authority that constructs Keiki terms. Every --- other generated module remains subject to the original firewall. -authoritativeScalarModule :: FilePath -> Bool -authoritativeScalarModule path = - any (`isSuffixOf` path) ["/Expressions.hs", "/Transducer.hs"] - -lineBreaches :: Text -> [Text] -lineBreaches line = case importModule line of - Just _ -> importBreaches line - Nothing -> tokenBreaches (codeTokens line) - where - tokenBreaches = mapMaybe breachFor - breachFor (IdentToken ident) - | ident `elem` forbiddenIdents firewallSurface = Just ident - breachFor (QualifiedToken qualifier) - | qualifier `elem` forbiddenQualifiers firewallSurface = Just (qualifier <> ".*") - breachFor (SymbolToken symbol) - | symbol `elem` forbiddenSymbolic firewallSurface = Just symbol - breachFor _ = Nothing - -data CodeToken = IdentToken !Text | QualifiedToken !Text | SymbolToken !Text - -codeTokens :: Text -> [CodeToken] -codeTokens = go . T.unpack - where - go [] = [] - go ('-' : '-' : _) = [] - go ('"' : rest) = go (dropString rest) - go ('\'' : rest) = go (dropChar rest) - go (c : rest) - | isIdentStart c = - let (identTail, afterIdent) = span isIdentContinue rest - ident = T.pack (c : identTail) - in case afterIdent of - '.' : next : more - | isUpper c && isIdentStart next -> - let (_member, afterMember) = span isIdentContinue more - in QualifiedToken ident : go afterMember - _ -> IdentToken ident : go afterIdent - | isSymbolChar c = - let (symbolTail, afterSymbol) = span isSymbolChar rest - in SymbolToken (T.pack (c : symbolTail)) : go afterSymbol - | otherwise = go rest - isIdentStart c = isAlpha c || c == '_' - isIdentContinue c = isAlphaNum c || c == '_' || c == '\'' - isSymbolChar c = c `elem` ("!#$%&*+./<=>?@\\^|-~:" :: String) - dropString [] = [] - dropString ('\\' : _escaped : rest) = dropString rest - dropString ('"' : rest) = rest - dropString (_ : rest) = dropString rest - dropChar [] = [] - dropChar ('\\' : _escaped : rest) = dropChar rest - dropChar ('\'' : rest) = rest - dropChar (_ : rest) = dropChar rest - -importBreaches :: Text -> [Text] -importBreaches line = case importModule line of - Nothing -> [] - Just imported - | imported `elem` forbiddenImports firewallSurface -> ["import:" <> imported] - | Just allowed <- lookup imported (restrictedImports firewallSurface), - not (hasAllowedExplicitImportList allowed line) -> - ["import:" <> imported] - | otherwise -> [] - -importModule :: Text -> Maybe Text -importModule line = case T.words (T.strip line) of - "import" : rest -> find (T.isPrefixOf "Keiki.") rest - _ -> Nothing - -hasAllowedExplicitImportList :: [Text] -> Text -> Bool -hasAllowedExplicitImportList allowed line = - case (T.breakOn "(" line, T.breakOnEnd ")" line) of - ((_, open), (close, _)) - | not (T.null open) && not (T.null close) -> - let inside = T.takeWhile (/= ')') (T.drop 1 open) - names = filter (not . T.null) (T.split (not . isAlphaNum) inside) - in all (`elem` allowed) names - _ -> False - --------------------------------------------------------------------------------- --- Derived naming --------------------------------------------------------------------------------- - --- | Resolved, denormalized view of an aggregate used by every emitter. -data Agg = Agg - { aContext :: !Context, - aLanguageContract :: !EffectiveLanguageContract, - aSpec :: !Spec, - aAggregate :: !Aggregate, - aCtxPascal :: !Text, - aName :: !Text, - aLoc :: !Loc, - aVertexType :: !Text, - aIds :: ![IdDecl], - aEnums :: ![EnumDecl], - aRegs :: ![ResolvedRegister], - aStates :: ![StateDecl], - aCommands :: ![ResolvedCtor], - aEvents :: ![ResolvedCtor], - -- | Generated IDs and enums used by this aggregate, in stable name order. - aGeneratedNominals :: ![ResolvedNominalType], - aTransitions :: ![Transition], - aOutputMappings :: !(Map.Map (Int, Int) EventOutputMapping), - aWire :: !WireSpec, - aProjection :: !(Maybe ProjectionSpec), - aSnapshot :: !(Maybe SnapshotSpec), - aFoldFingerprint :: !Text, - aReadModels :: ![ReadModelNode], - aTypeGraph :: !(Maybe TypeGraph), - aSymbols :: !AggregateSymbols, - -- | e.g. @Generated.HospitalCapacity.Reservation@ - aGenPrefix :: !Text, - -- | e.g. @HospitalCapacity.Reservation@ - aHolePrefix :: !Text - } - -aggregateCheckedService :: Agg -> CheckedService -aggregateCheckedService aggregate = - CheckedService - { checkedLanguageContract = aLanguageContract aggregate, - checkedSpec = aSpec aggregate - } - -data ResolvedRegister = ResolvedRegister - { rrName :: !Name, - rrType :: !ResolvedAggregateType, - rrInitial :: !ResolvedRegisterInitial, - rrLoc :: !Loc - } - deriving stock (Eq, Show) - --- | A command or event constructor with its fully-resolved field types. -data ResolvedCtor = ResolvedCtor - { rcName :: !Text, - -- | (field name, canonical aggregate type) - rcFields :: ![(Text, ResolvedAggregateType)], - -- | EP-2: schema version (1 for commands and unversioned events). - rcVersion :: !Int, - -- | EP-2: the source version this event migrates from (the upcaster step). - rcUpcastFrom :: !(Maybe Int) - } - -defaultWire :: WireSpec -defaultWire = WireSpec {wireKind = "ctorName", wireFields = "camelCase", wireSchemaVersion = 1} - -resolveAgg :: Context -> Spec -> Aggregate -> Agg -resolveAgg ctx spec = resolveAggForService ctx (legacyCheckedService spec) - --- | Resolve one aggregate under the service's effective runtime semantics. -resolveAggForService :: Context -> CheckedService -> Aggregate -> Agg -resolveAggForService ctx service agg = - Agg - { aContext = ctx, - aLanguageContract = checkedLanguageContract service, - aSpec = spec, - aAggregate = agg, - aCtxPascal = ctxPascal, - aName = nm, - aLoc = aggLoc agg, - aVertexType = vertexType, - aIds = specIds spec, - aEnums = specEnums spec, - aRegs = map resolveRegister (aggRegs agg), - aStates = aggStates agg, - aCommands = map resolveCommand (aggCommands agg), - aEvents = map resolveEvent (aggEvents agg), - aGeneratedNominals = generatedNominalsInTypes aggregateResolvedTypes, - aTransitions = aggTransitions agg, - aOutputMappings = - Map.fromList - [ ( (transitionIndex, emitIndex), - orDieOutput (eventOutputMapping spec agg transition emitIndex eventName) - ) - | (transitionIndex, transition) <- zip [1 ..] (aggTransitions agg), - (emitIndex, eventName) <- zip [1 ..] (tEmits transition) - ], - aWire = fromMaybe defaultWire (aggWire agg), - aProjection = aggProjection agg, - aSnapshot = aggSnapshot agg, - aFoldFingerprint = aggregateFoldFingerprintForService service agg, - aReadModels = [readModel | NReadModel readModel <- specNodes spec], - aTypeGraph = either (const Nothing) Just (resolveTypeGraph spec), - aSymbols = symbols, - aGenPrefix = genPrefixFor ctx nm, - aHolePrefix = holePrefixFor ctx nm - } - where - spec = checkedSpec service - nm = aggName agg - symbols = aggregateSymbols spec - ctxPascal = pascalFromKebab (contextName ctx) - vertexType = nm <> "Vertex" - commandFieldTypes = [(cmdName c, cmdFields c) | c <- aggCommands agg] - resolveCommand c = (mkCtor CommandFieldUse (cmdName c) (cmdFields c)) {rcVersion = 1, rcUpcastFrom = Nothing} - resolveEvent e = - (mkCtor EventFieldUse (evName e) (eventFields e)) - { rcVersion = evVersion e, - rcUpcastFrom = fst <$> evUpcastFrom e - } - where - eventFields ev = case evBody ev of - EventFields fs -> fs - EventFromCommand cn -> fromMaybe [] (lookup cn commandFieldTypes) - mkCtor useSite cn fs = - ResolvedCtor - { rcName = cn, - rcFields = map (\field -> (aggregateFieldName field, orDie (inferAggregateFieldType symbols agg useSite field))) fs, - rcVersion = 1, - rcUpcastFrom = Nothing - } - aggregateResolvedTypes = - map rrType (map resolveRegister (aggRegs agg)) - <> map snd (concatMap rcFields (map resolveCommand (aggCommands agg))) - <> map snd (concatMap rcFields (map resolveEvent (aggEvents agg))) - resolveRegister register = - let resolvedType = orDie (resolveAggregateType symbols (regLoc register) RegisterUse (regType register)) - resolvedInitial = orDie (resolveRegisterInitial symbols (regLoc register) resolvedType (regInitial register)) - in ResolvedRegister - { rrName = regName register, - rrType = resolvedType, - rrInitial = resolvedInitial, - rrLoc = regLoc register - } - orDie = either (error . ("validated aggregate resolution failed: " <>) . show) id - orDieOutput = either (error . ("validated aggregate output resolution failed: " <>) . show) id - --- | Keep only generated nominal IDs/enums from a resolved aggregate type list. --- The map both deduplicates and makes declaration/import order independent of --- member and field order. -generatedNominalsInTypes :: [ResolvedAggregateType] -> [ResolvedNominalType] -generatedNominalsInTypes resolvedTypes = - Map.elems . Map.fromList $ - [ (resolvedNominalName nominal, nominal) - | AggregateNominal nominal <- resolvedTypes, - GeneratedNominal <- [resolvedNominalOwnership nominal] - ] - --- | Plan declaration ownership and use closure without emitting text. Parsing --- and validation already reject malformed declarations; retaining the checked --- error here keeps this function total for direct library callers. -planNominalGeneration :: Context -> Spec -> Either (NonEmpty NominalTypeError) [NominalGenerationOwner] -planNominalGeneration ctx spec = planNominalGenerationForService ctx (legacyCheckedService spec) - -planNominalGenerationForService :: Context -> CheckedService -> Either (NonEmpty NominalTypeError) [NominalGenerationOwner] -planNominalGenerationForService ctx service = do - registry <- resolveNominalTypes spec - let aggregates = [resolveAggForService ctx service aggregate | NAggregate aggregate <- specNodes spec] - generated = - [ nominal - | nominal <- Map.elems (nominalTypes registry), - GeneratedNominal <- [resolvedNominalOwnership nominal] - ] - pure - [ NominalGenerationOwner - { nominalDeclaration = nominal, - nominalModule = generatedNominalModule ctx, - nominalUseSites = Set.fromList (concatMap (usesFor nominal) aggregates), - nominalEqualityUsed = any (nominalEqualityUsedInGeneratedExpressions nominal) aggregates - } - | nominal <- generated - ] - where - spec = checkedSpec service - usesFor nominal aggregate = - [ NominalUseSite (aName aggregate) useKind - | useKind <- aggregateUseKinds nominal aggregate - ] - -nominalEqualityUsedInGeneratedExpressions :: ResolvedNominalType -> Agg -> Bool -nominalEqualityUsedInGeneratedExpressions nominal aggregate = - any (anyTypedExpression comparesNominal) (resolvedGeneratedExpressions aggregate) - where - comparesNominal expression = case typedScalarNode expression of - TypedEqual left _ -> typedScalarType left == AggregateNominal nominal - TypedNotEqual left _ -> typedScalarType left == AggregateNominal nominal - _ -> False - -aggregateUseKinds :: ResolvedNominalType -> Agg -> [AggregateUseSite] -aggregateUseKinds nominal aggregate = - nub $ - [RegisterUse | nominal `elem` registerNominals] - <> [CommandFieldUse | nominal `elem` commandNominals] - <> [EventFieldUse | nominal `elem` eventNominals] - <> [CodecUse | nominal `elem` eventNominals] - <> [SnapshotUse | hasSnapshot aggregate && nominal `elem` registerNominals] - <> [HarnessSampleUse | nominal `elem` commandNominals || nominal `elem` eventNominals] - <> [HaskellLoweringUse | nominal `elem` aGeneratedNominals aggregate] - where - registerNominals = generatedNominalsInTypes (map rrType (aRegs aggregate)) - commandNominals = generatedNominalsInTypes (map snd (concatMap rcFields (aCommands aggregate))) - eventNominals = generatedNominalsInTypes (map snd (concatMap rcFields (aEvents aggregate))) - --------------------------------------------------------------------------------- --- Entry point --------------------------------------------------------------------------------- - --- | Emit the context-level private structural stratum. Shape modules contain --- only generated wire representations. The projection facade contains only --- schema-derived Keiki field witnesses; neither layer owns consumer behavior. -scaffoldStructural :: Context -> Spec -> [ScaffoldModule] -scaffoldStructural ctx spec = scaffoldStructuralForService ctx (legacyCheckedService spec) - -scaffoldStructuralForService :: Context -> CheckedService -> [ScaffoldModule] -scaffoldStructuralForService ctx service = map fst (scaffoldStructuralOwnersForService ctx service) - --- | 'scaffoldStructural' paired with the mapped declarations each module was --- emitted for. A shape module names exactly one declaration; a binding skeleton --- names every declaration whose obligations it carries (several declarations may --- share one leaf binding module); the projection facade names __none__, because it --- is emitted once for the whole context from the complete resolved graph. --- --- This is the attribution seam whole-workspace scaffolding needs: a workspace --- emits from one merged spec, and this list says which declaration — and therefore --- which member file — produced each structural module, without parsing the --- human-readable 'origin' string. -scaffoldStructuralOwners :: Context -> Spec -> [(ScaffoldModule, [Name])] -scaffoldStructuralOwners ctx spec = scaffoldStructuralOwnersForService ctx (legacyCheckedService spec) - -scaffoldStructuralOwnersForService :: Context -> CheckedService -> [(ScaffoldModule, [Name])] -scaffoldStructuralOwnersForService ctx service = case resolveTypeGraph (checkedSpec service) of - Left _ -> [] - Right graph -> - [(shapeModule ctx graph entry, [sdName (fst entry)]) | entry <- structural] - <> projectionModules - <> generatedNominalOwners ctx service - <> nominalRepresentationOwners ctx spec - <> nominalProjectionOwners ctx service - <> bindingSkeletonOwners ctx spec graph - where - structural = - [ (declaration, shape) - | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph) - ] - projectionModules = - [ ( ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" (structuralProjectionModule ctx) <> ".hs"), - moduleText = emitStructuralProjections ctx graph, - kind = Generated, - origin = "context " <> specContext spec <> " mapped structural facade" - }, - [] - ) - | not (null (projectionSpecs graph)) - ] - spec = checkedSpec service - --- | Plan one opt-in, non-production historical-codec comparison module. --- --- The module is intentionally absent from 'scaffoldStructural' and therefore --- from production manifests and scaffold records. It must be requested by name --- and is compiled only by consumer-owned test/tool components. -codecComparisonModule :: Context -> Spec -> Name -> Either Text ScaffoldModule -codecComparisonModule ctx spec requestedName = do - graph <- either (Left . ("mapped type graph did not resolve: " <>) . T.pack . show) Right (resolveTypeGraph spec) - (declaration, shape) <- case Map.lookup (MappedKey requestedName) (tgDeclarations graph) of - Nothing -> Left ("codec comparison target is not a mapped declaration: " <> requestedName) - Just (ResolvedOpaque _) -> - Left - ( "codec comparison target " - <> requestedName - <> " is opaque; finite evidence must never upgrade an opaque declaration to a structural claim" - ) - Just (ResolvedStructural declaration shape) -> Right (declaration, shape) - owner <- case sortOn aggName (comparisonOwners declaration) of - [] -> - Left - ( "codec comparison target " - <> requestedName - <> " is not reachable from a persisted private event payload" - ) - aggregate : _ -> Right aggregate - let moduleName = structuralPrefix ctx <> ".CodecCompare." <> requestedName - pure - ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"), - moduleText = emitCodecComparison ctx moduleName graph declaration shape owner, - kind = Generated, - origin = "non-production codec comparison " <> requestedName - } - where - comparisonOwners declaration = - [ aggregate - | NAggregate aggregate <- specNodes spec, - let resolved = resolveAgg ctx spec aggregate, - any ((== sdName declaration) . mappedName) (codecMappedDeclarations resolved) - ] - where - mappedName (ResolvedStructural structural _) = sdName structural - mappedName (ResolvedOpaque opaque) = odName opaque - -codecComparisonBanner :: Text -codecComparisonBanner = - "-- @generated by keiro-dsl codec comparison; non-production migration evidence; do not edit." - -emitCodecComparison :: Context -> Text -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Aggregate -> Text -emitCodecComparison ctx moduleName graph declaration shape owner = - nl - [ "", - codecComparisonBanner, - "-- This module compares historical and generated codecs in consumer-owned tests only.", - "-- It is never a runtime fallback and never changes the generated codec's authority.", - "module " <> moduleName <> " (compareWithHistorical) where", - "", - "import Control.Monad (filterM)", - "import Data.Aeson (Value)", - "import Data.Aeson qualified as Aeson", - "import Data.List (sort)", - "import Data.List.NonEmpty qualified as NonEmpty", - "import Data.Text (Text)", - "import Data.Text qualified", - "import " <> codecModule <> " qualified as GeneratedCodec", - "import Keiro.Codec.Structural (FixtureCases (..))", - "import Keiro.Dsl.CodecCompare", - "import Keiro.Dsl.TypeGraph (BindingVersion (..), CanonicalTypeId (..), QualifiedValueName (..))", - "import System.Directory (doesFileExist, listDirectory)", - "import System.FilePath (takeExtension, ())", - "", - "import " <> fixtureModule <> " qualified as ConsumerFixtures", - "import " <> hsModule (sdHaskell declaration) <> " qualified as ConsumerDomain", - "", - "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 ConsumerFixtures." <> fixtureSymbol <> ")", - " 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 = "ConsumerDomain." <> hsType (sdHaskell declaration) - codecModule = genPrefixFor ctx (aggName owner) <> ".Codec" - fixtureModule = qualifiedModule (sdFixtures declaration) - fixtureSymbol = lastSegment (unQualifiedValueName (sdFixtures declaration)) - -branchSchemaFor :: TypeGraph -> ResolvedMappedDecl -> BranchSchema -branchSchemaFor graph = - foldMappedDecl - MappedDeclAlgebra - { onStructuralDecl = \_ shape -> - foldMappedShape - MappedShapeAlgebra - { onRecord = \_ _ fields -> - BranchRecord - [ BranchField - (rwfKey field) - (rwfPresence field == POptional) - (branchExpr graph (rwfType field)) - | field <- fields - ], - onEnum = const BranchScalar, - onUnion = \encoding arms -> - BranchUnion - (ueTagField encoding) - (ueContentsField encoding) - [BranchArm (rwaTag arm) (branchExpr graph <$> rwaPayload arm) | arm <- arms] - } - shape, - onOpaqueDecl = const BranchScalar - } - -branchExpr :: TypeGraph -> ResolvedTypeExpr -> BranchSchema -branchExpr graph = - foldTypeExpr - TypeExprAlgebra - { onText = BranchScalar, - onInt = BranchScalar, - onInteger = BranchScalar, - onBool = BranchScalar, - onNatural = BranchScalar, - onTime = BranchScalar, - onJson = BranchScalar, - onOptional = BranchOptional, - onList = BranchList, - onMap = BranchMap, - onRef = \key -> maybe BranchScalar (branchSchemaFor graph) (Map.lookup key (tgDeclarations graph)) - } - -renderBranchSchema :: BranchSchema -> Text -renderBranchSchema schema = case schema of - BranchScalar -> "BranchScalar" - BranchOptional nested -> "BranchOptional (" <> renderBranchSchema nested <> ")" - BranchList nested -> "BranchList (" <> renderBranchSchema nested <> ")" - BranchMap nested -> "BranchMap (" <> renderBranchSchema nested <> ")" - BranchRecord fields -> - "BranchRecord [" - <> T.intercalate - ", " - [ "BranchField " - <> tshow (bfWireKey field) - <> " " - <> (if bfPresenceOptional field then "True" else "False") - <> " (" - <> renderBranchSchema (bfSchema field) - <> ")" - | field <- fields - ] - <> "]" - BranchUnion tagField contentsField arms -> - "BranchUnion " - <> tshow tagField - <> " " - <> tshow contentsField - <> " [" - <> T.intercalate - ", " - [ "BranchArm " - <> tshow (baWireTag arm) - <> " " - <> maybe "Nothing" (\nested -> "(Just (" <> renderBranchSchema nested <> "))") (baPayloadSchema arm) - | arm <- arms - ] - <> "]" - --- | Emit one create-once consumer module per distinct qualified obligation --- owner. Multiple mapped declarations may intentionally share a leaf binding --- module, so grouping happens by module rather than by declaration. -bindingSkeletonModules :: Context -> Spec -> TypeGraph -> [ScaffoldModule] -bindingSkeletonModules ctx spec graph = map fst (bindingSkeletonOwners ctx spec graph) - --- | 'bindingSkeletonModules' paired with the mapped declarations whose --- obligations each skeleton carries, in first-appearance order. A skeleton shared --- by declarations from different member files therefore names all of them, which --- is what lets whole-workspace scaffolding treat it as context-level rather than --- attributing it to an arbitrary member. -bindingSkeletonOwners :: Context -> Spec -> TypeGraph -> [(ScaffoldModule, [Name])] -bindingSkeletonOwners ctx spec graph = case bindingObligations spec of - Left _ -> [] - Right obligations -> - [ (emitBindingSkeleton ctx spec graph owner entries, nub (map obligationMappedName entries)) - | (owner, entries) <- Map.toAscList (Map.fromListWith (<>) [(obligationModule obligation, [obligation]) | obligation <- obligations]) - ] - -emitBindingSkeleton :: Context -> Spec -> TypeGraph -> Text -> [BindingObligation] -> ScaffoldModule -emitBindingSkeleton ctx spec graph owner obligations = - ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" owner <> ".hs"), - moduleText = - nl $ - [ "{-# LANGUAGE DataKinds #-}", - "{-# LANGUAGE LambdaCase #-}", - "", - "-- This is a HAND-OWNED consumer binding skeleton. keiro-dsl creates it once", - "-- and never overwrites it. Fill each HOLE and run the generated harness.", - "module " <> owner <> " (" - ] - <> exportLines - <> [") where", ""] - <> map ("import " <>) imports - <> [""] - <> 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 - ] - imports = - sort . nub $ - [ hsModule (sdHaskell declaration) <> " qualified" - | obligation <- obligations, - Just (declaration, _) <- [structuralFor obligation] - ] - <> [ structuralShapeModule ctx (sdName declaration) <> " qualified" - | obligation <- obligations, - obligationKind obligation == BindingValue, - Just (declaration, _) <- [structuralFor obligation] - ] - <> [ "Keiro.Codec.Structural (FixtureCases, StructuralBinding (..))" - | any (\obligation -> obligationCategory obligation == "structural" && obligationKind obligation `elem` [BindingValue, FixtureValue]) obligations - ] - <> [ hsModule (consumerNominalHaskell binding) <> " qualified" - | obligation <- obligations, - Just (_, binding) <- [nominalFor obligation] - ] - <> [ nominalRepresentationModule ctx (resolvedNominalName nominal) <> " qualified" - | obligation <- obligations, - obligationKind obligation == BindingValue, - Just (nominal, _) <- [nominalFor obligation], - EnumRepresentation {} <- [resolvedNominalRepresentation nominal] - ] - <> [ "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, _) -> renderNominalObligation nominal obligation - Nothing -> ["-- HOLE: declaration disappeared before skeleton rendering"] - Just (declaration, shape) -> case obligationKind obligation of - BindingValue -> renderBinding ctx declaration shape obligation - FixtureValue -> - [ "-- HOLE: provide deterministic labelled conformance fixtures for " <> sdName declaration, - obligationSignature obligation, - obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> sdName declaration <> " fixtures") - ] - InitialValue -> - [ "-- HOLE: provide the initial register value for " <> sdName declaration, - obligationSignature 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 obligation = case obligationKind obligation of - BindingValue -> - [ "-- HOLE: complete both total directions; the generated codec remains wire authority.", - obligationSignature 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, - obligationSignature obligation, - obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " fixtures") - ] - InitialValue -> - [ "-- HOLE: provide the initial register value for " <> resolvedNominalName nominal, - obligationSignature obligation, - obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " initial value") - ] - intercalateBlank [] = [] - intercalateBlank (section : rest) = section <> concatMap ("" :) rest - -renderBinding :: Context -> StructuralDecl -> ResolvedMappedShape -> BindingObligation -> [Text] -renderBinding 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 - domainModule = hsModule (sdHaskell declaration) - domainType = domainModule <> "." <> hsType (sdHaskell declaration) - shapeModuleName = structuralShapeModule ctx (sdName declaration) - shapeType = shapeModuleName <> "." <> sdName declaration <> "Shape" - domainCtor constructor = domainModule <> "." <> constructor - shapeCtor constructor = 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 - ) - <> ")" - -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 - ( equalityPragmas - <> [ "{-# LANGUAGE DeriveAnyClass #-}", - "{-# LANGUAGE DeriveGeneric #-}", - "{-# LANGUAGE LambdaCase #-}", - generatedBanner, - moduleHeader, - "", - "import Data.Aeson (FromJSON, ToJSON)", - "import Data.Text (Text)", - "import GHC.Generics (Generic)", - "import Keiki.Shape (CanonicalTypeName)" - ] - <> internalImports - <> equalityImports - <> [ "", - sectionsOf [map emitOwner owners] - ] - ) - where - usesEquality = any nominalEqualityUsed owners - usesExactEquality = any (\owner -> nominalEqualityUsed owner && exactOwner (nominalDeclaration owner)) owners - 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 [] - equalityPragmas = - if usesEquality - then - [ "{-# LANGUAGE DataKinds #-}", - "{-# LANGUAGE TypeApplications #-}", - "{-# LANGUAGE TypeFamilies #-}" - ] - else [] - equalityImports = - ["import Keiki.Core (ExactFieldProjection (..), FieldProjection (..), FieldWitness, exactFieldWitness, fieldWitness)" | usesEquality] - <> ["import Data.List.NonEmpty (NonEmpty (..))" | usesExactEquality] - <> ["import Keiki.ProjectionDomain (finiteProjectionDomain)" | usesExactEquality && null enforcingIds] - <> ["import Keiki.ProjectionDomain (TextPattern, finiteProjectionDomain, textProjectionDomain)" | usesExactEquality && not (null enforcingIds)] - <> ["import Keiro.Codec.IdDomain (idDomainTextPattern, typeIdV7Domain)" | not (null enforcingIds)] - internalImports = - [ "import " - <> generatedNominalInternalModule ctx - <> " (" - <> T.intercalate - ", " - (concatMap (\nominal -> [resolvedNominalName nominal, "mk" <> resolvedNominalName nominal, "parse" <> resolvedNominalName nominal, nominalTextName nominal]) enforcingIds) - <> ")" - | not (null enforcingIds) - ] - emitOwner owner = emitGeneratedNominal languageContract (nominalEqualityUsed owner) (nominalDeclaration owner) - exactOwner nominal = case resolvedNominalRepresentation nominal of - EnumRepresentation {} -> True - IdRepresentation prefix -> isJust (idDomainContractFor languageContract prefix) - ScalarRepresentation {} -> False - -emitGeneratedNominal :: EffectiveLanguageContract -> Bool -> ResolvedNominalType -> Text -emitGeneratedNominal languageContract equalityUsed nominal = case resolvedNominalRepresentation nominal of - IdRepresentation prefix - | Just _ <- idDomainContractFor languageContract prefix -> - nl $ - ["instance CanonicalTypeName " <> name] - <> 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 - [ "{-# LANGUAGE DeriveGeneric #-}", - 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 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 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 _ _ [] = [] -generatedNominalTypeImportsForService service ctx nominals = - [ "import " - <> generatedNominalModule ctx - <> " (" - <> T.intercalate ", " (concatMap importsFor (stableNominals nominals)) - <> ")" - ] - where - importsFor nominal = case resolvedNominalRepresentation nominal of - IdRepresentation prefix - | Just _ <- idDomainContractFor (checkedLanguageContract service) prefix -> - [resolvedNominalName nominal, "parse" <> resolvedNominalName nominal] - _ -> [resolvedNominalName nominal <> " (..)"] - -generatedNominalCodecImports :: CheckedService -> Context -> [ResolvedNominalType] -> [Text] -generatedNominalCodecImports _ _ [] = [] -generatedNominalCodecImports service ctx nominals = - [ "import " - <> generatedNominalModule ctx - <> " (" - <> T.intercalate - ", " - ( concat - [ [typeImport nominal, nominalTextName nominal] - | nominal <- stableNominals nominals - ] - ) - <> ")" - ] - <> [ "import " - <> generatedNominalInternalModule ctx - <> " (" - <> T.intercalate ", " [legacyNominalConstructorName nominal | nominal <- enforcingIds] - <> ")" - | not (null enforcingIds) - ] - where - typeImport nominal = case resolvedNominalRepresentation nominal of - IdRepresentation prefix - | Just _ <- idDomainContractFor (checkedLanguageContract service) prefix -> resolvedNominalName nominal - _ -> resolvedNominalName 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 - [ "{-# LANGUAGE DeriveGeneric #-}", - "{-# LANGUAGE LambdaCase #-}", - generatedBanner, - "module " <> moduleName <> " (" <> representationType <> " (..), " <> encoderName <> ") where", - "", - "import Data.Text (Text)", - "import GHC.Generics (Generic)", - "", - "data " <> representationType <> " = " <> T.intercalate " | " (map fst (NE.toList constructors)), - " deriving stock (Eq, Generic, Ord, Show, Enum, Bounded)", - "", - encoderName <> " :: " <> representationType <> " -> Text", - encoderName <> " = \\case", - nl [" " <> constructor <> " -> " <> tshow wire | (constructor, wire) <- NE.toList constructors] - ], - kind = Generated, - origin = nodeOrigin "bound nominal enum representation" (resolvedNominalName nominal) (resolvedNominalLoc nominal) - } - where - moduleName = nominalRepresentationModule ctx (resolvedNominalName nominal) - representationType = resolvedNominalName nominal <> "Representation" - encoderName = lowerFirst (resolvedNominalName nominal) <> "RepresentationText" - -nominalProjectionModule :: Context -> Text -nominalProjectionModule ctx = case placement ctx of - GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".NominalProjections" - CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.NominalProjections" - -nominalProjectionOwners :: Context -> CheckedService -> [(ScaffoldModule, [Name])] -nominalProjectionOwners ctx service = case nominalProjectionTypes spec of - [] -> [] - nominals -> - [ ( ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" (nominalProjectionModule ctx) <> ".hs"), - moduleText = emitNominalProjections (checkedLanguageContract service) ctx nominals, - kind = Generated, - origin = "context " <> specContext spec <> " nominal scalar projection facade" - }, - [] - ) - ] - where - spec = checkedSpec service - -nominalProjectionTypes :: Spec -> [ResolvedNominalType] -nominalProjectionTypes spec = - Map.elems . Map.fromList $ - [ (resolvedNominalName nominal, nominal) - | aggregate <- [value | NAggregate value <- specNodes spec], - resolved <- registerTypes aggregate <> commandTypes aggregate, - AggregateNominal nominal <- [resolved], - ConsumerNominal {} <- [resolvedNominalOwnership nominal] - ] - where - symbols = aggregateSymbols spec - registerTypes aggregate = - [ resolved - | register <- aggRegs aggregate, - Right resolved <- [resolveAggregateType symbols (regLoc register) RegisterUse (regType register)] - ] - commandTypes aggregate = - [ resolved - | command <- aggCommands aggregate, - field <- cmdFields command, - Right resolved <- [inferAggregateFieldType symbols aggregate CommandFieldUse field] - ] - -emitNominalProjections :: EffectiveLanguageContract -> Context -> [ResolvedNominalType] -> Text -emitNominalProjections languageContract ctx nominals = - nl $ - [ "{-# LANGUAGE DataKinds #-}", - "{-# LANGUAGE TypeApplications #-}", - "{-# LANGUAGE TypeFamilies #-}", - generatedBanner, - "module " <> moduleName <> " where", - "" - ] - <> map ("import " <>) imports - <> [""] - <> [T.intercalate "\n\n" (map emitNominalProjection nominals)] - where - moduleName = nominalProjectionModule ctx - imports = - sort . nub $ - [ "Keiki.Core (ExactFieldProjection (..), FieldProjection (..), FieldWitness, exactFieldWitness, fieldWitness)", - "Keiro.Codec.Nominal (nominalFromRepresentation, nominalToRepresentation)" - ] - <> [hsModule (consumerNominalHaskell binding) <> " qualified" | nominal <- nominals, ConsumerNominal binding <- [resolvedNominalOwnership nominal]] - <> [qualifiedModule (consumerNominalBinding binding) <> " qualified" | nominal <- nominals, ConsumerNominal binding <- [resolvedNominalOwnership nominal]] - <> [nominalRepresentationModule ctx (resolvedNominalName nominal) <> " qualified" | nominal <- nominals, EnumRepresentation {} <- [resolvedNominalRepresentation nominal]] - <> ["Data.KindID qualified as KindID" | any hasId nominals] - <> ["Keiro.Codec.IdDomain (idDomainTextPattern, typeIdV7Domain, validateIdDomainText)" | any hasEnforcedId nominals] - <> ["Data.List.NonEmpty (NonEmpty (..))" | any hasExactDomain nominals] - <> ["Data.Text (Text)" | any usesText nominals] - <> ["Data.Time (UTCTime)" | any (hasScalar NominalTime) nominals] - <> ["Keiki.ProjectionDomain (TextPattern, finiteProjectionDomain, matchesTextPattern, textCharSet, textConcat, textLiteral, textProjectionDomain, textRepeatBetween)" | any hasExactDomain nominals] - <> ["Numeric.Natural (Natural)" | any (hasScalar NominalNatural) nominals] - 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 - hasExactDomain nominal = case resolvedNominalRepresentation nominal of ScalarRepresentation {} -> False; _ -> True - usesText nominal = case resolvedNominalRepresentation nominal of ScalarRepresentation NominalText -> True; IdRepresentation {} -> True; EnumRepresentation {} -> True; _ -> False - 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 <> " = " <> renderHaskellSource (consumerNominalHaskell binding), - " type FieldResult " <> tagName <> " = " <> scalarHaskellType (resolvedNominalRepresentation nominal), - " fieldShapeId _ = " <> tshow (unCanonicalTypeId (consumerNominalCanonical binding)), - " projectFieldValue _ = nominalToRepresentation " <> unQualifiedValueName (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 = renderHaskellSource (consumerNominalHaskell binding) - bindingName = unQualifiedValueName (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 <> " " <> representationModule <> "." <> constructor <> ")" - | (constructor, wire) <- NE.toList constructors - ] - <> [ " _ -> Nothing", - "", - witnessName <> " :: FieldWitness " <> tagName, - witnessName <> " = exactFieldWitness @" <> tagName - ] - where - name = resolvedNominalName nominal - tagName = nominalEqualityTagName nominal - witnessName = nominalEqualityWitnessName nominal - ownerType = renderHaskellSource (consumerNominalHaskell binding) - bindingName = unQualifiedValueName (consumerNominalBinding binding) - representationModule = nominalRepresentationModule ctx name - encoderName = representationModule <> "." <> lowerFirst name <> "RepresentationText" - 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 - <> ["" | not (null imports)] - <> [shapeDeclaration] - where - moduleName = structuralShapeModule ctx (sdName declaration) - shapeType = sdName declaration <> "Shape" - requirements = shapeRequirements ctx graph shape - languagePragmas = - ["{-# LANGUAGE DeriveGeneric #-}"] - <> ["{-# LANGUAGE DuplicateRecordFields #-}" | shapeHasRecord shape] - 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] - <> [m <> " qualified" | ReqModule m <- requirements] - shapeDeclaration = - foldMappedShape - MappedShapeAlgebra - { onRecord = \constructor _ fields -> - nl $ - ["data " <> shapeType <> " = " <> constructor] - <> recordFields - [ (rwfHaskell field, renderShapeType 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 ctx graph) (rwaPayload arm) - -data ShapeRequirement - = ReqJson - | ReqMap - | ReqText - | ReqTime - | ReqNatural - | ReqModule !Text - deriving stock (Eq, Ord, Show) - -shapeHasRecord :: ResolvedMappedShape -> Bool -shapeHasRecord = - foldMappedShape - MappedShapeAlgebra - { onRecord = \_ _ _ -> True, - onEnum = const False, - onUnion = \_ _ -> False - } - -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 _) -> [ReqModule (structuralShapeModule ctx (sdName declaration))] - Just (ResolvedOpaque declaration) -> [ReqModule (hsModule (odHaskell declaration))] - Nothing -> [] - } - -renderShapeType :: Context -> TypeGraph -> ResolvedTypeExpr -> Text -renderShapeType ctx graph = - foldTypeExpr - TypeExprAlgebra - { onText = "Text", - onInt = "Int", - onInteger = "Integer", - onBool = "Bool", - onNatural = "Natural", - onTime = "UTCTime", - onJson = "Value", - onOptional = \value -> "(Maybe (" <> value <> "))", - onList = \value -> "([" <> value <> "])", - onMap = \value -> "(Map Text (" <> value <> "))", - onRef = \key -> case Map.lookup key (tgDeclarations graph) of - Just (ResolvedStructural nested _) -> - structuralShapeModule ctx (sdName nested) <> "." <> sdName nested <> "Shape" - Just (ResolvedOpaque opaque) -> - hsModule (odHaskell opaque) <> "." <> hsType (odHaskell opaque) - Nothing -> "()" - } - -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 . 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 = projectionTag (sdName root) pointer, - spWitness = lowerFirst (projectionTag (sdName root) pointer) <> "Witness", - spPointer = pointer, - spOwner = sdHaskell root, - spResult = result, - spCanonical = sdCanonical root, - spBinding = sdBinding root, - spSelectors = selectors - } - where - pointer = T.concat ["/" <> escapePointer key | key <- keys] - -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" - -projectionTag :: Name -> Text -> Text -projectionTag owner pointer = "StructuralProjection" <> encodeIdentifier (owner <> pointer) - -encodeIdentifier :: Text -> Text -encodeIdentifier = T.concatMap (\character -> "C" <> T.pack (showHex (ord character) "") <> "Z") - -emitStructuralProjections :: Context -> TypeGraph -> Text -emitStructuralProjections ctx graph = - nl $ - [ "{-# LANGUAGE DataKinds #-}", - "{-# LANGUAGE TypeApplications #-}", - "{-# LANGUAGE TypeFamilies #-}", - generatedBanner, - "-- Equality witnesses are emitted for Text, Int, Bool, Natural, and UTCTime.", - "-- Int, Natural, and UTCTime belong to Keiki's ordered subset.", - "module " <> moduleName, - " ( " <> T.intercalate "\n , " (map spWitness specs), - " ) where", - "", - "import Data.Text (Text)", - "import Data.Time (UTCTime)", - "import Numeric.Natural (Natural)", - "import Keiro.Codec.Structural (bindingToShape)", - "import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)" - ] - <> map ("import " <>) imports - <> concatMap renderProjection specs - where - moduleName = structuralProjectionModule ctx - specs = map (resolveProjectionModules ctx) (projectionSpecs graph) - imports = - sort . nub $ - [hsModule (spOwner spec) <> " qualified" | spec <- specs] - <> [qualifiedModule (spBinding spec) <> " qualified" | spec <- specs] - <> [shapeModuleName <> " qualified" | spec <- specs, (shapeModuleName, _) <- spSelectors spec] - renderProjection spec = - [ "", - "data " <> spTag spec, - "", - "instance FieldProjection " <> spTag spec <> " where", - " type FieldName " <> spTag spec <> " = " <> tshow (spPointer spec), - " type FieldOwner " <> spTag spec <> " = " <> renderHaskellSource (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) -> shapeModuleName <> "." <> selector <> " (" <> value <> ")") - ("bindingToShape " <> unQualifiedValueName (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) - -qualifiedModule :: QualifiedValueName -> Text -qualifiedModule = fst . splitQualified . unQualifiedValueName - -renderHaskellSource :: HaskellSource -> Text -renderHaskellSource source = hsModule source <> "." <> hsType source - -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 "Expressions" (emitExpressions a), - 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 $ - [ "{-# LANGUAGE DataKinds #-}", - "{-# LANGUAGE OverloadedLabels #-}", - "{-# OPTIONS_GHC -Wno-missing-signatures -Wno-name-shadowing #-}", - generatedBanner, - "module " <> aGenPrefix aggregate <> ".BehaviorContract where", - "", - "import " <> aGenPrefix aggregate <> ".Codec (encode" <> name <> "Event, parse" <> name <> "Event, " <> valueStem <> "Codec)", - "import " <> aGenPrefix aggregate <> ".Domain", - "import " <> aGenPrefix aggregate <> ".Transducer (" <> valueStem <> "Transducer)", - "import Data.Aeson (ToJSON (..), object, (.=))", - "import Data.List (sortOn)", - "import Data.List.NonEmpty (NonEmpty)", - "import Data.List.NonEmpty qualified as NonEmpty", - "import Data.Map.Strict qualified as Map", - "import Data.Text (Text)", - "import Data.Text qualified as T", - "import Keiki.Core qualified as K (EdgeMode (..), EdgeRef (..), RegFile, ReplayAttribution (..), ReplayEventSpan (..), ReplaySuccess (..), StepFailure (..), StepSuccess (..), applyEventsDetailedEither, stepDetailedEither, (!))", - "import Keiro.Codec qualified as Codec (Codec (eventType), EventType (..))", - "", - "newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }", - " deriving stock (Eq, Ord, Show)", - "", - "data ObligationKind = LiveTransition | RequiredRejection | ReplayTransition", - " deriving stock (Eq, Ord, Show)", - "", - "data EvidenceLevel = GeneratedAuthoritative | HoleWitnessed | LegacyRuntimeWitness", - " deriving stock (Eq, Ord, Show)", - "", - "data GuardCoverage = GuardTotal | GuardPartial | GuardUnknown | GuardNotApplicable", - " deriving stock (Eq, Ord, Show)", - "", - "data BehaviorRequirement = BehaviorRequirement", - " { requirementKey :: !BehaviorKey", - " , requirementKind :: !ObligationKind", - " , requirementEvidence :: !EvidenceLevel", - " , requirementGuardCoverage :: !GuardCoverage", - " , requirementSource :: !" <> aVertexType aggregate, - " , requirementCommandName :: !Text", - " , requirementExpectedEdge :: !(Maybe (K.EdgeRef " <> aVertexType aggregate <> "))", - " , requirementTarget :: !(Maybe " <> aVertexType aggregate <> ")", - " , requirementEventKinds :: ![Text]", - " , requirementLine :: !Int", - " }", - " deriving stock (Eq, Show)", - "", - "data RejectionClass = RejectNoOutgoingEdges | RejectNoMatchingEdge", - " deriving stock (Eq, Show)", - "", - "data LiveExpectation", - " = Emits (NonEmpty " <> name <> "Event)", - " | Rejects RejectionClass", - " | NoOp", - " deriving stock (Eq, Show)", - "", - "data BehaviorWitness", - " = Pending BehaviorKey", - " | LiveWitness", - " { witnessKey :: BehaviorKey", - " , witnessHistory :: [" <> name <> "Event]", - " , witnessCommand :: " <> name <> "Command", - " , witnessExpected :: LiveExpectation", - " }", - " | ReplayWitness", - " { witnessKey :: BehaviorKey", - " , witnessHistoryPrefix :: [" <> name <> "Event]", - " , witnessObservedChunk :: [" <> name <> "Event]", - " }", - " deriving stock (Eq, Show)", - "", - "data BehaviorFailure = BehaviorFailure", - " { failureKey :: !BehaviorKey", - " , failureCode :: !Text", - " , failureDetail :: !Text", - " }", - " deriving stock (Eq, Show)", - "", - "instance ToJSON BehaviorFailure where", - " toJSON failure = object", - " [ \"key\" .= unBehaviorKey (failureKey failure)", - " , \"code\" .= failureCode failure", - " , \"detail\" .= failureDetail failure", - " ]", - "", - "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 = [failure | (_, Left failure) <- 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 failure) <> \" [\" <> failureCode failure <> \"] \" <> failureDetail failure | failure <- 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 requirement seed command expectation = case expectation of", - " Emits _ -> failure requirement \"expectation-kind\" \"a rejection requirement cannot expect emitted events\"", - " NoOp -> failure requirement \"expectation-kind\" \"a rejection requirement cannot expect an accepted no-op\"", - " Rejects expectedClass -> case K.stepDetailedEither " <> valueStem <> "Transducer seed command of", - " Left K.NoOutgoingEdges {} -> ensure requirement (expectedClass == RejectNoOutgoingEdges) \"rejection-class\" \"expected NoMatchingEdge but runtime returned NoOutgoingEdges\"", - " Left K.NoMatchingEdge {} -> ensure requirement (expectedClass == RejectNoMatchingEdge) \"rejection-class\" \"expected NoOutgoingEdges but runtime returned NoMatchingEdge\"", - " Left K.AmbiguousEdges {} -> failure requirement \"ambiguous-edges\" \"AmbiguousEdges can never satisfy a rejection witness\"", - " Right _ -> failure requirement \"unexpected-acceptance\" \"runtime accepted a command required to reject\"", - "", - "runAcceptance requirement seed command expectation = case expectation of", - " Rejects _ -> failure requirement \"expectation-kind\" \"a live-transition requirement needs Emits or NoOp\"", - " NoOp -> case K.stepDetailedEither " <> valueStem <> "Transducer seed command of", - " Left stepFailure -> failure requirement \"unexpected-rejection\" (tshow stepFailure)", - " Right success -> do", - " checkAcceptedEnvelope requirement success", - " ensure requirement (null (K.stepSuccessOutputs success)) \"noop-emitted\" \"NoOp emitted one or more events\"", - " ensure requirement (K.stepSuccessState success == fst seed) \"noop-vertex-change\" \"NoOp changed the control vertex\"", - " ensure requirement (regsEqual (K.stepSuccessRegs success) (snd seed)) \"noop-register-change\" \"NoOp changed one or more registers\"", - " Emits expectedEvents -> case K.stepDetailedEither " <> valueStem <> "Transducer seed command of", - " Left stepFailure -> failure requirement \"unexpected-rejection\" (tshow stepFailure)", - " Right success -> do", - " checkAcceptedEnvelope requirement success", - " let expected = NonEmpty.toList expectedEvents", - " actual = K.stepSuccessOutputs success", - " ensure requirement (actual == expected) \"event-value-mismatch\" \"runtime event values differ from the exact witness expectation\"", - " ensure requirement (map eventKind actual == requirementEventKinds requirement) \"event-envelope-mismatch\" \"runtime event kinds differ from the declared ordered envelope\"", - " decoded <- either (failure requirement \"emitted-codec-decode\") Right (decodeEvents actual)", - " replayed <- case K.applyEventsDetailedEither " <> valueStem <> "Transducer seed decoded of", - " Left replayFailure -> failure requirement \"emitted-replay-failed\" (tshow replayFailure)", - " Right replaySuccess -> Right replaySuccess", - " ensure requirement (K.replaySuccessState replayed == K.stepSuccessState success) \"forward-replay-vertex\" \"decoded emissions replay to a different vertex\"", - " ensure requirement (regsEqual (K.replaySuccessRegs replayed) (K.stepSuccessRegs success)) \"forward-replay-registers\" \"decoded emissions replay to different registers\"", - " checkSingleAttribution requirement K.Live (length decoded) (K.replaySuccessTrace replayed)", - "", - "checkAcceptedEnvelope requirement success = do", - " ensure requirement (K.stepSuccessMode success == K.Live) \"forward-mode\" \"forward execution selected a non-live edge\"", - " ensure requirement (Just (K.stepSuccessEdge success) == requirementExpectedEdge requirement) \"edge-attribution\" \"runtime selected a different guarded sibling\"", - " ensure requirement (Just (K.stepSuccessState success) == requirementTarget requirement) \"target-mismatch\" \"runtime reached a different target vertex\"", - "", - "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\"", - " checkSingleAttribution requirement K.ReplayOnly (length decoded) (K.replaySuccessTrace replayed)", - " _ -> failure requirement \"witness-kind\" \"ReplayWitness supplied for a non-replay requirement\"", - "", - "checkSingleAttribution requirement expectedMode eventCount trace = case trace of", - " [attribution] -> do", - " ensure requirement (Just (K.replayAttributionEdge attribution) == requirementExpectedEdge requirement) \"replay-edge-attribution\" \"replay selected a different edge\"", - " ensure requirement (K.replayAttributionMode attribution == expectedMode) \"replay-mode-attribution\" \"replay selected the wrong live/replay-only phase\"", - " ensure requirement (K.replayAttributionSource attribution == requirementSource requirement) \"replay-source-attribution\" \"replay attribution starts at the wrong source\"", - " ensure requirement (Just (K.replayAttributionTarget attribution) == requirementTarget requirement) \"replay-target-attribution\" \"replay attribution ends at the wrong target\"", - " ensure requirement (K.replayAttributionSpan attribution == K.ReplayEventSpan 0 eventCount) \"replay-span-attribution\" \"replay attribution did not consume the exact chunk\"", - " _ -> failure requirement \"replay-trace-cardinality\" \"expected exactly one completed-edge attribution\"", - "", - "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 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 requirement =", - " requirementEvidence requirement == GeneratedAuthoritative", - " && requirementGuardCoverage requirement `elem` [GuardTotal, GuardNotApplicable]", - "", - "behaviorWitnessKey witness = case witness of", - " Pending key -> key", - " LiveWitness { witnessKey = key } -> key", - " ReplayWitness { witnessKey = key } -> key", - "", - "isPending Pending {} = True", - "isPending _ = False", - "", - "ensure requirement condition code detail = if condition then Right () else failure requirement code detail", - "failure requirement code detail = Left (BehaviorFailure (requirementKey requirement) code detail)", - "sortedKeys = sortOn unBehaviorKey", - "keyTexts = map unBehaviorKey", - "countLine label values = label <> \": \" <> tshow (length values)", - "tshow :: Show value => value -> Text", - "tshow = T.pack . show" - ] - where - name = aName aggregate - valueStem = lowerFirst name - -renderCommandKind :: Agg -> [Text] -renderCommandKind aggregate = case aCommands aggregate of - [] -> ["", "commandKind _ = \"\""] - commands -> - [ "", - "commandKind command = case command of" - ] - <> [" " <> rcName command <> " _ -> " <> tshow (rcName command) | command <- commands] - -renderBehaviorRequirementList :: Agg -> [Text] -renderBehaviorRequirementList aggregate = - case behaviorRequirementsFor aggregate of - [] -> [" []"] - requirements -> - [ (if index == (0 :: Int) then " [ " else " , ") <> render requirement - | (index, requirement) <- zip [0 ..] requirements - ] - <> [" ]"] - where - render requirement = - "BehaviorRequirement " - <> keyExpr requirement - <> " " - <> T.pack (show (Behavior.requirementKind requirement)) - <> " " - <> T.pack (show (Behavior.requirementEvidence requirement)) - <> " " - <> T.pack (show (Behavior.requirementGuardCoverage requirement)) - <> " " - <> vertexCtor aggregate (Behavior.requirementSource requirement) - <> " " - <> tshow (Behavior.requirementCommand requirement) - <> " " - <> edgeExpr aggregate requirement - <> " " - <> maybe "Nothing" (\target -> "(Just " <> vertexCtor aggregate target <> ")") (Behavior.requirementTarget requirement) - <> " " - <> renderBehaviorTextList (Behavior.requirementEvents requirement) - <> " " - <> tshow' (unLoc (Behavior.requirementLocation requirement)) - keyExpr requirement = "(BehaviorKey " <> tshow (Behavior.unBehaviorKey (Behavior.requirementKey requirement)) <> ")" - -edgeExpr :: Agg -> Behavior.BehaviorRequirement -> Text -edgeExpr aggregate requirement = case Behavior.requirementKind requirement of - Behavior.RequiredRejection -> "Nothing" - _ -> case behaviorEdgeIndex aggregate requirement of - Nothing -> error ("required behavior transition missing from resolved aggregate: " <> T.unpack (Behavior.requirementCanonical requirement)) - Just edgeIndex -> - "(Just (K.EdgeRef " - <> vertexCtor aggregate (Behavior.requirementSource requirement) - <> " " - <> tshow' edgeIndex - <> "))" - -behaviorEdgeIndex :: Agg -> Behavior.BehaviorRequirement -> Maybe Int -behaviorEdgeIndex aggregate requirement = - findIndex - matches - [ transition - | transition <- aTransitions aggregate, - tSource transition == Behavior.requirementSource requirement - ] - where - matches transition = - unLoc (tLoc transition) == unLoc (Behavior.requirementLocation requirement) - && tCommand transition == Behavior.requirementCommand requirement - -behaviorRequirementsFor :: Agg -> [Behavior.BehaviorRequirement] -behaviorRequirementsFor aggregate = - case Behavior.deriveAggregateBehaviorRequirements (aSpec aggregate) (aAggregate aggregate) of - Left derivationError -> error ("validated aggregate failed behavior derivation: " <> show derivationError) - Right requirements -> sortOn Behavior.requirementKey requirements - -renderBehaviorTextList :: [Text] -> Text -renderBehaviorTextList values = "[" <> T.intercalate ", " (map tshow values) <> "]" - -regsEqualityExpression :: Agg -> Text -regsEqualityExpression aggregate = case aRegs aggregate of - [] -> "regsEqual _ _ = True" - registers -> - "regsEqual left right = " - <> T.intercalate - " && " - [ "(left K.! #" <> rrName register <> ") == (right K.! #" <> rrName register <> ")" - | register <- registers - ] - -behaviorHoleModule :: Agg -> ScaffoldModule -behaviorHoleModule aggregate = - ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" (aHolePrefix aggregate) <> "/BehaviorHoles.hs"), - moduleText = emitBehaviorHoles aggregate, - kind = HoleStub, - origin = nodeOrigin "aggregate behavior witnesses" (aName aggregate) (aLoc aggregate) - } - -emitBehaviorHoles :: Agg -> Text -emitBehaviorHoles aggregate = - nl $ - [ "-- Consumer-owned behavioral witnesses. Created once; never overwritten.", - "module " <> aHolePrefix aggregate <> ".BehaviorHoles (behaviorWitnesses) where", - "", - "import " <> aGenPrefix aggregate <> ".BehaviorContract", - "", - "behaviorWitnesses :: [BehaviorWitness]", - "behaviorWitnesses =" - ] - <> case behaviorRequirementsFor aggregate of - [] -> [" []"] - requirements -> - [ (if index == (0 :: Int) then " [ " else " , ") - <> "Pending (BehaviorKey " - <> tshow (Behavior.unBehaviorKey (Behavior.requirementKey requirement)) - <> ")" - | (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" - contextGeneratedPrefix context = case placement context of - GeneratedPrefix -> rootPrefix context <> "Generated." <> ctxPascalOf context - CollocatedLeaf -> rootPrefix context <> ctxPascalOf context <> ".Generated" - emitReplayAudit = - nl $ - [ "{-# LANGUAGE GADTs #-}", - 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 c = - [ ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Contract.hs"), - moduleText = emitContractGen genPrefix c, - kind = Generated, - origin = nodeOrigin "contract" (ctrName c) (ctrLoc c) - } - ] - where - genPrefix = genPrefixFor ctx (pascal (ctrName c)) - -emitContractGen :: Text -> ContractNode -> Text -emitContractGen genPrefix c = - nl $ - [ "{-# LANGUAGE DuplicateRecordFields #-}", - "{-# LANGUAGE OverloadedRecordDot #-}", - "{-# OPTIONS_GHC -Wno-unused-top-binds #-}", - generatedBanner, - "module " <> genPrefix <> ".Contract", - " ( " <> payloadTy <> " (..)", - nl [" , " <> ceName e <> "Data (..)" | e <- ctrEvents c], - " , messageTypeOf", - " , encode" <> payloadTy, - " , parse" <> payloadTy, - " ) where", - "", - "import Data.Aeson (Value, object, withObject, (.:), (.=))", - "import Data.Aeson.Types (Parser, parseEither)", - "import Data.Text (Text)", - "import qualified Data.Text as T", - "", - "-- topic constants" - ] - ++ [lowerFirst alias <> "Topic :: Text\n" <> lowerFirst alias <> "Topic = " <> tshow t | (alias, t) <- ctrTopics c] - ++ [ "", - "-- the closed payload set (discriminated by " <> tshow (ctrDiscriminator c) <> ")" - ] - ++ [emitPayloadAdt 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 <- o .: " <> tshow (ctrDiscriminator c) <> " :: Parser Text", - " case kind of" - ] - ++ concatMap decodeArm (ctrEvents c) - ++ [ " _ -> fail \"unknown message type\"", - "", - "mapLeftText :: Either String b -> Either Text b", - "mapLeftText = either (Left . T.pack) Right" - ] - where - payloadTy = pascal (ctrName c) <> "Payload" - encodeArm e = - [ " " <> ceName e <> " payload ->", - " object" - ] - ++ [lead i kv | (i, kv) <- zip [(0 :: Int) ..] ((tshow (ctrDiscriminator c) <> " .= (" <> tshow (ceName e) <> " :: Text)") : [tshow (cfName f) <> " .= payload." <> cfName f | f <- ceFields e])] - ++ [" ]"] - lead 0 kv = " [ " <> kv - lead _ kv = " , " <> kv - decodeArm e = - [ " " <> tshow (ceName e) <> " ->", - " " <> ceName e <> " <$> (" <> ceName e <> "Data" <> fieldApps (ceFields e) <> ")" - ] - fieldApps [] = "" - fieldApps fs = " <$> " <> T.intercalate " <*> " ["o .: " <> tshow (cfName f) | f <- fs] - -emitPayloadAdt :: Text -> [ContractEvent] -> Text -emitPayloadAdt tyName events = - sectionsOf [map dataRecord events, [sumDecl]] - where - hsType CText = "Text" - hsType CInt = "Int" - hsType (CTypeId _) = "Text" - dataRecord e = - "data " - <> ceName e - <> "Data = " - <> ceName e - <> "Data { " - <> T.intercalate ", " [cfName f <> " :: !" <> hsType (cfType f) | f <- ceFields e] - <> " }\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 $ - ["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@ (Processed\/Duplicate\/ --- InProgress\/PreviouslyFailed). This pins the dangerous inversions --- (duplicate ⇒ ackOk, previouslyFailed ⇒ deadLetter) as compiled code over the --- runtime types. The handler-level decode\/dedupe\/store failures are noted but not --- part of @InboxResult@. 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 - [ "{-# OPTIONS_GHC -Wno-unused-top-binds #-}", - generatedBanner, - "module " <> genPrefix <> ".Inbox", - " ( InboxAck (..)", - " , inboxDedupePolicy", - " , inboxPersistence", - " , inboxDisposition", - " ) where", - "", - "import Keiro.Inbox.Types (InboxDedupePolicy (..), InboxPersistence (..), InboxResult (..))", - "", - "-- 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), - "", - "-- The service's ack decision for each inbox classification.", - "data InboxAck = InboxAckOk | InboxRetry | InboxDeadLetter", - " deriving stock (Eq, Show)", - "", - "-- The disposition table (hole-kind 2) over the LIVE Keiro.Inbox.Types.InboxResult.", - "-- duplicate => ackOk and previouslyFailed => deadLetter are the dangerous", - "-- inversions the spec states explicitly.", - "inboxDisposition :: InboxResult a -> InboxAck", - "inboxDisposition r = case r of", - " InboxProcessed _ -> " <> ackFor "processed", - " InboxDuplicate -> " <> ackFor "duplicate", - " InboxInProgress -> " <> ackFor "inProgress", - " InboxPreviouslyFailed _ -> " <> ackFor "previouslyFailed", - "", - "-- handler-level failures (not InboxResult): decodeFailed => " - <> ackText "decodeFailed" - <> ", dedupeFailed => " - <> ackText "dedupeFailed" - <> ", storeFailed => " - <> ackText "storeFailed" - ] - where - act o = lookup o [(drOutcome r, drAction r) | r <- inkDisposition i] - ackFor o = case act o of - Just IAckOk -> "InboxAckOk" - Just (IRetry _) -> "InboxRetry" - Just (IDeadLetter _) -> "InboxDeadLetter" - Nothing -> "InboxRetry" - ackText o = case act o of - Just IAckOk -> "ackOk" - Just (IRetry _) -> "retry" - Just (IDeadLetter _) -> "deadLetter" - Nothing -> "retry" - 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 - [ "{-# OPTIONS_GHC -Wno-unused-top-binds #-}", - generatedBanner, - "module " <> genPrefix <> ".Publisher", - " ( publisherOrdering", - " , publisherBackoff", - " , publisherMaxAttempts", - " ) where", - "", - "import Keiro.Outbox.Types (BackoffSchedule (..), ExponentialBackoffOptions (..), OrderingPolicy (..))", - "", - "publisherOrdering :: OrderingPolicy", - "publisherOrdering = " <> pubOrdering pb, - "", - "publisherBackoff :: BackoffSchedule", - "publisherBackoff = " <> backoffExpr (pubBackoff pb), - "", - "publisherMaxAttempts :: Int", - "publisherMaxAttempts = " <> tshow' (pubMaxAttempts pb) - ] - where - backoffExpr b = case boKind b of - "constant" -> "ConstantBackoff " <> windowText (boWindow b) - "exponential" -> - "ExponentialBackoff ExponentialBackoffOptions { initial = " - <> windowText (boWindow b) - <> ", maxDelay = " - <> maybe "0" windowText (boMax b) - <> ", multiplier = " - <> fromMaybe "0" (boMultiplier b) - <> " }" - _ -> "error \"keiro-dsl: unlowerable backoff kind\"" - --------------------------------------------------------------------------------- --- pgmq workqueue (EP-5): a self-contained Job payload record + codec --------------------------------------------------------------------------------- - --- | Emit the deterministic, symbol-free pgmq layer: the Job payload record, the --- field→wire-name JSON codec, and the captured physical\/dlq\/table name constants. --- Self-contained (base\/text\/aeson). The fan-out body and the raw-SQL dedup --- predicate are holes (not emitted). Firewall holds. -scaffoldWorkqueue :: Context -> WorkqueueNode -> [ScaffoldModule] -scaffoldWorkqueue ctx w = - [ ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Queue.hs"), - moduleText = emitWorkqueueGen genPrefix w, - kind = Generated, - origin = nodeOrigin "workqueue" (wqName w) (wqLoc w) - }, - ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/QueuePolicy.hs"), - moduleText = emitQueuePolicy genPrefix w, - kind = Generated, - origin = nodeOrigin "workqueue" (wqName w) (wqLoc w) - }, - ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/QueueCodec.hs"), - moduleText = emitQueueCodec genPrefix w, - kind = Generated, - origin = nodeOrigin "workqueue" (wqName w) (wqLoc w) - } - ] - where - genPrefix = genPrefixFor ctx (pascal (wqName w)) - -emitWorkqueueGen :: Text -> WorkqueueNode -> Text -emitWorkqueueGen genPrefix w = - nl $ - [ "{-# LANGUAGE OverloadedRecordDot #-}", - "{-# OPTIONS_GHC -Wno-unused-top-binds #-}", - generatedBanner, - "module " <> genPrefix <> ".Queue", - " ( " <> payloadTy <> " (..)", - " , encode" <> payloadTy, - " , parse" <> payloadTy, - " , queuePhysical, queueDlq, queueTable", - groupKeyExport, - " ) where", - "", - "import Data.Aeson (Value, object, withObject, (.:), (.=))", - "import Data.Aeson.Types (parseEither)", - "import Data.Text (Text)", - "import qualified Data.Text as T", - "", - "queuePhysical, queueDlq, queueTable :: Text", - "queuePhysical = " <> tshow (wqPhysical w), - "queueDlq = " <> tshow (wqDlq w), - "queueTable = " <> tshow (wqTable w), - "" - ] - ++ groupKeyLines - ++ [ "data " <> payloadTy <> " = " <> payloadTy, - " { " <> T.intercalate "\n , " [wqfName f <> " :: !" <> hsType (wqfType f) | f <- wqPayload w], - " }", - " deriving stock (Eq, Show)", - "", - "encode" <> payloadTy <> " :: " <> payloadTy <> " -> Value", - "encode" <> payloadTy <> " p =", - " object" - ] - ++ [lead i (tshow (wqfWire f) <> " .= p." <> wqfName f) | (i, f) <- zip [(0 :: Int) ..] (wqPayload w)] - ++ [ " ]", - "", - "parse" <> payloadTy <> " :: Value -> Either Text " <> payloadTy, - "parse" <> payloadTy <> " = mapLeftText . parseEither (withObject " <> tshow payloadTy <> " go)", - " where", - " go o = " <> payloadTy <> fieldApps (wqPayload w), - "", - "mapLeftText :: Either String b -> Either Text b", - "mapLeftText = either (Left . T.pack) Right" - ] - where - payloadTy = wqPayloadName w - groupKeyExport = case wqGroupKey w of - Nothing -> "" - Just groupKey - | gkVia groupKey == "raw" -> " , groupKeyField, groupKeyFor" - | otherwise -> " , groupKeyField" - groupKeyLines = case wqGroupKey w of - Nothing -> [] - Just groupKey -> common <> derivationLines groupKey - where - common = - [ "groupKeyField :: Text", - "groupKeyField = " <> tshow (gkField groupKey), - "" - ] - derivationLines key - | gkVia key == "raw" = - [ "groupKeyFor :: " <> payloadTy <> " -> Text", - "groupKeyFor payload = payload." <> gkField key, - "" - ] - | otherwise = - [ "-- Opaque group-key derivation '" <> gkVia key <> "' remains hand-owned.", - "-- Captured fixture: " <> fromMaybe "" (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] - --- | 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", - " ( retryPolicy, jobOutcomeFor", - " , jobOrdering, jobTuningFor, queueProvision", - " ) where", - "", - "import Data.Text (Text)", - "import Keiro.PGMQ.Job (JobOrdering (..), JobOutcome (..), JobTuning, PartitionSpec (..), QueueProvision, RetryDelay (..), RetryPolicy (..), partitionedProvision, standardProvision, unloggedProvision, withFifoIndexProvision, withOrdering)", - "", - "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.", - "jobOutcomeFor :: Text -> JobOutcome", - "jobOutcomeFor o = case o of" - ] - ++ [" " <> tshow (wqdOutcome r) <> " -> " <> outcome (wqdAction r) | r <- wqDisposition w] - ++ [" _ -> Retry (RetryDelay " <> windowText (wqDelay w) <> ")"] - where - orderingCtor = case wqOrdering w of - WqUnordered -> "Unordered" - WqFifoThroughput -> "FifoThroughput" - WqFifoRoundRobin -> "FifoRoundRobin" - provisionExpr = fifoWrap baseProvision - fifoWrap expression = case wqOrdering w of - WqUnordered -> expression - _ -> "withFifoIndexProvision (" <> expression <> ")" - baseProvision = case wqProvision w of - WqStandard -> "standardProvision" - WqUnlogged -> "unloggedProvision" - WqPartitioned interval retention -> - "partitionedProvision (PartitionSpec { partitionInterval = " - <> tshow interval - <> ", retentionInterval = " - <> tshow retention - <> " })" - outcome IAckOk = "Done" - outcome (IRetry win) = "Retry (RetryDelay " <> windowText win <> ")" - outcome (IDeadLetter mr) = "Dead " <> tshow (fromMaybe "dead-lettered" mr) - --------------------------------------------------------------------------------- --- First-class read models (EP-107) --------------------------------------------------------------------------------- - --- | Emit an acyclic three-module read-model vertical. @ReadModelTable@ owns the --- qualified-table constant shared by the hand-owned query and the generated --- runtime record; @ReadModel@ re-exports it as part of the public surface. -scaffoldReadModel :: Context -> ReadModelNode -> [ScaffoldModule] -scaffoldReadModel ctx readModel = - [ generated "ReadModelTable" (emitReadModelTable tableModule stem readModel), - generated "ReadModel" (emitReadModelGen ctx readModelModule tableModule readModelHolePrefix stem readModel), - ScaffoldModule - { modulePath = modulePathFor readModelHolePrefix "ReadModelHoles", - moduleText = emitReadModelHoles tableModule readModelHolePrefix stem readModel, - kind = HoleStub, - origin = readModelOrigin - } - ] - where - nodeSegment = pascal (rmName readModel) - stem = readModelStem readModel - readModelModule = genPrefixFor ctx nodeSegment - tableModule = readModelModule <> ".ReadModelTable" - readModelHolePrefix = holePrefixFor ctx nodeSegment - readModelOrigin = nodeOrigin "readmodel" (rmName readModel) (rmLoc readModel) - generated leaf body = - ScaffoldModule - { modulePath = modulePathFor readModelModule leaf, - moduleText = body, - kind = Generated, - origin = readModelOrigin - } - -modulePathFor :: Text -> Text -> FilePath -modulePathFor prefix leaf = T.unpack (T.replace "." "/" prefix <> "/" <> leaf <> ".hs") - -readModelStem :: ReadModelNode -> Text -readModelStem = lowerFirst . T.concat . map pascal . T.splitOn "_" . rmName - -emitReadModelTable :: Text -> Text -> ReadModelNode -> Text -emitReadModelTable tableModule stem readModel = - nl - [ generatedBanner, - "module " <> tableModule <> " (" <> qualifiedName <> ") where", - "", - "import Data.Text (Text)", - "import Keiro.Connection (qualifyTable)", - "", - "-- The fully-qualified, double-quoted data-table reference.", - qualifiedName <> " :: Text", - qualifiedName <> " = qualifyTable " <> tshow (rmSchema readModel) <> " " <> tshow (rmTable readModel) - ] - where - qualifiedName = stem <> "QualifiedTable" - -emitReadModelGen :: Context -> Text -> Text -> Text -> Text -> ReadModelNode -> Text -emitReadModelGen ctx readModelModule tableModule readModelHolePrefix stem readModel = - nl $ - [ "{-# LANGUAGE OverloadedRecordDot #-}", - generatedBanner, - "module " <> readModelModule <> ".ReadModel", - " ( " <> T.intercalate "\n , " exports, - " ) where", - "", - "import Data.Functor (void)", - "import Effectful (Eff, (:>))", - "import " <> tableModule <> " (" <> qualifiedName <> ")", - "import " <> readModelHolePrefix <> ".ReadModelHoles (" <> T.intercalate ", " holeImports <> ")" - ] - ++ asyncImports - ++ [ "import Keiro.ReadModel (ConsistencyMode (..), ReadModel (..), ReadModelMetadata, StrongScope (..), registerReadModel)", - "import Keiro.ReadModel.Rebuild qualified as Rebuild", - "import Kiroku.Store.Effect (Store)", - "import Kiroku.Store.Types (" <> kirokuTypes <> ")", - "", - readModelName <> " :: ReadModel " <> queryInputType <> " " <> queryResultType, - readModelName <> " =", - " ReadModel", - " { name = " <> tshow registryName, - " , tableName = " <> tshow (rmTable readModel), - " , schema = " <> tshow (rmSchema readModel), - " , subscriptionName = " <> tshow subscriptionName, - " , version = " <> tshow' (rmVersion readModel), - " , shapeHash = " <> tshow (rmShape readModel), - " , defaultConsistency = " <> consistencyExpr (rmConsistency readModel), - " , strongScope = " <> scopeExpr (rmScope readModel), - " , query = " <> queryName, - " }", - "", - "-- Call once at projection startup before serving queries.", - registerName <> " :: (Store :> es) => Eff es ()", - registerName <> " =", - " void (registerReadModel " <> tshow registryName <> " " <> tshow' (rmVersion readModel) <> " " <> tshow (rmShape readModel) <> ")", - "", - startName <> " :: (Store :> es) => GlobalPosition -> Eff es ReadModelMetadata", - startName <> " =", - " Rebuild.startRebuild " <> readModelName <> " " <> projectionNames, - "", - finishName <> " :: (Store :> es) => GlobalPosition -> Eff es (Either Rebuild.RebuildError ReadModelMetadata)", - finishName <> " =", - " Rebuild.finishRebuild " <> readModelName <> " " <> projectionNames, - "", - abandonName <> " :: (Store :> es) => Eff es ReadModelMetadata", - abandonName <> " = Rebuild.abandonRebuild " <> readModelName - ] - ++ asyncDefinition - where - registryName = registryNameFor (contextName ctx) readModel - subscriptionName = subscriptionNameFor (contextName ctx) readModel - asyncName = registryName <> "-async" - readModelName = stem <> "ReadModel" - qualifiedName = stem <> "QualifiedTable" - registerName = "register" <> pascal stem - startName = "start" <> pascal stem <> "Rebuild" - finishName = "finish" <> pascal stem <> "Rebuild" - abandonName = "abandon" <> pascal stem <> "Rebuild" - asyncValueName = stem <> "AsyncProjection" - queryInputType = pascal stem <> "QueryInput" - queryResultType = pascal stem <> "QueryResult" - queryName = stem <> "Query" - applyName = "apply" <> pascal stem - exports = - [ readModelName, - qualifiedName, - registerName, - startName, - finishName, - abandonName - ] - ++ [asyncValueName | rmFeed readModel == RmSubscription] - holeImports = [queryInputType, queryResultType, queryName] ++ [applyName | rmFeed readModel == RmSubscription] - asyncImports = case rmFeed readModel of - RmInline -> [] - RmSubscription -> ["import Keiro.Projection (AsyncProjection (..))"] - kirokuTypes = case rmFeed readModel of - RmInline -> "GlobalPosition" - RmSubscription -> "GlobalPosition, RecordedEvent (..)" - projectionNames = case rmFeed readModel of - RmInline -> "[]" - RmSubscription -> "[" <> tshow asyncName <> "]" - asyncDefinition = case rmFeed readModel of - RmInline -> [] - RmSubscription -> - [ "", - asyncValueName <> " :: AsyncProjection", - asyncValueName <> " =", - " AsyncProjection", - " { name = " <> tshow asyncName, - " , readModelName = " <> tshow registryName, - " , subscriptionName = " <> tshow subscriptionName, - " , applyRecorded = " <> applyName, - " , idempotencyKey = \\recorded -> recorded.eventId", - " }" - ] - consistencyExpr Strong = "Strong" - consistencyExpr Eventual = "Eventual" - scopeExpr Nothing = "EntireLog" - scopeExpr (Just RmEntireLog) = "EntireLog" - scopeExpr (Just (RmCategory categoryName)) = "CategoryHead " <> tshow categoryName - -emitReadModelHoles :: Text -> Text -> Text -> ReadModelNode -> Text -emitReadModelHoles tableModule readModelHolePrefix stem readModel = - nl $ - [ "-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.", - "module " <> readModelHolePrefix <> ".ReadModelHoles", - " ( " <> T.intercalate "\n , " exports, - " ) where", - "", - "import " <> tableModule <> " (" <> qualifiedName <> ")", - "import Hasql.Transaction qualified as Tx" - ] - ++ ["import Kiroku.Store.Types (RecordedEvent(..))" | rmFeed readModel == RmSubscription] - ++ [ "", - "-- HOLE: replace these aliases with the real query input and result types.", - "type " <> queryInputType <> " = ()", - "type " <> queryResultType <> " = ()", - "", - "-- HOLE: query " <> qualifiedTableLiteral readModel <> " via " <> qualifiedName <> "; never rely on search_path.", - "-- Declared columns:" - ] - ++ map (("-- " <>) . readModelColumnDoc) (rmColumns readModel) - ++ [ queryName <> " :: " <> queryInputType <> " -> Tx.Transaction " <> queryResultType, - queryName <> " _input = " <> qualifiedName <> " `seq` error " <> tshow ("HOLE: fill " <> rmName readModel <> " query") - ] - ++ applyStub - where - qualifiedName = stem <> "QualifiedTable" - queryInputType = pascal stem <> "QueryInput" - queryResultType = pascal stem <> "QueryResult" - queryName = stem <> "Query" - applyName = "apply" <> pascal stem - exports = [queryInputType, queryResultType, queryName] ++ [applyName | rmFeed readModel == RmSubscription] - applyStub = case rmFeed readModel of - RmInline -> [] - RmSubscription -> - [ "", - "-- HOLE: apply one recorded event; runtime deduplication makes redelivery safe.", - applyName <> " :: RecordedEvent -> Tx.Transaction ()", - applyName <> " _recorded = error " <> tshow ("HOLE: fill " <> rmName readModel <> " async apply") - ] - -qualifiedTableLiteral :: ReadModelNode -> Text -qualifiedTableLiteral readModel = quoteSqlIdentifier (rmSchema readModel) <> "." <> quoteSqlIdentifier (rmTable readModel) - -quoteSqlIdentifier :: Text -> Text -quoteSqlIdentifier identifier = "\"" <> T.replace "\"" "\"\"" identifier <> "\"" - -readModelColumnDoc :: RmColumn -> Text -readModelColumnDoc columnDecl = - rmcName columnDecl - <> " " - <> rmcType columnDecl - <> if rmcRequired columnDecl then " NOT NULL" else "" - --------------------------------------------------------------------------------- --- Router + shared worker-policy lowering (EP-108) --------------------------------------------------------------------------------- - -scaffoldRouter :: Context -> RouterNode -> [ScaffoldModule] -scaffoldRouter ctx router = - [ ScaffoldModule - { modulePath = modulePathFor genPrefix "Router", - moduleText = emitRouterGen genPrefix router, - kind = Generated, - origin = routerOrigin - }, - ScaffoldModule - { modulePath = modulePathFor holePrefix "RouterHoles", - moduleText = emitRouterHoles holePrefix router, - kind = HoleStub, - origin = routerOrigin - } - ] - where - genPrefix = genPrefixFor ctx (rtId router) - holePrefix = holePrefixFor ctx (rtId router) - routerOrigin = nodeOrigin "router" (rtId router) (rtLoc router) - -emitRouterGen :: Text -> RouterNode -> Text -emitRouterGen genPrefix router = - nl $ - [ generatedBanner, - "module " <> genPrefix <> ".Router", - " ( " <> stem <> "Name", - " , " <> stem <> "WorkerOptions", - " ) where", - "", - "import Data.Text (Text)" - ] - ++ workerPolicyImports (rtPoison router) - ++ [ "", - "-- The STABLE router name. It participates in every target-keyed", - "-- deterministicRouterCommandId; renaming it re-keys replayed dispatches.", - stem <> "Name :: Text", - stem <> "Name = " <> tshow (rtName router), - "", - "-- Runtime-owned dispatch id inputs: (name, key, sourceEventId,", - "-- targetStreamName, occurrence). Target-keyed, not positional.", - "", - "-- Node-level worker policy lowered from the spec. Pass this value to", - "-- Keiro.Router.runRouterWorkerWith; do not silently use defaultWorkerOptions." - ] - ++ workerOptionsLines (stem <> "WorkerOptions") (rtRejected router) (rtPoison router) - where - stem = lowerFirst (rtId router) - -emitRouterHoles :: Text -> RouterNode -> Text -emitRouterHoles holePrefix router = - nl - [ "-- HAND-OWNED hole module for the router's behaviour-bearing bodies.", - "-- keiro-dsl creates it once and never overwrites it.", - "module " <> holePrefix <> ".RouterHoles () where", - "", - "-- HOLE resolve :: " <> inName (rtInput router) <> " -> Eff es [PMCommand targetCommand]", - "-- Spec source: " <> resolveSourceText (rvSource (rtResolve router)) <> ".", - "-- The spec's 'stable' keyword acknowledges that retry attempts accumulate", - "-- the UNION of resolved target identities. Keep the recipient set stable", - "-- for a source event whenever an exact recipient set matters.", - "-- HOLE router value: assemble Keiro.Router.Router with name = " <> lowerFirst (rtId router) <> "Name,", - "-- key, resolve, targetEventStream, and targetProjections; run it with", - "-- runRouterWorkerWith " <> lowerFirst (rtId router) <> "WorkerOptions.", - "-- HOLE targetProjections: spec projections = " <> renderNames (rtProjections router) <> ".", - "-- NOTE on-duplicate AckOk is sound because Keiro.Router confirms a duplicate", - "-- event id against the TARGET stream via confirmBenignDuplicate before", - "-- returning PMCommandDuplicate. Hand-rolled dispatch paths must do likewise." - ] - where - renderNames names = "[" <> T.intercalate ", " names <> "]" - -resolveSourceText :: ResolveSource -> Text -resolveSourceText (ResolveReadModel name) = "read-model " <> name <> " (typically Keiro.ReadModel.runQuery)" -resolveSourceText ResolveHole = "typed resolver hole" - -workerPolicyImports :: PolicyChoice -> [Text] -workerPolicyImports poison = - [ "import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))", - "import Shibuya.Core.Ack (RetryDelay (..))" - ] - ++ if poison == PolHalt - then [] - else ["import Effectful (Eff)", "import Shibuya.Core.Types (Envelope)"] - -workerOptionsLines :: Text -> PolicyChoice -> PolicyChoice -> [Text] -workerOptionsLines valueName rejected poison = - [ valueName <> signature, - valueName <> argument <> " =", - " WorkerOptions", - " { poisonPolicy = " <> poisonExpr, - " , rejectedCommandPolicy = " <> rejectedExpr rejected, - " , transientRetryDelay = RetryDelay 5 -- matches defaultWorkerOptions; runtime tuning", - " , metrics = Nothing -- runtime configuration; install at call site", - " }" - ] - where - signature = case poison of - PolHalt -> " :: WorkerOptions es msg" - _ -> " :: (Envelope msg -> Eff es ()) -> WorkerOptions es msg" - argument = case poison of - PolHalt -> "" - _ -> " poisonCallback" - poisonExpr = case poison of - PolHalt -> "PoisonHalt" - PolDeadLetter -> "PoisonDeadLetter poisonCallback" - PolSkip -> "PoisonSkip poisonCallback" - rejectedExpr = \case - PolHalt -> "RejectedHalt" - PolDeadLetter -> "RejectedDeadLetter" - PolSkip -> "RejectedSkip" - --------------------------------------------------------------------------------- --- Process manager + durable timer (EP-3) --------------------------------------------------------------------------------- - --- | Emit the symbol-free deterministic wiring for a process manager + its timer --- into a @Generated@ module, plus a create-if-absent @ProcessHoles@ module for the --- behaviour-bearing bodies (the @handle@ reaction, the deadline window, and the --- fire command). The @Generated@ module contains no keiki symbolic operator (the --- saga's transducer is the separate aggregate hole), so the firewall invariant --- holds. The timer worker uses the spec's @max-attempts@ ceiling, never the --- dangerous @defaultTimerWorkerOptions@ (@Nothing@) default. -scaffoldProcess :: Context -> ProcessNode -> [ScaffoldModule] -scaffoldProcess ctx p = - [ ScaffoldModule - { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Process.hs"), - moduleText = emitProcessGen ctxPascal 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 - ctxPascal = pascalFromKebab (contextName ctx) - genPrefix = genPrefixFor ctx (procId p) - holePrefix = holePrefixFor ctx (procId p) - -emitProcessGen :: Text -> Text -> Text -> ProcessNode -> Text -emitProcessGen _ctxPascal 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 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 '-' via Keiro.Stream.entityStream.", - "-- categoryUnsafe is safe here because keiro-dsl check proved the literal legal.", - lo <> "Category :: Stream.StreamCategory a", - 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) - 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) <> "Category. 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 $ - [ "{-# LANGUAGE DataKinds #-}" - ] - ++ ["{-# LANGUAGE DeriveAnyClass #-}" | hasSnapshot a] - ++ [ "{-# LANGUAGE DuplicateRecordFields #-}", - "{-# LANGUAGE TemplateHaskell #-}", - "{-# LANGUAGE TypeApplications #-}", - "{-# OPTIONS_GHC -Wno-unused-top-binds #-}", - generatedBanner, - "module " <> aGenPrefix a <> ".Domain where", - "" - ] - ++ ["import Data.Aeson (FromJSON, ToJSON)" | hasSnapshot a] - ++ [ "import Data.Proxy (Proxy (..))", - "import Data.Text (Text)", - "import GHC.Generics (Generic)", - "import Keiki.Core (RegFile (..))" - ] - ++ ["import Keiki.Shape (CanonicalStateShape, CanonicalTypeName)" | hasSnapshot a] - ++ generatedNominalTypeImportsForService (aggregateCheckedService a) (aContext a) (aGeneratedNominals a) - ++ map ("import " <>) (domainConsumerImports a) - ++ [ "import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)", - "", - sectionsOf - [ [emitVertex a], - map (emitRecord a) (aCommands a), - [emitSum (aName a <> "Command") (aCommands a)], - map (emitRecord a) (aEvents a), - [emitSum (aName a <> "Event") (aEvents a)], - [emitRegsType a, emitInitialRegs a], - [ "$(deriveAggregateCtorsAll ''" <> aName a <> "Command ''" <> aName a <> "Regs)", - "", - "$(deriveWireCtorsAll ''" <> aName a <> "Event)" - ] - ] - ] - -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 :: Agg -> ResolvedCtor -> Text -emitRecord a rc = - nl $ - [ "data " <> rcName rc <> "Data = " <> rcName rc <> "Data" - ] - ++ recordFields [(name, renderDomainType a fieldType) | (name, 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 :: Agg -> Text -emitRegsType a = - nl $ - ["type " <> aName a <> "Regs ="] - ++ regListLines a (aRegs a) - -regListLines :: Agg -> [ResolvedRegister] -> [Text] -regListLines _ [] = [" '[]"] -regListLines a rs = - [ lead i <> "'(" <> tshow (rrName r) <> ", " <> renderDomainType a (rrType r) <> ")" - | (i, r) <- zip [(0 :: Int) ..] rs - ] - ++ [" ]"] - where - lead 0 = " '[ " - lead _ = " , " - -emitInitialRegs :: Agg -> Text -emitInitialRegs 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 a r <> " $" - | r <- init rs - ] - ++ [" RCons (Proxy @" <> tshow (rrName lastR) <> ") " <> regInitialValue a lastR <> " RNil"] - where - lastR = last rs - --- | The Haskell initial value for a register, by the category of its type. -regInitialValue :: Agg -> ResolvedRegister -> Text -regInitialValue aggregate register = case rrInitial register of - InitialId name -> case find ((== name) . resolvedNominalName) (aGeneratedNominals aggregate) >>= generatedIdSampleHaskell aggregate of - Just value -> value - Nothing -> renderRegisterInitial (rrInitial register) - _ -> renderRegisterInitial (rrInitial register) - -domainConsumerImports :: Agg -> [Text] -domainConsumerImports a = - sort . nub $ - Set.toList (Set.unions [aggregateImports (aSymbols a) resolved | resolved <- aggregateTypes]) - <> [ qualifiedModule initialValue <> " qualified" - | declaration <- mappedUses a, - initialValue <- maybeToListText (mappedInitial declaration) - ] - <> [ qualifiedModule initialValue <> " qualified" - | resolvedType <- aggregateTypes, - AggregateNominal nominal <- [resolvedType], - ConsumerNominal binding <- [resolvedNominalOwnership nominal], - initialValue <- maybeToListText (consumerNominalInitial binding) - ] - where - aggregateTypes = map snd (concatMap rcFields (aCommands a <> aEvents a)) <> map rrType (aRegs a) - -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 :: Agg -> ResolvedAggregateType -> Text -renderDomainType a = aggregateHaskellType (aSymbols a) - -maybeToListText :: Maybe value -> [value] -maybeToListText = maybe [] pure - --------------------------------------------------------------------------------- --- Codec module --------------------------------------------------------------------------------- - -emitCodec :: Agg -> Text -emitCodec a = - nl $ - ["{-# LANGUAGE DataKinds #-}" | hasConsumerNominalIdCodec a] - ++ ["{-# LANGUAGE TypeApplications #-}" | hasConsumerNominalIdCodec a] - ++ ["{-# LANGUAGE LambdaCase #-}" | hasConsumerNominalCodec a || hasGeneratedNominalEnumCodec a] - ++ [ "{-# LANGUAGE OverloadedRecordDot #-}", - 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) - ++ ( if hasMappedCodec a - then - [ "import Control.Monad (unless)", - "import Data.Aeson (Value (..), object, parseJSON, toJSON, withObject, withText, (.:), (.=))", - "import Data.Aeson.Key qualified as Key", - "import Data.Aeson.KeyMap qualified as KeyMap" - ] - else ["import Data.Aeson (Value, object, withObject, (.:), (.=))"] - ) - ++ [ "import Data.Aeson.Types (Parser, parseEither)", - "import Data.List.NonEmpty (NonEmpty (..))" - ] - ++ ( if hasMappedCodec 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)" | hasMappedCodec a] - ++ [ "import Keiro.Codec (Codec (..), EventType (..))", - upcasterImport a - ] - ++ [nl (map ("import " <>) (codecMappedImports a)) | hasMappedCodec a] - ++ [nl (map ("import " <>) (codecNominalImports a)) | hasConsumerNominalCodec a] - ++ [ "", - emitEnumParsers a, - emitConsumerNominalParsers a - ] - ++ [emitMappedCodecs a | hasMappedCodec a] - ++ [ "", - emitCodecValue a, - "", - emitEncode a, - "", - emitDecode a, - "", - "mapLeftText :: Either String b -> Either Text b", - "mapLeftText = either (Left . T.pack) Right" - ] - ++ ( if hasMappedCodec 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 - mappedExports (ResolvedStructural declaration _) = - [ " encode" <> sdName declaration <> "Mapped,", - " decode" <> sdName declaration <> "Mapped," - ] - mappedExports ResolvedOpaque {} = [] - -hasMappedCodec :: Agg -> Bool -hasMappedCodec = not . null . codecMappedDeclarations - -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) - -hasGeneratedNominalEnumCodec :: Agg -> Bool -hasGeneratedNominalEnumCodec aggregate = - any - (\nominal -> case resolvedNominalRepresentation nominal of EnumRepresentation {} -> True; _ -> False) - (codecGeneratedNominals 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] - ++ [" _ -> fail " <> tshow ("unknown " <> name)] - _ -> error "non-enum reached generated enum parser emission" - where - name = resolvedNominalName nominal - -emitConsumerNominalParsers :: Agg -> Text -emitConsumerNominalParsers aggregate = sectionsOf [map emitParser (codecConsumerNominals aggregate)] - where - emitParser nominal = case (resolvedNominalRepresentation nominal, resolvedNominalOwnership nominal) of - (IdRepresentation prefix, ConsumerNominal binding) -> - nl - [ parserName nominal <> " :: Text -> Parser " <> renderHaskellSource (consumerNominalHaskell binding), - parserName nominal <> " input = " <> validationPrefix prefix <> "case KindID.parseText @" <> tshow prefix <> " input of", - " Left reason -> fail (show reason)", - " Right representation -> pure (nominalFromRepresentation " <> unQualifiedValueName (consumerNominalBinding binding) <> " representation)" - ] - (EnumRepresentation constructors, ConsumerNominal binding) -> - nl $ - [ parserName nominal <> " :: Text -> Parser " <> renderHaskellSource (consumerNominalHaskell binding), - parserName nominal <> " = \\case" - ] - <> [ " " - <> tshow wire - <> " -> pure (nominalFromRepresentation " - <> unQualifiedValueName (consumerNominalBinding binding) - <> " " - <> nominalRepresentationModule (aContext aggregate) (resolvedNominalName nominal) - <> "." - <> constructor - <> ")" - | (constructor, wire) <- NE.toList constructors - ] - <> [" _ -> fail " <> tshow ("unknown " <> resolvedNominalName nominal <> " wire value")] - _ -> "" - parserName nominal = "parse" <> resolvedNominalName nominal <> "Nominal" - validationPrefix prefix = case idDomainContractFor (aLanguageContract aggregate) prefix of - Nothing -> "" - Just _ -> - "case validateIdDomainText (typeIdV7Domain " - <> tshow prefix - <> ") input of Left reason -> fail (show reason); Right () -> " - -emitCodecValue :: Agg -> Text -emitCodecValue a = - nl $ - [ lowerFirst (aName a) <> "Codec :: Codec " <> aName a <> "Event", - lowerFirst (aName a) <> "Codec =", - " Codec", - " { eventTypes = " <> eventTypesExpr, - " , 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 - where - eventTypesExpr = case map rcName (aEvents a) of - [] -> "error \"no events\"" - (e : es) -> "EventType " <> tshow e <> " :| [" <> T.intercalate ", " (map (("EventType " <>) . tshow) es) <> "]" - --- | 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 :: Agg -> Text -emitEncode 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 (n, ty) = - tshow n - <> " .= " - <> encodeFieldValue n ty - encodeFieldValue name ty = case ty of - AggregateNominal nominal -> encodeNominalValue nominal ("payload." <> name) - _ -> case fieldCat a ty of - MappedStructuralCat declaration _ -> "encode" <> sdName declaration <> "Mapped payload." <> name - MappedOpaqueCat {} -> "toJSON payload." <> name - _ -> "payload." <> name - 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 {} -> - nominalRepresentationModule (aContext a) (resolvedNominalName nominal) - <> "." - <> lowerFirst (resolvedNominalName nominal) - <> "RepresentationText (nominalToRepresentation " - <> bindingName binding - <> " " - <> value - <> ")" - ScalarRepresentation {} -> "nominalToRepresentation " <> bindingName binding <> " " <> value - bindingName = unQualifiedValueName . consumerNominalBinding - -emitDecode :: Agg -> Text -emitDecode 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) - ++ [" _ -> fail \"unknown event type\""] - where - decodeArm e = - [ " " <> tshow (rcName e) <> " ->", - " " <> rcName e <> " <$> (" <> rcName e <> "Data" <> fieldApps (rcFields e) <> ")" - ] - fieldApps [] = "" - fieldApps fs = " <$> " <> T.intercalate " <*> " (map decodeField fs) - -- The first field uses <$> (handled above), the rest <*>. We instead build - -- a uniform list and join; for an empty record there are no fields. - decodeField (n, ty) = case ty of - AggregateNominal nominal -> decodeNominalField n nominal - _ -> case fieldCat a ty of - MappedStructuralCat declaration _ -> "(o .: " <> tshow n <> " >>= parse" <> sdName declaration <> "Mapped)" - MappedOpaqueCat {} -> "o .: " <> tshow n - _ -> "o .: " <> tshow n - 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 {} -> "(o .: " <> tshow name <> " >>= parse" <> resolvedNominalName nominal <> ")" - ScalarRepresentation {} -> "o .: " <> tshow name - ConsumerNominal binding -> case resolvedNominalRepresentation nominal of - IdRepresentation {} -> "(o .: " <> tshow name <> " >>= parse" <> resolvedNominalName nominal <> "Nominal)" - EnumRepresentation {} -> "(o .: " <> tshow name <> " >>= parse" <> resolvedNominalName nominal <> "Nominal)" - ScalarRepresentation {} -> "(nominalFromRepresentation " <> unQualifiedValueName (consumerNominalBinding binding) <> " <$> o .: " <> tshow name <> ")" - -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 - ] - -codecNominalImports :: Agg -> [Text] -codecNominalImports aggregate = - sort . nub $ - concat - [ [ hsModule (consumerNominalHaskell binding) <> " qualified", - qualifiedModule (consumerNominalBinding binding) <> " qualified" - ] - <> [ nominalRepresentationModule (aContext aggregate) (resolvedNominalName nominal) <> " qualified" - | EnumRepresentation {} <- [resolvedNominalRepresentation nominal] - ] - | nominal <- codecConsumerNominals aggregate, - ConsumerNominal binding <- [resolvedNominalOwnership nominal] - ] - -codecMappedImports :: Agg -> [Text] -codecMappedImports a = case aTypeGraph a of - Nothing -> [] - Just graph -> - sort . nub $ - [ structuralShapeModule (aContext a) (sdName declaration) <> " qualified" - | ResolvedStructural declaration _ <- codecMappedDeclarations a - ] - <> [ hsModule (sdHaskell declaration) <> " qualified" - | ResolvedStructural declaration _ <- codecMappedDeclarations a - ] - <> [ qualifiedModule (sdBinding declaration) <> " qualified" - | ResolvedStructural declaration _ <- codecMappedDeclarations a - ] - <> [ hsModule (odHaskell declaration) <> " qualified" - | ResolvedOpaque declaration <- codecMappedDeclarations a - ] - <> [ hsModule (odHaskell declaration) <> " qualified" - | 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 :: Agg -> Text -emitMappedCodecs a = case aTypeGraph a of - Nothing -> "" - Just graph -> - T.intercalate - "\n\n" - [ emitStructuralCodec a graph declaration shape - | ResolvedStructural declaration shape <- codecMappedDeclarations a - ] - -emitStructuralCodec :: Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text -emitStructuralCodec a graph declaration shape = - nl - [ "encode" <> name <> "Mapped :: " <> consumerType <> " -> Value", - "encode" <> name <> "Mapped = encode" <> name <> "Shape . bindingToShape " <> binding, - "", - "parse" <> name <> "Mapped :: Value -> Parser " <> consumerType, - "parse" <> name <> "Mapped value = bindingFromShape " <> binding <> " <$> parse" <> name <> "Shape value", - "", - "decode" <> name <> "Mapped :: Value -> Either Text " <> consumerType, - "decode" <> name <> "Mapped = mapLeftText . parseEither parse" <> name <> "Mapped", - "", - "encode" <> name <> "Shape :: " <> shapeType <> " -> Value", - emitShapeEncoder a graph declaration shape, - "", - "parse" <> name <> "Shape :: Value -> Parser " <> shapeType, - emitShapeDecoder a graph declaration shape - ] - where - name = sdName declaration - consumerType = renderHaskellSource (sdHaskell declaration) - shapeType = structuralShapeModule (aContext a) name <> "." <> name <> "Shape" - binding = unQualifiedValueName (sdBinding declaration) - -emitShapeEncoder :: Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text -emitShapeEncoder a graph declaration = - foldMappedShape - MappedShapeAlgebra - { onRecord = \_ _ fields -> - nl $ - ["encode" <> name <> "Shape shape =", " object"] - <> objectEntries - [ tshow (rwfKey field) - <> " .= " - <> encodeShapeExpr a graph (rwfType field) (shapeModuleName <> "." <> rwfHaskell field <> " shape") - | field <- fields - ], - onEnum = \entries -> - nl $ - ["encode" <> name <> "Shape = \\case"] - <> [" " <> shapeModuleName <> "." <> weCtor entry <> " -> String " <> tshow (weTag entry) | entry <- entries], - onUnion = \encoding arms -> - nl $ - ["encode" <> name <> "Shape = \\case"] - <> concatMap (unionEncodeArm encoding) arms - } - where - name = sdName declaration - shapeModuleName = structuralShapeModule (aContext a) name - unionEncodeArm encoding arm = - [ " " <> shapeModuleName <> "." <> rwaCtor arm <> payloadPattern <> " ->", - " object" - ] - <> objectEntries - ( [tshow (ueTagField encoding) <> " .= (" <> tshow (rwaTag arm) <> " :: Text)"] - <> [ tshow (ueContentsField encoding) <> " .= " <> encodeShapeExpr a graph payload "payload" - | payload <- maybeToListText (rwaPayload arm) - ] - ) - where - payloadPattern = maybe "" (const " payload") (rwaPayload arm) - -emitShapeDecoder :: Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text -emitShapeDecoder a graph declaration = - foldMappedShape - MappedShapeAlgebra - { onRecord = \constructor unknownFields fields -> - nl $ - [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do" - ] - <> rejectLine " " unknownFields (map rwfKey fields) "objectValue" - <> [ " " <> shapeModuleName <> "." <> constructor, - " <$> " <> T.intercalate "\n <*> " (map (decodeRecordField a graph) fields) - ], - onEnum = \entries -> - nl $ - [ "parse" <> name <> "Shape = withText " <> tshow (name <> "Shape") <> " $ \\tag -> case tag of" - ] - <> [" " <> tshow (weTag entry) <> " -> pure " <> shapeModuleName <> "." <> weCtor entry | entry <- entries] - <> [" _ -> fail " <> tshow ("unknown " <> name <> " wire value")], - onUnion = \encoding arms -> - nl $ - [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do", - " tag <- objectValue .: " <> tshow (ueTagField encoding) <> " :: Parser Text", - " case tag of" - ] - <> concatMap (unionDecodeArm encoding) arms - <> [" _ -> fail " <> tshow ("unknown " <> name <> " union tag")] - } - where - name = sdName declaration - shapeModuleName = structuralShapeModule (aContext a) name - 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 " <> shapeModuleName <> "." <> rwaCtor arm - Just payload -> - " " - <> shapeModuleName - <> "." - <> rwaCtor arm - <> " <$> (objectValue .: " - <> tshow (ueContentsField encoding) - <> " >>= (" - <> decodeShapeExpr a graph payload - <> "))" - ] - where - allowed = ueTagField encoding : [ueContentsField encoding | rwaPayload arm /= Nothing] - -decodeRecordField :: Agg -> TypeGraph -> ResolvedWireField -> Text -decodeRecordField a graph field = case rwfPresence field of - PRequired -> - "((objectValue .: " <> key <> " :: Parser Value) >>= (" <> decoder <> "))" - POptional -> - "(case KeyMap.lookup (Key.fromText " - <> key - <> ") objectValue of Nothing -> " - <> missing - <> "; Just presentValue -> " - <> "(" - <> decoder - <> ") presentValue)" - where - key = tshow (rwfKey field) - decoder = decodeShapeExpr a graph (rwfType field) - missing = case rwfOnMissing field of - Nothing -> "fail " <> tshow ("missing optional field without default: " <> rwfKey field) - Just onMissing -> "pure " <> renderMissingDefault a graph (rwfType field) onMissing - -encodeShapeExpr :: Agg -> TypeGraph -> ResolvedTypeExpr -> Text -> Text -encodeShapeExpr _a graph expression value = - foldTypeExpr - TypeExprAlgebra - { onText = \v -> "toJSON (" <> v <> ")", - onInt = \v -> "toJSON (" <> v <> ")", - onInteger = \v -> "toJSON (" <> v <> ")", - onBool = \v -> "toJSON (" <> v <> ")", - onNatural = \v -> "toJSON (" <> v <> ")", - onTime = \v -> "toJSON (" <> v <> ")", - onJson = id, - onOptional = \encode v -> "maybe Null (\\item -> " <> encode "item" <> ") (" <> v <> ")", - onList = \encode v -> "toJSON (map (\\item -> " <> encode "item" <> ") (" <> v <> "))", - onMap = \encode v -> "toJSON (Map.map (\\item -> " <> encode "item" <> ") (" <> v <> "))", - onRef = \key v -> case Map.lookup key (tgDeclarations graph) of - Just (ResolvedStructural nested _) -> "encode" <> sdName nested <> "Shape (" <> v <> ")" - Just (ResolvedOpaque _) -> "toJSON (" <> v <> ")" - Nothing -> "toJSON (" <> v <> ")" - } - expression - value - -decodeShapeExpr :: Agg -> TypeGraph -> ResolvedTypeExpr -> Text -decodeShapeExpr _a graph = - foldTypeExpr - TypeExprAlgebra - { onText = "parseJSON", - onInt = "parseJSON", - onInteger = "parseJSON", - onBool = "parseJSON", - onNatural = "parseJSON", - onTime = "parseJSON", - onJson = "pure", - onOptional = \decode -> "\\value -> case value of Null -> pure Nothing; other -> Just <$> " <> decode <> " other", - onList = \decode -> "\\value -> (parseJSON value :: Parser [Value]) >>= traverse (" <> decode <> ")", - onMap = \decode -> "\\value -> (parseJSON value :: Parser (Map Text Value)) >>= traverse (" <> decode <> ")", - onRef = \key -> case Map.lookup key (tgDeclarations graph) of - Just (ResolvedStructural nested _) -> "parse" <> sdName nested <> "Shape" - Just (ResolvedOpaque _) -> "parseJSON" - Nothing -> "parseJSON" - } - -renderMissingDefault :: Agg -> TypeGraph -> ResolvedTypeExpr -> OnMissing -> Text -renderMissingDefault a graph expression = \case - OmNull -> "Nothing" - OmText value -> tshow value - OmInt value -> T.pack (show value) - OmBool value -> if value then "True" else "False" - OmEmptyList -> "[]" - OmEmptyMap -> "Map.empty" - OmCtor constructor -> case expression of - RRef key -> case Map.lookup key (tgDeclarations graph) of - Just (ResolvedStructural declaration _) -> structuralShapeModule (aContext a) (sdName declaration) <> "." <> constructor - _ -> constructor - _ -> constructor - -objectEntries :: [Text] -> [Text] -objectEntries entries = - [lead index <> entry | (index, entry) <- zip [(0 :: Int) ..] entries] - <> [" ]"] - where - lead 0 = " [ " - lead _ = " , " - -renderTextList :: [Text] -> Text -renderTextList values = "[" <> T.intercalate ", " (map tshow values) <> "]" - --------------------------------------------------------------------------------- --- Authoritative version-2 expressions and transducer --------------------------------------------------------------------------------- - -hasVersion2Ownership :: Agg -> Bool -hasVersion2Ownership = any ((/= LegacyHoleImplementation) . tImplementation) . aTransitions - -transitionEntries :: Agg -> [(Int, Transition)] -transitionEntries aggregate = zip [1 ..] (aTransitions aggregate) - -transitionStem :: Int -> Transition -> Text -transitionStem index transition = - "transition" - <> tshow' index - <> pascal (tSource transition) - <> pascal (tCommand transition) - -guardFunctionName :: Int -> Transition -> Text -guardFunctionName index transition = transitionStem index transition <> "Guard" - -writeFunctionName :: Int -> Transition -> Name -> Text -writeFunctionName index transition registerName = - transitionStem index transition <> "Write" <> pascal registerName - -holeFunctionName :: Int -> Transition -> Text -holeFunctionName index transition = transitionStem index transition <> "Hole" - -holeFoldVersionName :: Int -> Transition -> Text -holeFoldVersionName index transition = holeFunctionName index transition <> "FoldVersion" - -outputFunctionName :: Int -> Transition -> Int -> Name -> Text -outputFunctionName transitionIndex transition emitIndex eventName = - transitionStem transitionIndex transition - <> "Output" - <> tshow' emitIndex - <> pascal eventName - --- | Legacy create-once output-hook names made obsolete by authoritative --- version-2 @fields(Command)@ generation. Scaffolding reports these names as --- safe-to-remove candidates without parsing or modifying consumer Haskell. -obsoleteGeneratedOutputHooks :: Spec -> [(Name, Text)] -obsoleteGeneratedOutputHooks spec = - [ ( aggName aggregate, - outputFunctionName transitionIndex transition emitIndex eventName - ) - | aggregate <- [value | NAggregate value <- specNodes spec], - (transitionIndex, transition) <- zip [1 ..] (aggTransitions aggregate), - (emitIndex, eventName) <- zip [1 ..] (tEmits transition), - Right GeneratedCommandIdentity {} <- [eventOutputMapping spec aggregate transition emitIndex eventName] - ] - -commandForTransition :: Agg -> Transition -> ResolvedCtor -commandForTransition aggregate transition = - fromMaybe - (error ("validated aggregate command disappeared: " <> T.unpack (tCommand transition))) - (find ((== tCommand transition) . rcName) (aCommands aggregate)) - -eventForName :: Agg -> Name -> ResolvedCtor -eventForName aggregate eventName = - fromMaybe - (error ("validated aggregate event disappeared: " <> T.unpack eventName)) - (find ((== eventName) . rcName) (aEvents aggregate)) - -commandFieldsType :: Transition -> Text -commandFieldsType transition = "RegFieldsOf " <> tCommand transition <> "Data" - -payloadProjectionType :: Agg -> Transition -> Text -payloadProjectionType aggregate transition = - "B.PayloadProj " - <> aName aggregate - <> "Regs " - <> aName aggregate - <> "Command (" - <> commandFieldsType transition - <> ")" - -expressionFunctionNames :: Agg -> [Text] -expressionFunctionNames aggregate = - concat - [ maybe [] (const [guardFunctionName index transition]) (tGuard transition) - <> [writeFunctionName index transition registerName | (registerName, _) <- tWrites transition] - | (index, transition) <- transitionEntries aggregate, - tImplementation transition == GeneratedImplementation - ] - -emitExpressions :: Agg -> Text -emitExpressions aggregate - | null exports = nl [generatedBanner, "module " <> aGenPrefix aggregate <> ".Expressions () where"] - | otherwise = - nl $ - [ "{-# LANGUAGE DataKinds #-}", - "{-# LANGUAGE OverloadedLabels #-}", - "{-# LANGUAGE OverloadedRecordDot #-}", - "{-# LANGUAGE TypeApplications #-}", - generatedBanner - ] - ++ moduleDeclaration - ++ [ "", - "import " <> aGenPrefix aggregate <> ".Domain", - "import Keiki.Builder qualified as B", - "import Keiki.Core qualified as K", - "import Keiki.Generics (RegFieldsOf)" - ] - ++ ["import Data.Text (Text)" | expressionUsesType AggregateText || expressionUsesNominalEqualityKey] - ++ ["import Data.Time.Clock (UTCTime)" | expressionUsesType AggregateTime && not expressionUsesTimeLiteral] - ++ ["import Data.Time.Calendar (fromGregorian)" | expressionUsesTimeLiteral] - ++ ["import Data.Time.Clock (UTCTime (..), picosecondsToDiffTime)" | expressionUsesTimeLiteral] - ++ ["import Numeric.Natural (Natural)" | expressionUsesType AggregateNatural] - ++ generatedNominalTypeImportsForService (aggregateCheckedService aggregate) (aContext aggregate) generatedExpressionNominals - ++ structuralProjectionImport - ++ generatedNominalProjectionImport - ++ consumerNominalProjectionImport - ++ consumerImports - ++ ["import Data.KindID qualified as KindID" | expressionUsesConsumerIdLiteral] - ++ ["import Keiro.Codec.Nominal (nominalFromRepresentation)" | expressionUsesConsumerNominalLiteral] - ++ consumerLiteralImports - ++ concatMap (uncurry (emitTransitionExpressions aggregate)) (transitionEntries aggregate) - where - exports = expressionFunctionNames aggregate - moduleDeclaration = case exports of - firstExport : rest -> - [ "module " <> aGenPrefix aggregate <> ".Expressions", - " ( " <> firstExport - ] - ++ [" , " <> value | value <- rest] - ++ [" ) where"] - [] -> error "non-empty expression export invariant" - structuralProjectionImport = - [ "import " <> structuralProjectionModule (aContext aggregate) <> " qualified as StructuralProjections" - | maybe False (not . null . projectionSpecs) (aTypeGraph aggregate) - ] - generatedNominalProjectionImport = - [ "import " <> generatedNominalModule (aContext aggregate) <> " qualified as GeneratedNominals" - | any expressionUsesGeneratedNominalProjection resolvedExpressions - ] - consumerNominalProjectionImport = - [ "import " <> nominalProjectionModule (aContext aggregate) <> " qualified as NominalProjections" - | any expressionUsesConsumerNominalProjection resolvedExpressions - ] - consumerImports = - map ("import " <>) - . filter (not . builtinExpressionImport) - . sort - . nub - . Set.toList - . Set.unions - $ [ aggregateImports (aSymbols aggregate) resolvedType - | resolvedType <- map rrType (aRegs aggregate) <> map snd (concatMap rcFields (aCommands aggregate)) - ] - consumerLiteralImports = - [ "import " <> nominalRepresentationModule (aContext aggregate) (resolvedNominalName nominal) <> " qualified" - | nominal <- consumerLiteralNominals, - EnumRepresentation {} <- [resolvedNominalRepresentation nominal] - ] - <> [ "import " <> qualifiedModule (consumerNominalBinding binding) <> " qualified" - | nominal <- consumerLiteralNominals, - ConsumerNominal binding <- [resolvedNominalOwnership nominal] - ] - resolvedExpressions = resolvedGeneratedExpressions aggregate - expressionUsesType wanted = any (anyTypedExpression ((== wanted) . typedScalarType)) resolvedExpressions - expressionUsesTimeLiteral = any (anyTypedExpression isTimeLiteral) resolvedExpressions - expressionUsesConsumerNominalLiteral = not (null consumerLiteralNominals) - expressionUsesConsumerIdLiteral = any (isIdRepresentation . resolvedNominalRepresentation) consumerLiteralNominals - expressionUsesNominalEqualityKey = any (anyTypedExpression isNominalEqualityOperand) resolvedExpressions - consumerLiteralNominals = nub [nominal | expression <- resolvedExpressions, nominal <- typedConsumerLiteralNominals expression] - generatedExpressionNominals = - stableNominals - [ nominal - | expression <- resolvedExpressions, - nominal <- typedGeneratedNominals expression - ] - isTimeLiteral expression = case typedScalarNode expression of - TypedLiteral ScalarTimeValue {} -> True - _ -> False - isIdRepresentation IdRepresentation {} = True - isIdRepresentation _ = False - -builtinExpressionImport :: Text -> Bool -builtinExpressionImport imported = - any (`T.isPrefixOf` imported) ["Data.Text", "Data.Time", "Numeric.Natural"] - -resolvedGeneratedExpressions :: Agg -> [TypedScalarExpr] -resolvedGeneratedExpressions aggregate = - concat - [ maybe [] (pure . resolvedGuard index transition) (tGuard transition) - <> [ resolvedWrite index transition registerName expression - | (registerName, expression) <- tWrites transition - ] - | (index, transition) <- transitionEntries aggregate, - tImplementation transition == GeneratedImplementation - ] - where - environment transition = expressionEnvironment (aSpec aggregate) (aAggregate aggregate) transition - resolvedGuard index transition expression = - expressionOrDie (guardFunctionName index transition) (resolveGuardExpr (environment transition) expression) - resolvedWrite index transition registerName expression = - expressionOrDie (writeFunctionName index transition registerName) (resolveWriteExpr (environment transition) registerName expression) - -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] - -isNominalEqualityOperand :: TypedScalarExpr -> Bool -isNominalEqualityOperand expression = case (typedScalarType expression, typedScalarNode expression) of - (AggregateNominal nominal, TypedRoot {}) -> case (resolvedNominalOwnership nominal, resolvedNominalRepresentation nominal) of - (ConsumerNominal {}, ScalarRepresentation {}) -> True - (_, IdRepresentation {}) -> True - (_, EnumRepresentation {}) -> True - _ -> False - _ -> False - -expressionUsesGeneratedNominalProjection :: TypedScalarExpr -> Bool -expressionUsesGeneratedNominalProjection = anyTypedExpression $ \expression -> case (typedScalarType expression, typedScalarNode expression) of - (AggregateNominal nominal, TypedRoot {}) -> case (resolvedNominalOwnership nominal, resolvedNominalRepresentation nominal) of - (GeneratedNominal, IdRepresentation {}) -> True - (GeneratedNominal, EnumRepresentation {}) -> True - _ -> False - _ -> False - -expressionUsesConsumerNominalProjection :: TypedScalarExpr -> Bool -expressionUsesConsumerNominalProjection = anyTypedExpression $ \expression -> case (typedScalarType expression, typedScalarNode expression) of - (AggregateNominal nominal, TypedRoot {}) -> case resolvedNominalOwnership nominal of - ConsumerNominal {} -> True - GeneratedNominal -> False - _ -> False - -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] - _ -> [] - -emitTransitionExpressions :: Agg -> Int -> Transition -> [Text] -emitTransitionExpressions aggregate index transition - | tImplementation transition /= GeneratedImplementation = [] - | otherwise = - concat - [ maybe [] (emitGuardDefinition aggregate index transition) (tGuard transition), - concatMap (uncurry (emitWriteDefinition aggregate index transition)) (tWrites transition) - ] - -emitGuardDefinition :: Agg -> Int -> Transition -> Expr -> [Text] -emitGuardDefinition aggregate index transition expression = - [ "", - functionName <> " :: " <> payloadProjectionType aggregate transition <> " -> K.HsPred " <> aName aggregate <> "Regs " <> aName aggregate <> "Command", - functionName <> " d = " <> renderKeikiPredicate aggregate transition resolved - ] - where - functionName = guardFunctionName index transition - resolved = expressionOrDie functionName (resolveGuardExpr (expressionEnvironment (aSpec aggregate) (aAggregate aggregate) transition) expression) - -emitWriteDefinition :: Agg -> Int -> Transition -> Name -> Expr -> [Text] -emitWriteDefinition aggregate index transition registerName expression = - [ "", - functionName - <> " :: " - <> payloadProjectionType aggregate transition - <> " -> K.Term " - <> aName aggregate - <> "Regs " - <> aName aggregate - <> "Command (" - <> commandFieldsType transition - <> ") " - <> renderDomainType aggregate (typedScalarType resolved), - functionName <> " d = " <> renderKeikiTerm aggregate transition resolved - ] - where - functionName = writeFunctionName index transition registerName - resolved = expressionOrDie functionName (resolveWriteExpr (expressionEnvironment (aSpec aggregate) (aAggregate aggregate) transition) registerName expression) - -expressionOrDie :: Text -> Either (NonEmpty ExpressionDiagnostic) TypedScalarExpr -> TypedScalarExpr -expressionOrDie owner = either (error . (("validated expression disappeared for " <> T.unpack owner <> ": ") <>) . show) id - -renderKeikiPredicate :: Agg -> Transition -> TypedScalarExpr -> Text -renderKeikiPredicate aggregate transition expression = case typedScalarNode expression of - TypedEqual left right -> "K.PEq " <> atom (renderComparisonTerm aggregate transition left) <> " " <> atom (renderComparisonTerm aggregate transition right) - TypedNotEqual left right -> "K.pnot (K.PEq " <> atom (renderComparisonTerm aggregate transition left) <> " " <> atom (renderComparisonTerm aggregate transition right) <> ")" - TypedCompare operator left right -> - "K.PCmp " - <> renderKeikiCmp operator - <> " " - <> atom (renderComparisonTerm aggregate transition left) - <> " " - <> atom (renderComparisonTerm aggregate transition right) - TypedAnd left right -> "K.PAnd " <> atom (renderKeikiPredicate aggregate transition left) <> " " <> atom (renderKeikiPredicate aggregate transition right) - TypedOr left right -> "K.POr " <> atom (renderKeikiPredicate aggregate transition left) <> " " <> atom (renderKeikiPredicate aggregate transition right) - _ -> "K.PEq " <> atom (renderKeikiTerm aggregate transition expression) <> " (K.lit True)" - where - atom value = "(" <> value <> ")" - -renderKeikiCmp :: CmpOp -> Text -renderKeikiCmp = \case - OpEq -> error "equality is rendered as PEq" - OpNeq -> error "inequality is rendered as pnot PEq" - OpLt -> "K.CmpLt" - OpLe -> "K.CmpLe" - OpGt -> "K.CmpGt" - OpGe -> "K.CmpGe" - -renderComparisonTerm :: Agg -> Transition -> TypedScalarExpr -> Text -renderComparisonTerm aggregate transition expression = case (typedScalarType expression, typedScalarNode expression) of - (AggregateNominal nominal, TypedRoot provenance) - | nominalComparisonProjection nominal -> renderNominalProjectionTerm aggregate transition nominal provenance - (AggregateNominal nominal, TypedLiteral (ScalarEnumValue _ constructor)) -> - "K.lit (" <> tshow (enumWireFor nominal constructor) <> " :: Text)" - (AggregateNominal _, TypedLiteral (ScalarIdValue _ value)) -> - "K.lit (" <> tshow value <> " :: Text)" - _ -> renderKeikiTerm 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 :: Agg -> Transition -> ResolvedNominalType -> ScalarRootProvenance -> Text -renderNominalProjectionTerm aggregate transition nominal provenance = case provenance of - ScalarRegisterRoot registerName ownerType -> - "K.regProj " - <> projectionQualifier - <> "." - <> witness - <> " (#" - <> registerName - <> " :: K.Index " - <> aName aggregate - <> "Regs " - <> renderDomainType aggregate ownerType - <> ")" - ScalarCommandRoot fieldName ownerType -> - "K.inpProj " - <> projectionQualifier - <> "." - <> witness - <> " inCtor" - <> tCommand transition - <> " (#" - <> fieldName - <> " :: K.Index (" - <> commandFieldsType transition - <> ") " - <> renderDomainType 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 :: Agg -> Transition -> TypedScalarExpr -> Text -renderKeikiTerm aggregate transition expression = case typedScalarNode expression of - TypedLiteral value -> renderKeikiLiteral aggregate (typedScalarType expression) value - TypedRoot (ScalarRegisterRoot registerName _) -> "B.reg @" <> tshow registerName - TypedRoot (ScalarCommandRoot fieldName _) -> "d." <> fieldName - TypedProject provenance projection -> renderStructuralProjectionTerm aggregate transition provenance projection - TypedAdd _ left right -> binary "K.tadd" left right - TypedSubtract _ left right -> binary "K.tsub" left right - TypedMultiply _ left right -> binary "K.tmul" left right - TypedEqual {} -> impossiblePredicate - TypedNotEqual {} -> impossiblePredicate - TypedCompare {} -> impossiblePredicate - TypedAnd {} -> impossiblePredicate - TypedOr {} -> impossiblePredicate - where - binary operator left right = operator <> " " <> parenthesized left <> " " <> parenthesized right - parenthesized = (\value -> "(" <> value <> ")") . renderKeikiTerm aggregate transition - impossiblePredicate = error "predicate-valued Boolean expressions cannot be lowered as register terms" - -renderStructuralProjectionTerm :: Agg -> Transition -> ScalarRootProvenance -> ResolvedScalarProjection -> Text -renderStructuralProjectionTerm aggregate transition provenance projection = case provenance of - ScalarRegisterRoot registerName ownerType -> - "K.regProj StructuralProjections." - <> witness - <> " (#" - <> registerName - <> " :: K.Index " - <> aName aggregate - <> "Regs " - <> renderDomainType aggregate ownerType - <> ")" - ScalarCommandRoot fieldName ownerType -> - "K.inpProj StructuralProjections." - <> witness - <> " inCtor" - <> tCommand transition - <> " (#" - <> fieldName - <> " :: K.Index (" - <> commandFieldsType transition - <> ") " - <> renderDomainType aggregate ownerType - <> ")" - where - witness = lowerFirst (projectionTag (unMappedKey (scalarProjectionOwner projection)) (scalarProjectionPointer projection)) <> "Witness" - -renderKeikiLiteral :: Agg -> ResolvedAggregateType -> ScalarValue -> Text -renderKeikiLiteral 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 " - <> unQualifiedValueName (consumerNominalBinding binding) - <> " " - <> nominalRepresentationModule (aContext aggregate) typeName - <> "." - <> 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 " - <> unQualifiedValueName (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 $ - [ "{-# LANGUAGE BlockArguments #-}", - "{-# LANGUAGE DataKinds #-}", - "{-# LANGUAGE GADTs #-}", - "{-# LANGUAGE OverloadedRecordDot #-}", - "{-# LANGUAGE QualifiedDo #-}", - "{-# LANGUAGE TypeApplications #-}", - 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 Keiki.Builder qualified as B", - "import Keiki.Core (HsPred, SymTransducer)", - "import Keiki.Core qualified as K", - "import Keiki.Symbolic qualified as S" - ] - ++ ["import " <> aHolePrefix aggregate <> ".Holes qualified as Holes" | transducerUsesHoles aggregate] - ++ ["import " <> aGenPrefix aggregate <> ".Expressions qualified as Expressions" | not (null (expressionFunctionNames aggregate))] - ++ ["import Data.Text qualified as T" | anyHoleOwned aggregate] - ++ ["import Keiki.Builder ((=:))" | any (not . null . tWrites . snd) (transitionEntries aggregate)] - ++ ["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 aggregate) (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\")" - ] - -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) <- groupTransitionEntriesBySource aggregate, - (edgeIndex, (transitionIndex, transition)) <- zip [0 ..] transitions - ] - -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 = go [] (transitionEntries aggregate) - where - go accumulated [] = reverse accumulated - go accumulated (entry@(_, transition) : remaining) = - let source = tSource transition - (same, rest) = span ((== source) . tSource . snd) remaining - in go ((source, entry : same) : accumulated) rest - -generatedFromBlock :: Agg -> (Text, [(Int, Transition)]) -> [Text] -generatedFromBlock aggregate (source, transitions) = - [" B.from " <> vertexCtor aggregate source <> " do"] - ++ concatMap (uncurry (generatedOnCmdBlock aggregate)) transitions - -generatedOnCmdBlock :: Agg -> Int -> Transition -> [Text] -generatedOnCmdBlock aggregate index transition = - [" B.onCmd inCtor" <> tCommand transition <> " $ \\d -> B.do"] - ++ [" 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 [] (const [" B.requireGuard (Expressions." <> guardFunctionName index transition <> " d)"]) (tGuard transition) - ++ [ " B.slot @" <> tshow registerName <> " =: Expressions." <> writeFunctionName index transition registerName <> " d" - | (registerName, _) <- tWrites transition - ] - HoleImplementation -> [" Holes." <> holeFunctionName index transition <> " d"] - LegacyHoleImplementation -> error "legacy transition reached version-2 transducer generation" - outputLines = - concat - [ generatedOutputLines aggregate index transition emitIndex eventName - | (emitIndex, eventName) <- zip [1 ..] (tEmits transition) - ] - -generatedOutputLines :: Agg -> Int -> Transition -> Int -> Name -> [Text] -generatedOutputLines aggregate transitionIndex transition emitIndex eventName = - case outputMappingFor aggregate transitionIndex emitIndex of - GeneratedCommandIdentity _ fields -> case fields of - [] -> [" B.emit wire" <> eventName <> " B.oNil"] - _ -> - [ " B.emit wire" <> eventName <> " (" <> eventName <> "TermFields" - ] - <> [ lead fieldIndex - <> outputSelector field - <> " = d." - <> outputSelector field - | (fieldIndex, field) <- zip [0 :: Int ..] fields - ] - <> [" })"] - HandOwnedEventOutput {} -> - [ " B.emit wire" - <> eventName - <> " (Holes." - <> outputFunctionName transitionIndex transition emitIndex eventName - <> " d)" - ] - where - lead 0 = " { " - lead _ = " , " - -outputMappingFor :: Agg -> Int -> Int -> EventOutputMapping -outputMappingFor aggregate transitionIndex emitIndex = - fromMaybe - (error ("missing checked event-output mapping for transition " <> show transitionIndex <> ", emit " <> show emitIndex)) - (Map.lookup (transitionIndex, emitIndex) (aOutputMappings aggregate)) - --------------------------------------------------------------------------------- --- EventStream module --------------------------------------------------------------------------------- - -emitEventStream :: Agg -> Text -emitEventStream a = - nl $ - [ generatedBanner, - "module " <> aGenPrefix a <> ".EventStream", - " ( " <> lowerFirst (aName a) <> "Category", - " , " <> lowerFirst (aName a) <> "EventStream", - " , " <> lowerFirst (aName a) <> "EventStreamDef", - " , " <> aName a <> "EventStream", - " , " <> aName a <> "EventStreamDef" - ] - ++ [" , " <> lowerFirst (aName a) <> "SnapshotFixture" | hasSnapshot a] - ++ [ " ) where", - "", - "import " <> aGenPrefix a <> ".Domain", - "import " <> aGenPrefix a <> ".Codec (" <> lowerFirst (aName a) <> "Codec)", - transducerImport a, - "import Keiki.Core (HsPred)", - "import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))", - "import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)" - ] - ++ ["import Data.Text (Text)" | hasSnapshot a] - ++ ["import Keiro.Snapshot.Codec (defaultStateCodec, withFoldFingerprint)" | hasSnapshot a] - ++ [ "import Keiro.Stream qualified as Stream", - "", - "-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).", - "-- Entity streams are '-' via Keiro.Stream.entityStream.", - "-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.", - lowerFirst (aName a) <> "Category :: Stream.StreamCategory a", - lowerFirst (aName a) <> "Category = Stream.categoryUnsafe " <> tshow categoryName, - "", - "type " <> aName a <> "EventStreamDef =", - " EventStream (HsPred " <> aName a <> "Regs " <> aName a <> "Command) " <> aName a <> "Regs " <> aVertexType a <> " " <> aName a <> "Command " <> aName a <> "Event", - "", - "type " <> aName a <> "EventStream =", - " ValidatedEventStream (HsPred " <> aName a <> "Regs " <> aName a <> "Command) " <> aName a <> "Regs " <> aVertexType a <> " " <> aName a <> "Command " <> aName a <> "Event", - "", - lowerFirst (aName a) <> "EventStreamDef :: " <> aName a <> "EventStreamDef", - lowerFirst (aName a) <> "EventStreamDef =", - " EventStream", - " { transducer = " <> lowerFirst (aName a) <> "Transducer", - " , initialState = " <> initialVertex a, - " , initialRegisters = initial" <> aName a <> "Regs", - " , eventCodec = " <> lowerFirst (aName a) <> "Codec", - " , resolveStreamName = Stream.streamName", - " , snapshotPolicy = " <> snapshotPolicyExpr a - ] - ++ stateCodecFieldLines a - ++ [ " }", - "" - ] - ++ snapshotFixtureLines a - ++ [ lowerFirst (aName a) <> "EventStream :: " <> aName a <> "EventStream", - lowerFirst (aName a) <> "EventStream =", - " mkEventStreamOrThrow " <> tshow (aName a) <> " " <> lowerFirst (aName a) <> "EventStreamDef" - ] - where - categoryName = staticCategory ("aggregate " <> aName a) (lowerFirst (aName a)) - -snapshotPolicyExpr :: Agg -> Text -snapshotPolicyExpr aggregate = case aSnapshot aggregate of - Nothing -> "Never" - Just snapshot -> case snapPolicy snapshot of - SnapEvery interval -> "Every " <> tshow' interval - SnapOnTerminal -> "OnTerminal" - -stateCodecExpr :: Agg -> Text -stateCodecExpr aggregate = case aSnapshot aggregate of - Nothing -> "Nothing" - Just snapshot -> - "Just (withFoldFingerprint " - <> foldFingerprintValue aggregate - <> " (defaultStateCodec " - <> tshow' (snapCodecVersion snapshot) - <> "))" - -transducerImport :: Agg -> Text -transducerImport aggregate - | hasVersion2Ownership aggregate = - "import " - <> aGenPrefix aggregate - <> ".Transducer (" - <> lowerFirst (aName aggregate) - <> "FoldFingerprint, " - <> 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 [generatedBanner, "module " <> aGenPrefix a <> ".Projection () where"] - Just p -> - nl - [ "{-# LANGUAGE OverloadedRecordDot #-}", - 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 [(fieldName, outputFieldValue fieldName fieldType) | (fieldName, fieldType) <- rcFields event]) - command = commandForTransition aggregate transition - outputFieldValue fieldName fieldType - | Just commandType <- lookup fieldName (rcFields command), - commandType == fieldType = - "d." <> fieldName - | Just register <- find ((== fieldName) . rrName) (aRegs aggregate), - rrType register == fieldType = - "B.reg @" <> tshow fieldName - | otherwise = "error " <> tshow ("HOLE: fill output field " <> rcName event <> "." <> fieldName) - valueRecord fields = - [ lead fieldIndex <> fieldName <> " = " <> fieldValue - | (fieldIndex, (fieldName, fieldValue)) <- zip [0 :: Int ..] fields - ] - ++ [" }"] - lead 0 = " { " - lead _ = " , " - -emitHoleImplementation :: Agg -> Int -> Transition -> [Text] -emitHoleImplementation _ 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 <> " _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 = go [] (transitionsOf a) - where - go acc [] = reverse acc - go acc (t : ts) = - let src = tSource t - (same, rest) = span ((== src) . tSource) ts - in go ((src, t : same) : acc) rest - --- 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." +-- service and output module-namespace root), it emits deterministic +-- @-- \@generated@ modules plus create-if-absent Hole modules for the behavior +-- that remains explicitly hand-owned. +-- +-- The load-bearing invariant of this module is the __firewall__: only a +-- generated aggregate @Transducer.hs@ may contain Keiki symbolic operators +-- (@./=@, @.==@, @.||@, @lit@, @B.slot@, @B.requireGuard@). Hand-owned Hole +-- modules remain the other intentional construction boundary. A generated-text +-- scan enforces the exception by path. +-- +-- Version-2 generated-owned transition bodies are rendered authoritatively in +-- that transducer. Explicit Hole-owned transitions keep only predicate/update +-- ownership; the generated command/event/target envelope remains authoritative. +-- Read-model SQL (the projection @apply@) is still a DB-coupled Hole delegated +-- to @codd@/the agent; the @Generated@ Projection module emits deterministic +-- @InlineProjection@ wiring and the pure event→status mapping. The decode emitted +-- here is /strict/ (every field required); lenient\/optional decode is EP-4's +-- concern. +module Keiro.Dsl.Scaffold + ( ScaffoldModule (..), + ModuleKind (..), + Context (..), + Placement (..), + defaultContext, + genPrefixFor, + holePrefixFor, + generatedNominalModule, + NominalUseSite (..), + NominalGenerationOwner (..), + planNominalGeneration, + planNominalGenerationForService, + generatedNominalsInTypes, + generatedNominalTypeImports, + generatedNominalTypeImportsForService, + generatedIdSampleHaskell, + scaffoldReplayAudit, + scaffoldStructural, + scaffoldStructuralForService, + scaffoldStructuralOwners, + scaffoldStructuralOwnersForService, + codecComparisonModule, + codecComparisonBanner, + bindingSkeletonModules, + bindingSkeletonOwners, + scaffoldAggregateForService, + scaffoldAggregate, + obsoleteGeneratedOutputHooks, + scaffoldProcess, + scaffoldRouter, + scaffoldContract, + scaffoldContractForService, + scaffoldIntake, + scaffoldPublisher, + scaffoldWorkqueue, + scaffoldReadModel, + scaffoldRefusals, + windowSeconds, + + -- * Firewall self-check (M3) + FirewallSurface (..), + firewallSurface, + firewallBreaches, + + -- * Internal resolution, shared with "Keiro.Dsl.Harness" + Agg (..), + aggregateCheckedService, + ResolvedRegister (..), + ResolvedCtor (..), + StructuralProjection (..), + resolveAggForService, + resolveAgg, + nominalEqualityUsedInGeneratedExpressions, + projectionSpecs, + resolveProjectionModules, + nominalProjectionModule, + codecMappedDeclarations, + FieldCat (..), + fieldCat, + vertexCtor, + initialVertex, + firstEnumCtor, + lowerFirst, + pascal, + pascalFromKebab, + generatedBanner, + generatedBannerFor, + isGeneratedBannerLine, + stampGeneratedModule, + stampGeneratedModules, + ) +where + +import Data.Char (isAlpha, isAlphaNum, isDigit, isUpper, toLower, toUpper) +import Data.List (find, findIndex, groupBy, isSuffixOf, nub, sort, sortOn) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Version (showVersion) +import Keiro.Dsl.AggregateType +import Keiro.Dsl.BehaviorCoverage qualified as Behavior +import Keiro.Dsl.CodecCompare (BranchArm (..), BranchField (..), BranchSchema (..)) +import Keiro.Dsl.EventOutput +import Keiro.Dsl.ExplainBindings (BindingObligation (..), BindingObligationKind (..), bindingObligations) +import Keiro.Dsl.Expression +import Keiro.Dsl.FoldFingerprint (aggregateFoldFingerprintForService, renderFoldSurfaceError) +import Keiro.Dsl.Grammar +import Keiro.Dsl.IdDomain (IdDomainContract, contractIdDomainContractFor, idDomainContractFor, idDomainPrefix, idDomainSampleText) +import Keiro.Dsl.LanguageVersion (SourceLanguage (LegacyUnversioned), languageVersionText) +import Keiro.Dsl.NominalType +import Keiro.Dsl.PrettyPrint (renderExpr) +import Keiro.Dsl.ReadModelShape (fnv1a64, registryNameFor, subscriptionNameFor) +import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveContractLanguageVersion, effectiveLanguageContract, legacyCheckedService) +import Keiro.Dsl.TypeGraph +import Keiro.Dsl.Validate (sagaCategoryError) +import Paths_keiro_dsl qualified as Package +import Text.Read (readMaybe) + +-- | One emitted module: its on-disk path (relative to the scaffold @--out@ +-- directory), its full text, and whether it is overwritten every run +-- ('Generated') or written only when absent ('HoleStub'). +data ScaffoldModule = ScaffoldModule + { modulePath :: !FilePath, + moduleText :: !Text, + kind :: !ModuleKind, + origin :: !Text + } + deriving stock (Eq, Show) + +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 +-- @\.Generated.\.\@ (identical to the historical layout); for +-- 'CollocatedLeaf' it is @\.\.\.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 hand-owned (hole) namespace for a 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 = case placement ctx of + GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".Nominals" + CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.Nominals" + +-- | The root namespace prefix, dot-terminated, or @""@ when no root is set. +rootPrefix :: Context -> Text +rootPrefix ctx = case moduleRoot ctx of r | T.null r -> ""; r -> r <> "." + +-- | The context name in PascalCase, e.g. @hospital-capacity@ -> @HospitalCapacity@. +ctxPascalOf :: Context -> Text +ctxPascalOf = pascalFromKebab . contextName + +-------------------------------------------------------------------------------- +-- Firewall self-check (M3) +-------------------------------------------------------------------------------- + +-- | The canonical keiki surface forbidden in generated modules. Symbolic +-- operators are matched as maximal Haskell symbol tokens, identifiers as complete +-- tokens, qualifiers by their leading module alias, and imports structurally. +data FirewallSurface = FirewallSurface + { forbiddenSymbolic :: ![Text], + forbiddenIdents :: ![Text], + forbiddenQualifiers :: ![Text], + forbiddenImports :: ![Text], + restrictedImports :: ![(Text, [Text])] + } + deriving stock (Eq, Show) + +firewallSurface :: FirewallSurface +firewallSurface = + FirewallSurface + { forbiddenSymbolic = [".==", "./=", ".<", ".<=", ".>", ".>=", ".&&", ".||", ".+", ".-", ".*", "=:", "*:"], + forbiddenIdents = ["lit", "pnot", "tadd", "tsub", "tmul"], + forbiddenQualifiers = ["B"], + forbiddenImports = ["Keiki.Builder", "Keiki.Operators", "Keiki.Symbolic"], + -- Generated aggregate modules use the first two names; generated + -- harnesses validate, step, and replay filled holes register by register. + restrictedImports = + [ ( "Keiki.Core", + [ "RegFile", + "HsPred", + "FieldProjection", + "ExactFieldProjection", + "FieldWitness", + "fieldWitness", + "exactFieldWitness", + "fieldWitnessAgrees", + "applyEventsEither", + "defaultValidationOptions", + "step", + "validateTransducer", + "EdgeMode", + "EdgeRef", + "StepSuccess", + "StepFailure", + "ReplayEventSpan", + "ReplayAttribution", + "ReplaySuccess", + "applyEventsDetailedEither", + "stepDetailedEither", + "!" + ] + ) + ] + } + +-- | Scan generated modules for firewall breaches, returning every offending +-- @(module path, token, 1-based line number)@. Only modules whose 'kind' is +-- 'Generated' are scanned. Strings and comments are skipped, symbol runs use +-- maximal munch, and keiki imports are checked independently of token spelling. +firewallBreaches :: [ScaffoldModule] -> [(FilePath, Text, Int)] +firewallBreaches mods = + [ (modulePath m, breach, n) + | m <- mods, + kind m == Generated, + not (authoritativeScalarModule (modulePath m)), + (n, line) <- zip [1 ..] (T.lines (moduleText m)), + breach <- lineBreaches line + ] + +-- The version-2 aggregate transducer is the narrow, intentional exception to +-- the generated symbolic-operator firewall: it is precisely the generated +-- authority that constructs Keiki terms. Every other generated module remains +-- subject to the original firewall. +authoritativeScalarModule :: FilePath -> Bool +authoritativeScalarModule path = "/Transducer.hs" `isSuffixOf` path + +lineBreaches :: Text -> [Text] +lineBreaches line = case importModule line of + Just _ -> importBreaches line + Nothing -> tokenBreaches (codeTokens line) + where + tokenBreaches = mapMaybe breachFor + breachFor (IdentToken ident) + | ident `elem` forbiddenIdents firewallSurface = Just ident + breachFor (QualifiedToken qualifier) + | qualifier `elem` forbiddenQualifiers firewallSurface = Just (qualifier <> ".*") + breachFor (SymbolToken symbol) + | symbol `elem` forbiddenSymbolic firewallSurface = Just symbol + breachFor _ = Nothing + +data CodeToken = IdentToken !Text | QualifiedToken !Text | SymbolToken !Text + +codeTokens :: Text -> [CodeToken] +codeTokens = go . T.unpack + where + go [] = [] + go ('-' : '-' : _) = [] + go ('"' : rest) = go (dropString rest) + go ('\'' : rest) = go (dropChar rest) + go (c : rest) + | isIdentStart c = + let (identTail, afterIdent) = span isIdentContinue rest + ident = T.pack (c : identTail) + in case afterIdent of + '.' : next : more + | isUpper c && isIdentStart next -> + let (_member, afterMember) = span isIdentContinue more + in QualifiedToken ident : go afterMember + _ -> IdentToken ident : go afterIdent + | isSymbolChar c = + let (symbolTail, afterSymbol) = span isSymbolChar rest + in SymbolToken (T.pack (c : symbolTail)) : go afterSymbol + | otherwise = go rest + isIdentStart c = isAlpha c || c == '_' + isIdentContinue c = isAlphaNum c || c == '_' || c == '\'' + isSymbolChar c = c `elem` ("!#$%&*+./<=>?@\\^|-~:" :: String) + dropString [] = [] + dropString ('\\' : _escaped : rest) = dropString rest + dropString ('"' : rest) = rest + dropString (_ : rest) = dropString rest + dropChar [] = [] + dropChar ('\\' : _escaped : rest) = dropChar rest + dropChar ('\'' : rest) = rest + dropChar (_ : rest) = dropChar rest + +importBreaches :: Text -> [Text] +importBreaches line = case importModule line of + Nothing -> [] + Just imported + | imported `elem` forbiddenImports firewallSurface -> ["import:" <> imported] + | Just allowed <- lookup imported (restrictedImports firewallSurface), + not (hasAllowedExplicitImportList allowed line) -> + ["import:" <> imported] + | otherwise -> [] + +importModule :: Text -> Maybe Text +importModule line = case T.words (T.strip line) of + "import" : rest -> find (T.isPrefixOf "Keiki.") rest + _ -> Nothing + +hasAllowedExplicitImportList :: [Text] -> Text -> Bool +hasAllowedExplicitImportList allowed line = + case (T.breakOn "(" line, T.breakOnEnd ")" line) of + ((_, open), (close, _)) + | not (T.null open) && not (T.null close) -> + let inside = T.takeWhile (/= ')') (T.drop 1 open) + names = filter (not . T.null) (T.split (not . isAlphaNum) inside) + in all (`elem` allowed) names + _ -> False + +-------------------------------------------------------------------------------- +-- Derived naming +-------------------------------------------------------------------------------- + +-- | Resolved, denormalized view of an aggregate used by every emitter. +data Agg = Agg + { aContext :: !Context, + aLanguageContract :: !EffectiveLanguageContract, + aSpec :: !Spec, + aAggregate :: !Aggregate, + aCtxPascal :: !Text, + aName :: !Text, + aLoc :: !Loc, + aVertexType :: !Text, + aIds :: ![IdDecl], + aEnums :: ![EnumDecl], + aRegs :: ![ResolvedRegister], + aStates :: ![StateDecl], + aCommands :: ![ResolvedCtor], + aEvents :: ![ResolvedCtor], + -- | Generated IDs and enums used by this aggregate, in stable name order. + aGeneratedNominals :: ![ResolvedNominalType], + aTransitions :: ![Transition], + aOutputMappings :: !(Map.Map (Int, Int) EventOutputMapping), + aWire :: !WireSpec, + aProjection :: !(Maybe ProjectionSpec), + aSnapshot :: !(Maybe SnapshotSpec), + aFoldFingerprint :: !Text, + aReadModels :: ![ReadModelNode], + aTypeGraph :: !(Maybe TypeGraph), + aSymbols :: !AggregateSymbols, + -- | e.g. @Generated.HospitalCapacity.Reservation@ + aGenPrefix :: !Text, + -- | e.g. @HospitalCapacity.Reservation@ + aHolePrefix :: !Text + } + +aggregateCheckedService :: Agg -> CheckedService +aggregateCheckedService aggregate = + CheckedService + { checkedLanguageContract = aLanguageContract aggregate, + checkedSpec = aSpec aggregate + } + +data ResolvedRegister = ResolvedRegister + { rrName :: !Name, + rrType :: !ResolvedAggregateType, + rrInitial :: !ResolvedRegisterInitial, + rrLoc :: !Loc + } + deriving stock (Eq, Show) + +-- | A command or event constructor with its fully-resolved field types. +data ResolvedCtor = ResolvedCtor + { rcName :: !Text, + -- | (field name, canonical aggregate type) + rcFields :: ![(Text, ResolvedAggregateType)], + -- | EP-2: schema version (1 for commands and unversioned events). + rcVersion :: !Int, + -- | EP-2: the source version this event migrates from (the upcaster step). + rcUpcastFrom :: !(Maybe Int) + } + +defaultWire :: WireSpec +defaultWire = WireSpec {wireKind = "ctorName", wireFields = "camelCase", wireSchemaVersion = 1} + +resolveAgg :: Context -> Spec -> Aggregate -> Agg +resolveAgg ctx spec = resolveAggForService ctx (legacyCheckedService spec) + +-- | Resolve one aggregate under the service's effective runtime semantics. +resolveAggForService :: Context -> CheckedService -> Aggregate -> Agg +resolveAggForService ctx service agg = + Agg + { aContext = ctx, + aLanguageContract = checkedLanguageContract service, + aSpec = spec, + aAggregate = agg, + aCtxPascal = ctxPascal, + aName = nm, + aLoc = aggLoc agg, + aVertexType = vertexType, + aIds = specIds spec, + aEnums = specEnums spec, + aRegs = map resolveRegister (aggRegs agg), + aStates = aggStates agg, + aCommands = map resolveCommand (aggCommands agg), + aEvents = map resolveEvent (aggEvents agg), + aGeneratedNominals = generatedNominalsInTypes aggregateResolvedTypes, + aTransitions = aggTransitions agg, + aOutputMappings = + Map.fromList + [ ( (transitionIndex, emitIndex), + orDieOutput (eventOutputMapping spec agg transition emitIndex eventName) + ) + | (transitionIndex, transition) <- zip [1 ..] (aggTransitions agg), + (emitIndex, eventName) <- zip [1 ..] (tEmits transition) + ], + aWire = fromMaybe defaultWire (aggWire agg), + aProjection = aggProjection agg, + aSnapshot = aggSnapshot agg, + aFoldFingerprint = either (error . T.unpack . renderFoldSurfaceError) id (aggregateFoldFingerprintForService service agg), + aReadModels = [readModel | NReadModel readModel <- specNodes spec], + aTypeGraph = either (const Nothing) Just (resolveTypeGraph spec), + aSymbols = symbols, + aGenPrefix = genPrefixFor ctx nm, + aHolePrefix = holePrefixFor ctx nm + } + where + spec = checkedSpec service + nm = aggName agg + symbols = aggregateSymbols spec + ctxPascal = pascalFromKebab (contextName ctx) + vertexType = nm <> "Vertex" + commandFieldTypes = [(cmdName c, cmdFields c) | c <- aggCommands agg] + resolveCommand c = (mkCtor CommandFieldUse (cmdName c) (cmdFields c)) {rcVersion = 1, rcUpcastFrom = Nothing} + resolveEvent e = + (mkCtor EventFieldUse (evName e) (eventFields e)) + { rcVersion = evVersion e, + rcUpcastFrom = fst <$> evUpcastFrom e + } + where + eventFields ev = case evBody ev of + EventFields fs -> fs + EventFromCommand cn -> fromMaybe [] (lookup cn commandFieldTypes) + mkCtor useSite cn fs = + ResolvedCtor + { rcName = cn, + rcFields = map (\field -> (aggregateFieldName field, orDie (inferAggregateFieldType symbols agg useSite field))) fs, + rcVersion = 1, + rcUpcastFrom = Nothing + } + aggregateResolvedTypes = + map rrType (map resolveRegister (aggRegs agg)) + <> map snd (concatMap rcFields (map resolveCommand (aggCommands agg))) + <> map snd (concatMap rcFields (map resolveEvent (aggEvents agg))) + resolveRegister register = + let resolvedType = orDie (resolveAggregateType symbols (regLoc register) RegisterUse (regType register)) + resolvedInitial = orDie (resolveRegisterInitial symbols (regLoc register) resolvedType (regInitial register)) + in ResolvedRegister + { rrName = regName register, + rrType = resolvedType, + rrInitial = resolvedInitial, + rrLoc = regLoc register + } + orDie = either (error . ("validated aggregate resolution failed: " <>) . show) id + orDieOutput = either (error . ("validated aggregate output resolution failed: " <>) . show) id + +-- | Keep only generated nominal IDs/enums from a resolved aggregate type list. +-- The map both deduplicates and makes declaration/import order independent of +-- member and field order. +generatedNominalsInTypes :: [ResolvedAggregateType] -> [ResolvedNominalType] +generatedNominalsInTypes resolvedTypes = + Map.elems . Map.fromList $ + [ (resolvedNominalName nominal, nominal) + | AggregateNominal nominal <- resolvedTypes, + GeneratedNominal <- [resolvedNominalOwnership nominal] + ] + +-- | Plan declaration ownership and use closure without emitting text. Parsing +-- and validation already reject malformed declarations; retaining the checked +-- error here keeps this function total for direct library callers. +planNominalGeneration :: Context -> Spec -> Either (NonEmpty NominalTypeError) [NominalGenerationOwner] +planNominalGeneration ctx spec = planNominalGenerationForService ctx (legacyCheckedService spec) + +planNominalGenerationForService :: Context -> CheckedService -> Either (NonEmpty NominalTypeError) [NominalGenerationOwner] +planNominalGenerationForService ctx service = do + registry <- resolveNominalTypes spec + let aggregates = [resolveAggForService ctx service aggregate | NAggregate aggregate <- specNodes spec] + generated = + [ nominal + | nominal <- Map.elems (nominalTypes registry), + GeneratedNominal <- [resolvedNominalOwnership nominal] + ] + pure + [ NominalGenerationOwner + { nominalDeclaration = nominal, + nominalModule = generatedNominalModule ctx, + nominalUseSites = Set.fromList (concatMap (usesFor nominal) aggregates), + nominalEqualityUsed = any (nominalEqualityUsedInGeneratedExpressions nominal) aggregates + } + | nominal <- generated + ] + where + spec = checkedSpec service + usesFor nominal aggregate = + [ NominalUseSite (aName aggregate) useKind + | useKind <- aggregateUseKinds nominal aggregate + ] + +nominalEqualityUsedInGeneratedExpressions :: ResolvedNominalType -> Agg -> Bool +nominalEqualityUsedInGeneratedExpressions nominal aggregate = + any (anyTypedExpression comparesNominal) (resolvedGeneratedExpressions aggregate) + where + comparesNominal expression = case typedScalarNode expression of + TypedEqual left _ -> typedScalarType left == AggregateNominal nominal + TypedNotEqual left _ -> typedScalarType left == AggregateNominal nominal + _ -> False + +aggregateUseKinds :: ResolvedNominalType -> Agg -> [AggregateUseSite] +aggregateUseKinds nominal aggregate = + nub $ + [RegisterUse | nominal `elem` registerNominals] + <> [CommandFieldUse | nominal `elem` commandNominals] + <> [EventFieldUse | nominal `elem` eventNominals] + <> [CodecUse | nominal `elem` eventNominals] + <> [SnapshotUse | hasSnapshot aggregate && nominal `elem` registerNominals] + <> [HarnessSampleUse | nominal `elem` commandNominals || nominal `elem` eventNominals] + <> [HaskellLoweringUse | nominal `elem` aGeneratedNominals aggregate] + where + registerNominals = generatedNominalsInTypes (map rrType (aRegs aggregate)) + commandNominals = generatedNominalsInTypes (map snd (concatMap rcFields (aCommands aggregate))) + eventNominals = generatedNominalsInTypes (map snd (concatMap rcFields (aEvents aggregate))) + +-------------------------------------------------------------------------------- +-- Entry point +-------------------------------------------------------------------------------- + +-- | Emit the context-level private structural stratum. Shape modules contain +-- only generated wire representations. The projection facade contains only +-- schema-derived Keiki field witnesses; neither layer owns consumer behavior. +scaffoldStructural :: Context -> Spec -> [ScaffoldModule] +scaffoldStructural ctx spec = scaffoldStructuralForService ctx (legacyCheckedService spec) + +scaffoldStructuralForService :: Context -> CheckedService -> [ScaffoldModule] +scaffoldStructuralForService ctx service = map fst (scaffoldStructuralOwnersForService ctx service) + +-- | 'scaffoldStructural' paired with the mapped declarations each module was +-- emitted for. A shape module names exactly one declaration; a binding skeleton +-- names every declaration whose obligations it carries (several declarations may +-- share one leaf binding module); the projection facade names __none__, because it +-- is emitted once for the whole context from the complete resolved graph. +-- +-- This is the attribution seam whole-workspace scaffolding needs: a workspace +-- emits from one merged spec, and this list says which declaration — and therefore +-- which member file — produced each structural module, without parsing the +-- human-readable 'origin' string. +scaffoldStructuralOwners :: Context -> Spec -> [(ScaffoldModule, [Name])] +scaffoldStructuralOwners ctx spec = scaffoldStructuralOwnersForService ctx (legacyCheckedService spec) + +scaffoldStructuralOwnersForService :: Context -> CheckedService -> [(ScaffoldModule, [Name])] +scaffoldStructuralOwnersForService ctx service = case resolveTypeGraph (checkedSpec service) of + Left _ -> [] + Right graph -> + [(shapeModule ctx graph entry, [sdName (fst entry)]) | entry <- structural] + <> projectionModules + <> generatedNominalOwners ctx service + <> nominalRepresentationOwners ctx spec + <> nominalProjectionOwners ctx service + <> bindingSkeletonOwners ctx spec graph + where + structural = + [ (declaration, shape) + | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph) + ] + projectionModules = + [ ( ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" (structuralProjectionModule ctx) <> ".hs"), + moduleText = emitStructuralProjections ctx graph, + kind = Generated, + origin = "context " <> specContext spec <> " mapped structural facade" + }, + [] + ) + | not (null (projectionSpecs graph)) + ] + spec = checkedSpec service + +-- | Plan one opt-in, non-production historical-codec comparison module. +-- +-- The module is intentionally absent from 'scaffoldStructural' and therefore +-- from production manifests and scaffold records. It must be requested by name +-- and is compiled only by consumer-owned test/tool components. +codecComparisonModule :: Context -> Spec -> Name -> Either Text ScaffoldModule +codecComparisonModule ctx spec requestedName = do + graph <- either (Left . ("mapped type graph did not resolve: " <>) . T.pack . show) Right (resolveTypeGraph spec) + (declaration, shape) <- case Map.lookup (MappedKey requestedName) (tgDeclarations graph) of + Nothing -> Left ("codec comparison target is not a mapped declaration: " <> requestedName) + Just (ResolvedOpaque _) -> + Left + ( "codec comparison target " + <> requestedName + <> " is opaque; finite evidence must never upgrade an opaque declaration to a structural claim" + ) + Just (ResolvedStructural declaration shape) -> Right (declaration, shape) + owner <- case sortOn aggName (comparisonOwners declaration) of + [] -> + Left + ( "codec comparison target " + <> requestedName + <> " is not reachable from a persisted private event payload" + ) + aggregate : _ -> Right aggregate + let moduleName = structuralPrefix ctx <> ".CodecCompare." <> requestedName + pure + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"), + moduleText = emitCodecComparison ctx moduleName graph declaration shape owner, + kind = Generated, + origin = "non-production codec comparison " <> requestedName + } + where + comparisonOwners declaration = + [ aggregate + | NAggregate aggregate <- specNodes spec, + let resolved = resolveAgg ctx spec aggregate, + any ((== sdName declaration) . mappedName) (codecMappedDeclarations resolved) + ] + where + mappedName (ResolvedStructural structural _) = sdName structural + mappedName (ResolvedOpaque opaque) = odName opaque + +codecComparisonBanner :: Text +codecComparisonBanner = + "-- @generated by keiro-dsl codec comparison; non-production migration evidence; do not edit." + +emitCodecComparison :: Context -> Text -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Aggregate -> Text +emitCodecComparison ctx moduleName graph declaration shape owner = + nl + [ "", + codecComparisonBanner, + "-- This module compares historical and generated codecs in consumer-owned tests only.", + "-- It is never a runtime fallback and never changes the generated codec's authority.", + "module " <> moduleName <> " (compareWithHistorical) where", + "", + "import Control.Monad (filterM)", + "import Data.Aeson (Value)", + "import Data.Aeson qualified as Aeson", + "import Data.List (sort)", + "import Data.List.NonEmpty qualified as NonEmpty", + "import Data.Text (Text)", + "import Data.Text qualified", + "import " <> codecModule <> " qualified as GeneratedCodec", + "import Keiro.Codec.Structural (FixtureCases (..))", + "import Keiro.Dsl.CodecCompare", + "import Keiro.Dsl.TypeGraph (BindingVersion (..), CanonicalTypeId (..), QualifiedValueName (..))", + "import System.Directory (doesFileExist, listDirectory)", + "import System.FilePath (takeExtension, ())", + "", + "import " <> fixtureModule <> " qualified as ConsumerFixtures", + "import " <> hsModule (sdHaskell declaration) <> " qualified as ConsumerDomain", + "", + "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 ConsumerFixtures." <> fixtureSymbol <> ")", + " 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 = "ConsumerDomain." <> hsType (sdHaskell declaration) + codecModule = genPrefixFor ctx (aggName owner) <> ".Codec" + fixtureModule = qualifiedModule (sdFixtures declaration) + fixtureSymbol = lastSegment (unQualifiedValueName (sdFixtures declaration)) + +branchSchemaFor :: TypeGraph -> ResolvedMappedDecl -> BranchSchema +branchSchemaFor graph = + foldMappedDecl + MappedDeclAlgebra + { onStructuralDecl = \_ shape -> + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ fields -> + BranchRecord + [ BranchField + (rwfKey field) + (rwfPresence field == POptional) + (branchExpr graph (rwfType field)) + | field <- fields + ], + onEnum = const BranchScalar, + onUnion = \encoding arms -> + BranchUnion + (ueTagField encoding) + (ueContentsField encoding) + [BranchArm (rwaTag arm) (branchExpr graph <$> rwaPayload arm) | arm <- arms] + } + shape, + onOpaqueDecl = const BranchScalar + } + +branchExpr :: TypeGraph -> ResolvedTypeExpr -> BranchSchema +branchExpr graph = + foldTypeExpr + TypeExprAlgebra + { onText = BranchScalar, + onInt = BranchScalar, + onInteger = BranchScalar, + onBool = BranchScalar, + onNatural = BranchScalar, + onTime = BranchScalar, + onJson = BranchScalar, + onOptional = BranchOptional, + onList = BranchList, + onMap = BranchMap, + onRef = \key -> maybe BranchScalar (branchSchemaFor graph) (Map.lookup key (tgDeclarations graph)) + } + +renderBranchSchema :: BranchSchema -> Text +renderBranchSchema schema = case schema of + BranchScalar -> "BranchScalar" + BranchOptional nested -> "BranchOptional (" <> renderBranchSchema nested <> ")" + BranchList nested -> "BranchList (" <> renderBranchSchema nested <> ")" + BranchMap nested -> "BranchMap (" <> renderBranchSchema nested <> ")" + BranchRecord fields -> + "BranchRecord [" + <> T.intercalate + ", " + [ "BranchField " + <> tshow (bfWireKey field) + <> " " + <> (if bfPresenceOptional field then "True" else "False") + <> " (" + <> renderBranchSchema (bfSchema field) + <> ")" + | field <- fields + ] + <> "]" + BranchUnion tagField contentsField arms -> + "BranchUnion " + <> tshow tagField + <> " " + <> tshow contentsField + <> " [" + <> T.intercalate + ", " + [ "BranchArm " + <> tshow (baWireTag arm) + <> " " + <> maybe "Nothing" (\nested -> "(Just (" <> renderBranchSchema nested <> "))") (baPayloadSchema arm) + | arm <- arms + ] + <> "]" + +-- | Emit one create-once consumer module per distinct qualified obligation +-- owner. Multiple mapped declarations may intentionally share a leaf binding +-- module, so grouping happens by module rather than by declaration. +bindingSkeletonModules :: Context -> Spec -> TypeGraph -> [ScaffoldModule] +bindingSkeletonModules ctx spec graph = map fst (bindingSkeletonOwners ctx spec graph) + +-- | 'bindingSkeletonModules' paired with the mapped declarations whose +-- obligations each skeleton carries, in first-appearance order. A skeleton shared +-- by declarations from different member files therefore names all of them, which +-- is what lets whole-workspace scaffolding treat it as context-level rather than +-- attributing it to an arbitrary member. +bindingSkeletonOwners :: Context -> Spec -> TypeGraph -> [(ScaffoldModule, [Name])] +bindingSkeletonOwners ctx spec graph = case bindingObligations spec of + Left _ -> [] + Right obligations -> + [ (emitBindingSkeleton ctx spec graph owner entries, nub (map obligationMappedName entries)) + | (owner, entries) <- Map.toAscList (Map.fromListWith (<>) [(obligationModule obligation, [obligation]) | obligation <- obligations]) + ] + +emitBindingSkeleton :: Context -> Spec -> TypeGraph -> Text -> [BindingObligation] -> ScaffoldModule +emitBindingSkeleton ctx spec graph owner obligations = + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" owner <> ".hs"), + moduleText = + nl $ + [ "{-# LANGUAGE DataKinds #-}", + "{-# LANGUAGE LambdaCase #-}", + "", + "-- This is a HAND-OWNED consumer binding skeleton. keiro-dsl creates it once", + "-- and never overwrites it. Fill each HOLE and run the generated harness.", + "module " <> owner <> " (" + ] + <> exportLines + <> [") where", ""] + <> map ("import " <>) imports + <> [""] + <> 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 + ] + imports = + sort . nub $ + [ hsModule (sdHaskell declaration) <> " qualified" + | obligation <- obligations, + Just (declaration, _) <- [structuralFor obligation] + ] + <> [ structuralShapeModule ctx (sdName declaration) <> " qualified" + | obligation <- obligations, + obligationKind obligation == BindingValue, + Just (declaration, _) <- [structuralFor obligation] + ] + <> [ "Keiro.Codec.Structural (FixtureCases, StructuralBinding (..))" + | any (\obligation -> obligationCategory obligation == "structural" && obligationKind obligation `elem` [BindingValue, FixtureValue]) obligations + ] + <> [ hsModule (consumerNominalHaskell binding) <> " qualified" + | obligation <- obligations, + Just (_, binding) <- [nominalFor obligation] + ] + <> [ nominalRepresentationModule ctx (resolvedNominalName nominal) <> " qualified" + | obligation <- obligations, + obligationKind obligation == BindingValue, + Just (nominal, _) <- [nominalFor obligation], + EnumRepresentation {} <- [resolvedNominalRepresentation nominal] + ] + <> [ "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, _) -> renderNominalObligation nominal obligation + Nothing -> ["-- HOLE: declaration disappeared before skeleton rendering"] + Just (declaration, shape) -> case obligationKind obligation of + BindingValue -> renderBinding ctx declaration shape obligation + FixtureValue -> + [ "-- HOLE: provide deterministic labelled conformance fixtures for " <> sdName declaration, + obligationSignature obligation, + obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> sdName declaration <> " fixtures") + ] + InitialValue -> + [ "-- HOLE: provide the initial register value for " <> sdName declaration, + obligationSignature 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 obligation = case obligationKind obligation of + BindingValue -> + [ "-- HOLE: complete both total directions; the generated codec remains wire authority.", + obligationSignature 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, + obligationSignature obligation, + obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " fixtures") + ] + InitialValue -> + [ "-- HOLE: provide the initial register value for " <> resolvedNominalName nominal, + obligationSignature obligation, + obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " initial value") + ] + intercalateBlank [] = [] + intercalateBlank (section : rest) = section <> concatMap ("" :) rest + +renderBinding :: Context -> StructuralDecl -> ResolvedMappedShape -> BindingObligation -> [Text] +renderBinding 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 + domainModule = hsModule (sdHaskell declaration) + domainType = domainModule <> "." <> hsType (sdHaskell declaration) + shapeModuleName = structuralShapeModule ctx (sdName declaration) + shapeType = shapeModuleName <> "." <> sdName declaration <> "Shape" + domainCtor constructor = domainModule <> "." <> constructor + shapeCtor constructor = 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 + ) + <> ")" + +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 + ( equalityPragmas + <> [ "{-# LANGUAGE DeriveAnyClass #-}", + "{-# LANGUAGE DeriveGeneric #-}", + "{-# LANGUAGE LambdaCase #-}", + generatedBanner, + moduleHeader, + "", + "import Data.Aeson (FromJSON, ToJSON)", + "import Data.Text (Text)", + "import GHC.Generics (Generic)", + "import Keiki.Shape (CanonicalTypeName)" + ] + <> internalImports + <> equalityImports + <> [ "", + sectionsOf [map emitOwner owners] + ] + ) + where + usesEquality = any nominalEqualityUsed owners + usesExactEquality = any (\owner -> nominalEqualityUsed owner && exactOwner (nominalDeclaration owner)) owners + 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 [] + equalityPragmas = + if usesEquality + then + [ "{-# LANGUAGE DataKinds #-}", + "{-# LANGUAGE TypeApplications #-}", + "{-# LANGUAGE TypeFamilies #-}" + ] + else [] + equalityImports = + ["import Keiki.Core (ExactFieldProjection (..), FieldProjection (..), FieldWitness, exactFieldWitness, fieldWitness)" | usesEquality] + <> ["import Data.List.NonEmpty (NonEmpty (..))" | usesExactEquality] + <> ["import Keiki.ProjectionDomain (finiteProjectionDomain)" | usesExactEquality && null enforcingIds] + <> ["import Keiki.ProjectionDomain (TextPattern, finiteProjectionDomain, textProjectionDomain)" | usesExactEquality && not (null enforcingIds)] + <> ["import Keiro.Codec.IdDomain (idDomainTextPattern, typeIdV7Domain)" | not (null enforcingIds)] + internalImports = + [ "import " + <> generatedNominalInternalModule ctx + <> " (" + <> T.intercalate + ", " + (concatMap (\nominal -> [resolvedNominalName nominal, "mk" <> resolvedNominalName nominal, "parse" <> resolvedNominalName nominal, nominalTextName nominal]) enforcingIds) + <> ")" + | not (null enforcingIds) + ] + emitOwner owner = emitGeneratedNominal languageContract (nominalEqualityUsed owner) (nominalDeclaration owner) + exactOwner nominal = case resolvedNominalRepresentation nominal of + EnumRepresentation {} -> True + IdRepresentation prefix -> isJust (idDomainContractFor languageContract prefix) + ScalarRepresentation {} -> False + +emitGeneratedNominal :: EffectiveLanguageContract -> Bool -> ResolvedNominalType -> Text +emitGeneratedNominal languageContract equalityUsed nominal = case resolvedNominalRepresentation nominal of + IdRepresentation prefix + | Just _ <- idDomainContractFor languageContract prefix -> + nl $ + ["instance CanonicalTypeName " <> name] + <> 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 + [ "{-# LANGUAGE DeriveGeneric #-}", + 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 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 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 _ _ [] = [] +generatedNominalTypeImportsForService service ctx nominals = + [ "import " + <> generatedNominalModule ctx + <> " (" + <> T.intercalate ", " (concatMap importsFor (stableNominals nominals)) + <> ")" + ] + where + importsFor nominal = case resolvedNominalRepresentation nominal of + IdRepresentation prefix + | Just _ <- idDomainContractFor (checkedLanguageContract service) prefix -> + [resolvedNominalName nominal, "parse" <> resolvedNominalName nominal] + _ -> [resolvedNominalName nominal <> " (..)"] + +generatedNominalCodecImports :: CheckedService -> Context -> [ResolvedNominalType] -> [Text] +generatedNominalCodecImports _ _ [] = [] +generatedNominalCodecImports service ctx nominals = + [ "import " + <> generatedNominalModule ctx + <> " (" + <> T.intercalate + ", " + ( concat + [ [typeImport nominal, nominalTextName nominal] + | nominal <- stableNominals nominals + ] + ) + <> ")" + ] + <> [ "import " + <> generatedNominalInternalModule ctx + <> " (" + <> T.intercalate ", " [legacyNominalConstructorName nominal | nominal <- enforcingIds] + <> ")" + | not (null enforcingIds) + ] + where + typeImport nominal = case resolvedNominalRepresentation nominal of + IdRepresentation prefix + | Just _ <- idDomainContractFor (checkedLanguageContract service) prefix -> resolvedNominalName nominal + _ -> resolvedNominalName 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 + [ "{-# LANGUAGE DeriveGeneric #-}", + "{-# LANGUAGE LambdaCase #-}", + generatedBanner, + "module " <> moduleName <> " (" <> representationType <> " (..), " <> encoderName <> ") where", + "", + "import Data.Text (Text)", + "import GHC.Generics (Generic)", + "", + "data " <> representationType <> " = " <> T.intercalate " | " (map fst (NE.toList constructors)), + " deriving stock (Eq, Generic, Ord, Show, Enum, Bounded)", + "", + encoderName <> " :: " <> representationType <> " -> Text", + encoderName <> " = \\case", + nl [" " <> constructor <> " -> " <> tshow wire | (constructor, wire) <- NE.toList constructors] + ], + kind = Generated, + origin = nodeOrigin "bound nominal enum representation" (resolvedNominalName nominal) (resolvedNominalLoc nominal) + } + where + moduleName = nominalRepresentationModule ctx (resolvedNominalName nominal) + representationType = resolvedNominalName nominal <> "Representation" + encoderName = lowerFirst (resolvedNominalName nominal) <> "RepresentationText" + +nominalProjectionModule :: Context -> Text +nominalProjectionModule ctx = case placement ctx of + GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".NominalProjections" + CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.NominalProjections" + +nominalProjectionOwners :: Context -> CheckedService -> [(ScaffoldModule, [Name])] +nominalProjectionOwners ctx service = case nominalProjectionTypes spec of + [] -> [] + nominals -> + [ ( ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" (nominalProjectionModule ctx) <> ".hs"), + moduleText = emitNominalProjections (checkedLanguageContract service) ctx nominals, + kind = Generated, + origin = "context " <> specContext spec <> " nominal scalar projection facade" + }, + [] + ) + ] + where + spec = checkedSpec service + +nominalProjectionTypes :: Spec -> [ResolvedNominalType] +nominalProjectionTypes spec = + Map.elems . Map.fromList $ + [ (resolvedNominalName nominal, nominal) + | aggregate <- [value | NAggregate value <- specNodes spec], + resolved <- registerTypes aggregate <> commandTypes aggregate, + AggregateNominal nominal <- [resolved], + ConsumerNominal {} <- [resolvedNominalOwnership nominal] + ] + where + symbols = aggregateSymbols spec + registerTypes aggregate = + [ resolved + | register <- aggRegs aggregate, + Right resolved <- [resolveAggregateType symbols (regLoc register) RegisterUse (regType register)] + ] + commandTypes aggregate = + [ resolved + | command <- aggCommands aggregate, + field <- cmdFields command, + Right resolved <- [inferAggregateFieldType symbols aggregate CommandFieldUse field] + ] + +emitNominalProjections :: EffectiveLanguageContract -> Context -> [ResolvedNominalType] -> Text +emitNominalProjections languageContract ctx nominals = + nl $ + [ "{-# LANGUAGE DataKinds #-}", + "{-# LANGUAGE TypeApplications #-}", + "{-# LANGUAGE TypeFamilies #-}", + generatedBanner, + "module " <> moduleName <> " where", + "" + ] + <> map ("import " <>) imports + <> [""] + <> [T.intercalate "\n\n" (map emitNominalProjection nominals)] + where + moduleName = nominalProjectionModule ctx + imports = + sort . nub $ + [ "Keiki.Core (ExactFieldProjection (..), FieldProjection (..), FieldWitness, exactFieldWitness, fieldWitness)", + "Keiro.Codec.Nominal (nominalFromRepresentation, nominalToRepresentation)" + ] + <> [hsModule (consumerNominalHaskell binding) <> " qualified" | nominal <- nominals, ConsumerNominal binding <- [resolvedNominalOwnership nominal]] + <> [qualifiedModule (consumerNominalBinding binding) <> " qualified" | nominal <- nominals, ConsumerNominal binding <- [resolvedNominalOwnership nominal]] + <> [nominalRepresentationModule ctx (resolvedNominalName nominal) <> " qualified" | nominal <- nominals, EnumRepresentation {} <- [resolvedNominalRepresentation nominal]] + <> ["Data.KindID qualified as KindID" | any hasId nominals] + <> ["Keiro.Codec.IdDomain (idDomainTextPattern, typeIdV7Domain, validateIdDomainText)" | any hasEnforcedId nominals] + <> ["Data.List.NonEmpty (NonEmpty (..))" | any hasExactDomain nominals] + <> ["Data.Text (Text)" | any usesText nominals] + <> ["Data.Time (UTCTime)" | any (hasScalar NominalTime) nominals] + <> ["Keiki.ProjectionDomain (TextPattern, finiteProjectionDomain, matchesTextPattern, textCharSet, textConcat, textLiteral, textProjectionDomain, textRepeatBetween)" | any hasExactDomain nominals] + <> ["Numeric.Natural (Natural)" | any (hasScalar NominalNatural) nominals] + 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 + hasExactDomain nominal = case resolvedNominalRepresentation nominal of ScalarRepresentation {} -> False; _ -> True + usesText nominal = case resolvedNominalRepresentation nominal of ScalarRepresentation NominalText -> True; IdRepresentation {} -> True; EnumRepresentation {} -> True; _ -> False + 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 <> " = " <> renderHaskellSource (consumerNominalHaskell binding), + " type FieldResult " <> tagName <> " = " <> scalarHaskellType (resolvedNominalRepresentation nominal), + " fieldShapeId _ = " <> tshow (unCanonicalTypeId (consumerNominalCanonical binding)), + " projectFieldValue _ = nominalToRepresentation " <> unQualifiedValueName (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 = renderHaskellSource (consumerNominalHaskell binding) + bindingName = unQualifiedValueName (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 <> " " <> representationModule <> "." <> constructor <> ")" + | (constructor, wire) <- NE.toList constructors + ] + <> [ " _ -> Nothing", + "", + witnessName <> " :: FieldWitness " <> tagName, + witnessName <> " = exactFieldWitness @" <> tagName + ] + where + name = resolvedNominalName nominal + tagName = nominalEqualityTagName nominal + witnessName = nominalEqualityWitnessName nominal + ownerType = renderHaskellSource (consumerNominalHaskell binding) + bindingName = unQualifiedValueName (consumerNominalBinding binding) + representationModule = nominalRepresentationModule ctx name + encoderName = representationModule <> "." <> lowerFirst name <> "RepresentationText" + 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 + <> ["" | not (null imports)] + <> [shapeDeclaration] + where + moduleName = structuralShapeModule ctx (sdName declaration) + shapeType = sdName declaration <> "Shape" + requirements = shapeRequirements ctx graph shape + languagePragmas = + ["{-# LANGUAGE DeriveGeneric #-}"] + <> ["{-# LANGUAGE DuplicateRecordFields #-}" | shapeHasRecord shape] + 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] + <> [m <> " qualified" | ReqModule m <- requirements] + shapeDeclaration = + foldMappedShape + MappedShapeAlgebra + { onRecord = \constructor _ fields -> + nl $ + ["data " <> shapeType <> " = " <> constructor] + <> recordFields + [ (rwfHaskell field, renderShapeType 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 ctx graph) (rwaPayload arm) + +data ShapeRequirement + = ReqJson + | ReqMap + | ReqText + | ReqTime + | ReqNatural + | ReqModule !Text + deriving stock (Eq, Ord, Show) + +shapeHasRecord :: ResolvedMappedShape -> Bool +shapeHasRecord = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ _ -> True, + onEnum = const False, + onUnion = \_ _ -> False + } + +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 _) -> [ReqModule (structuralShapeModule ctx (sdName declaration))] + Just (ResolvedOpaque declaration) -> [ReqModule (hsModule (odHaskell declaration))] + Nothing -> [] + } + +renderShapeType :: Context -> TypeGraph -> ResolvedTypeExpr -> Text +renderShapeType ctx graph = + foldTypeExpr + TypeExprAlgebra + { onText = "Text", + onInt = "Int", + onInteger = "Integer", + onBool = "Bool", + onNatural = "Natural", + onTime = "UTCTime", + onJson = "Value", + onOptional = \value -> "(Maybe (" <> value <> "))", + onList = \value -> "([" <> value <> "])", + onMap = \value -> "(Map Text (" <> value <> "))", + onRef = \key -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural nested _) -> + structuralShapeModule ctx (sdName nested) <> "." <> sdName nested <> "Shape" + Just (ResolvedOpaque opaque) -> + hsModule (odHaskell opaque) <> "." <> hsType (odHaskell opaque) + Nothing -> "()" + } + +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 $ + [ "{-# LANGUAGE DataKinds #-}", + "{-# LANGUAGE TypeApplications #-}", + "{-# LANGUAGE TypeFamilies #-}", + generatedBanner, + "-- Equality witnesses are emitted for Text, Int, Bool, Natural, and UTCTime.", + "-- Int, Natural, and UTCTime belong to Keiki's ordered subset.", + "module " <> moduleName, + " ( " <> T.intercalate "\n , " (map spWitness specs), + " ) where", + "", + "import Data.Text (Text)", + "import Data.Time (UTCTime)", + "import Numeric.Natural (Natural)", + "import Keiro.Codec.Structural (bindingToShape)", + "import Keiki.Core (FieldProjection (..), FieldWitness, fieldWitness)" + ] + <> map ("import " <>) imports + <> concatMap renderProjection specs + where + moduleName = structuralProjectionModule ctx + specs = map (resolveProjectionModules ctx) (projectionSpecs graph) + imports = + sort . nub $ + [hsModule (spOwner spec) <> " qualified" | spec <- specs] + <> [qualifiedModule (spBinding spec) <> " qualified" | spec <- specs] + <> [shapeModuleName <> " qualified" | spec <- specs, (shapeModuleName, _) <- spSelectors spec] + renderProjection spec = + [ "", + "data " <> spTag spec, + "", + "instance FieldProjection " <> spTag spec <> " where", + " type FieldName " <> spTag spec <> " = " <> tshow (spPointer spec), + " type FieldOwner " <> spTag spec <> " = " <> renderHaskellSource (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) -> shapeModuleName <> "." <> selector <> " (" <> value <> ")") + ("bindingToShape " <> unQualifiedValueName (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) + +qualifiedModule :: QualifiedValueName -> Text +qualifiedModule = fst . splitQualified . unQualifiedValueName + +renderHaskellSource :: HaskellSource -> Text +renderHaskellSource source = hsModule source <> "." <> hsType source + +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 $ + [ "{-# LANGUAGE DataKinds #-}", + "{-# LANGUAGE OverloadedLabels #-}", + "{-# OPTIONS_GHC -Wno-missing-signatures -Wno-name-shadowing #-}", + generatedBanner, + "module " <> aGenPrefix aggregate <> ".BehaviorContract where", + "", + "import " <> aGenPrefix aggregate <> ".Codec (encode" <> name <> "Event, parse" <> name <> "Event, " <> valueStem <> "Codec)", + "import " <> aGenPrefix aggregate <> ".Domain", + "import " <> aGenPrefix aggregate <> ".Transducer (" <> valueStem <> "Transducer)", + "import Data.Aeson (ToJSON (..), object, (.=))", + "import Data.List (sortOn)", + "import Data.List.NonEmpty (NonEmpty)", + "import Data.List.NonEmpty qualified as NonEmpty", + "import Data.Map.Strict qualified as Map", + "import Data.Text (Text)", + "import Data.Text qualified as T", + "import Keiki.Core qualified as K (EdgeMode (..), EdgeRef (..), RegFile, ReplayAttribution (..), ReplayEventSpan (..), ReplaySuccess (..), StepFailure (..), StepSuccess (..), applyEventsDetailedEither, stepDetailedEither, (!))", + "import Keiro.Codec qualified as Codec (Codec (eventType), EventType (..))", + "", + "newtype BehaviorKey = BehaviorKey { unBehaviorKey :: Text }", + " deriving stock (Eq, Ord, Show)", + "", + "data ObligationKind = LiveTransition | RequiredRejection | ReplayTransition", + " deriving stock (Eq, Ord, Show)", + "", + "data EvidenceLevel = GeneratedAuthoritative | HoleWitnessed | LegacyRuntimeWitness", + " deriving stock (Eq, Ord, Show)", + "", + "data GuardCoverage = GuardTotal | GuardPartial | GuardUnknown | GuardNotApplicable", + " deriving stock (Eq, Ord, Show)", + "", + "data BehaviorRequirement = BehaviorRequirement", + " { requirementKey :: !BehaviorKey", + " , requirementKind :: !ObligationKind", + " , requirementEvidence :: !EvidenceLevel", + " , requirementGuardCoverage :: !GuardCoverage", + " , requirementSource :: !" <> aVertexType aggregate, + " , requirementCommandName :: !Text", + " , requirementExpectedEdge :: !(Maybe (K.EdgeRef " <> aVertexType aggregate <> "))", + " , requirementTarget :: !(Maybe " <> aVertexType aggregate <> ")", + " , requirementEventKinds :: ![Text]", + " , requirementLine :: !Int", + " }", + " deriving stock (Eq, Show)", + "", + "data RejectionClass = RejectNoOutgoingEdges | RejectNoMatchingEdge", + " deriving stock (Eq, Show)", + "", + "data LiveExpectation", + " = Emits (NonEmpty " <> name <> "Event)", + " | Rejects RejectionClass", + " | NoOp", + " deriving stock (Eq, Show)", + "", + "data BehaviorWitness", + " = Pending BehaviorKey", + " | LiveWitness", + " { witnessKey :: BehaviorKey", + " , witnessHistory :: [" <> name <> "Event]", + " , witnessCommand :: " <> name <> "Command", + " , witnessExpected :: LiveExpectation", + " }", + " | ReplayWitness", + " { witnessKey :: BehaviorKey", + " , witnessHistoryPrefix :: [" <> name <> "Event]", + " , witnessObservedChunk :: [" <> name <> "Event]", + " }", + " deriving stock (Eq, Show)", + "", + "data BehaviorFailure = BehaviorFailure", + " { failureKey :: !BehaviorKey", + " , failureCode :: !Text", + " , failureDetail :: !Text", + " }", + " deriving stock (Eq, Show)", + "", + "instance ToJSON BehaviorFailure where", + " toJSON failure = object", + " [ \"key\" .= unBehaviorKey (failureKey failure)", + " , \"code\" .= failureCode failure", + " , \"detail\" .= failureDetail failure", + " ]", + "", + "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 = [failure | (_, Left failure) <- 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 failure) <> \" [\" <> failureCode failure <> \"] \" <> failureDetail failure | failure <- 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 requirement seed command expectation = case expectation of", + " Emits _ -> failure requirement \"expectation-kind\" \"a rejection requirement cannot expect emitted events\"", + " NoOp -> failure requirement \"expectation-kind\" \"a rejection requirement cannot expect an accepted no-op\"", + " Rejects expectedClass -> case K.stepDetailedEither " <> valueStem <> "Transducer seed command of", + " Left K.NoOutgoingEdges {} -> ensure requirement (expectedClass == RejectNoOutgoingEdges) \"rejection-class\" \"expected NoMatchingEdge but runtime returned NoOutgoingEdges\"", + " Left K.NoMatchingEdge {} -> ensure requirement (expectedClass == RejectNoMatchingEdge) \"rejection-class\" \"expected NoOutgoingEdges but runtime returned NoMatchingEdge\"", + " Left K.AmbiguousEdges {} -> failure requirement \"ambiguous-edges\" \"AmbiguousEdges can never satisfy a rejection witness\"", + " Right _ -> failure requirement \"unexpected-acceptance\" \"runtime accepted a command required to reject\"", + "", + "runAcceptance requirement seed command expectation = case expectation of", + " Rejects _ -> failure requirement \"expectation-kind\" \"a live-transition requirement needs Emits or NoOp\"", + " NoOp -> case K.stepDetailedEither " <> valueStem <> "Transducer seed command of", + " Left stepFailure -> failure requirement \"unexpected-rejection\" (tshow stepFailure)", + " Right success -> do", + " checkAcceptedEnvelope requirement success", + " ensure requirement (null (K.stepSuccessOutputs success)) \"noop-emitted\" \"NoOp emitted one or more events\"", + " ensure requirement (K.stepSuccessState success == fst seed) \"noop-vertex-change\" \"NoOp changed the control vertex\"", + " ensure requirement (regsEqual (K.stepSuccessRegs success) (snd seed)) \"noop-register-change\" \"NoOp changed one or more registers\"", + " Emits expectedEvents -> case K.stepDetailedEither " <> valueStem <> "Transducer seed command of", + " Left stepFailure -> failure requirement \"unexpected-rejection\" (tshow stepFailure)", + " Right success -> do", + " checkAcceptedEnvelope requirement success", + " let expected = NonEmpty.toList expectedEvents", + " actual = K.stepSuccessOutputs success", + " ensure requirement (actual == expected) \"event-value-mismatch\" \"runtime event values differ from the exact witness expectation\"", + " ensure requirement (map eventKind actual == requirementEventKinds requirement) \"event-envelope-mismatch\" \"runtime event kinds differ from the declared ordered envelope\"", + " decoded <- either (failure requirement \"emitted-codec-decode\") Right (decodeEvents actual)", + " replayed <- case K.applyEventsDetailedEither " <> valueStem <> "Transducer seed decoded of", + " Left replayFailure -> failure requirement \"emitted-replay-failed\" (tshow replayFailure)", + " Right replaySuccess -> Right replaySuccess", + " ensure requirement (K.replaySuccessState replayed == K.stepSuccessState success) \"forward-replay-vertex\" \"decoded emissions replay to a different vertex\"", + " ensure requirement (regsEqual (K.replaySuccessRegs replayed) (K.stepSuccessRegs success)) \"forward-replay-registers\" \"decoded emissions replay to different registers\"", + " checkSingleAttribution requirement K.Live (length decoded) (K.replaySuccessTrace replayed)", + "", + "checkAcceptedEnvelope requirement success = do", + " ensure requirement (K.stepSuccessMode success == K.Live) \"forward-mode\" \"forward execution selected a non-live edge\"", + " ensure requirement (Just (K.stepSuccessEdge success) == requirementExpectedEdge requirement) \"edge-attribution\" \"runtime selected a different guarded sibling\"", + " ensure requirement (Just (K.stepSuccessState success) == requirementTarget requirement) \"target-mismatch\" \"runtime reached a different target vertex\"", + "", + "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\"", + " checkSingleAttribution requirement K.ReplayOnly (length decoded) (K.replaySuccessTrace replayed)", + " _ -> failure requirement \"witness-kind\" \"ReplayWitness supplied for a non-replay requirement\"", + "", + "checkSingleAttribution requirement expectedMode eventCount trace = case trace of", + " [attribution] -> do", + " ensure requirement (Just (K.replayAttributionEdge attribution) == requirementExpectedEdge requirement) \"replay-edge-attribution\" \"replay selected a different edge\"", + " ensure requirement (K.replayAttributionMode attribution == expectedMode) \"replay-mode-attribution\" \"replay selected the wrong live/replay-only phase\"", + " ensure requirement (K.replayAttributionSource attribution == requirementSource requirement) \"replay-source-attribution\" \"replay attribution starts at the wrong source\"", + " ensure requirement (Just (K.replayAttributionTarget attribution) == requirementTarget requirement) \"replay-target-attribution\" \"replay attribution ends at the wrong target\"", + " ensure requirement (K.replayAttributionSpan attribution == K.ReplayEventSpan 0 eventCount) \"replay-span-attribution\" \"replay attribution did not consume the exact chunk\"", + " _ -> failure requirement \"replay-trace-cardinality\" \"expected exactly one completed-edge attribution\"", + "", + "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 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 requirement =", + " requirementEvidence requirement == GeneratedAuthoritative", + " && requirementGuardCoverage requirement `elem` [GuardTotal, GuardNotApplicable]", + "", + "behaviorWitnessKey witness = case witness of", + " Pending key -> key", + " LiveWitness { witnessKey = key } -> key", + " ReplayWitness { witnessKey = key } -> key", + "", + "isPending Pending {} = True", + "isPending _ = False", + "", + "ensure requirement condition code detail = if condition then Right () else failure requirement code detail", + "failure requirement code detail = Left (BehaviorFailure (requirementKey requirement) code detail)", + "sortedKeys = sortOn unBehaviorKey", + "keyTexts = map unBehaviorKey", + "countLine label values = label <> \": \" <> tshow (length values)", + "tshow :: Show value => value -> Text", + "tshow = T.pack . show" + ] + where + name = aName aggregate + valueStem = lowerFirst name + +renderCommandKind :: Agg -> [Text] +renderCommandKind aggregate = case aCommands aggregate of + [] -> ["", "commandKind _ = \"\""] + commands -> + [ "", + "commandKind command = case command of" + ] + <> [" " <> rcName command <> " _ -> " <> tshow (rcName command) | command <- commands] + +renderBehaviorRequirementList :: Agg -> [Text] +renderBehaviorRequirementList aggregate = + case behaviorRequirementsFor aggregate of + [] -> [" []"] + requirements -> + [ (if index == (0 :: Int) then " [ " else " , ") <> render requirement + | (index, requirement) <- zip [0 ..] requirements + ] + <> [" ]"] + where + render requirement = + "BehaviorRequirement " + <> keyExpr requirement + <> " " + <> T.pack (show (Behavior.requirementKind requirement)) + <> " " + <> T.pack (show (Behavior.requirementEvidence requirement)) + <> " " + <> T.pack (show (Behavior.requirementGuardCoverage requirement)) + <> " " + <> vertexCtor aggregate (Behavior.requirementSource requirement) + <> " " + <> tshow (Behavior.requirementCommand requirement) + <> " " + <> edgeExpr aggregate requirement + <> " " + <> maybe "Nothing" (\target -> "(Just " <> vertexCtor aggregate target <> ")") (Behavior.requirementTarget requirement) + <> " " + <> renderBehaviorTextList (Behavior.requirementEvents requirement) + <> " " + <> tshow' (unLoc (Behavior.requirementLocation requirement)) + keyExpr requirement = "(BehaviorKey " <> tshow (Behavior.unBehaviorKey (Behavior.requirementKey requirement)) <> ")" + +edgeExpr :: Agg -> Behavior.BehaviorRequirement -> Text +edgeExpr aggregate requirement = case Behavior.requirementKind requirement of + Behavior.RequiredRejection -> "Nothing" + _ -> case behaviorEdgeIndex aggregate requirement of + Nothing -> error ("required behavior transition missing from resolved aggregate: " <> T.unpack (Behavior.requirementCanonical requirement)) + Just edgeIndex -> + "(Just (K.EdgeRef " + <> vertexCtor aggregate (Behavior.requirementSource requirement) + <> " " + <> tshow' edgeIndex + <> "))" + +behaviorEdgeIndex :: Agg -> Behavior.BehaviorRequirement -> Maybe Int +behaviorEdgeIndex aggregate requirement = + findIndex + matches + [ transition + | transition <- aTransitions aggregate, + tSource transition == Behavior.requirementSource requirement + ] + where + matches transition = + unLoc (tLoc transition) == unLoc (Behavior.requirementLocation requirement) + && tCommand transition == Behavior.requirementCommand requirement + +behaviorRequirementsFor :: Agg -> [Behavior.BehaviorRequirement] +behaviorRequirementsFor aggregate = + case Behavior.deriveAggregateBehaviorRequirements (aSpec aggregate) (aAggregate aggregate) of + Left derivationError -> error ("validated aggregate failed behavior derivation: " <> show derivationError) + Right requirements -> sortOn Behavior.requirementKey requirements + +renderBehaviorTextList :: [Text] -> Text +renderBehaviorTextList values = "[" <> T.intercalate ", " (map tshow values) <> "]" + +regsEqualityExpression :: Agg -> Text +regsEqualityExpression aggregate = case aRegs aggregate of + [] -> "regsEqual _ _ = True" + registers -> + "regsEqual left right = " + <> T.intercalate + " && " + [ "(left K.! #" <> rrName register <> ") == (right K.! #" <> rrName register <> ")" + | register <- registers + ] + +behaviorHoleModule :: Agg -> ScaffoldModule +behaviorHoleModule aggregate = + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" (aHolePrefix aggregate) <> "/BehaviorHoles.hs"), + moduleText = emitBehaviorHoles aggregate, + kind = HoleStub, + origin = nodeOrigin "aggregate behavior witnesses" (aName aggregate) (aLoc aggregate) + } + +emitBehaviorHoles :: Agg -> Text +emitBehaviorHoles aggregate = + nl $ + [ "-- Consumer-owned behavioral witnesses. Created once; never overwritten.", + "module " <> aHolePrefix aggregate <> ".BehaviorHoles (behaviorWitnesses) where", + "", + "import " <> aGenPrefix aggregate <> ".BehaviorContract", + "", + "behaviorWitnesses :: [BehaviorWitness]", + "behaviorWitnesses =" + ] + <> case behaviorRequirementsFor aggregate of + [] -> [" []"] + requirements -> + [ (if index == (0 :: Int) then " [ " else " , ") + <> "Pending (BehaviorKey " + <> tshow (Behavior.unBehaviorKey (Behavior.requirementKey requirement)) + <> ")" + | (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" + contextGeneratedPrefix context = case placement context of + GeneratedPrefix -> rootPrefix context <> "Generated." <> ctxPascalOf context + CollocatedLeaf -> rootPrefix context <> ctxPascalOf context <> ".Generated" + emitReplayAudit = + nl $ + [ "{-# LANGUAGE GADTs #-}", + 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 + ++ ["" | hasTypedTypeIds] + ++ [generatedBanner] + ++ moduleHeader + ++ [ "", + "import Data.Aeson (Value, object, withObject, withText, (.:), (.=))", + 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) + pragmas = + ["{-# LANGUAGE DataKinds #-}" | hasTypedTypeIds] + ++ [ "{-# LANGUAGE DuplicateRecordFields #-}", + "{-# LANGUAGE OverloadedRecordDot #-}" + ] + ++ ["{-# LANGUAGE TypeApplications #-}" | hasTypedTypeIds] + 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 (cfName field) + <> " .= " + <> case cfType field of + CTypeId prefix + | isJust (contractIdDomainContractFor languageContract prefix) -> "KindID.toText payload." <> cfName field + _ -> "payload." <> cfName field + decodeField field = case cfType field of + CTypeId prefix + | isJust (contractIdDomainContractFor languageContract prefix) -> + "explicitParseField (parseKindIdV7Value @" <> tshow prefix <> ") o " <> tshow (cfName field) + _ -> "o .: " <> tshow (cfName field) + +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 ", " [cfName 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 $ + [ "{-# LANGUAGE OverloadedStrings #-}", + 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", + "", + "import Keiro.Outbox.Types (BackoffSchedule (..), ExponentialBackoffOptions (..), OrderingPolicy (..))", + "", + "publisherOrdering :: OrderingPolicy", + "publisherOrdering = " <> pubOrdering pb, + "", + "publisherBackoff :: BackoffSchedule", + "publisherBackoff = " <> backoffExpr (pubBackoff pb), + "", + "publisherMaxAttempts :: Int", + "publisherMaxAttempts = " <> tshow' (pubMaxAttempts pb) + ] + where + backoffExpr b = case boKind b of + "constant" -> "ConstantBackoff " <> windowText (boWindow b) + "exponential" -> + "ExponentialBackoff ExponentialBackoffOptions { initial = " + <> windowText (boWindow b) + <> ", maxDelay = " + <> maybe "0" windowText (boMax b) + <> ", multiplier = " + <> fromMaybe "0" (boMultiplier b) + <> " }" + _ -> "error \"keiro-dsl: unlowerable backoff kind\"" + +-------------------------------------------------------------------------------- +-- pgmq workqueue (EP-5): a self-contained Job payload record + codec +-------------------------------------------------------------------------------- + +-- | Emit the deterministic, symbol-free pgmq layer: the Job payload record, the +-- field→wire-name JSON codec, and the captured physical\/dlq\/table name constants. +-- Self-contained (base\/text\/aeson). The fan-out body and the raw-SQL dedup +-- predicate are holes (not emitted). Firewall holds. +scaffoldWorkqueue :: Context -> WorkqueueNode -> [ScaffoldModule] +scaffoldWorkqueue ctx w = + [ ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Queue.hs"), + moduleText = emitWorkqueueGen genPrefix w, + kind = Generated, + origin = nodeOrigin "workqueue" (wqName w) (wqLoc w) + }, + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/QueuePolicy.hs"), + moduleText = emitQueuePolicy genPrefix w, + kind = Generated, + origin = nodeOrigin "workqueue" (wqName w) (wqLoc w) + }, + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/QueueCodec.hs"), + moduleText = emitQueueCodec genPrefix w, + kind = Generated, + origin = nodeOrigin "workqueue" (wqName w) (wqLoc w) + } + ] + where + genPrefix = genPrefixFor ctx (pascal (wqName w)) + +emitWorkqueueGen :: Text -> WorkqueueNode -> Text +emitWorkqueueGen genPrefix w = + nl $ + [ "{-# LANGUAGE OverloadedRecordDot #-}", + generatedBanner, + "module " <> genPrefix <> ".Queue", + " ( " <> payloadTy <> " (..)", + " , encode" <> payloadTy, + " , parse" <> payloadTy, + " , queuePhysical, queueDlq, queueTable", + groupKeyExport, + " ) where", + "", + "import Data.Aeson (Value, object, withObject, (.:), (.=))", + "import Data.Aeson.Types (parseEither)", + "import Data.Text (Text)", + "import qualified Data.Text as T", + "", + "queuePhysical, queueDlq, queueTable :: Text", + "queuePhysical = " <> tshow (wqPhysical w), + "queueDlq = " <> tshow (wqDlq w), + "queueTable = " <> tshow (wqTable w), + "" + ] + ++ groupKeyLines + ++ [ "data " <> payloadTy <> " = " <> payloadTy, + " { " <> T.intercalate "\n , " [wqfName f <> " :: !" <> hsType (wqfType f) | f <- wqPayload w], + " }", + " deriving stock (Eq, Show)", + "", + "encode" <> payloadTy <> " :: " <> payloadTy <> " -> Value", + "encode" <> payloadTy <> " p =", + " object" + ] + ++ [lead i (tshow (wqfWire f) <> " .= p." <> wqfName f) | (i, f) <- zip [(0 :: Int) ..] (wqPayload w)] + ++ [ " ]", + "", + "parse" <> payloadTy <> " :: Value -> Either Text " <> payloadTy, + "parse" <> payloadTy <> " = mapLeftText . parseEither (withObject " <> tshow payloadTy <> " go)", + " where", + " go o = " <> payloadTy <> fieldApps (wqPayload w), + "", + "mapLeftText :: Either String b -> Either Text b", + "mapLeftText = either (Left . T.pack) Right" + ] + where + payloadTy = wqPayloadName w + groupKeyExport = case wqGroupKey w of + Nothing -> "" + Just groupKey + | gkVia groupKey == "raw" -> " , groupKeyField, groupKeyFor" + | otherwise -> " , groupKeyField" + groupKeyLines = case wqGroupKey w of + Nothing -> [] + Just groupKey -> common <> derivationLines groupKey + where + common = + [ "groupKeyField :: Text", + "groupKeyField = " <> tshow (gkField groupKey), + "" + ] + derivationLines key + | gkVia key == "raw" = + [ "groupKeyFor :: " <> payloadTy <> " -> Text", + "groupKeyFor payload = payload." <> gkField key, + "" + ] + | otherwise = + [ "-- Opaque group-key derivation '" <> gkVia key <> "' remains hand-owned.", + "-- Captured fixture: " <> fromMaybe "" (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] + +-- | 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 (JobOrdering (..), JobOutcome (..), JobTuning, PartitionSpec (..), QueueProvision, RetryDelay (..), RetryPolicy (..), partitionedProvision, standardProvision, unloggedProvision, withFifoIndexProvision, withOrdering)", + "", + "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" + orderingCtor = case wqOrdering w of + WqUnordered -> "Unordered" + WqFifoThroughput -> "FifoThroughput" + WqFifoRoundRobin -> "FifoRoundRobin" + provisionExpr = fifoWrap baseProvision + fifoWrap expression = case wqOrdering w of + WqUnordered -> expression + _ -> "withFifoIndexProvision (" <> expression <> ")" + baseProvision = case wqProvision w of + WqStandard -> "standardProvision" + WqUnlogged -> "unloggedProvision" + WqPartitioned interval retention -> + "partitionedProvision (PartitionSpec { partitionInterval = " + <> tshow interval + <> ", retentionInterval = " + <> tshow retention + <> " })" + outcome IAckOk = "Done" + outcome (IRetry win) = "Retry (RetryDelay " <> windowText win <> ")" + outcome (IDeadLetter mr) = "Dead " <> tshow (fromMaybe "dead-lettered" mr) + +-------------------------------------------------------------------------------- +-- First-class read models (EP-107) +-------------------------------------------------------------------------------- + +-- | Emit an acyclic three-module read-model vertical. @ReadModelTable@ owns the +-- qualified-table constant shared by the hand-owned query and the generated +-- runtime record; @ReadModel@ re-exports it as part of the public surface. +scaffoldReadModel :: Context -> ReadModelNode -> [ScaffoldModule] +scaffoldReadModel ctx readModel = + [ generated "ReadModelTable" (emitReadModelTable tableModule stem readModel), + generated "ReadModel" (emitReadModelGen ctx readModelModule tableModule readModelHolePrefix stem readModel), + ScaffoldModule + { modulePath = modulePathFor readModelHolePrefix "ReadModelHoles", + moduleText = emitReadModelHoles tableModule readModelHolePrefix stem readModel, + kind = HoleStub, + origin = readModelOrigin + } + ] + where + nodeSegment = pascal (rmName readModel) + stem = readModelStem readModel + readModelModule = genPrefixFor ctx nodeSegment + tableModule = readModelModule <> ".ReadModelTable" + readModelHolePrefix = holePrefixFor ctx nodeSegment + readModelOrigin = nodeOrigin "readmodel" (rmName readModel) (rmLoc readModel) + generated leaf body = + ScaffoldModule + { modulePath = modulePathFor readModelModule leaf, + moduleText = body, + kind = Generated, + origin = readModelOrigin + } + +modulePathFor :: Text -> Text -> FilePath +modulePathFor prefix leaf = T.unpack (T.replace "." "/" prefix <> "/" <> leaf <> ".hs") + +readModelStem :: ReadModelNode -> Text +readModelStem = lowerFirst . T.concat . map pascal . T.splitOn "_" . rmName + +emitReadModelTable :: Text -> Text -> ReadModelNode -> Text +emitReadModelTable tableModule stem readModel = + nl + [ generatedBanner, + "module " <> tableModule <> " (" <> qualifiedName <> ") where", + "", + "import Data.Text (Text)", + "import Keiro.Connection (qualifyTable)", + "", + "-- The fully-qualified, double-quoted data-table reference.", + qualifiedName <> " :: Text", + qualifiedName <> " = qualifyTable " <> tshow (rmSchema readModel) <> " " <> tshow (rmTable readModel) + ] + where + qualifiedName = stem <> "QualifiedTable" + +emitReadModelGen :: Context -> Text -> Text -> Text -> Text -> ReadModelNode -> Text +emitReadModelGen ctx readModelModule tableModule readModelHolePrefix stem readModel = + nl $ + [ "{-# LANGUAGE OverloadedRecordDot #-}", + generatedBanner, + "module " <> readModelModule <> ".ReadModel", + " ( " <> T.intercalate "\n , " exports, + " ) where", + "", + "import Data.Functor (void)", + "import Effectful (Eff, (:>))", + "import " <> tableModule <> " (" <> qualifiedName <> ")", + "import " <> readModelHolePrefix <> ".ReadModelHoles (" <> T.intercalate ", " holeImports <> ")" + ] + ++ asyncImports + ++ [ "import Keiro.ReadModel (ConsistencyMode (..), ReadModel (..), ReadModelMetadata, StrongScope (..), registerReadModel)", + "import Keiro.ReadModel.Rebuild qualified as Rebuild", + "import Kiroku.Store.Effect (Store)", + "import Kiroku.Store.Types (" <> kirokuTypes <> ")", + "", + readModelName <> " :: ReadModel " <> queryInputType <> " " <> queryResultType, + readModelName <> " =", + " ReadModel", + " { name = " <> tshow registryName, + " , tableName = " <> tshow (rmTable readModel), + " , schema = " <> tshow (rmSchema readModel), + " , subscriptionName = " <> tshow subscriptionName, + " , version = " <> tshow' (rmVersion readModel), + " , shapeHash = " <> tshow (rmShape readModel), + " , defaultConsistency = " <> consistencyExpr (rmConsistency readModel), + " , strongScope = " <> scopeExpr (rmScope readModel), + " , query = " <> queryName, + " }", + "", + "-- Call once at projection startup before serving queries.", + registerName <> " :: (Store :> es) => Eff es ()", + registerName <> " =", + " void (registerReadModel " <> tshow registryName <> " " <> tshow' (rmVersion readModel) <> " " <> tshow (rmShape readModel) <> ")", + "", + startName <> " :: (Store :> es) => GlobalPosition -> Eff es ReadModelMetadata", + startName <> " =", + " Rebuild.startRebuild " <> readModelName <> " " <> projectionNames, + "", + finishName <> " :: (Store :> es) => GlobalPosition -> Eff es (Either Rebuild.RebuildError ReadModelMetadata)", + finishName <> " =", + " Rebuild.finishRebuild " <> readModelName <> " " <> projectionNames, + "", + abandonName <> " :: (Store :> es) => Eff es ReadModelMetadata", + abandonName <> " = Rebuild.abandonRebuild " <> readModelName + ] + ++ asyncDefinition + where + registryName = registryNameFor (contextName ctx) readModel + subscriptionName = subscriptionNameFor (contextName ctx) readModel + asyncName = registryName <> "-async" + readModelName = stem <> "ReadModel" + qualifiedName = stem <> "QualifiedTable" + registerName = "register" <> pascal stem + startName = "start" <> pascal stem <> "Rebuild" + finishName = "finish" <> pascal stem <> "Rebuild" + abandonName = "abandon" <> pascal stem <> "Rebuild" + asyncValueName = stem <> "AsyncProjection" + queryInputType = pascal stem <> "QueryInput" + queryResultType = pascal stem <> "QueryResult" + queryName = stem <> "Query" + applyName = "apply" <> pascal stem + exports = + [ readModelName, + qualifiedName, + registerName, + startName, + finishName, + abandonName + ] + ++ [asyncValueName | rmFeed readModel == RmSubscription] + holeImports = [queryInputType, queryResultType, queryName] ++ [applyName | rmFeed readModel == RmSubscription] + asyncImports = case rmFeed readModel of + RmInline -> [] + RmSubscription -> ["import Keiro.Projection (AsyncProjection (..))"] + kirokuTypes = case rmFeed readModel of + RmInline -> "GlobalPosition" + RmSubscription -> "GlobalPosition, RecordedEvent (..)" + projectionNames = case rmFeed readModel of + RmInline -> "[]" + RmSubscription -> "[" <> tshow asyncName <> "]" + asyncDefinition = case rmFeed readModel of + RmInline -> [] + RmSubscription -> + [ "", + asyncValueName <> " :: AsyncProjection", + asyncValueName <> " =", + " AsyncProjection", + " { name = " <> tshow asyncName, + " , readModelName = " <> tshow registryName, + " , subscriptionName = " <> tshow subscriptionName, + " , applyRecorded = " <> applyName, + " , idempotencyKey = \\recorded -> recorded.eventId", + " }" + ] + consistencyExpr Strong = "Strong" + consistencyExpr Eventual = "Eventual" + scopeExpr Nothing = "EntireLog" + scopeExpr (Just RmEntireLog) = "EntireLog" + scopeExpr (Just (RmCategory categoryName)) = "CategoryHead " <> tshow categoryName + +emitReadModelHoles :: Text -> Text -> Text -> ReadModelNode -> Text +emitReadModelHoles tableModule readModelHolePrefix stem readModel = + nl $ + [ "-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.", + "module " <> readModelHolePrefix <> ".ReadModelHoles", + " ( " <> T.intercalate "\n , " exports, + " ) where", + "", + "import " <> tableModule <> " (" <> qualifiedName <> ")", + "import Hasql.Transaction qualified as Tx" + ] + ++ ["import Kiroku.Store.Types (RecordedEvent(..))" | rmFeed readModel == RmSubscription] + ++ [ "", + "-- HOLE: replace these aliases with the real query input and result types.", + "type " <> queryInputType <> " = ()", + "type " <> queryResultType <> " = ()", + "", + "-- HOLE: query " <> qualifiedTableLiteral readModel <> " via " <> qualifiedName <> "; never rely on search_path.", + "-- Declared columns:" + ] + ++ map (("-- " <>) . readModelColumnDoc) (rmColumns readModel) + ++ [ queryName <> " :: " <> queryInputType <> " -> Tx.Transaction " <> queryResultType, + queryName <> " _input = " <> qualifiedName <> " `seq` error " <> tshow ("HOLE: fill " <> rmName readModel <> " query") + ] + ++ applyStub + where + qualifiedName = stem <> "QualifiedTable" + queryInputType = pascal stem <> "QueryInput" + queryResultType = pascal stem <> "QueryResult" + queryName = stem <> "Query" + applyName = "apply" <> pascal stem + exports = [queryInputType, queryResultType, queryName] ++ [applyName | rmFeed readModel == RmSubscription] + applyStub = case rmFeed readModel of + RmInline -> [] + RmSubscription -> + [ "", + "-- HOLE: apply one recorded event; runtime deduplication makes redelivery safe.", + applyName <> " :: RecordedEvent -> Tx.Transaction ()", + applyName <> " _recorded = error " <> tshow ("HOLE: fill " <> rmName readModel <> " async apply") + ] + +qualifiedTableLiteral :: ReadModelNode -> Text +qualifiedTableLiteral readModel = quoteSqlIdentifier (rmSchema readModel) <> "." <> quoteSqlIdentifier (rmTable readModel) + +quoteSqlIdentifier :: Text -> Text +quoteSqlIdentifier identifier = "\"" <> T.replace "\"" "\"\"" identifier <> "\"" + +readModelColumnDoc :: RmColumn -> Text +readModelColumnDoc columnDecl = + rmcName columnDecl + <> " " + <> rmcType columnDecl + <> if rmcRequired columnDecl then " NOT NULL" else "" + +-------------------------------------------------------------------------------- +-- Router + shared worker-policy lowering (EP-108) +-------------------------------------------------------------------------------- + +scaffoldRouter :: Context -> RouterNode -> [ScaffoldModule] +scaffoldRouter ctx router = + [ ScaffoldModule + { modulePath = modulePathFor genPrefix "Router", + moduleText = emitRouterGen genPrefix router, + kind = Generated, + origin = routerOrigin + }, + ScaffoldModule + { modulePath = modulePathFor holePrefix "RouterHoles", + moduleText = emitRouterHoles holePrefix router, + kind = HoleStub, + origin = routerOrigin + } + ] + where + genPrefix = genPrefixFor ctx (rtId router) + holePrefix = holePrefixFor ctx (rtId router) + routerOrigin = nodeOrigin "router" (rtId router) (rtLoc router) + +emitRouterGen :: Text -> RouterNode -> Text +emitRouterGen genPrefix router = + nl $ + [ generatedBanner, + "module " <> genPrefix <> ".Router", + " ( " <> stem <> "Name", + " , " <> stem <> "WorkerOptions", + " ) where", + "", + "import Data.Text (Text)" + ] + ++ workerPolicyImports (rtPoison router) + ++ [ "", + "-- The STABLE router name. It participates in every target-keyed", + "-- deterministicRouterCommandId; renaming it re-keys replayed dispatches.", + stem <> "Name :: Text", + stem <> "Name = " <> tshow (rtName router), + "", + "-- Runtime-owned dispatch id inputs: (name, key, sourceEventId,", + "-- targetStreamName, occurrence). Target-keyed, not positional.", + "", + "-- Node-level worker policy lowered from the spec. Pass this value to", + "-- Keiro.Router.runRouterWorkerWith; do not silently use defaultWorkerOptions." + ] + ++ workerOptionsLines (stem <> "WorkerOptions") (rtRejected router) (rtPoison router) + where + stem = lowerFirst (rtId router) + +emitRouterHoles :: Text -> RouterNode -> Text +emitRouterHoles holePrefix router = + nl + [ "-- HAND-OWNED hole module for the router's behaviour-bearing bodies.", + "-- keiro-dsl creates it once and never overwrites it.", + "module " <> holePrefix <> ".RouterHoles () where", + "", + "-- HOLE resolve :: " <> inName (rtInput router) <> " -> Eff es [PMCommand targetCommand]", + "-- Spec source: " <> resolveSourceText (rvSource (rtResolve router)) <> ".", + "-- The spec's 'stable' keyword acknowledges that retry attempts accumulate", + "-- the UNION of resolved target identities. Keep the recipient set stable", + "-- for a source event whenever an exact recipient set matters.", + "-- HOLE router value: assemble Keiro.Router.Router with name = " <> lowerFirst (rtId router) <> "Name,", + "-- key, resolve, targetEventStream, and targetProjections; run it with", + "-- runRouterWorkerWith " <> lowerFirst (rtId router) <> "WorkerOptions.", + "-- HOLE targetProjections: spec projections = " <> renderNames (rtProjections router) <> ".", + "-- NOTE on-duplicate AckOk is sound because Keiro.Router confirms a duplicate", + "-- event id against the TARGET stream via confirmBenignDuplicate before", + "-- returning PMCommandDuplicate. Hand-rolled dispatch paths must do likewise." + ] + where + renderNames names = "[" <> T.intercalate ", " names <> "]" + +resolveSourceText :: ResolveSource -> Text +resolveSourceText (ResolveReadModel name) = "read-model " <> name <> " (typically Keiro.ReadModel.runQuery)" +resolveSourceText ResolveHole = "typed resolver hole" + +workerPolicyImports :: PolicyChoice -> [Text] +workerPolicyImports poison = + [ "import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))", + "import Shibuya.Core.Ack (RetryDelay (..))" + ] + ++ if poison == PolHalt + then [] + else ["import Effectful (Eff)", "import Shibuya.Core.Types (Envelope)"] + +workerOptionsLines :: Text -> PolicyChoice -> PolicyChoice -> [Text] +workerOptionsLines valueName rejected poison = + [ valueName <> signature, + valueName <> argument <> " =", + " WorkerOptions", + " { poisonPolicy = " <> poisonExpr <> ",", + " rejectedCommandPolicy = " <> rejectedExpr rejected <> ",", + " transientRetryDelay = RetryDelay 5, -- matches defaultWorkerOptions; runtime tuning", + " metrics = Nothing -- runtime configuration; install at call site", + " }" + ] + where + signature = case poison of + PolHalt -> " :: WorkerOptions es msg" + _ -> " :: (Envelope msg -> Eff es ()) -> WorkerOptions es msg" + argument = case poison of + PolHalt -> "" + _ -> " poisonCallback" + poisonExpr = case poison of + PolHalt -> "PoisonHalt" + PolDeadLetter -> "PoisonDeadLetter poisonCallback" + PolSkip -> "PoisonSkip poisonCallback" + rejectedExpr = \case + PolHalt -> "RejectedHalt" + PolDeadLetter -> "RejectedDeadLetter" + PolSkip -> "RejectedSkip" + +-------------------------------------------------------------------------------- +-- Process manager + durable timer (EP-3) +-------------------------------------------------------------------------------- + +-- | Emit the symbol-free deterministic wiring for a process manager + its timer +-- into a @Generated@ module, plus a create-if-absent @ProcessHoles@ module for the +-- behaviour-bearing bodies (the @handle@ reaction, the deadline window, and the +-- fire command). The @Generated@ module contains no keiki symbolic operator (the +-- saga's transducer is the separate aggregate hole), so the firewall invariant +-- holds. The timer worker uses the spec's @max-attempts@ ceiling, never the +-- dangerous @defaultTimerWorkerOptions@ (@Nothing@) default. +scaffoldProcess :: Context -> ProcessNode -> [ScaffoldModule] +scaffoldProcess ctx p = + [ ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Process.hs"), + moduleText = emitProcessGen sagaGenPrefix genPrefix holePrefix p, + kind = Generated, + origin = nodeOrigin "process" (procId p) (procLoc p) + }, + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" holePrefix <> "/ProcessHoles.hs"), + moduleText = emitProcessHoles genPrefix holePrefix p, + kind = HoleStub, + origin = nodeOrigin "process" (procId p) (procLoc p) + } + ] + where + genPrefix = genPrefixFor ctx (procId p) + holePrefix = holePrefixFor ctx (procId p) + sagaGenPrefix = genPrefixFor ctx (pascal (sagaAgg (procSaga p))) + +emitProcessGen :: Text -> Text -> Text -> ProcessNode -> Text +emitProcessGen sagaGenPrefix genPrefix _holePrefix p = + nl $ + [ generatedBanner, + "module " <> genPrefix <> ".Process", + " ( " <> lo <> "ProcessName", + " , " <> lo <> "Category", + " , " <> lo <> "ProcessWorkerOptions", + " , " <> lo <> "TimerRequest", + " , " <> lo <> "FireOutcome", + " ) where", + "", + "import Data.Aeson (Value, object, (.=))", + "import Data.Text (Text)", + "import qualified Data.Text as T", + "import Data.Time (UTCTime)", + "import Data.UUID (UUID)", + "import qualified Data.UUID.V5 as UUID.V5", + "import " <> sagaGenPrefix <> ".EventStream (" <> sagaEventStreamType <> ")", + "import Keiro.Command (CommandError (..))", + "import Keiro.Stream qualified as Stream", + "import Keiro.Timer (TimerId (..), TimerRequest (..))" + ] + ++ workerPolicyImports (procPoison p) + ++ [ "", + "-- The define-once ProcessManager name (hole-kind 5: referenced, never retyped).", + lo <> "ProcessName :: Text", + lo <> "ProcessName = " <> tshow (procName p), + "", + "-- The validated saga stream category (hole-kind 5: referenced, never retyped).", + "-- Saga streams are '-' 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 $ + [ "{-# LANGUAGE DataKinds #-}" + ] + ++ ["{-# LANGUAGE DeriveAnyClass #-}" | hasSnapshot a] + ++ ["{-# LANGUAGE EmptyDataDecls #-}" | null (aCommands a) || null (aEvents a)] + ++ [ "{-# LANGUAGE DuplicateRecordFields #-}", + "{-# LANGUAGE TemplateHaskell #-}", + "{-# LANGUAGE TypeApplications #-}", + generatedBanner, + "module " <> aGenPrefix a <> ".Domain where", + "" + ] + ++ ["import Data.Aeson (FromJSON, ToJSON)" | hasSnapshot a] + ++ [ "import Data.Proxy (Proxy (..))", + "import Data.Text (Text)", + "import GHC.Generics (Generic)", + "import Keiki.Core (RegFile (..))" + ] + ++ ["import Keiki.Shape (CanonicalStateShape, CanonicalTypeName)" | hasSnapshot a] + ++ generatedNominalTypeImportsForService (aggregateCheckedService a) (aContext a) (aGeneratedNominals a) + ++ map ("import " <>) (domainConsumerImports a) + ++ [ "import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)", + "", + sectionsOf + [ [emitVertex a], + map (emitRecord a) (aCommands a), + [emitSum (aName a <> "Command") (aCommands a)], + map (emitRecord a) (aEvents a), + [emitSum (aName a <> "Event") (aEvents a)], + [emitRegsType a, emitInitialRegs a], + [ "$(deriveAggregateCtorsAll ''" <> aName a <> "Command ''" <> aName a <> "Regs)", + "", + "$(deriveWireCtorsAll ''" <> aName a <> "Event)" + ] + ] + ] + +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 :: Agg -> ResolvedCtor -> Text +emitRecord a rc = + nl $ + [ "data " <> rcName rc <> "Data = " <> rcName rc <> "Data" + ] + ++ recordFields [(name, renderDomainType a fieldType) | (name, 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 :: Agg -> Text +emitRegsType a = + nl $ + ["type " <> aName a <> "Regs ="] + ++ regListLines a (aRegs a) + +regListLines :: Agg -> [ResolvedRegister] -> [Text] +regListLines _ [] = [" '[]"] +regListLines a rs = + [ lead i <> "'(" <> tshow (rrName r) <> ", " <> renderDomainType a (rrType r) <> ")" + | (i, r) <- zip [(0 :: Int) ..] rs + ] + ++ [" ]"] + where + lead 0 = " '[ " + lead _ = " , " + +emitInitialRegs :: Agg -> Text +emitInitialRegs 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 a r <> " $" + | r <- init rs + ] + ++ [" RCons (Proxy @" <> tshow (rrName lastR) <> ") " <> regInitialValue a lastR <> " RNil"] + where + lastR = last rs + +-- | The Haskell initial value for a register, by the category of its type. +regInitialValue :: Agg -> ResolvedRegister -> Text +regInitialValue aggregate register = case rrInitial register of + InitialId name -> case find ((== name) . resolvedNominalName) (aGeneratedNominals aggregate) >>= generatedIdSampleHaskell aggregate of + Just value -> value + Nothing -> renderRegisterInitial (rrInitial register) + _ -> renderRegisterInitial (rrInitial register) + +domainConsumerImports :: Agg -> [Text] +domainConsumerImports a = + sort . nub $ + Set.toList (Set.unions [aggregateImports (aSymbols a) resolved | resolved <- aggregateTypes]) + <> [ qualifiedModule initialValue <> " qualified" + | declaration <- mappedUses a, + initialValue <- maybeToListText (mappedInitial declaration) + ] + <> [ qualifiedModule initialValue <> " qualified" + | resolvedType <- aggregateTypes, + AggregateNominal nominal <- [resolvedType], + ConsumerNominal binding <- [resolvedNominalOwnership nominal], + initialValue <- maybeToListText (consumerNominalInitial binding) + ] + where + aggregateTypes = map snd (concatMap rcFields (aCommands a <> aEvents a)) <> map rrType (aRegs a) + +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 :: Agg -> ResolvedAggregateType -> Text +renderDomainType a = aggregateHaskellType (aSymbols a) + +maybeToListText :: Maybe value -> [value] +maybeToListText = maybe [] pure + +-------------------------------------------------------------------------------- +-- Codec module +-------------------------------------------------------------------------------- + +emitCodec :: Agg -> Text +emitCodec a = + nl $ + ["{-# LANGUAGE DataKinds #-}" | hasConsumerNominalIdCodec a] + ++ ["{-# LANGUAGE TypeApplications #-}" | hasConsumerNominalIdCodec a] + ++ ["{-# LANGUAGE LambdaCase #-}" | hasConsumerNominalCodec a || hasGeneratedNominalEnumCodec a] + ++ [ "{-# LANGUAGE OverloadedRecordDot #-}", + 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) + ++ ( if hasMappedCodec a + then + [ "import Control.Monad (unless)", + "import Data.Aeson (Value (..), object, parseJSON, toJSON, withObject, withText, (.:), (.=))", + "import Data.Aeson.Key qualified as Key", + "import Data.Aeson.KeyMap qualified as KeyMap" + ] + else ["import Data.Aeson (Value, object, withObject, withText, (.:), (.=))"] + ) + ++ [ "import Data.Aeson.Types (Parser, explicitParseField, parseEither)", + "import Data.List.NonEmpty (NonEmpty (..))" + ] + ++ ( if hasMappedCodec 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)" | hasMappedCodec a] + ++ [ "import Keiro.Codec (Codec (..), EventType (..))", + upcasterImport a + ] + ++ [nl (map ("import " <>) (codecMappedImports a)) | hasMappedCodec a] + ++ [nl (map ("import " <>) (codecNominalImports a)) | hasConsumerNominalCodec a] + ++ [ "", + emitEnumParsers a, + emitConsumerNominalParsers a + ] + ++ [emitMappedCodecs a | hasMappedCodec a] + ++ [ "", + emitCodecValue a, + "", + emitEncode a, + "", + emitDecode a, + "", + "mapLeftText :: Either String b -> Either Text b", + "mapLeftText = either (Left . T.pack) Right" + ] + ++ ( if hasMappedCodec 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 + mappedExports (ResolvedStructural declaration _) = + [ " encode" <> sdName declaration <> "Mapped,", + " decode" <> sdName declaration <> "Mapped," + ] + mappedExports ResolvedOpaque {} = [] + +hasMappedCodec :: Agg -> Bool +hasMappedCodec = not . null . codecMappedDeclarations + +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) + +hasGeneratedNominalEnumCodec :: Agg -> Bool +hasGeneratedNominalEnumCodec aggregate = + any + (\nominal -> case resolvedNominalRepresentation nominal of EnumRepresentation {} -> True; _ -> False) + (codecGeneratedNominals 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 :: Agg -> Text +emitConsumerNominalParsers aggregate = sectionsOf [map emitParser (codecConsumerNominals aggregate)] + where + emitParser nominal = case (resolvedNominalRepresentation nominal, resolvedNominalOwnership nominal) of + (IdRepresentation prefix, ConsumerNominal binding) -> + nl $ + [ parserName nominal <> " :: Text -> Parser " <> renderHaskellSource (consumerNominalHaskell binding) + ] + <> parserBody nominal prefix binding + (EnumRepresentation constructors, ConsumerNominal binding) -> + nl $ + [ parserName nominal <> " :: Text -> Parser " <> renderHaskellSource (consumerNominalHaskell binding), + parserName nominal <> " = \\case" + ] + <> [ " " + <> tshow wire + <> " -> pure (nominalFromRepresentation " + <> unQualifiedValueName (consumerNominalBinding binding) + <> " " + <> nominalRepresentationModule (aContext aggregate) (resolvedNominalName 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 " <> unQualifiedValueName (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 " <> unQualifiedValueName (consumerNominalBinding binding) <> " representation)" + ] + +emitCodecValue :: Agg -> Text +emitCodecValue a = + nl $ + [ lowerFirst (aName a) <> "Codec :: Codec " <> aName a <> "Event", + lowerFirst (aName a) <> "Codec =", + " Codec", + " { eventTypes = " <> eventTypesExpr, + " , 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 + where + eventTypesExpr = case map rcName (aEvents a) of + [] -> "error \"no events\"" + (e : es) -> "EventType " <> tshow e <> " :| [" <> T.intercalate ", " (map (("EventType " <>) . tshow) es) <> "]" + +-- | 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 :: Agg -> Text +emitEncode 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 (n, ty) = + tshow n + <> " .= " + <> encodeFieldValue n ty + encodeFieldValue name ty = case ty of + AggregateNominal nominal -> encodeNominalValue nominal ("payload." <> name) + _ -> case fieldCat a ty of + MappedStructuralCat declaration _ -> "encode" <> sdName declaration <> "Mapped payload." <> name + MappedOpaqueCat {} -> "toJSON payload." <> name + _ -> "payload." <> name + 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 {} -> + nominalRepresentationModule (aContext a) (resolvedNominalName nominal) + <> "." + <> lowerFirst (resolvedNominalName nominal) + <> "RepresentationText (nominalToRepresentation " + <> bindingName binding + <> " " + <> value + <> ")" + ScalarRepresentation {} -> "nominalToRepresentation " <> bindingName binding <> " " <> value + bindingName = unQualifiedValueName . consumerNominalBinding + +emitDecode :: Agg -> Text +emitDecode 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) + ++ [" _ -> " <> renderUnknownFailure "event type" "tag" (map rcName (aEvents a))] + 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 (n, ty) = case ty of + AggregateNominal nominal -> decodeNominalField n nominal + _ -> case fieldCat a ty of + MappedStructuralCat declaration _ -> "explicitParseField parse" <> sdName declaration <> "Mapped o " <> tshow n + MappedOpaqueCat {} -> "o .: " <> tshow n + _ -> "o .: " <> tshow n + 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 " <> unQualifiedValueName (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 + ] + +codecNominalImports :: Agg -> [Text] +codecNominalImports aggregate = + sort . nub $ + concat + [ [ hsModule (consumerNominalHaskell binding) <> " qualified", + qualifiedModule (consumerNominalBinding binding) <> " qualified" + ] + <> [ nominalRepresentationModule (aContext aggregate) (resolvedNominalName nominal) <> " qualified" + | EnumRepresentation {} <- [resolvedNominalRepresentation nominal] + ] + | nominal <- codecConsumerNominals aggregate, + ConsumerNominal binding <- [resolvedNominalOwnership nominal] + ] + +codecMappedImports :: Agg -> [Text] +codecMappedImports a = case aTypeGraph a of + Nothing -> [] + Just graph -> + sort . nub $ + [ structuralShapeModule (aContext a) (sdName declaration) <> " qualified" + | ResolvedStructural declaration _ <- codecMappedDeclarations a + ] + <> [ hsModule (sdHaskell declaration) <> " qualified" + | ResolvedStructural declaration _ <- codecMappedDeclarations a + ] + <> [ qualifiedModule (sdBinding declaration) <> " qualified" + | ResolvedStructural declaration _ <- codecMappedDeclarations a + ] + <> [ hsModule (odHaskell declaration) <> " qualified" + | ResolvedOpaque declaration <- codecMappedDeclarations a + ] + <> [ hsModule (odHaskell declaration) <> " qualified" + | 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 :: Agg -> Text +emitMappedCodecs a = case aTypeGraph a of + Nothing -> "" + Just graph -> + T.intercalate + "\n\n" + [ emitStructuralCodec a graph declaration shape + | ResolvedStructural declaration shape <- codecMappedDeclarations a + ] + +emitStructuralCodec :: Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text +emitStructuralCodec a graph declaration shape = + nl + [ "encode" <> name <> "Mapped :: " <> consumerType <> " -> Value", + "encode" <> name <> "Mapped = encode" <> name <> "Shape . bindingToShape " <> binding, + "", + "parse" <> name <> "Mapped :: Value -> Parser " <> consumerType, + "parse" <> name <> "Mapped value = bindingFromShape " <> binding <> " <$> parse" <> name <> "Shape value", + "", + "decode" <> name <> "Mapped :: Value -> Either Text " <> consumerType, + "decode" <> name <> "Mapped = mapLeftText . parseEither parse" <> name <> "Mapped", + "", + "encode" <> name <> "Shape :: " <> shapeType <> " -> Value", + emitShapeEncoder a graph declaration shape, + "", + "parse" <> name <> "Shape :: Value -> Parser " <> shapeType, + emitShapeDecoder a graph declaration shape + ] + where + name = sdName declaration + consumerType = renderHaskellSource (sdHaskell declaration) + shapeType = structuralShapeModule (aContext a) name <> "." <> name <> "Shape" + binding = unQualifiedValueName (sdBinding declaration) + +emitShapeEncoder :: Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text +emitShapeEncoder a graph declaration = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ fields -> + nl $ + ["encode" <> name <> "Shape shape =", " object"] + <> objectEntries + [ tshow (rwfKey field) + <> " .= " + <> encodeShapeExpr a graph (rwfType field) (shapeModuleName <> "." <> rwfHaskell field <> " shape") + | field <- fields + ], + onEnum = \entries -> + nl $ + ["encode" <> name <> "Shape = \\case"] + <> [" " <> shapeModuleName <> "." <> weCtor entry <> " -> String " <> tshow (weTag entry) | entry <- entries], + onUnion = \encoding arms -> + nl $ + ["encode" <> name <> "Shape = \\case"] + <> concatMap (unionEncodeArm encoding) arms + } + where + name = sdName declaration + shapeModuleName = structuralShapeModule (aContext a) name + unionEncodeArm encoding arm = + [ " " <> shapeModuleName <> "." <> rwaCtor arm <> payloadPattern <> " ->", + " object" + ] + <> objectEntries + ( [tshow (ueTagField encoding) <> " .= (" <> tshow (rwaTag arm) <> " :: Text)"] + <> [ tshow (ueContentsField encoding) <> " .= " <> encodeShapeExpr a graph payload "payload" + | payload <- maybeToListText (rwaPayload arm) + ] + ) + where + payloadPattern = maybe "" (const " payload") (rwaPayload arm) + +emitShapeDecoder :: Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text +emitShapeDecoder a graph declaration = + foldMappedShape + MappedShapeAlgebra + { onRecord = \constructor unknownFields fields -> + nl $ + [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do" + ] + <> rejectLine " " unknownFields (map rwfKey fields) "objectValue" + <> [ " " <> shapeModuleName <> "." <> constructor, + " <$> " <> T.intercalate "\n <*> " (map (decodeRecordField a graph) fields) + ], + onEnum = \entries -> + nl $ + [ "parse" <> name <> "Shape = withText " <> tshow (name <> "Shape") <> " $ \\tag -> case tag of" + ] + <> [" " <> tshow (weTag entry) <> " -> pure " <> shapeModuleName <> "." <> weCtor entry | entry <- entries] + <> [" tag -> " <> renderUnknownFailure (name <> " wire value") "tag" (map weTag entries)], + onUnion = \encoding arms -> + nl $ + [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do", + " tag <- explicitParseField (withText " <> tshow (name <> " tag") <> " validate" <> name <> "Tag) objectValue " <> tshow (ueTagField encoding), + " case tag of" + ] + <> concatMap (unionDecodeArm encoding) arms + <> [ " _ -> fail \"validated union tag was not handled\"", + "", + "validate" <> name <> "Tag :: Text -> Parser Text", + "validate" <> name <> "Tag tag", + " | tag `elem` " <> renderTextList (map rwaTag arms) <> " = pure tag", + " | otherwise = " <> renderUnknownFailure (name <> " union tag") "tag" (map rwaTag arms) + ] + } + where + name = sdName declaration + shapeModuleName = structuralShapeModule (aContext a) name + 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 " <> shapeModuleName <> "." <> rwaCtor arm + Just payload -> + " " + <> shapeModuleName + <> "." + <> rwaCtor arm + <> " <$> explicitParseField (" + <> decodeShapeExpr a graph payload + <> ") objectValue " + <> tshow (ueContentsField encoding) + ] + where + allowed = ueTagField encoding : [ueContentsField encoding | rwaPayload arm /= Nothing] + +decodeRecordField :: Agg -> TypeGraph -> ResolvedWireField -> Text +decodeRecordField a graph field = case rwfPresence field of + PRequired -> + "explicitParseField (" <> decoder <> ") objectValue " <> key + POptional -> + "(case KeyMap.lookup (Key.fromText " + <> key + <> ") objectValue of Nothing -> " + <> missing + <> "; Just _ -> explicitParseField (" + <> decoder + <> ") objectValue " + <> key + <> ")" + where + key = tshow (rwfKey field) + decoder = decodeShapeExpr a graph (rwfType field) + missing = case rwfOnMissing field of + Nothing -> "fail " <> tshow ("missing optional field without default: " <> rwfKey field) + Just onMissing -> "pure " <> renderMissingDefault a graph (rwfType field) onMissing + +encodeShapeExpr :: Agg -> TypeGraph -> ResolvedTypeExpr -> Text -> Text +encodeShapeExpr _a graph expression value = + foldTypeExpr + TypeExprAlgebra + { onText = \v -> "toJSON (" <> v <> ")", + onInt = \v -> "toJSON (" <> v <> ")", + onInteger = \v -> "toJSON (" <> v <> ")", + onBool = \v -> "toJSON (" <> v <> ")", + onNatural = \v -> "toJSON (" <> v <> ")", + onTime = \v -> "toJSON (" <> v <> ")", + onJson = id, + onOptional = \encode v -> "maybe Null (\\item -> " <> encode "item" <> ") (" <> v <> ")", + onList = \encode v -> "toJSON (map (\\item -> " <> encode "item" <> ") (" <> v <> "))", + onMap = \encode v -> "toJSON (Map.map (\\item -> " <> encode "item" <> ") (" <> v <> "))", + onRef = \key v -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural nested _) -> "encode" <> sdName nested <> "Shape (" <> v <> ")" + Just (ResolvedOpaque _) -> "toJSON (" <> v <> ")" + Nothing -> "toJSON (" <> v <> ")" + } + expression + value + +decodeShapeExpr :: Agg -> TypeGraph -> ResolvedTypeExpr -> Text +decodeShapeExpr _a graph = + foldTypeExpr + TypeExprAlgebra + { onText = "parseJSON", + onInt = "parseJSON", + onInteger = "parseJSON", + onBool = "parseJSON", + onNatural = "parseJSON", + onTime = "parseJSON", + onJson = "pure", + onOptional = \decode -> "\\value -> case value of Null -> pure Nothing; other -> Just <$> " <> decode <> " other", + onList = \decode -> "\\value -> (parseJSON value :: Parser [Value]) >>= traverse (" <> decode <> ")", + onMap = \decode -> "\\value -> (parseJSON value :: Parser (Map Text Value)) >>= traverse (" <> decode <> ")", + onRef = \key -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural nested _) -> "parse" <> sdName nested <> "Shape" + Just (ResolvedOpaque _) -> "parseJSON" + Nothing -> "parseJSON" + } + +renderMissingDefault :: Agg -> TypeGraph -> ResolvedTypeExpr -> OnMissing -> Text +renderMissingDefault a graph expression = \case + OmNull -> "Nothing" + OmText value -> tshow value + OmInt value -> T.pack (show value) + OmBool value -> if value then "True" else "False" + OmEmptyList -> "[]" + OmEmptyMap -> "Map.empty" + OmCtor constructor -> case expression of + RRef key -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural declaration _) -> structuralShapeModule (aContext a) (sdName declaration) <> "." <> constructor + _ -> constructor + _ -> constructor + +objectEntries :: [Text] -> [Text] +objectEntries entries = + [lead index <> entry | (index, entry) <- zip [(0 :: Int) ..] entries] + <> [" ]"] + where + lead 0 = " [ " + lead _ = " , " + +renderTextList :: [Text] -> Text +renderTextList values = "[" <> T.intercalate ", " (map tshow values) <> "]" + +-- | Emit a parser failure that names the rejected runtime value and the full, +-- deterministic wire set accepted at that point. +renderUnknownFailure :: Text -> Text -> [Text] -> Text +renderUnknownFailure label variable expected = + "fail (" + <> tshow ("unknown " <> label <> " ") + <> " <> show " + <> variable + <> " <> " + <> tshow ("; expected one of: " <> expectedText) + <> ")" + where + expectedText = case expected of + [] -> "" + values -> T.intercalate ", " values + +-------------------------------------------------------------------------------- +-- Authoritative version-2 expressions and transducer +-------------------------------------------------------------------------------- + +hasVersion2Ownership :: Agg -> Bool +hasVersion2Ownership = any ((/= LegacyHoleImplementation) . tImplementation) . aTransitions + +transitionEntries :: Agg -> [(Int, Transition)] +transitionEntries aggregate = zip [1 ..] (aTransitions aggregate) + +transitionStem :: Int -> Transition -> Text +transitionStem index transition = + "transition" + <> tshow' index + <> pascal (tSource transition) + <> pascal (tCommand transition) + +guardFunctionName :: Int -> Transition -> Text +guardFunctionName index transition = transitionStem index transition <> "Guard" + +writeFunctionName :: Int -> Transition -> Name -> Text +writeFunctionName index transition registerName = + transitionStem index transition <> "Write" <> pascal registerName + +holeFunctionName :: Int -> Transition -> Text +holeFunctionName index transition = transitionStem index transition <> "Hole" + +holeFoldVersionName :: Int -> Transition -> Text +holeFoldVersionName index transition = holeFunctionName index transition <> "FoldVersion" + +outputFunctionName :: Int -> Transition -> Int -> Name -> Text +outputFunctionName transitionIndex transition emitIndex eventName = + transitionStem transitionIndex transition + <> "Output" + <> tshow' emitIndex + <> pascal eventName + +-- | Legacy create-once output-hook names made obsolete by authoritative +-- version-2 @fields(Command)@ generation. Scaffolding reports these names as +-- safe-to-remove candidates without parsing or modifying consumer Haskell. +obsoleteGeneratedOutputHooks :: Spec -> [(Name, Text)] +obsoleteGeneratedOutputHooks spec = + [ ( aggName aggregate, + outputFunctionName transitionIndex transition emitIndex eventName + ) + | aggregate <- [value | NAggregate value <- specNodes spec], + (transitionIndex, transition) <- zip [1 ..] (aggTransitions aggregate), + (emitIndex, eventName) <- zip [1 ..] (tEmits transition), + Right GeneratedCommandIdentity {} <- [eventOutputMapping spec aggregate transition emitIndex eventName] + ] + +commandForTransition :: Agg -> Transition -> ResolvedCtor +commandForTransition aggregate transition = + fromMaybe + (error ("validated aggregate command disappeared: " <> T.unpack (tCommand transition))) + (find ((== tCommand transition) . rcName) (aCommands aggregate)) + +eventForName :: Agg -> Name -> ResolvedCtor +eventForName aggregate eventName = + fromMaybe + (error ("validated aggregate event disappeared: " <> T.unpack eventName)) + (find ((== eventName) . rcName) (aEvents aggregate)) + +commandFieldsType :: Transition -> Text +commandFieldsType transition = "RegFieldsOf " <> tCommand transition <> "Data" + +payloadProjectionType :: Agg -> Transition -> Text +payloadProjectionType aggregate transition = + "B.PayloadProj " + <> aName aggregate + <> "Regs " + <> aName aggregate + <> "Command (" + <> commandFieldsType transition + <> ")" + +data ResolvedGeneratedTransition = ResolvedGeneratedTransition + { resolvedTransitionIndex :: !Int, + resolvedTransitionSource :: !Transition, + resolvedTransitionGuard :: !(Maybe TypedScalarExpr), + resolvedTransitionWrites :: ![(Name, TypedScalarExpr)] + } + deriving stock (Eq, Show) + +-- Resolve each generated-owned transition exactly once. Import analysis, +-- projection planning, and Haskell emission all consume this inventory. +resolvedGeneratedTransitions :: Agg -> [ResolvedGeneratedTransition] +resolvedGeneratedTransitions aggregate = + [ ResolvedGeneratedTransition + { resolvedTransitionIndex = index, + resolvedTransitionSource = transition, + resolvedTransitionGuard = resolvedGuard index transition <$> tGuard transition, + resolvedTransitionWrites = + [ (registerName, resolvedWrite index transition registerName expression) + | (registerName, expression) <- tWrites transition + ] + } + | (index, transition) <- transitionEntries aggregate, + tImplementation transition == GeneratedImplementation + ] + where + environment transition = expressionEnvironment (aSpec aggregate) (aAggregate aggregate) transition + resolvedGuard index transition expression = + expressionOrDie (guardFunctionName index transition) (resolveGuardExpr (environment transition) expression) + resolvedWrite index transition registerName expression = + expressionOrDie (writeFunctionName index transition registerName) (resolveWriteExpr (environment transition) registerName expression) + +resolvedGeneratedExpressions :: Agg -> [TypedScalarExpr] +resolvedGeneratedExpressions = generatedTransitionExpressions . resolvedGeneratedTransitions + +generatedTransitionExpressions :: [ResolvedGeneratedTransition] -> [TypedScalarExpr] +generatedTransitionExpressions = concatMap transitionExpressions + where + transitionExpressions resolved = + maybe [] pure (resolvedTransitionGuard resolved) + <> map snd (resolvedTransitionWrites resolved) + +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 :: [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> Text +renderKeikiPredicate 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 aliases aggregate transition expression) + (renderedAtom "K.lit True") + comparison operator left right = + renderedInfix + 4 + RenderNonAssociative + operator + (renderComparisonTerm aliases aggregate transition left) + (renderComparisonTerm 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 :: [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> RenderedKeikiExpr +renderComparisonTerm 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 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 :: Agg -> Transition -> ResolvedNominalType -> ScalarRootProvenance -> Text +renderNominalProjectionTerm aggregate transition nominal provenance = case provenance of + ScalarRegisterRoot registerName ownerType -> + "K.regProj " + <> projectionQualifier + <> "." + <> witness + <> " (#" + <> registerName + <> " :: K.Index " + <> aName aggregate + <> "Regs " + <> renderDomainType aggregate ownerType + <> ")" + ScalarCommandRoot fieldName ownerType -> + "K.inpProj " + <> projectionQualifier + <> "." + <> witness + <> " inCtor" + <> tCommand transition + <> " (#" + <> fieldName + <> " :: K.Index (" + <> commandFieldsType transition + <> ") " + <> renderDomainType 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 :: [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> RenderedKeikiExpr +renderKeikiTerm aliases aggregate transition expression = case typedScalarNode expression of + TypedLiteral value -> renderedAtom (renderKeikiLiteral aggregate (typedScalarType expression) value) + TypedRoot (ScalarRegisterRoot registerName _) -> renderedAtom ("B.reg @" <> tshow registerName) + TypedRoot (ScalarCommandRoot fieldName _) -> renderedAtom ("d." <> 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 aliases aggregate transition left) + (renderKeikiTerm aliases aggregate transition right) + impossiblePredicate = error "predicate-valued Boolean expressions cannot be lowered as register terms" + +renderStructuralProjectionTerm :: Agg -> Transition -> ScalarRootProvenance -> ResolvedScalarProjection -> Text +renderStructuralProjectionTerm aggregate transition provenance projection = case provenance of + ScalarRegisterRoot registerName ownerType -> + "K.regProj StructuralProjections." + <> witness + <> " (#" + <> registerName + <> " :: K.Index " + <> aName aggregate + <> "Regs " + <> renderDomainType aggregate ownerType + <> ")" + ScalarCommandRoot fieldName ownerType -> + "K.inpProj StructuralProjections." + <> witness + <> " inCtor" + <> tCommand transition + <> " (#" + <> fieldName + <> " :: K.Index (" + <> commandFieldsType transition + <> ") " + <> renderDomainType aggregate ownerType + <> ")" + where + witness = + fromMaybe + (error ("resolved structural projection witness disappeared: " <> show projection)) + (aTypeGraph aggregate >>= \graph -> projectionWitnessName graph (scalarProjectionOwner projection) (scalarProjectionPointer projection)) + +renderKeikiLiteral :: Agg -> ResolvedAggregateType -> ScalarValue -> Text +renderKeikiLiteral 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 " + <> unQualifiedValueName (consumerNominalBinding binding) + <> " " + <> nominalRepresentationModule (aContext aggregate) typeName + <> "." + <> 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 " + <> unQualifiedValueName (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 $ + [ "{-# LANGUAGE BlockArguments #-}", + "{-# LANGUAGE DataKinds #-}", + "{-# LANGUAGE GADTs #-}", + "{-# LANGUAGE OverloadedRecordDot #-}" + ] + ++ ["{-# LANGUAGE OverloadedLabels #-}" | not (null projectionAliases)] + ++ [ "{-# LANGUAGE QualifiedDo #-}", + "{-# LANGUAGE TypeApplications #-}", + 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] + ++ generatedNominalTypeImportsForService (aggregateCheckedService aggregate) (aContext aggregate) generatedExpressionNominals + ++ structuralProjectionImport + ++ generatedNominalProjectionImport + ++ consumerNominalProjectionImport + ++ consumerImports + ++ ["import Data.KindID qualified as KindID" | expressionUsesConsumerIdLiteral] + ++ ["import Keiro.Codec.Nominal (nominalFromRepresentation)" | expressionUsesConsumerNominalLiteral] + ++ consumerLiteralImports + ++ [ "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 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 = + map ("import " <>) + . filter (not . builtinExpressionImport) + . sort + . nub + . Set.toList + . Set.unions + $ [ aggregateImports (aSymbols aggregate) resolvedType + | resolvedType <- expressionImportTypes + ] + expressionImportTypes = nub (concatMap typedExpressionImportTypes resolvedExpressions) + consumerLiteralImports = + [ "import " <> nominalRepresentationModule (aContext aggregate) (resolvedNominalName nominal) <> " qualified" + | nominal <- consumerLiteralNominals, + EnumRepresentation {} <- [resolvedNominalRepresentation nominal] + ] + <> [ "import " <> qualifiedModule (consumerNominalBinding binding) <> " qualified" + | nominal <- consumerLiteralNominals, + ConsumerNominal binding <- [resolvedNominalOwnership nominal] + ] + consumerLiteralNominals = nub [nominal | expression <- resolvedExpressions, nominal <- typedConsumerLiteralNominals expression] + generatedExpressionNominals = + stableNominals + [ nominal + | expression <- resolvedExpressions, + nominal <- typedGeneratedNominals expression + ] + 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 + +builtinExpressionImport :: Text -> Bool +builtinExpressionImport imported = + any (`T.isPrefixOf` imported) ["Data.Text", "Data.Time", "Numeric.Natural"] + +typedExpressionImportTypes :: TypedScalarExpr -> [ResolvedAggregateType] +typedExpressionImportTypes expression = own <> concatMap typedExpressionImportTypes (typedExpressionChildren expression) + where + own = case typedScalarNode expression of + TypedLiteral {} -> [typedScalarType expression] + TypedRoot provenance -> [scalarRootType provenance] + TypedProject provenance _ -> [scalarRootType provenance] + _ -> [] + +scalarRootType :: ScalarRootProvenance -> ResolvedAggregateType +scalarRootType = \case + ScalarRegisterRoot _ resolvedType -> resolvedType + ScalarCommandRoot _ resolvedType -> resolvedType + +isStructuralProjection :: ProjectionAliasTarget -> Bool +isStructuralProjection StructuralProjectionAlias {} = True +isStructuralProjection NominalProjectionAlias {} = False + +isGeneratedNominalProjection :: ProjectionAliasTarget -> Bool +isGeneratedNominalProjection (NominalProjectionAlias nominal _) = resolvedNominalOwnership nominal == GeneratedNominal +isGeneratedNominalProjection StructuralProjectionAlias {} = False + +isConsumerNominalProjection :: ProjectionAliasTarget -> Bool +isConsumerNominalProjection (NominalProjectionAlias nominal _) = case resolvedNominalOwnership nominal of + ConsumerNominal {} -> True + GeneratedNominal -> False +isConsumerNominalProjection StructuralProjectionAlias {} = False + +expressionOperatorOrder :: [Text] +expressionOperatorOrder = [".*", ".+", ".-", ".==", "./=", ".<", ".<=", ".>", ".>=", ".&&", ".||"] + +generatedTransitionOperators :: ResolvedGeneratedTransition -> [Text] +generatedTransitionOperators resolved = + maybe [] predicateOperators (resolvedTransitionGuard resolved) + <> concatMap (termOperators . snd) (resolvedTransitionWrites resolved) + where + predicateOperators expression = case typedScalarNode expression of + TypedEqual left right -> ".==" : termOperators left <> termOperators right + TypedNotEqual left right -> "./=" : termOperators left <> termOperators right + TypedCompare operator left right -> renderComparisonOperator operator : termOperators left <> termOperators right + TypedAnd left right -> ".&&" : predicateOperators left <> predicateOperators right + TypedOr left right -> ".||" : predicateOperators left <> predicateOperators right + _ -> ".==" : termOperators expression + termOperators expression = case typedScalarNode expression of + TypedAdd _ left right -> ".+" : termOperators left <> termOperators right + TypedSubtract _ left right -> ".-" : termOperators left <> termOperators right + TypedMultiply _ left right -> ".*" : termOperators left <> termOperators right + _ -> concatMap termOperators (typedExpressionChildren expression) + +anyHoleOwned :: Agg -> Bool +anyHoleOwned = any ((== HoleImplementation) . tImplementation) . aTransitions + +transducerUsesHoles :: Agg -> Bool +transducerUsesHoles aggregate = + anyHoleOwned aggregate + || any isHandOwned (Map.elems (aOutputMappings aggregate)) + where + isHandOwned HandOwnedEventOutput {} = True + isHandOwned GeneratedCommandIdentity {} = False + +renderVerificationList :: Agg -> [Text] +renderVerificationList aggregate = + [ (if listIndex == (0 :: Int) then " [ " else " , ") + <> "verifyTransition " + <> tshow (transitionStem transitionIndex transition) + <> " " + <> ownership + <> " " + <> vertexCtor aggregate source + <> " " + <> tshow' edgeIndex + | (listIndex, (source, edgeIndex, transitionIndex, transition)) <- zip [0 ..] entries, + let ownership = case tImplementation transition of + GeneratedImplementation -> "GeneratedOwned" + HoleImplementation -> "HoleOwned" + LegacyHoleImplementation -> error "legacy transition reached version-2 verification generation" + ] + <> [" ]"] + where + entries = + [ (source, edgeIndex, transitionIndex, transition) + | (source, transitions) <- groupTransitionEntriesBySource aggregate, + (edgeIndex, (transitionIndex, transition)) <- zip [0 ..] transitions + ] + +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 = go [] (transitionEntries aggregate) + where + go accumulated [] = reverse accumulated + go accumulated (entry@(_, transition) : remaining) = + let source = tSource transition + (same, rest) = span ((== source) . tSource . snd) remaining + in go ((source, entry : same) : accumulated) rest + +generatedFromBlock :: Agg -> [ResolvedGeneratedTransition] -> (Text, [(Int, Transition)]) -> [Text] +generatedFromBlock aggregate resolvedTransitions (source, transitions) = + [" B.from " <> vertexCtor aggregate source <> " do"] + ++ concatMap (uncurry (generatedOnCmdBlock aggregate resolvedTransitions)) transitions + +generatedOnCmdBlock :: Agg -> [ResolvedGeneratedTransition] -> Int -> Transition -> [Text] +generatedOnCmdBlock 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 aliases aggregate transition) (resolvedTransitionGuard resolved) + ++ [ " B.slot @" <> tshow registerName <> " =: " <> renderAssignmentOperand (renderKeikiTerm 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 aggregate transition firstAlias] + <> [" " <> renderProjectionAliasBinding 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 :: Agg -> Transition -> ProjectionAlias -> Text +renderProjectionAliasBinding aggregate transition alias = + projectionAliasName alias <> " = " <> case projectionAliasTarget alias of + StructuralProjectionAlias provenance projection -> renderStructuralProjectionTerm aggregate transition provenance projection + NominalProjectionAlias nominal provenance -> renderNominalProjectionTerm aggregate transition nominal provenance + +renderGuardLines :: [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> [Text] +renderGuardLines aliases aggregate transition expression = + [" B.requireGuard $"] + <> [" " <> line | line <- T.lines readable] + where + readable = + T.replace " .|| " "\n.|| " + . T.replace " .&& " "\n.&& " + $ renderKeikiPredicate 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 _ fields -> case fields of + [] -> [" B.emit wire" <> eventName <> " B.oNil"] + _ -> + [ " B.emit wire" <> eventName <> " (" <> eventName <> "TermFields" + ] + <> [ lead fieldIndex + <> outputSelector field + <> " = d." + <> outputSelector field + | (fieldIndex, field) <- zip [0 :: Int ..] fields + ] + <> [" })"] + HandOwnedEventOutput {} -> + [ " B.emit wire" + <> eventName + <> " (Holes." + <> outputFunctionName transitionIndex transition emitIndex eventName + <> " d)" + ] + where + lead 0 = " { " + lead _ = " , " + +outputMappingFor :: Agg -> Int -> Int -> EventOutputMapping +outputMappingFor aggregate transitionIndex emitIndex = + fromMaybe + (error ("missing checked event-output mapping for transition " <> show transitionIndex <> ", emit " <> show emitIndex)) + (Map.lookup (transitionIndex, emitIndex) (aOutputMappings aggregate)) + +-------------------------------------------------------------------------------- +-- EventStream module +-------------------------------------------------------------------------------- + +emitEventStream :: Agg -> Text +emitEventStream a = + nl $ + [ generatedBanner, + "module " <> aGenPrefix a <> ".EventStream", + " ( " <> lowerFirst (aName a) <> "Category", + " , " <> lowerFirst (aName a) <> "CommandCategory", + " , " <> lowerFirst (aName a) <> "EventStream", + " , " <> lowerFirst (aName a) <> "EventStreamDef", + " , " <> aName a <> "EventStream", + " , " <> aName a <> "EventStreamDef" + ] + ++ [" , " <> lowerFirst (aName a) <> "SnapshotFixture" | hasSnapshot a] + ++ [ " ) where", + "", + "import " <> aGenPrefix a <> ".Domain", + "import " <> aGenPrefix a <> ".Codec (" <> lowerFirst (aName a) <> "Codec)", + transducerImport a, + "import Keiki.Core (HsPred)", + "import Keiro.EventStream (EventStream (..), SnapshotPolicy (..))", + "import Keiro.EventStream.Validate (ValidatedEventStream, mkEventStreamOrThrow)" + ] + ++ ["import Data.Text (Text)" | hasSnapshot a] + ++ ["import Keiro.Snapshot.Codec (defaultStateCodec, withFoldFingerprint)" | hasSnapshot a] + ++ [ "import Keiro.Stream qualified as Stream", + "", + "-- The validated aggregate stream category (hole-kind 5: referenced, never retyped).", + "-- Entity streams are '-' via Keiro.Stream.entityStream.", + "-- categoryUnsafe is safe here because this generated literal passed the DSL category proof.", + lowerFirst (aName a) <> "Category :: Stream.StreamCategory " <> aName a <> "EventStreamDef", + lowerFirst (aName a) <> "Category = Stream.categoryUnsafe " <> tshow categoryName, + "", + "-- The same category text, typed for command envelopes such as PMCommand.", + lowerFirst (aName a) <> "CommandCategory :: Stream.StreamCategory " <> aName a <> "Command", + lowerFirst (aName a) <> "CommandCategory = Stream.categoryUnsafe " <> tshow categoryName, + "", + "type " <> aName a <> "EventStreamDef =", + " EventStream (HsPred " <> aName a <> "Regs " <> aName a <> "Command) " <> aName a <> "Regs " <> aVertexType a <> " " <> aName a <> "Command " <> aName a <> "Event", + "", + "type " <> aName a <> "EventStream =", + " ValidatedEventStream (HsPred " <> aName a <> "Regs " <> aName a <> "Command) " <> aName a <> "Regs " <> aVertexType a <> " " <> aName a <> "Command " <> aName a <> "Event", + "", + lowerFirst (aName a) <> "EventStreamDef :: " <> aName a <> "EventStreamDef", + lowerFirst (aName a) <> "EventStreamDef =", + " EventStream", + " { transducer = " <> lowerFirst (aName a) <> "Transducer,", + " initialState = " <> initialVertex a <> ",", + " initialRegisters = initial" <> aName a <> "Regs,", + " eventCodec = " <> lowerFirst (aName a) <> "Codec,", + " resolveStreamName = Stream.streamName,", + " snapshotPolicy = " <> snapshotPolicyExpr a <> "," + ] + ++ stateCodecFieldLines a + ++ [ " }", + "" + ] + ++ snapshotFixtureLines a + ++ [ lowerFirst (aName a) <> "EventStream :: " <> aName a <> "EventStream", + lowerFirst (aName a) <> "EventStream =", + " mkEventStreamOrThrow " <> tshow (aName a) <> " " <> lowerFirst (aName a) <> "EventStreamDef" + ] + where + categoryName = staticCategory ("aggregate " <> aName a) (lowerFirst (aName a)) + +snapshotPolicyExpr :: Agg -> Text +snapshotPolicyExpr aggregate = case aSnapshot aggregate of + Nothing -> "Never" + Just snapshot -> case snapPolicy snapshot of + SnapEvery interval -> "Every " <> tshow' interval + SnapOnTerminal -> "OnTerminal" + +stateCodecExpr :: Agg -> Text +stateCodecExpr aggregate = case aSnapshot aggregate of + Nothing -> "Nothing" + Just snapshot -> + "Just (withFoldFingerprint " + <> foldFingerprintValue aggregate + <> " (defaultStateCodec " + <> tshow' (snapCodecVersion snapshot) + <> "))" + +transducerImport :: Agg -> Text +transducerImport aggregate + | hasVersion2Ownership aggregate = + "import " + <> aGenPrefix aggregate + <> ".Transducer (" + <> lowerFirst (aName aggregate) + <> "FoldFingerprint, " + <> 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 [generatedBanner, "module " <> aGenPrefix a <> ".Projection () where"] + Just p -> + nl + [ "{-# LANGUAGE OverloadedRecordDot #-}", + 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 [(fieldName, outputFieldValue fieldName fieldType) | (fieldName, fieldType) <- rcFields event]) + command = commandForTransition aggregate transition + outputFieldValue fieldName fieldType + | Just commandType <- lookup fieldName (rcFields command), + commandType == fieldType = + "d." <> fieldName + | Just register <- find ((== fieldName) . rrName) (aRegs aggregate), + rrType register == fieldType = + "B.reg @" <> tshow fieldName + | otherwise = "error " <> tshow ("HOLE: fill output field " <> rcName event <> "." <> fieldName) + valueRecord fields = + [ lead fieldIndex <> fieldName <> " = " <> fieldValue + | (fieldIndex, (fieldName, fieldValue)) <- zip [0 :: Int ..] fields + ] + ++ [" }"] + lead 0 = " { " + lead _ = " , " + +emitHoleImplementation :: Agg -> Int -> Transition -> [Text] +emitHoleImplementation _ 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 <> " _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 = go [] (transitionsOf a) + where + go acc [] = reverse acc + go acc (t : ts) = + let src = tSource t + (same, rest) = span ((== src) . tSource) ts + in go ((src, t : same) : acc) rest + +-- 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 = diff --git a/src/Keiro/Dsl/ScaffoldRun.hs b/src/Keiro/Dsl/ScaffoldRun.hs --- a/src/Keiro/Dsl/ScaffoldRun.hs +++ b/src/Keiro/Dsl/ScaffoldRun.hs @@ -3,6 +3,7 @@ module Keiro.Dsl.ScaffoldRun ( Refusal (..), WriteDisposition (..), + StaleGeneratedEvidence (..), StaleModule (..), MappingDrift (..), SourceLanguageDrift (..), @@ -45,12 +46,13 @@ import Data.Text.IO qualified as TIO import Keiro.Dsl.BehaviorCoverage (BehaviorDerivationError, BehaviorKey (..), BehaviorRecordRow (..), behaviorRecordRows, deriveBehaviorRequirements) import Keiro.Dsl.ExplainBindings (BindingHole (..), BindingObligationKind (..), bindingHolesForService) +import Keiro.Dsl.FoldFingerprint (FoldSurfaceError, aggregateFoldSurfaceForService, renderFoldSurfaceError) import Keiro.Dsl.Goldens (GoldenPayload) import Keiro.Dsl.Grammar (Node (..), Spec (..)) import Keiro.Dsl.Harness (harnessForServiceWithGoldens, harnessProcess, harnessReadModel, harnessRouter, harnessWorkflow) import Keiro.Dsl.IdDomain (idDomainIdentitiesForService) import Keiro.Dsl.LanguageVersion (SourceLanguage (..), effectiveLanguageVersion, languageVersionText, sourceFormText) -import Keiro.Dsl.Manifest (moduleNameOf, renderManifest) +import Keiro.Dsl.Manifest (moduleNameOf, renderManifestForService) import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), MappingIdentity (..), consumerPlan) import Keiro.Dsl.NominalType (nominalEqualityIdentitiesForService) import Keiro.Dsl.Scaffold @@ -75,6 +77,8 @@ | MissingGeneratedBanner ![FilePath] | ImportCycle ![Text] | BehaviorRefusal ![BehaviorDerivationError] + | -- | 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 @@ -90,9 +94,15 @@ data WriteDisposition = Overwritten | Created | Skipped | Unchanged deriving stock (Eq, Show) +data StaleGeneratedEvidence + = ExactGeneratedBannerPresent + | ExactGeneratedBannerMissing + deriving stock (Eq, Show) + data StaleModule = StaleModule { staleKind :: !ModuleKind, - stalePath :: !FilePath + stalePath :: !FilePath, + staleGeneratedEvidence :: !(Maybe StaleGeneratedEvidence) } deriving stock (Eq, Show) @@ -144,7 +154,7 @@ NAggregate agg -> scaffoldAggregateForService ctx service agg <> harnessForServiceWithGoldens goldens ctx service agg NProcess process -> scaffoldProcess ctx process <> harnessProcess ctx process NRouter router -> scaffoldRouter ctx router <> harnessRouter ctx router - NContract contract -> scaffoldContract ctx contract + NContract contract -> scaffoldContractForService ctx service contract NIntake intake -> scaffoldIntake ctx intake NPublisher publisher -> scaffoldPublisher ctx publisher NWorkqueue workqueue -> scaffoldWorkqueue ctx workqueue @@ -171,13 +181,15 @@ planServiceScaffoldWithGoldens :: [GoldenPayload] -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule] planServiceScaffoldWithGoldens goldens ctx service = - case scaffoldRefusals spec of - lowering@(_ : _) -> Left [LoweringRefusal lowering] - [] -> - let modules = scaffoldServiceModulesWithGoldens goldens ctx service - in case pureRefusals ctx spec modules of - [] -> Right modules - refusals -> Left refusals + case traverse (aggregateFoldSurfaceForService service) [aggregate | NAggregate aggregate <- specNodes spec] of + Left surfaceError -> Left [FoldSurfaceRefusal surfaceError] + Right _ -> case scaffoldRefusals spec of + lowering@(_ : _) -> Left [LoweringRefusal lowering] + [] -> + let modules = stampGeneratedModules (checkedLanguageContract service) (scaffoldServiceModulesWithGoldens goldens ctx service) + in case pureRefusals ctx spec modules of + [] -> Right modules + refusals -> Left refusals where spec = checkedSpec service @@ -279,12 +291,13 @@ -- 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 out forceGeneratedOverwrite specPath sourceLanguage ctx service modules +executeServiceScaffold 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 = executeCheckedScaffold where spec = checkedSpec service + modules = stampGeneratedModules (checkedLanguageContract service) plannedModules executeCheckedScaffold = case deriveBehaviorRequirements spec of Left errors -> pure (Left [BehaviorRefusal errors]) @@ -310,7 +323,7 @@ createDirectoryIfMissing True out dispositions <- mapM (writeModule out) modules let manifestPath = out ("keiro-dsl-manifest." <> T.unpack (specContext spec) <> ".txt") - TIO.writeFile manifestPath (renderManifest (T.pack specPath) modules spec) + TIO.writeFile manifestPath (renderManifestForService (T.pack specPath) modules service) TIO.writeFile recordPath (renderRecord (currentRecord specPath sourceLanguage ctx service modules currentBehavior)) pure $ Right @@ -402,8 +415,20 @@ currentPaths = Set.fromList currentPathList removed = [(fileKind, path) | (fileKind, path) <- previous, path `Set.notMember` currentPaths] stillExists (fileKind, path) = do - exists <- doesFileExist (out path) - pure [StaleModule fileKind path | exists] + 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] -> [BehaviorRecordRow] -> ScaffoldRecord currentRecord specPath sourceLanguage ctx service modules currentBehavior = @@ -434,7 +459,7 @@ then pure [] else do contents <- TIO.readFile path - pure [modulePath m | not (any (T.isPrefixOf "-- @generated") (T.lines contents))] + pure [modulePath m | not (any isGeneratedBannerLine (T.lines contents))] writeModule :: FilePath -> ScaffoldModule -> IO (ScaffoldModule, WriteDisposition) writeModule out m = do @@ -479,6 +504,10 @@ render (BehaviorRefusal errors) = ["error: behavior obligations cannot be derived soundly -- refusing to scaffold; nothing was written"] <> [" " <> T.pack (show behaviorError) | behaviorError <- errors] + 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 @@ -610,9 +639,12 @@ ] <> map staleLine stale <> ["note: keiro-dsl never deletes files."] - staleLine stale = case staleKind stale of - Generated -> " generated " <> T.pack (stalePath stale) <> " (safe to delete; still on disk)" - HoleStub -> " hole " <> T.pack (stalePath stale) <> " (hand-owned — review before deleting)" + 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 = diff --git a/src/Keiro/Dsl/SemanticContract.hs b/src/Keiro/Dsl/SemanticContract.hs --- a/src/Keiro/Dsl/SemanticContract.hs +++ b/src/Keiro/Dsl/SemanticContract.hs @@ -8,10 +8,12 @@ module Keiro.Dsl.SemanticContract ( EffectiveLanguageContract, effectiveContractLanguageVersion, + effectiveRuntimeProfile, effectiveRuntimeSemantics, + effectiveLanguageSupport, effectiveLanguageContract, effectiveLanguageContractForVersion, - runtimeSemanticsFingerprintSegment, + runtimeSemanticsFingerprintSegments, CheckedService (..), checkedSource, checkedService, @@ -19,20 +21,25 @@ ) where -import Control.Monad (guard) import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=)) import Data.Maybe (fromMaybe) import Data.Text (Text) import Keiro.Dsl.Grammar (Spec) import Keiro.Dsl.LanguageVersion - ( LanguageVersion, + ( LanguageSupport, + LanguageVersion, ParsedSource (..), + RuntimeSemanticsProfile, SourceLanguage (..), - definitionRuntimeSemantics, + definitionRuntimeSemanticsProfile, effectiveLanguageVersion, + languageSupportForVersion, + languageSupportText, languageVersion, languageVersionNumber, lookupLanguageDefinition, + runtimeProfileFoldSegments, + runtimeProfileIdentifier, ) -- | One effective released-language selection plus the runtime-semantics @@ -43,15 +50,28 @@ -- than re-deriving policy from source text. data EffectiveLanguageContract = EffectiveLanguageContract { effectiveContractLanguageVersion :: !LanguageVersion, - effectiveRuntimeSemantics :: !Text + effectiveRuntimeProfile :: !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 + +-- | 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)) + instance ToJSON EffectiveLanguageContract where toJSON contract = object [ "languageVersion" .= languageVersionNumber (effectiveContractLanguageVersion contract), - "runtimeSemantics" .= effectiveRuntimeSemantics contract + "runtimeSemantics" .= effectiveRuntimeSemantics contract, + "languageSupport" .= languageSupportText (effectiveLanguageSupport contract) ] instance FromJSON EffectiveLanguageContract where @@ -60,8 +80,17 @@ runtimeSemantics <- fields .: "runtimeSemantics" version <- maybe (fail "semantic contract language version must be positive") pure (languageVersion rawVersion) contract <- maybe (fail "semantic contract language version is unsupported") pure (effectiveLanguageContractForVersion version) - guard (effectiveRuntimeSemantics contract == runtimeSemantics) - pure contract + if effectiveRuntimeSemantics contract == runtimeSemantics + then pure contract + else + fail + ( "semantic contract runtimeSemantics does not match language version " + <> show rawVersion + <> ": expected " + <> show (effectiveRuntimeSemantics contract) + <> ", received " + <> show (runtimeSemantics :: Text) + ) -- | Resolve source provenance to the semantic contract used by every -- downstream planner. This function is total for parsed sources: the parser has @@ -81,15 +110,14 @@ pure EffectiveLanguageContract { effectiveContractLanguageVersion = version, - effectiveRuntimeSemantics = definitionRuntimeSemantics definition + effectiveRuntimeProfile = definitionRuntimeSemanticsProfile definition } --- | Fold/replay discriminator for runtime semantics newer than the historical --- baseline. Grammar-only language changes deliberately contribute no segment. -runtimeSemanticsFingerprintSegment :: EffectiveLanguageContract -> Maybe Text -runtimeSemanticsFingerprintSegment contract - | effectiveRuntimeSemantics contract == "keiro-dsl/runtime-semantics/1" = Nothing - | otherwise = Just ("semantic-contract:" <> effectiveRuntimeSemantics contract) +-- | 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 -- | A normalized service graph paired with the effective contract under which -- it was checked. Member-level declared/legacy provenance intentionally stays diff --git a/src/Keiro/Dsl/Skeleton.hs b/src/Keiro/Dsl/Skeleton.hs --- a/src/Keiro/Dsl/Skeleton.hs +++ b/src/Keiro/Dsl/Skeleton.hs @@ -15,6 +15,7 @@ import Data.Text (Text) import Data.Text qualified as T +import Keiro.Dsl.LanguageVersion (currentStableLanguageVersion, languageVersionText) -- | The valid @new \@ arguments, in help/listing order. skeletonKinds :: [Text] @@ -51,7 +52,7 @@ Left $ "unknown kind '" <> other <> "'. Valid kinds: " <> T.intercalate ", " skeletonKinds where - versioned source = "language keiro-dsl 1\n" <> source + versioned source = "language keiro-dsl " <> languageVersionText currentStableLanguageVersion <> "\n" <> source aggregateSkeleton :: Text aggregateSkeleton = @@ -63,14 +64,12 @@ "aggregate Thing", " regs", " thingId ThingId = placeholder", - " state ThingVertex = Pending", " states Pending Done!", "", " command DoThing { thingId attempt:Int }", " event ThingCompleted { thingId attempt:Int }", "", " Pending -- DoThing -->", - " write state := Done", " emit ThingCompleted", " goto Done", "", diff --git a/src/Keiro/Dsl/Validate.hs b/src/Keiro/Dsl/Validate.hs --- a/src/Keiro/Dsl/Validate.hs +++ b/src/Keiro/Dsl/Validate.hs @@ -36,12 +36,14 @@ import Keiro.Dsl.EventOutput import Keiro.Dsl.Expression import Keiro.Dsl.Grammar -import Keiro.Dsl.IdDomain (idDomainContractFor) +import Keiro.Dsl.IdDomain (contractIdDomainContractFor, idDomainContractFor) +import Keiro.Dsl.LanguageVersion (RuntimeCapability (..), runtimeProfileHasCapability) import Keiro.Dsl.NominalType qualified as Nominal import Keiro.Dsl.ReadModelShape (deriveShapeHash) -import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, legacyCheckedService) +import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveRuntimeProfile, legacyCheckedService) import Keiro.Dsl.TypeGraph import Numeric (showHex) +import Text.Read (readMaybe) data Severity = Error | Warning deriving stock (Eq, Show) @@ -331,6 +333,39 @@ | -- 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 deriving stock (Eq, Show) -- | A line-numbered, structured diagnostic. @@ -377,8 +412,15 @@ validateCheckedSpec :: EffectiveLanguageContract -> Spec -> [Diagnostic] validateCheckedSpec languageContract spec = - sortOn line (validateNames spec ++ validateMapped spec ++ validateNominal languageContract spec ++ validateAggregateTypes spec ++ specLevelRules spec ++ concatMap (validateNode spec) (specNodes spec)) + sortOn line (validateNames spec ++ validateMapped spec ++ validateNominal languageContract spec ++ validateAggregateTypes spec ++ specLevelRules languageContract spec ++ concatMap (validateNode languageContract spec) (specNodes spec)) +-- | Rules added before language 4 ships consult the effective semantic +-- contract, not the numeric source spelling. Versions 1 through 3 retain their +-- released acceptance; runtime semantics 3 is the unreleased tightening gate. +enforcesSpecSurfaceClosures :: EffectiveLanguageContract -> Bool +enforcesSpecSurfaceClosures languageContract = + runtimeProfileHasCapability (effectiveRuntimeProfile languageContract) StrictSpecSurfaceValidation + validateNominal :: EffectiveLanguageContract -> Spec -> [Diagnostic] validateNominal languageContract spec = domainErrors <> resolutionErrors where @@ -1258,9 +1300,29 @@ 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 :: Spec -> [Diagnostic] -specLevelRules spec = duplicateNodes ++ duplicateEnumMembers ++ duplicateIdPrefixes ++ ruleDiagnostics +specLevelRules :: EffectiveLanguageContract -> Spec -> [Diagnostic] +specLevelRules languageContract spec = duplicateNodes ++ duplicateEnumMembers ++ duplicateIdPrefixes ++ duplicateDeclarations ++ runtimeIdentities ++ duplicateRuntimeIdentities ++ ruleDiagnostics where duplicateNodes = [ mkErr (locLine loc) DuplicateNodeName $ @@ -1284,6 +1346,35 @@ "id '" <> idName d <> "' reuses prefix '" <> idPrefix d <> "'" | d <- duplicatesBy idPrefix (specIds spec) ] + duplicateDeclarations = + [ mkErr (locLine loc) NominalDuplicateDeclaration $ + "duplicate " <> category <> " declaration '" <> name <> "'; the last declaration would silently replace the earlier one" + | enforcesSpecSurfaceClosures languageContract, + (category, name, loc) <- duplicatesBy (\(category, name, _) -> (category, name)) declarationOrigins + ] + declarationOrigins = + [("id", idName value, idLoc value) | value <- specIds spec] + <> [("enum", enumName value, enumLoc value) | value <- specEnums spec] + <> [("nominal scalar", nominalScalarName value, nominalScalarLoc value) | value <- specNominalScalars spec] + <> [("mapped", mappedName value, mappedLoc value) | value <- specMapped spec] + <> [("rule", ruleName value, ruleLoc value) | value <- specRules spec] + runtimeIdentities = + [ mkErr (locLine loc) RuntimeIdentityInvalid $ + kind <> " stable identity " <> T.pack (show identity) <> " " <> reason + | enforcesSpecSurfaceClosures languageContract, + (kind, identity, loc) <- stableIdentityOrigins, + Just reason <- [stableIdentityError identity] + ] + duplicateRuntimeIdentities = + [ mkErr (locLine loc) RuntimeIdentityDuplicate $ + kind <> " stable identity " <> T.pack (show identity) <> " is already used by another workflow, process, or router" + | enforcesSpecSurfaceClosures languageContract, + (kind, identity, loc) <- duplicatesBy (\(_, identity, _) -> identity) stableIdentityOrigins + ] + stableIdentityOrigins = + [("workflow", wfStable workflow, workflowNodeLoc workflow) | NWorkflow workflow <- specNodes spec] + <> [("process", procName process, procLoc process) | NProcess process <- specNodes spec] + <> [("router", rtName router, rtLoc router) | NRouter router <- specNodes spec] ruleDiagnostics = concatMap (validateRule spec) (specRules spec) nodeIdentity :: Node -> (Text, Name, Loc) @@ -1300,20 +1391,100 @@ nodeIdentity (NWorkflow w) = ("workflow", wfId w, workflowNodeLoc w) nodeIdentity (NOperation o) = ("operation", opName o, opLoc o) -validateNode :: Spec -> Node -> [Diagnostic] -validateNode spec (NAggregate agg) = validateAggregate spec agg -validateNode spec (NProcess p) = validateProcess spec p -validateNode spec (NRouter router) = validateRouter spec router -validateNode _spec (NContract _) = [] -- a contract is a declaration; coupling is checked at the referrers -validateNode spec (NIntake i) = validateIntake i ++ intakeCoupling spec i -validateNode spec (NEmit e) = validateEmit spec e -validateNode spec (NPublisher p) = validatePublisher spec p -validateNode _spec (NWorkqueue w) = validateWorkqueue w -validateNode spec (NPgmqDispatch d) = validatePgmqDispatch spec d -validateNode spec (NReadModel readModel) = validateReadModel spec readModel -validateNode _spec (NWorkflow w) = validateWorkflow w -validateNode spec (NOperation o) = validateOperation spec o +validateNode :: EffectiveLanguageContract -> Spec -> Node -> [Diagnostic] +validateNode languageContract spec (NAggregate agg) = validateAggregate languageContract spec agg +validateNode _languageContract spec (NProcess p) = validateProcess spec p +validateNode _languageContract spec (NRouter router) = validateRouter spec router +validateNode languageContract _spec (NContract contract) = validateContract languageContract contract +validateNode languageContract spec (NIntake i) = validateIntake languageContract i ++ intakeCoupling languageContract spec i +validateNode languageContract spec (NEmit e) = validateEmit languageContract spec e +validateNode languageContract spec (NPublisher p) = validatePublisher languageContract spec p +validateNode _languageContract _spec (NWorkqueue w) = validateWorkqueue w +validateNode _languageContract spec (NPgmqDispatch d) = validatePgmqDispatch spec d +validateNode languageContract spec (NReadModel readModel) = validateReadModel languageContract spec readModel +validateNode _languageContract _spec (NWorkflow w) = validateWorkflow w +validateNode _languageContract spec (NOperation o) = validateOperation spec o +validateContract :: EffectiveLanguageContract -> ContractNode -> [Diagnostic] +validateContract languageContract contract = + typeIdPrefixErrors + <> schemaVersionFloor + <> topicNames + <> duplicateEvents + <> duplicateTopicAliases + <> duplicateFields + <> discriminatorShadows + <> unresolvedTopicAliases + where + typeIdPrefixErrors = + [ mkErr (locLine (ctrLoc contract)) 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 (ctrLoc contract)) 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 (ctrLoc contract)) ContractFieldShadowsDiscriminator $ + "contract '" + <> ctrName contract + <> "' event '" + <> ceName event + <> "' field '" + <> cfName field + <> "' shadows the payload discriminator" + | enforcesSpecSurfaceClosures languageContract, + event <- ctrEvents contract, + field <- ceFields event, + cfName field == ctrDiscriminator 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 @@ -1497,9 +1668,9 @@ ] -- | Validate captured identity, feed semantics, and the declared column surface. -validateReadModel :: Spec -> ReadModelNode -> [Diagnostic] -validateReadModel spec readModel = - shapeFixture ++ columnTypes ++ strongFeed ++ scopeMode ++ inlineReference +validateReadModel :: EffectiveLanguageContract -> Spec -> ReadModelNode -> [Diagnostic] +validateReadModel languageContract spec readModel = + shapeFixture ++ columnTypes ++ strongFeed ++ scopeMode ++ inlineReference ++ versionFloor ++ identifiers ++ duplicateColumns where readModelLine = locLine (rmLoc readModel) expectedShape = deriveShapeHash readModel @@ -1541,6 +1712,27 @@ | rmFeed readModel == RmInline, rmName readModel `notElem` [projTable projection | NAggregate aggregate <- specNodes spec, Just projection <- [aggProjection aggregate]] ] + versionFloor = + [ mkErr readModelLine ReadModelVersionBelowMinimum $ + "readmodel '" <> rmName readModel <> "' version must be at least 1" + | enforcesSpecSurfaceClosures languageContract, + rmVersion readModel < 1 + ] + identifiers = + [ mkErr readModelLine ReadModelIdentifierInvalid $ + "readmodel '" <> rmName readModel <> "' " <> kind <> " " <> T.pack (show identifier) <> " is not a PostgreSQL unquoted identifier" + | enforcesSpecSurfaceClosures languageContract, + (kind, identifier) <- + [("schema", rmSchema readModel), ("table", rmTable readModel)] + <> [("column", rmcName columnDecl) | columnDecl <- rmColumns readModel], + not (validPostgresIdentifier identifier) + ] + duplicateColumns = + [ mkErr readModelLine ReadModelDuplicateColumn $ + "readmodel '" <> rmName readModel <> "' declares column '" <> rmcName columnDecl <> "' more than once" + | enforcesSpecSurfaceClosures languageContract, + columnDecl <- duplicatesBy rmcName (rmColumns readModel) + ] -- | EP-5 workqueue rules: the captured physical name must match the queueRef -- derivation; the disposition inversions (storeFailure transient => must retry; @@ -1674,8 +1866,8 @@ specContracts spec = [c | NContract c <- specNodes spec] -- | EP-4 cross-node coupling: an intake's contract/topic/accepted-events resolve. -intakeCoupling :: Spec -> IntakeNode -> [Diagnostic] -intakeCoupling spec i = case lookupContract (inkContract i) of +intakeCoupling :: EffectiveLanguageContract -> Spec -> IntakeNode -> [Diagnostic] +intakeCoupling languageContract spec i = case lookupContract (inkContract i) of Nothing -> [mkErr (locLine (inkLoc i)) IntakeUnresolvedContract ("intake '" <> inkName i <> "' references undeclared contract '" <> inkContract i <> "'")] Just c -> @@ -1692,17 +1884,54 @@ 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 + ] where 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 + ] -validateEmit :: Spec -> EmitNode -> [Diagnostic] -validateEmit spec e = skipRule ++ coupling +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 : _) -> @@ -1721,16 +1950,66 @@ ceTopic event /= emTopic e ] -validatePublisher :: Spec -> PublisherNode -> [Diagnostic] -validatePublisher spec p = - [ mkErr (locLine (pubLoc p)) PublisherUnresolvedEmit ("publisher '" <> pubName p <> "' references undeclared emit '" <> pubEmit p <> "'") - | pubEmit p `notElem` [emName e | NEmit e <- specNodes spec] - ] +validatePublisher :: EffectiveLanguageContract -> Spec -> PublisherNode -> [Diagnostic] +validatePublisher languageContract spec p = + unresolvedEmit ++ orderingVocabulary ++ backoffPolicy ++ attemptsFloor + 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 + ] +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 + -- | 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 :: IntakeNode -> [Diagnostic] -validateIntake i = concat [completeness, duplicateRows, inversions] +validateIntake :: EffectiveLanguageContract -> IntakeNode -> [Diagnostic] +validateIntake languageContract i = concat [completeness, duplicateRows, inversions, dedupeVocabulary, decodeVersionFloor, envelopeVocabulary] where il = locLine (inkLoc i) rows = inkDisposition i @@ -1747,6 +2026,27 @@ "intake '" <> inkName i <> "' repeats disposition outcome '" <> drOutcome row <> "'; the first row would shadow this row" | row <- duplicatesBy drOutcome rows ] + 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 @@ -1768,6 +2068,31 @@ isRetry row ] +intakeDedupePolicies :: Set Name +intakeDedupePolicies = Set.fromList ["PreferIntegrationMessageId", "PreferSourceEventIdentity", "KafkaDeliveryIdentity"] + +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 :: Spec -> ProcessNode -> [Diagnostic] validateProcess spec p = @@ -1912,13 +2237,19 @@ -- the toolchain library. The final @:@ case is deliberately stricter because -- that prefix is reserved for the @wf:@ workflow stream family. sagaCategoryError :: Text -> Maybe Text -sagaCategoryError categoryName - | T.null categoryName = Just "is empty; use a non-empty camelCase category" - | categoryName == "$all" = Just "is reserved by the event store; choose a service-owned camelCase category" - | T.isInfixOf "-" categoryName = Just "contains '-' (kiroku's category/id boundary); write compound categories in camelCase, for example \"hospitalSurge\"" - | Just illegal <- T.find (\character -> isSpace character || isControl character) categoryName = +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 ":" categoryName = Just "contains ':' which is reserved for the wf: workflow stream family; choose a camelCase category without ':'" + | T.isInfixOf ":" identity = Just "contains ':' which is reserved for runtime stream-family prefixes; choose a stable name without ':'" | otherwise = Nothing -- | EP-108 rules for a stateless content-based router. @@ -2057,8 +2388,8 @@ isDeadLetter DDeadLetter {} = True isDeadLetter _ = False -validateAggregate :: Spec -> Aggregate -> [Diagnostic] -validateAggregate spec agg = +validateAggregate :: EffectiveLanguageContract -> Spec -> Aggregate -> [Diagnostic] +validateAggregate languageContract spec agg = concat [ duplicateMembers, declaredRefs, @@ -2074,7 +2405,8 @@ evolutionRules, snapshotRules, replayOnlyRules, - eventlessStateChangeRules + eventlessStateChangeRules, + wirePolicyRules ] where states = Set.fromList (map stName (aggStates agg)) @@ -2100,6 +2432,21 @@ | 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" @@ -2109,6 +2456,54 @@ "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 $ @@ -2556,3 +2951,11 @@ | (index, x) <- zip [0 :: Int ..] xs, key x `elem` map key (take index xs) ] + +-- | Return every source-ordered group whose selected key occurs at least +-- twice. New diagnostics that describe a relationship use this helper; the +-- older 'duplicatesBy' contract remains first-shadow only. +duplicateGroupsBy :: (Ord key) => (a -> key) -> [a] -> [[a]] +duplicateGroupsBy key values = + filter ((> 1) . length) . Map.elems $ + Map.fromListWith (flip (<>)) [(key value, [value]) | value <- values] diff --git a/src/Keiro/Dsl/Workspace.hs b/src/Keiro/Dsl/Workspace.hs --- a/src/Keiro/Dsl/Workspace.hs +++ b/src/Keiro/Dsl/Workspace.hs @@ -1277,22 +1277,14 @@ instance HasLocs DecodeSpec -instance HasLocs DerivStrategy - -instance HasLocs Derivation - instance HasLocs DeriveSpec instance HasLocs Disp -instance HasLocs DispAction - instance HasLocs DispatchDisposition instance HasLocs DispatchNode -instance HasLocs Disposition - instance HasLocs DispositionRow instance HasLocs EmitMapRow @@ -1300,10 +1292,6 @@ instance HasLocs EmitNode instance HasLocs EnumDecl - -instance HasLocs EnvelopeBinding - -instance HasLocs EnvelopeLayer instance HasLocs Event diff --git a/src/Keiro/Dsl/WorkspaceAdoption.hs b/src/Keiro/Dsl/WorkspaceAdoption.hs --- a/src/Keiro/Dsl/WorkspaceAdoption.hs +++ b/src/Keiro/Dsl/WorkspaceAdoption.hs @@ -47,9 +47,9 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as TIO -import Keiro.Dsl.Scaffold (ModuleKind (..), ScaffoldModule (..)) +import Keiro.Dsl.Scaffold (ModuleKind (..), ScaffoldModule (..), isGeneratedBannerLine) import Keiro.Dsl.ScaffoldRecord (ScaffoldRecord (..), parseRecord, recordFileName) -import Keiro.Dsl.ScaffoldRun (StaleModule (..)) +import Keiro.Dsl.ScaffoldRun (StaleGeneratedEvidence (..), StaleModule (..), staleAgainst) import Keiro.Dsl.WorkspaceRecord (AdoptedRow (..), supersededByLine, workspaceMigrationReportFileName) import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) import System.FilePath (()) @@ -120,18 +120,13 @@ onDisk path, path `Set.notMember` recordClaimedPaths ] + likelyStale <- staleAgainst out (map modulePath modules) recordedFiles let claimedFromBanner = [ ClaimedFile {cfPath = path, cfEvidence = ClaimedFromBanner, cfSource = Nothing, cfSpec = Nothing} | (path, True) <- bannerCandidates ] claimed = claimedFromRecord <> claimedFromBanner - likelyStale = - [ StaleModule fileKind path - | (fileKind, path) <- recordedFiles, - path `Set.notMember` plannedAll, - onDisk path - ] staleOrGenerated = Set.fromList (map stalePath likelyStale) <> Set.fromList plannedGenerated @@ -213,7 +208,7 @@ hasGeneratedBanner :: FilePath -> IO Bool hasGeneratedBanner path = do contents <- TIO.readFile path - pure (any (T.isPrefixOf "-- @generated") (T.lines contents)) + pure (any isGeneratedBannerLine (T.lines contents)) -- | Render the report a human reviews. It is printed in the scaffold output and -- written to @keiro-dsl-migration-report.workspace.\.txt@. @@ -249,9 +244,12 @@ <> " file(s) the legacy scaffold recorded that this workspace does not produce:" ] <> map staleLine stale - staleLine stale = case staleKind stale of - Generated -> " generated " <> T.pack (stalePath stale) <> " (safe to delete; still on disk)" - HoleStub -> " hole " <> T.pack (stalePath stale) <> " (hand-owned — review before deleting)" + 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)" unclaimedSection = case mrUnclaimed report of [] -> [] unclaimed -> diff --git a/src/Keiro/Dsl/WorkspaceDiff.hs b/src/Keiro/Dsl/WorkspaceDiff.hs --- a/src/Keiro/Dsl/WorkspaceDiff.hs +++ b/src/Keiro/Dsl/WorkspaceDiff.hs @@ -23,18 +23,22 @@ import Data.Text qualified as T import Keiro.Dsl.Diff (Change (..), ChangeKind (..), advisoryAt, consumerBuildContext, diffServices, sourceLanguageChange) import Keiro.Dsl.DiffReport (OwnedSite (..), WorkspaceChange (..), WorkspaceDiffReport, WorkspaceMeta (..), renderFinding, workspaceDiffReport) +import Keiro.Dsl.FoldFingerprint (FoldSurfaceError) import Keiro.Dsl.Grammar (Loc (..), Name, Placement (..)) import Keiro.Dsl.LanguageVersion (SourceLanguage (..)) import Keiro.Dsl.Validate (DiagnosticCode (..)) import Keiro.Dsl.Workspace (OwnershipIndex (..), WorkspaceMember (..), WorkspaceSpec (..), checkedWorkspace) -- | Diff two composed service graphs and cite every participant we can resolve. -diffWorkspaces :: WorkspaceSpec -> WorkspaceSpec -> [WorkspaceChange] -diffWorkspaces old new = - memberLanguageChanges old new - <> map annotate (diffServices (checkedWorkspace old) (checkedWorkspace new)) - <> ownershipMoveChanges old new - <> authorityChanges old new +diffWorkspaces :: WorkspaceSpec -> WorkspaceSpec -> Either FoldSurfaceError [WorkspaceChange] +diffWorkspaces old new = do + semanticChanges <- diffServices (checkedWorkspace old) (checkedWorkspace new) + pure + ( memberLanguageChanges old new + <> map annotate semanticChanges + <> ownershipMoveChanges old new + <> authorityChanges old new + ) where annotate change = WorkspaceChange diff --git a/src/Keiro/Dsl/WorkspaceScaffold.hs b/src/Keiro/Dsl/WorkspaceScaffold.hs --- a/src/Keiro/Dsl/WorkspaceScaffold.hs +++ b/src/Keiro/Dsl/WorkspaceScaffold.hs @@ -55,18 +55,20 @@ import Data.Text.IO qualified as TIO import Keiro.Dsl.BehaviorCoverage (BehaviorKey (..), BehaviorRecordRow (..), attributeBehaviorOwner, behaviorRecordRows, deriveBehaviorRequirements) import Keiro.Dsl.ExplainBindings (BindingHole (..), bindingHolesForService) +import Keiro.Dsl.FoldFingerprint (aggregateFoldSurfaceForService) import Keiro.Dsl.Goldens (GoldenPayload) import Keiro.Dsl.Grammar import Keiro.Dsl.Harness (harnessForServiceWithGoldens, harnessProcess, harnessReadModel, harnessRouter, harnessWorkflow) import Keiro.Dsl.IdDomain (idDomainIdentitiesForService) import Keiro.Dsl.LanguageVersion (SourceLanguage, effectiveLanguageVersion, languageVersionText, sourceFormText) -import Keiro.Dsl.Manifest (moduleNameOf, renderManifest) +import Keiro.Dsl.Manifest (moduleNameOf, renderManifestForService) import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), consumerPlan) import Keiro.Dsl.NominalType (nominalEqualityIdentitiesForService) import Keiro.Dsl.Scaffold import Keiro.Dsl.ScaffoldRun ( MappingDrift (..), Refusal (..), + StaleGeneratedEvidence (..), StaleModule (..), WriteDisposition (..), behaviorDrift, @@ -137,17 +139,19 @@ WorkspaceSpec -> Either [Refusal] WorkspacePlan planWorkspaceScaffoldWithGoldens goldens goldenRoot ctx workspace = - case pureRefusals ctx merged (map fst tagged) of - [] -> - Right - WorkspacePlan - { wpWorkspace = workspace, - wpCheckedService = service, - wpContext = ctx, - wpGoldenRoot = goldenRoot, - wpModules = tagged - } - refusals -> Left refusals + case traverse (aggregateFoldSurfaceForService service) [aggregate | NAggregate aggregate <- specNodes merged] of + Left surfaceError -> Left [FoldSurfaceRefusal surfaceError] + Right _ -> case pureRefusals ctx merged (map fst tagged) of + [] -> + Right + WorkspacePlan + { wpWorkspace = workspace, + wpCheckedService = service, + wpContext = ctx, + wpGoldenRoot = goldenRoot, + wpModules = tagged + } + refusals -> Left refusals where service = checkedWorkspace workspace merged = checkedSpec service @@ -163,22 +167,26 @@ -- member file. workspaceModules :: [GoldenPayload] -> Context -> WorkspaceSpec -> [(ScaffoldModule, ModuleProvenance)] workspaceModules goldens ctx workspace = - [attributed (declarationProvenance names) m | (m, names) <- scaffoldStructuralOwnersForService ctx service] - <> [attributed ContextLevel m | m <- scaffoldReplayAudit ctx merged] + [attributedStamped (declarationProvenance names) m | (m, names) <- scaffoldStructuralOwnersForService ctx service] + <> [attributedStamped ContextLevel m | m <- scaffoldReplayAudit ctx merged] <> concat - [ map (attributed (nodeProvenance node)) (emittersFor node) + [ map (attributedStamped (nodeProvenance node)) (emittersFor node) | node <- specNodes merged ] where service = checkedWorkspace workspace merged = checkedSpec service ownership = wsOwnership workspace + stamp = stampGeneratedModule (checkedLanguageContract service) + attributedStamped provenance moduleValue = + let (annotated, attribution) = attributed provenance moduleValue + in (stamp annotated, attribution) emittersFor node = case node of NAggregate aggregate -> scaffoldAggregateForService ctx service aggregate <> harnessForServiceWithGoldens goldens ctx service aggregate NProcess process -> scaffoldProcess ctx process <> harnessProcess ctx process NRouter router -> scaffoldRouter ctx router <> harnessRouter ctx router - NContract contract -> scaffoldContract ctx contract + NContract contract -> scaffoldContractForService ctx service contract NIntake intake -> scaffoldIntake ctx intake NPublisher publisher -> scaffoldPublisher ctx publisher NWorkqueue workqueue -> scaffoldWorkqueue ctx workqueue @@ -364,7 +372,7 @@ (addedBehavior, removedBehavior) = maybe (currentBehavior, []) (behaviorDrift currentBehavior . wrBehaviorRequirements) previous createDirectoryIfMissing True out dispositions <- traverse (writeWorkspaceModule out) (wpModules plan) - TIO.writeFile buildManifestPath (renderManifest (T.pack manifestName) modules merged) + TIO.writeFile buildManifestPath (renderManifestForService (T.pack manifestName) modules (wpCheckedService 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. @@ -684,9 +692,12 @@ ] <> map staleLine stale <> ["note: keiro-dsl never deletes files."] - staleLine stale = case staleKind stale of - Generated -> " generated " <> T.pack (stalePath stale) <> " (safe to delete; still on disk)" - HoleStub -> " hole " <> T.pack (stalePath stale) <> " (hand-owned — review before deleting)" + 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)" workspaceSourceLanguageLabel :: SourceLanguage -> Text workspaceSourceLanguageLabel sourceLanguage = diff --git a/test/Keiro/Dsl/ConformanceBaseline.hs b/test/Keiro/Dsl/ConformanceBaseline.hs new file mode 100644 --- /dev/null +++ b/test/Keiro/Dsl/ConformanceBaseline.hs @@ -0,0 +1,293 @@ +module Keiro.Dsl.ConformanceBaseline (conformanceBaselineSpec) where + +import Control.Monad (filterM, forM, forM_, unless) +import Data.Aeson (FromJSON (..), withObject, (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.List (nub, sort, (\\)) +import Data.Maybe (listToMaybe, mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Keiro.Dsl.FrontendCompatibility (SourceExpectation (..), observeSource, readRepoText) +import Keiro.Dsl.Grammar (Spec (..)) +import Keiro.Dsl.LanguageVersion (currentStableLanguageVersion, languageVersionNumber) +import Keiro.Dsl.Parser (parseSource) +import Keiro.Dsl.Scaffold (Context (..), ModuleKind (..), Placement (..), ScaffoldModule (..), defaultContext) +import Keiro.Dsl.ScaffoldRun (scaffoldServiceModules) +import Keiro.Dsl.SemanticContract (CheckedService (..), checkedSource) +import Keiro.Dsl.Skeleton (skeletonFor) +import Keiro.Dsl.Workspace (WorkspaceSpec (..), fileContentSource, loadWorkspace) +import Keiro.Dsl.WorkspaceScaffold (WorkspacePlan (..), planWorkspaceScaffold) +import Numeric.Natural (Natural) +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) +import System.Environment (lookupEnv) +import System.FilePath (takeDirectory, takeExtension, ()) +import Test.Hspec + +data FixtureException = FixtureException + { exceptionPath :: !FilePath, + exceptionSourceForm :: !Text, + exceptionEffectiveVersion :: !(Maybe Natural), + exceptionRole :: !Text, + exceptionReason :: !Text + } + deriving stock (Eq, Show) + +instance FromJSON FixtureException where + parseJSON = withObject "FixtureException" $ \fields -> + FixtureException + <$> fields .: "path" + <*> fields .: "sourceForm" + <*> fields .:? "effectiveVersion" + <*> fields .: "role" + <*> fields .: "reason" + +data CompiledSuite = CompiledSuite + { suiteComponent :: !Text, + suiteDirectory :: !FilePath, + suiteSource :: !(Maybe FilePath), + suiteGeneration :: !Text, + suiteRole :: !Text, + suiteReason :: !Text + } + deriving stock (Eq, Show) + +instance FromJSON CompiledSuite where + parseJSON = withObject "CompiledSuite" $ \fields -> + CompiledSuite + <$> fields .: "component" + <*> fields .: "directory" + <*> fields .:? "source" + <*> fields .: "generation" + <*> fields .: "role" + <*> fields .: "reason" + +data ConformanceBaseline = ConformanceBaseline + { baselineSchema :: !Text, + baselineStableLanguageVersion :: !Natural, + baselineFixtureExceptions :: ![FixtureException], + baselineCompiledSuites :: ![CompiledSuite] + } + deriving stock (Eq, Show) + +instance FromJSON ConformanceBaseline where + parseJSON = withObject "ConformanceBaseline" $ \fields -> + ConformanceBaseline + <$> fields .: "schema" + <*> fields .: "stableLanguageVersion" + <*> fields .: "fixtureExceptions" + <*> fields .: "compiledSuites" + +conformanceBaselineSpec :: SpecWith () +conformanceBaselineSpec = describe "conformance baseline" $ do + it "uses the registered stable language and explicit non-stable fixture rows" $ do + baseline <- readBaseline + baselineSchema baseline `shouldBe` "keiro-dsl/conformance-baseline/1" + baselineStableLanguageVersion baseline + `shouldBe` languageVersionNumber currentStableLanguageVersion + paths <- fixturePaths + observations <- forM paths $ \path -> (path,) <$> observeSource path + let stableVersion = languageVersionNumber currentStableLanguageVersion + nonStablePaths = + sort + [ path + | (path, observation) <- observations, + sourceForm observation /= "declared" + || sourceEffectiveVersion observation /= Just stableVersion + ] + 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 + `shouldBe` "compatibility-proof" + exceptionReason exception `shouldSatisfy` (not . T.null . T.strip) + + it "accounts for every compiled conformance component and stable generated banner" $ do + baseline <- readBaseline + cabal <- readRepoText "keiro-dsl/keiro-dsl.cabal" + let cabalComponents = conformanceComponents cabal + manifestComponents = sort (map suiteComponent (baselineCompiledSuites baseline)) + (cabalComponents \\ manifestComponents) + `shouldBe` ([] :: [Text]) + (manifestComponents \\ cabalComponents) + `shouldBe` ([] :: [Text]) + forM_ (baselineCompiledSuites baseline) $ \suite -> do + suiteRole suite + `shouldSatisfy` (`elem` ["stable-primary", "compatibility-proof", "version-independent"]) + suiteReason suite `shouldSatisfy` (not . T.null . T.strip) + directory <- resolveRepoDirectory ("keiro-dsl" suiteDirectory suite) + doesDirectoryExist directory `shouldReturn` True + case suiteRole suite of + "stable-primary" -> do + unless (suiteGeneration suite `elem` ["workspace", "skeletons"]) $ do + source <- requiredSuiteSource suite + observation <- observeSource source + sourceForm observation `shouldBe` "declared" + sourceResult observation `shouldBe` "accept" + sourceEffectiveVersion observation + `shouldBe` Just (languageVersionNumber currentStableLanguageVersion) + banners <- generatedBannerLines directory + unless (not (null banners)) $ + expectationFailure (T.unpack (suiteComponent suite <> " has no generated banners")) + let expected = + "language keiro-dsl " + <> T.pack (show (languageVersionNumber currentStableLanguageVersion)) + stableBanners = [(path, banner) | (path, banner) <- banners, expected `T.isInfixOf` banner] + isVersionIndependentAuxiliary banner = "@generated by keiro-dsl codec comparison" `T.isInfixOf` banner + unless (not (null stableBanners)) $ + expectationFailure (T.unpack (suiteComponent suite <> " has no stable generated banners")) + forM_ banners $ \(path, banner) -> + unless (expected `T.isInfixOf` banner || isVersionIndependentAuxiliary banner) $ + expectationFailure (T.unpack (decorate path banner <> " (expected " <> expected <> ")")) + expectedPaths <- expectedStableGeneratedPaths suite + let actualPaths = sort (nub (map fst stableBanners)) + unless (actualPaths == expectedPaths) $ + expectationFailure + ( T.unpack + ( suiteComponent suite + <> " generated module inventory differs\nexpected: " + <> T.pack (show expectedPaths) + <> "\n but got: " + <> T.pack (show actualPaths) + ) + ) + _ -> pure () + +expectedStableGeneratedPaths :: CompiledSuite -> IO [FilePath] +expectedStableGeneratedPaths suite = case suiteGeneration suite of + "source" -> do + source <- requiredSuiteSource suite + generatedPathsForSource source + "workspace" -> do + source <- requiredSuiteSource suite + resolved <- resolveRepoFile ("keiro-dsl" source) + loaded <- loadWorkspace (fileContentSource (takeDirectory resolved)) resolved + workspace <- case loaded of + Left problem -> expectationFailure (show problem) >> fail "invalid stable workspace" + Right value -> pure value + 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))) + "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} + pure (generatedPaths (scaffoldServiceModules scaffoldContext service)) + 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 <- parseCheckedSource path source + pure (generatedPaths (scaffoldServiceModules (defaultContext (specContext (checkedSpec service))) service)) + +parseCheckedSource :: FilePath -> Text -> IO CheckedService +parseCheckedSource path source = case parseSource path source of + Left problem -> expectationFailure (show problem) >> fail "invalid stable source" + Right parsed -> pure (checkedSource parsed) + +generatedPaths :: [ScaffoldModule] -> [FilePath] +generatedPaths = sort . map modulePath . 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" + Just source -> pure source + +workspaceContext :: WorkspaceSpec -> Context +workspaceContext workspace = + Context + { contextName = wsContext workspace, + moduleRoot = maybe "" id (wsModuleRoot workspace), + placement = maybe GeneratedPrefix id (wsLayout workspace) + } + +skeletonModuleRoots :: [(Text, Text)] +skeletonModuleRoots = + [ ("aggregate", "SkelAggregate"), + ("process", "SkelProcess"), + ("router", "SkelRouter"), + ("contract", "SkelContract"), + ("intake", "SkelIntake"), + ("emit", "SkelEmit"), + ("workqueue", "SkelQueue"), + ("workflow", "SkelWorkflow") + ] + +readBaseline :: IO ConformanceBaseline +readBaseline = do + path <- resolveRepoFile "keiro-dsl/test/conformance-baseline.json" + decoded <- Aeson.eitherDecodeFileStrict' path + case decoded of + Left problem -> expectationFailure problem >> fail "invalid conformance baseline" + Right baseline -> pure baseline + +fixturePaths :: IO [FilePath] +fixturePaths = do + root <- resolveRepoDirectory "keiro-dsl/test/fixtures" + relative <- walk root "" + pure . sort $ ["test/fixtures" path | path <- relative, takeExtension path == ".keiro"] + +conformanceComponents :: Text -> [Text] +conformanceComponents = + sort + . mapMaybe (listToMaybe . T.words) + . filter ("keiro-dsl-conformance" `T.isPrefixOf`) + . mapMaybeTestSuite + . T.lines + where + mapMaybeTestSuite = foldr collect [] + collect line rest = case T.stripPrefix "test-suite " (T.strip line) of + Just component -> component : rest + Nothing -> rest + +generatedBannerLines :: FilePath -> IO [(FilePath, Text)] +generatedBannerLines root = do + relative <- walk root "" + fmap concat . forM [path | path <- relative, takeExtension path == ".hs"] $ \path -> do + contents <- TIO.readFile (root path) + pure + [ (path, line) + | line <- T.lines contents, + "@generated" `T.isInfixOf` line + ] + +walk :: FilePath -> FilePath -> IO [FilePath] +walk root relative = do + entries <- sort <$> listDirectory (root relative) + fmap concat . forM entries $ \entry -> do + let child = if null relative then entry else relative entry + isDirectory <- doesDirectoryExist (root child) + if isDirectory then walk root child else pure [child] + +resolveRepoFile :: FilePath -> IO FilePath +resolveRepoFile path = do + override <- lookupEnv "KEIRO_DSL_TEST_ROOT" + let packageRelative = maybe path T.unpack (T.stripPrefix "keiro-dsl/" (T.pack path)) + candidates = nub ([packageRelative, path] <> maybe [] (\root -> [root packageRelative, root path]) override) + existing <- filterM doesFileExist candidates + case existing of + candidate : _ -> pure candidate + [] -> fail ("unable to locate conformance baseline file " <> show path) + +resolveRepoDirectory :: FilePath -> IO FilePath +resolveRepoDirectory path = do + override <- lookupEnv "KEIRO_DSL_TEST_ROOT" + let packageRelative = maybe path T.unpack (T.stripPrefix "keiro-dsl/" (T.pack path)) + candidates = nub ([packageRelative, path] <> maybe [] (\root -> [root packageRelative, root path]) override) + existing <- filterM doesDirectoryExist candidates + case existing of + candidate : _ -> pure candidate + [] -> fail ("unable to locate conformance directory " <> show path) + +decorate :: FilePath -> Text -> Text +decorate path banner = T.pack path <> ": " <> banner diff --git a/test/Keiro/Dsl/FrontendCompatibility.hs b/test/Keiro/Dsl/FrontendCompatibility.hs --- a/test/Keiro/Dsl/FrontendCompatibility.hs +++ b/test/Keiro/Dsl/FrontendCompatibility.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ImportQualifiedPost #-} - -- | The executable compatibility oracle for the released keiro-dsl-0.7.0.0 -- language frontend. The checked JSON is deliberately data, not an update mode: -- a behavior change must produce a reviewed manifest diff. @@ -271,16 +269,16 @@ readCompatibilityManifest = readManifest sourceFixturePaths :: IO [FilePath] -sourceFixturePaths = fixturePaths ".keiro" +sourceFixturePaths = fixturePaths "keiro-dsl/test/frontend-0.7/sources" ".keiro" workspaceFixturePaths :: IO [FilePath] -workspaceFixturePaths = fixturePaths ".keiro-workspace" +workspaceFixturePaths = fixturePaths "keiro-dsl/test/frontend-0.7/workspaces" ".keiro-workspace" -fixturePaths :: String -> IO [FilePath] -fixturePaths extension = do - fixtureRoot <- resolveRepoDirectory "keiro-dsl/test/fixtures" +fixturePaths :: FilePath -> String -> IO [FilePath] +fixturePaths rootPath extension = do + fixtureRoot <- resolveRepoDirectory rootPath relative <- walk fixtureRoot "" - pure . sort $ ["keiro-dsl/test/fixtures" path | path <- relative, takeExtension path == extension] + pure . sort $ [rootPath path | path <- relative, takeExtension path == extension] where walk root relative = do entries <- sort <$> listDirectory (root relative) @@ -370,11 +368,12 @@ renderWorkspaceMemberFailure :: IO Text renderWorkspaceMemberFailure = do - let path = "keiro-dsl/test/fixtures/workspace-member-parse-failed/service.keiro-workspace" - resolved <- resolveRepoPath path - loaded <- loadWorkspace (fileContentSource (takeDirectory resolved)) path + let vectorPath = "keiro-dsl/test/frontend-0.7/workspaces/member-parse-failed/service.keiro-workspace" + releasedDiagnosticPath = "keiro-dsl/test/fixtures/workspace-member-parse-failed/service.keiro-workspace" + resolved <- resolveRepoPath vectorPath + loaded <- loadWorkspace (fileContentSource (takeDirectory resolved)) releasedDiagnosticPath pure $ case loaded of - Left failure -> T.stripEnd (T.unlines (renderWorkspaceFailure path failure)) <> "\n" + Left failure -> T.stripEnd (T.unlines (renderWorkspaceFailure releasedDiagnosticPath failure)) <> "\n" Right _ -> error "workspace-member-parse-failed unexpectedly composed" integerFeatureSource :: Text diff --git a/test/Keiro/Dsl/FrontendProfiles.hs b/test/Keiro/Dsl/FrontendProfiles.hs --- a/test/Keiro/Dsl/FrontendProfiles.hs +++ b/test/Keiro/Dsl/FrontendProfiles.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NoFieldSelectors #-} module Keiro.Dsl.FrontendProfiles (frontendProfilesSpec) where import Control.Monad (forM_) +import Data.List (tails) import Data.List.NonEmpty qualified as NE import Data.Text (Text) import Data.Text qualified as T @@ -24,26 +24,68 @@ map definitionRow (NE.toList languageRegistry) `shouldBe` [ (1, Nothing, "keiro-dsl/syntax-profile/1", "keiro-dsl/runtime-semantics/1"), (2, Just 1, "keiro-dsl/syntax-profile/2", "keiro-dsl/runtime-semantics/1"), - (3, Just 2, "keiro-dsl/syntax-profile/2", "keiro-dsl/runtime-semantics/2") + (3, Just 2, "keiro-dsl/syntax-profile/2", "keiro-dsl/runtime-semantics/2"), + (4, Just 3, "keiro-dsl/syntax-profile/2", "keiro-dsl/runtime-semantics/3") ] + map definitionCapabilities (NE.toList languageRegistry) + `shouldBe` [ [], + [], + [GeneratedIdDomainTypeIdV7, NominalEqualityV2], + [GeneratedIdDomainTypeIdV7, NominalEqualityV2, ContractIdDomainTypeIdV7, StrictSpecSurfaceValidation] + ] + map (runtimeProfileFoldSegments . definitionRuntimeSemanticsProfile) (NE.toList languageRegistry) + `shouldBe` [ [], + [], + ["semantic-contract:keiro-dsl/runtime-semantics/2"], + ["semantic-contract:keiro-dsl/runtime-semantics/2"] + ] + map definitionSupport (NE.toList languageRegistry) + `shouldBe` [CompatibilityOnly, CompatibilityOnly, CompatibilityOnly, Stable] + currentStableLanguageVersion `shouldBe` version 4 + languageSupportForVersion (version 1) `shouldBe` Just CompatibilityOnly + languageSupportForVersion (version 2) `shouldBe` Just CompatibilityOnly + languageSupportForVersion (version 3) `shouldBe` Just CompatibilityOnly + languageSupportForVersion (version 4) `shouldBe` Just Stable + languageSupportForVersion (version 5) `shouldBe` Nothing + [definitionVersion definition | definition <- NE.toList languageRegistry, definitionSupport definition == Stable] + `shouldBe` [currentStableLanguageVersion] + definitionVersion (NE.last languageRegistry) `shouldBe` currentStableLanguageVersion + definitionPredecessor (NE.last languageRegistry) `shouldBe` Just (version 3) + forM_ (adjacent (NE.toList languageRegistry)) $ \(predecessor, successor) -> + forM_ allRuntimeCapabilities $ \capability -> + runtimeProfileHasCapability (definitionRuntimeSemanticsProfile predecessor) capability + `shouldSatisfy` \wasSupported -> + not wasSupported + || runtimeProfileHasCapability (definitionRuntimeSemanticsProfile successor) capability forM_ allFeatures $ \feature -> do languageFeatureMinimumVersion feature `shouldBe` version 2 languageSupportsFeature (version 1) feature `shouldBe` False languageSupportsFeature (version 2) feature `shouldBe` True languageSupportsFeature (version 3) feature `shouldBe` True + languageSupportsFeature (version 4) feature `shouldBe` True it "does not infer a hypothetical successor profile or runtime contract" $ do - lookupLanguageDefinition (version 4) `shouldBe` Nothing - effectiveLanguageContractForVersion (version 4) `shouldBe` Nothing - forM_ allFeatures $ \feature -> languageSupportsFeature (version 4) feature `shouldBe` False + lookupLanguageDefinition (version 5) `shouldBe` Nothing + effectiveLanguageContractForVersion (version 5) `shouldBe` Nothing + forM_ allFeatures $ \feature -> languageSupportsFeature (version 5) feature `shouldBe` False languageVersionPolicy <- readRepoText "keiro-dsl/src/Keiro/Dsl/LanguageVersion.hs" semanticPolicy <- readRepoText "keiro-dsl/src/Keiro/Dsl/SemanticContract.hs" languageVersionPolicy `shouldNotSatisfy` T.isInfixOf "version >=" semanticPolicy `shouldNotSatisfy` T.isInfixOf "version >=" + it "keeps runtime identifier strings out of semantic gates" $ do + forM_ + [ "keiro-dsl/src/Keiro/Dsl/IdDomain.hs", + "keiro-dsl/src/Keiro/Dsl/NominalType.hs", + "keiro-dsl/src/Keiro/Dsl/Validate.hs" + ] + $ \path -> do + policy <- readRepoText path + policy `shouldNotSatisfy` T.isInfixOf "keiro-dsl/runtime-semantics/" + it "checks every real feature marker against the exact selected profile" $ do forM_ featureCases $ \FeatureCase {feature, marker, body} -> - forM_ [1, 2, 3] $ \versionNumber -> do + forM_ [1, 2, 3, 4] $ \versionNumber -> do let sourceName = "profile-" <> show versionNumber <> ".keiro" source = preamble versionNumber <> body case (versionNumber, parseSurfaceSource sourceName source) of @@ -51,7 +93,7 @@ phase `shouldBe` BodyParsingPhase code `shouldBe` SourceLanguageError LanguageFeatureRequiresVersion spanText source span `shouldBe` marker - supportedVersions `shouldBe` [version 2, version 3] + supportedVersions `shouldBe` [version 2, version 3, version 4] languageSupportsFeature (version versionNumber) feature `shouldBe` False (1, result) -> expectationFailure ("expected v1 feature refusal, got " <> show result) (_, Right _) -> languageSupportsFeature (version versionNumber) feature `shouldBe` True @@ -59,14 +101,14 @@ it "keeps feature spellings inert in comments, strings, wire keys, and identifiers" $ do inertBody <- readRepoText "keiro-dsl/test/fixtures/language-identifier-v1.keiro" - forM_ [1, 2, 3] $ \versionNumber -> + forM_ [1, 2, 3, 4] $ \versionNumber -> parseSurfaceSource ("inert-" <> show versionNumber <> ".keiro") (preamble versionNumber <> inertBody) `shouldSatisfy` isRight describe "frontend diagnostics" $ do it "classifies malformed and unsupported preambles at source selection with exact spans" $ do assertSourceSelection InvalidLanguageVersion "language keiro-dsl nope\ncontext malformed\n" "language keiro-dsl nope" - assertSourceSelection UnsupportedLanguageVersion "language keiro-dsl 4\ncontext future\n" "language keiro-dsl 4" + assertSourceSelection UnsupportedLanguageVersion "language keiro-dsl 5\ncontext future\n" "language keiro-dsl 5" it "reports ordinary body syntax with expected items and a point span" $ do let source = "language keiro-dsl 1\ncontext body\nlayout\n" @@ -101,7 +143,7 @@ it "keeps the released compatibility renderer byte-identical" $ do forM_ [ "language keiro-dsl nope\ncontext malformed\n", - "language keiro-dsl 4\ncontext future\n", + "language keiro-dsl 5\ncontext future\n", preamble 1 <> featureBody TypedAggregateExpressionSyntax, "language keiro-dsl 1\ncontext\n" ] @@ -152,6 +194,19 @@ allFeatures :: [LanguageFeature] allFeatures = [NominalBindingSyntax, IntegerScalarSyntax, TypedAggregateExpressionSyntax, ExplicitTransitionImplementationSyntax] + +allRuntimeCapabilities :: [RuntimeCapability] +allRuntimeCapabilities = [minBound .. maxBound] + +definitionCapabilities :: LanguageDefinition -> [RuntimeCapability] +definitionCapabilities definition = + [ capability + | capability <- allRuntimeCapabilities, + runtimeProfileHasCapability (definitionRuntimeSemanticsProfile definition) capability + ] + +adjacent :: [a] -> [(a, a)] +adjacent values = [(left, right) | left : right : _ <- tails values] preamble :: Int -> Text preamble versionNumber = "language keiro-dsl " <> T.pack (show versionNumber) <> "\n" diff --git a/test/Keiro/Dsl/FrontendSurface.hs b/test/Keiro/Dsl/FrontendSurface.hs --- a/test/Keiro/Dsl/FrontendSurface.hs +++ b/test/Keiro/Dsl/FrontendSurface.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NoFieldSelectors #-} module Keiro.Dsl.FrontendSurface (frontendSurfaceSpec) where @@ -84,7 +83,7 @@ let fields = [(name, spanText aggregateSource fieldSpan) | Located {span = fieldSpan, value = SurfaceField name} <- elements] expressions = [spanText aggregateSource expressionSpan | Located {span = expressionSpan, value = SurfaceExpression _} <- elements] fields `shouldContain` [("observedAt", "observedAt:Time")] - expressions `shouldContain` ["observedAt >= observedAt && revision >= revision"] + expressions `shouldContain` ["cmd.observedAt >= reg.observedAt && cmd.revision >= reg.revision"] other -> expectationFailure ("unexpected aggregate surface shape: " <> show other) emptySurface <- parseSurfaceRight "empty.keiro" "context empty # trailing\n" case emptySurface of diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,5805 +1,7014 @@ -{-# LANGUAGE ImportQualifiedPost #-} - --- | Test driver for keiro-dsl. EP-1 milestone 1 tests: the @parse . pretty@ --- round-trip property over generated specs, and a unit test pinning the shape --- of the canonical Reservation fixture. -module Main (main) where - -import Control.Exception (bracket) -import Control.Monad (filterM, forM, forM_, unless) -import Data.Aeson (Value, object, (.=)) -import Data.Aeson qualified as Aeson -import Data.Aeson.KeyMap qualified as KeyMap -import Data.Either (isLeft, isRight) -import Data.Foldable (toList) -import Data.List (partition, 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 Keiki.ProjectionDomain (matchesTextPattern) -import Keiro.Codec (Codec (..), EventType (..), decodeRaw) -import Keiro.Codec.IdDomain (idDomainSampleText, idDomainTextPattern, typeIdV7Domain, validateIdDomainText) -import Keiro.Dsl.AggregateType -import Keiro.Dsl.BehaviorCoverage qualified as Behavior -import Keiro.Dsl.CodecCompare -import Keiro.Dsl.Coverage qualified as Coverage -import Keiro.Dsl.Diff (Change (..), ChangeKind (..), CompatibilitySurface (..), CompatibilityVector (..), FamilyDiff (..), Label (..), NodeFamily, RolloutConstraint (..), SurfaceVerdict (..), defaultGate, deriveLabel, diffServices, diffSources, diffSpecs, familyRegistry, gateWith, gatedBreaking, isAdvisory, isBreaking, verdictFor) -import Keiro.Dsl.DiffReport (Remedy (..), diffReport, parseSurfaceName, remediationFor, renderExplainBlock, renderFinding) -import Keiro.Dsl.EventOutput -import Keiro.Dsl.ExplainBindings (BindingHole (..), BindingObligation (..), BindingObligationKind (..), bindingHoles, bindingObligations, bindingObligationsForService, renderBindingObligations) -import Keiro.Dsl.Expression -import Keiro.Dsl.FoldFingerprint (aggregateFoldFingerprint, aggregateFoldFingerprintForService, aggregateFoldSurface, aggregateFoldSurfaceForService) -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, harnessForWithGoldens, harnessReadModel, harnessRouter, harnessWorkflow) -import Keiro.Dsl.IdDomain (IdDomainContract (..), idDomainContractFor, idDomainIdentitiesForService) -import Keiro.Dsl.LanguageVersion -import Keiro.Dsl.Manifest (manifestDependencies, moduleNameOf, renderManifest) -import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), MappingIdentity (..), consumerPlan) -import Keiro.Dsl.NominalType hiding (NominalInvalidHaskellSource, NominalInvalidIdPrefix, NominalInvalidIdentity, NominalMissingIngredient) -import Keiro.Dsl.Parser (parseSource, parseSpec) -import Keiro.Dsl.PrettyPrint (renderSource, renderSpec, renderTransition) -import Keiro.Dsl.ReadModelShape (canonicalShape, deriveShapeHash, registryNameFor, subscriptionNameFor) -import Keiro.Dsl.ReplayImpact (AggregateImpact (..), ReplayImpact (..)) -import Keiro.Dsl.ReplayImpact qualified as ReplayImpact -import Keiro.Dsl.Scaffold (Context (..), ModuleKind (..), NominalGenerationOwner (..), NominalUseSite (..), ScaffoldModule (..), codecComparisonBanner, codecComparisonModule, defaultContext, firewallBreaches, genPrefixFor, generatedNominalModule, holePrefixFor, obsoleteGeneratedOutputHooks, planNominalGeneration, scaffoldAggregate, scaffoldIntake, scaffoldProcess, scaffoldPublisher, scaffoldReadModel, scaffoldRefusals, scaffoldReplayAudit, scaffoldRouter, scaffoldWorkqueue, windowSeconds) -import Keiro.Dsl.ScaffoldRecord (ScaffoldRecord (..), parseRecord, recordFileName, renderRecord) -import Keiro.Dsl.ScaffoldRun (MappingDrift (..), Refusal (..), ScaffoldReport (..), SourceLanguageDrift (..), StaleModule (..), WriteDisposition (..), executeScaffold, executeScaffoldWithLanguage, executeServiceScaffold, planScaffold, planServiceScaffold, renderRefusals, renderScaffoldReport, scaffoldModules, scaffoldServiceModules) -import Keiro.Dsl.SemanticContract -import Keiro.Dsl.Skeleton (skeletonFor, skeletonKinds) -import Keiro.Dsl.TypeGraph -import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), Severity (..), derivedQueueTrio, renderDiagnostic, validateService, validateSpec) -import Keiro.Dsl.Workspace -import Keiro.Dsl.WorkspaceAdoption -import Keiro.Dsl.WorkspaceDiff -import Keiro.Dsl.WorkspaceRecord -import Keiro.Dsl.WorkspaceScaffold -import System.Directory (createDirectory, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getTemporaryDirectory, listDirectory, removeFile, removePathForcibly) -import System.Environment (lookupEnv) -import System.Exit (ExitCode (..)) -import System.FilePath (takeDirectory, takeExtension, ()) -import System.IO (hClose, openTempFile) -import System.Process (readProcessWithExitCode) -import Test.Hspec hiding (Spec) -import Test.QuickCheck - -main :: IO () -main = hspec $ do - frontendCompatibilitySpec - frontendSurfaceSpec - frontendProfilesSpec - - 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` [] - ReplayImpact.replayImpactServices v1Service v2Service `shouldBe` ReplayNeutral - - it "retains one effective contract for same-version workspaces and refuses mixed versions" $ do - let manifest = "service semantic-workspace\nspec domain/a.keiro\nspec domain/b.keiro\n" - v1Body = "language keiro-dsl 1\ncontext semantic-workspace\n" - v2Body = "language keiro-dsl 2\ncontext semantic-workspace\n" - sourceWith b = - memoryContentSource - ( Map.fromList - [ ("service.keiro-workspace", manifest), - ("domain/a.keiro", b), - ("domain/b.keiro", b) - ] - ) - mixedSource = - memoryContentSource - ( Map.fromList - [ ("service.keiro-workspace", manifest), - ("domain/a.keiro", v1Body), - ("domain/b.keiro", v2Body) - ] - ) - sameVersion <- loadWorkspace (sourceWith v2Body) "service.keiro-workspace" - case sameVersion of - Right workspace -> do - Just (effectiveContractLanguageVersion (checkedLanguageContract (checkedWorkspace workspace))) `shouldBe` languageVersion 2 - validateService (checkedWorkspace workspace) `shouldBe` [] - Left failure -> expectationFailure (show failure) - mixed <- loadWorkspace mixedSource "service.keiro-workspace" - case mixed of - Left (WorkspaceRefused diagnostics) -> - map wdCode (NE.toList diagnostics) `shouldContain` [WorkspaceLanguageVersionMismatch] - other -> expectationFailure ("expected a mixed-version refusal, got " <> show other) - - it "refuses a source/service contract mismatch before creating the output directory" $ do - v1Version <- maybe (expectationFailure "version 1 missing" >> fail "unreachable") pure (languageVersion 1) - parsed <- parseRight "semantic-v2.keiro" "language keiro-dsl 2\ncontext semantic-refusal\n" - let service = checkedSource parsed - ctx = defaultContext "semantic-refusal" - modules <- case planServiceScaffold ctx service of - Left refusals -> expectationFailure (show refusals) >> fail "unreachable" - Right planned -> pure planned - withTempDirectory "keiro-dsl-semantic-refusal" $ \root -> do - let out = root "not-created" - result <- executeServiceScaffold out False "semantic-v2.keiro" (DeclaredLanguage v1Version noLoc) ctx service modules - result `shouldBe` Left [SemanticContractMismatch "source provenance and checked service selected different effective language contracts"] - doesDirectoryExist out `shouldReturn` False - - it "retains explicit declarations in source rendering and leaves legacy unversioned" $ do - legacySource <- parseRight "legacy.keiro" legacy - declaredSource <- parseRight "declared.keiro" declared - renderSource legacySource `shouldBe` "context hospital-capacity\n" - renderSource declaredSource `shouldBe` "language keiro-dsl 1\ncontext hospital-capacity\n" - parseSpec "declared.keiro" declared `shouldBe` Right (parsedSpec declaredSource) - - it "classifies invalid, unsupported, duplicate, and misplaced preambles" $ do - failureCode "language keiro-dsl 0\ncontext hospital-capacity\n" `shouldBe` Just InvalidLanguageVersion - failureCode "language keiro-dsl nope\ncontext hospital-capacity\n" `shouldBe` Just InvalidLanguageVersion - failureCode "language keiro-dsl -1\ncontext hospital-capacity\n" `shouldBe` Just InvalidLanguageVersion - failureCode "language keiro-dsl 4\ncontext hospital-capacity\n" `shouldBe` Just UnsupportedLanguageVersion - failureCode "language keiro-dsl 1\nlanguage keiro-dsl 1\ncontext hospital-capacity\n" `shouldBe` Just DuplicateLanguagePreamble - failureCode "context hospital-capacity\nlanguage keiro-dsl 1\n" `shouldBe` Just MisplacedLanguagePreamble - - it "treats language and successor spellings as data in nested grammar positions" $ do - forM_ ["language-identifier-v1.keiro", "language-identifier-v2.keiro"] $ \fixture -> do - source <- readTestText ("test/fixtures/" <> fixture) - parsed <- parseRight fixture source - validateSpec (parsedSpec parsed) `shouldBe` [] - v1 <- readTestText "test/fixtures/language-identifier-v1.keiro" - let manifest = "service language-collisions\nspec domain/collisions.keiro\n" - workspaceSource = memoryContentSource (Map.fromList [("service.keiro-workspace", manifest), ("domain/collisions.keiro", v1)]) - loaded <- loadWorkspace workspaceSource "service.keiro-workspace" - loaded `shouldSatisfy` isRight - - it "keeps duplicate and misplaced preamble diagnostics on their grammar lines" $ do - let sourceFailureAt expectedCode expectedLine source = - case parseSource "located.keiro" source of - Left (SourceLanguageFailure diagnostic) -> do - sourceLanguageErrorCode diagnostic `shouldBe` expectedCode - unLoc (sourceLanguageLoc diagnostic) `shouldBe` expectedLine - other -> expectationFailure ("expected located source-language failure, got " <> show other) - sourceFailureAt DuplicateLanguagePreamble 2 "language keiro-dsl 1\nlanguage keiro-dsl 1\ncontext located\n" - sourceFailureAt MisplacedLanguagePreamble 3 "context located\nid language prefix=lang\nlanguage keiro-dsl 1\n" - - it "rejects a future version before parsing an invalid v1 body" $ - case parseSource "future.keiro" "language keiro-dsl 4\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" - 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 "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/reservation.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] - diffSpecs 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 generatedSurface spec = - [ (modulePath scaffoldModule, moduleText scaffoldModule, kind scaffoldModule) - | scaffoldModule <- scaffoldModules (defaultContext (specContext spec)) spec - ] - generatedSurface oldSpec `shouldBe` generatedSurface newSpec - [aggregateFoldFingerprint oldSpec aggregate | NAggregate aggregate <- specNodes oldSpec] - `shouldBe` [aggregateFoldFingerprint newSpec aggregate | NAggregate aggregate <- specNodes newSpec] - ReplayImpact.replayImpact oldSpec newSpec `shouldBe` ReplayNeutral - - it "exposes stable JSON inspection for a source and canonically ordered workspace members" $ do - (sourceCode, sourceOut, sourceErr) <- runKeiroDsl ["inspect", "test/fixtures/reservation.keiro", "--format=json"] - sourceCode `shouldBe` ExitSuccess - sourceErr `shouldBe` "" - sourceOut `shouldContain` "\"schema\":\"keiro-dsl/source-inspection/1\"" - sourceOut `shouldContain` "\"kind\":\"source\"" - sourceOut `shouldContain` "\"sourceForm\":\"declared\"" - sourceOut `shouldContain` "\"declaredLanguageVersion\":1" - sourceOut `shouldContain` "\"effectiveLanguageVersion\":1" - sourceOut `shouldContain` "\"effectiveSemanticContract\":{" - sourceOut `shouldContain` "\"runtimeSemantics\":\"keiro-dsl/runtime-semantics/1\"" - (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 `shouldSatisfy` orderedSubstrings ["domain/project-artifact.keiro", "domain/project.keiro", "domain/shared.keiro"] - - it "keeps only the named source-version compatibility fixtures outside canonical v1" $ do - fixtureTree <- treeSnapshot "test/fixtures" - let withoutCanonicalV1 = - sort - [ path - | (path, contents) <- fixtureTree, - takeExtension path == ".keiro", - "language keiro-dsl 1" `notElem` T.lines contents - ] - withoutCanonicalV1 - `shouldBe` sort - [ "language-duplicate.keiro", - "aggregate-collection-expressions-v2-rejects.keiro", - "aggregate-scalar-expressions-v2.keiro", - "behavior-complete-workspace/declarations.keiro", - "behavior-complete-workspace/journey.keiro", - "behavior-complete.keiro", - "id-domain-migration-v3.keiro", - "language-future.keiro", - "language-identifier-v1.keiro", - "language-identifier-v2.keiro", - "language-legacy.keiro", - "language-malformed.keiro", - "language-misplaced.keiro", - "language-zero.keiro", - "nominal-bad-qualified.keiro", - "nominal-invalid-prefix.keiro", - "nominal-missing-facts.keiro", - "nominal-missing-initial.keiro", - "nominal-name-collision.keiro", - "nominal-scalars.keiro", - "nominal-unsupported-representation.keiro", - "workspace-nominals/domain/project-artifact.keiro", - "workspace-nominals/domain/project.keiro", - "workspace-nominals/domain/shared.keiro" - ] - - it "checks v1, rejects a future contract once, and inspects legacy explicitly" $ do - (v1Code, v1Out, v1Err) <- runKeiroDsl ["check", "test/fixtures/language-v1.keiro"] - v1Code `shouldBe` ExitSuccess - v1Out `shouldBe` "OK\n" - v1Err `shouldBe` "" - (futureCode, _, futureErr) <- runKeiroDsl ["check", "test/fixtures/language-future.keiro"] - futureCode `shouldBe` ExitFailure 1 - T.count "UnsupportedLanguageVersion" (T.pack futureErr) `shouldBe` 1 - futureErr `shouldContain` "supported versions: 1, 2, 3" - futureErr `shouldNotContain` "expecting `context`" - (legacyCode, legacyOut, legacyErr) <- runKeiroDsl ["inspect", "test/fixtures/language-legacy.keiro", "--format=json"] - legacyCode `shouldBe` ExitSuccess - legacyErr `shouldBe` "" - legacyOut `shouldContain` "\"sourceForm\":\"legacy-unversioned\"" - legacyOut `shouldContain` "\"declaredLanguageVersion\":null" - legacyOut `shouldContain` "\"effectiveLanguageVersion\":1" - - 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 `shouldBe` "" - withTempDirectory ("keiro-dsl-" <> fixture) $ \out -> do - (scaffoldCode, _, scaffoldErr) <- runKeiroDsl ["scaffold", sourcePath, "--out", out] - scaffoldCode `shouldBe` ExitSuccess - scaffoldErr `shouldContain` "firewall: OK" - - 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 4\nthis body must not parse\n" - source = memoryContentSource (Map.fromList [("service.keiro-workspace", manifest), ("domain/future.keiro", futureSource)]) - loaded <- loadWorkspace source "service.keiro-workspace" - case loaded of - Left (WorkspaceRefused (diagnostic :| [])) -> do - wdCode diagnostic `shouldBe` WorkspaceMemberParseFailed - sourceLanguageErrorCode <$> wdSourceLanguageCause diagnostic - `shouldBe` Just UnsupportedLanguageVersion - renderWorkspaceDiagnostic "service.keiro-workspace" diagnostic - `shouldSatisfy` T.isInfixOf "UnsupportedLanguageVersion" - other -> expectationFailure ("expected one attributed source-language refusal, got " <> show other) - - it "attributes a workspace provenance-only diff to the changed member" $ do - workspace <- shouldComposeWorkspace canonicalWorkspacePath - case wsMembers workspace of - firstMember : remaining -> do - let changedMember = firstMember {wmSourceLanguage = LegacyUnversioned} - changedWorkspace = workspace {wsMembers = changedMember : remaining} - changes = diffWorkspaces workspace changedWorkspace - map (changeCode . wcChange) changes `shouldBe` [SourceLanguageDeclarationChanged] - map (fmap osFile . wcDeclarationSite) changes `shouldBe` [Just (wmPath firstMember)] - map wcChange changes `shouldSatisfy` all (not . gatedBreaking (gateWith [minBound .. maxBound])) - _ -> expectationFailure "canonical workspace had no member" - - describe "ID domain" $ do - 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 "keeps runtime validation and the exact Keiki text image in agreement" $ do - let contract = typeIdV7Domain "req" - sample = idDomainSampleText contract - suffix = T.drop (T.length "req_") sample - replaceAt position replacement value = - T.take position value <> T.singleton replacement <> T.drop (position + 1) value - accepted = - [ sample, - replaceAt (T.length "req_" + 10) 'f' sample, - replaceAt (T.length "req_" + 13) 'v' sample - ] - rejected = - [ "", - "req_", - "other_" <> suffix, - "req__" <> suffix, - T.dropEnd 1 sample, - sample <> "0", - T.toUpper sample, - replaceAt (T.length "req_" + 0) '8' sample, - replaceAt (T.length "req_" + 10) 'd' sample, - replaceAt (T.length "req_" + 13) 'c' sample - ] - 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 sample - 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 - variant <- elements "89abrstv" - afterVariant <- segment 12 - let value = T.pack ("req_" <> [leading] <> beforeVersion <> [version] <> beforeVariant <> [variant] <> 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") - ReplayImpact.replayImpactServices oldService newService `shouldSatisfy` \case - ReplayImpact.ReplayAffected impacts -> - maybe False includeSnapshotStreams (Map.lookup "OrderBook" impacts) - ReplayImpact.ReplayNeutral -> False - - it "keeps the raw constructor outside the compiled public module surface" $ - withTempDirectory "keiro-dsl-id-domain-hidden-constructor" $ \out -> do - sourceText <- readTestText "test/fixtures/id-domain-migration-v3.keiro" - parsed <- case parseSource "id-domain-migration-v3.keiro" sourceText of - Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable" - Right value -> pure value - let service = checkedSource parsed - spec = checkedSpec service - ctx = defaultContext (specContext spec) - modules = scaffoldServiceModules ctx service - attempt = out "Attempt.hs" - ghcOutput = out ".ghc" - result <- executeServiceScaffold out False "id-domain-migration-v3.keiro" (parsedSourceLanguage parsed) ctx service modules - result `shouldSatisfy` isRight - recordContents <- TIO.readFile (out recordFileName (specContext spec)) - record <- case parseRecord recordContents of - Nothing -> expectationFailure "generated ID-domain scaffold record did not parse" >> fail "unreachable" - Just value -> pure value - recIdDomains record `shouldBe` idDomainIdentitiesForService service - recNominalEqualities record - `shouldSatisfy` any (T.isInfixOf "keiro-dsl/id-domain/typeid-v7/1") - createDirectoryIfMissing True ghcOutput - TIO.writeFile - attempt - ( T.unlines - [ "module Attempt where", - "import Generated.IdDomainMigration.Nominals (OrderId (..))", - "bad :: OrderId", - "bad = OrderId \"ord_LEGACY-NOT-TYPEID\"" - ] - ) - (exitCode, standardOutput, standardError) <- - readProcessWithExitCode - "cabal" - [ "exec", - "--", - "ghc", - "-XGHC2024", - "-XOverloadedStrings", - "-fno-code", - "-fforce-recomp", - "-outputdir", - ghcOutput, - "-i" <> out, - attempt - ] - "" - exitCode `shouldSatisfy` (/= ExitSuccess) - (standardOutput <> standardError) `shouldContain` "OrderId" - - it "emits one enforced nominal owner for a version-3 workspace" $ do - manifest <- readTestText "test/fixtures/workspace-nominals/service.keiro-workspace" - shared <- readTestText "test/fixtures/workspace-nominals/domain/shared.keiro" - project <- readTestText "test/fixtures/workspace-nominals/domain/project.keiro" - artifact <- readTestText "test/fixtures/workspace-nominals/domain/project-artifact.keiro" - let v3 = T.replace "language keiro-dsl 2" "language keiro-dsl 3" - source = - memoryContentSource - ( Map.fromList - [ ("service.keiro-workspace", manifest), - ("domain/shared.keiro", v3 shared), - ("domain/project.keiro", v3 project), - ("domain/project-artifact.keiro", v3 artifact) - ] - ) - loaded <- loadWorkspace source "service.keiro-workspace" - workspace <- case loaded of - Left failure -> expectationFailure (show failure) >> fail "unreachable" - Right value -> pure value - plan <- case planWorkspaceScaffold "goldens" (workspaceContext workspace) workspace of - Left refusals -> expectationFailure (show refusals) >> fail "unreachable" - Right value -> pure value - let paths = map (modulePath . fst) (wpModules plan) - length (filter (== "Generated/WorkspaceNominalProof/Nominals.hs") paths) `shouldBe` 1 - length (filter (== "Generated/WorkspaceNominalProof/Nominals/Internal.hs") paths) `shouldBe` 1 - forM_ [moduleText value | (value, _) <- wpModules plan, "/Domain.hs" `T.isSuffixOf` T.pack (modulePath value)] $ \domainText -> - domainText `shouldSatisfy` (not . T.isInfixOf "ProjectId (..)") - withTempDirectory "keiro-dsl-v3-workspace-record" $ \out -> do - emitted <- executeWorkspaceScaffold out False plan - emitted `shouldSatisfy` isRight - recordContents <- TIO.readFile (out workspaceRecordFileName (wsService workspace)) - record <- case parseWorkspaceRecord recordContents of - Nothing -> expectationFailure "version-3 workspace record did not parse" >> fail "unreachable" - Just value -> pure value - wrIdDomains record `shouldBe` idDomainIdentitiesForService (wpCheckedService plan) - wrNominalEqualities record - `shouldSatisfy` any (T.isInfixOf "keiro-dsl/id-domain/typeid-v7/1") - - it "emits an abstract public ID, an internal legacy seam, and exact equality" $ do - v2Source <- readTestText "test/fixtures/aggregate-scalar-expressions-v2.keiro" - let v3Source = T.replace "language keiro-dsl 2" "language keiro-dsl 3" v2Source - parsed <- case parseSource "aggregate-scalar-expressions-v3.keiro" v3Source of - Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable" - Right value -> pure value - let service = checkedSource parsed - spec = checkedSpec service - modules = scaffoldServiceModules (defaultContext (specContext spec)) service - moduleAt path = case [value | value <- modules, modulePath value == path] of - [value] -> pure value - values -> expectationFailure ("expected one module at " <> path <> ", got " <> show (map modulePath values)) >> fail "unreachable" - validateService service `shouldBe` [] - publicNominals <- moduleAt "Generated/AggregateScalarExpressions/Nominals.hs" - internalNominals <- moduleAt "Generated/AggregateScalarExpressions/Nominals/Internal.hs" - domainModule <- moduleAt "Generated/AggregateScalarExpressions/ScalarAccount/Domain.hs" - codecModule <- moduleAt "Generated/AggregateScalarExpressions/ScalarAccount/Codec.hs" - expressionsModule <- moduleAt "Generated/AggregateScalarExpressions/ScalarAccount/Expressions.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 expressionsModule `shouldSatisfy` T.isInfixOf "case parseRequestId" - firewallBreaches modules `shouldBe` [] - - describe "scalar expressions" $ do - it "parses, validates, and round-trips the authoritative v2 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 modules = scaffoldAggregate (defaultContext (specContext (parsedSpec parsed))) (parsedSpec parsed) aggregate - expressions = generatedTextEndingIn "Expressions.hs" modules - transducer = generatedTextEndingIn "Transducer.hs" modules - holes = holeTextEndingIn "Holes.hs" modules - map modulePath modules `shouldSatisfy` any (T.isSuffixOf "Expressions.hs" . T.pack) - map modulePath modules `shouldSatisfy` any (T.isSuffixOf "Transducer.hs" . T.pack) - expressions `shouldSatisfy` T.isInfixOf "K.tsub (d.requested) (B.reg @\"capacity\")" - transducer `shouldSatisfy` T.isInfixOf "B.requireGuard (Expressions.transition1OpenAdjustGuard d)" - transducer `shouldSatisfy` T.isInfixOf "B.slot @\"balance\" =: Expressions.transition1OpenAdjustWriteBalance d" - 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 "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 "" 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 "" 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 "" 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 "" 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 "" 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 "" 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 "" 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 "" 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` [] - 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 - spec <- specOf "test/fixtures/aggregate-scalar-expressions-v2.keiro" - let modules = scaffoldModules (defaultContext (specContext spec)) spec - 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 "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` 14 - length [() | requirement <- requirements, Behavior.requirementKind requirement == Behavior.LiveTransition] `shouldBe` 5 - length [() | requirement <- requirements, Behavior.requirementKind requirement == Behavior.RequiredRejection] `shouldBe` 8 - length [() | requirement <- requirements, Behavior.requirementKind requirement == Behavior.ReplayTransition] `shouldBe` 1 - [Behavior.requirementSource requirement | requirement <- requirements, Behavior.requirementKind requirement == Behavior.RequiredRejection] - `shouldContain` ["Active", "Closed"] - length [() | requirement <- requirements, Behavior.requirementGuardCoverage requirement == Behavior.GuardTotal] `shouldBe` 4 - length [() | requirement <- requirements, Behavior.requirementGuardCoverage requirement == Behavior.GuardUnknown] `shouldBe` 1 - let report = Behavior.BehaviorObligationsReport "behavior-complete.keiro" Nothing requirements - encoded = Behavior.encodeBehaviorObligationsJson report - encoded `shouldSatisfy` T.isInfixOf "\"schema\":\"keiro-dsl/behavior-obligations/1\"" - encoded `shouldSatisfy` T.isInfixOf "\"source\":\"Closed\"" - encoded `shouldSatisfy` T.isInfixOf "\"kind\":\"replay-transition\"" - encoded `shouldSatisfy` (not . T.isInfixOf "\"filled\"") - encoded `shouldSatisfy` (not . T.isInfixOf "\"missing\"") - - it "keeps semantic keys stable across line movement and canonical pretty printing" $ do - source <- readTestText "test/fixtures/behavior-complete.keiro" - parsed <- case parseSource "behavior-complete.keiro" source of - Left failure -> expectationFailure (T.unpack (renderParseFailure failure)) >> fail "unreachable" - Right value -> pure value - let original = parsedSpec parsed - moved <- parseInlineSpec "behavior-complete-moved.keiro" ("# line movement must not rename witnesses\n\n" <> source) - pretty <- parseInlineSpec "behavior-complete-pretty.keiro" (renderSource parsed) - let keys spec = fmap (map Behavior.requirementKey) (Behavior.deriveBehaviorRequirements spec) - keys moved `shouldBe` keys original - keys pretty `shouldBe` keys original - - it "generates direct fields(Command) output and separate create-once pending witnesses" $ do - spec <- specOf "test/fixtures/behavior-complete.keiro" - aggregate <- case [value | NAggregate value <- specNodes spec] of - [value] -> pure value - _ -> expectationFailure "expected one behavior-complete aggregate" >> fail "unreachable" - let modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate - transducer = generatedTextEndingIn "Transducer.hs" modules - codec = generatedTextEndingIn "Codec.hs" modules - contract = generatedTextEndingIn "BehaviorContract.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")] - contract `shouldSatisfy` T.isInfixOf "keiro/behavior-conformance/1" - contract `shouldSatisfy` T.isInfixOf "commandKind command == requirementCommandName requirement" - T.count "Pending (BehaviorKey " behaviorHoles `shouldBe` 14 - behaviorHoles `shouldSatisfy` (not . T.isInfixOf "undefined") - behaviorHoles `shouldSatisfy` (not . T.isInfixOf "error") - - it "rejects eventless state or register changes while accepting a true no-op" $ do - invalid <- - parseInlineSpec "" $ - 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 "" $ - T.unlines - [ "language keiro-dsl 2", - "context eventless-noop", - "aggregate Counter", - " regs", - " count Natural = 0", - " states Open", - " command Tick { count:Natural }", - " Open -- Tick --> goto Open" - ] - errorCodes valid `shouldBe` [] - - it "refuses duplicate semantic behavior identities before scaffolding" $ do - duplicate <- - parseInlineSpec "" $ - T.unlines - [ "language keiro-dsl 2", - "context duplicate-behavior", - "aggregate Counter", - " regs", - " states Open", - " command Tick { amount:Natural }", - " event Ticked = fields(Tick)", - " Open -- Tick --> emit Ticked ; goto Open", - " Open -- Tick --> emit Ticked ; goto Open" - ] - let isBehaviorRefusal (BehaviorRefusal _) = True - isBehaviorRefusal _ = False - case planScaffold (defaultContext (specContext duplicate)) duplicate of - Left refusals -> refusals `shouldSatisfy` any isBehaviorRefusal - Right _ -> expectationFailure "duplicate behavior identity reached a scaffold write set" - - it "round-trips additive single-file and workspace behavior rows with member ownership" $ do - spec <- specOf "test/fixtures/behavior-complete.keiro" - requirements <- either (\errors -> expectationFailure (show errors) >> pure []) pure (Behavior.deriveBehaviorRequirements spec) - version <- maybe (expectationFailure "language version 2 was not constructible" >> fail "unreachable") pure (languageVersion 2) - let rows = Behavior.behaviorRecordRows requirements - singleRecord = - ScaffoldRecord - { recSpecPath = "behavior-complete.keiro", - recModuleRoot = "", - recLayout = "prefixed", - recSourceLanguage = DeclaredLanguage version noLoc, - recLanguageContract = effectiveLanguageContract (DeclaredLanguage version noLoc), - recFiles = [], - recMappings = [], - recIdDomains = [], - recNominalEqualities = [], - recBindingObligations = [], - recBehaviorRequirements = rows - } - T.count "behavior " (renderRecord singleRecord) `shouldBe` 14 - 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, - wrModules = [], - wrMappings = [], - wrIdDomains = [], - wrNominalEqualities = [], - wrBindingObligations = [], - wrBehaviorRequirements = ownedRows, - wrAdopted = [] - } - map Behavior.behaviorRecordOwner ownedRows `shouldSatisfy` all (== Just "journey.keiro") - T.count "behavior " (renderWorkspaceRecord workspaceRecord) `shouldBe` 14 - parseWorkspaceRecord (renderWorkspaceRecord workspaceRecord) `shouldBe` Just workspaceRecord - - 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` [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, 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 "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 = NominalConformance.Domain.AccountNumber" - moduleText projectionModule `shouldSatisfy` T.isInfixOf "projectFieldValue _ = nominalToRepresentation NominalConformance.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 "orderIdBinding :: NominalBinding NominalConformance.Domain.OrderId (KindID \"ord\")" - 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, - recFiles = [], - recMappings = consumerMappings plan, - recIdDomains = [], - recNominalEqualities = nominalEqualityIdentities spec, - recBindingObligations = [], - recBehaviorRequirements = [] - } - encoded = renderRecord record - workspaceRecord = - (sampleWorkspaceRecord workspace) - { wrMappings = consumerMappings plan - } - workspaceEncoded = renderWorkspaceRecord workspaceRecord - consumerPackages plan `shouldBe` ["nominal-conformance"] - length [() | NominalMapping {} <- consumerMappings plan] `shouldBe` 7 - T.count "nominal-mapping " encoded `shouldBe` 7 - T.count "nominal-equality " encoded `shouldBe` 2 - T.count "\nmapping " encoded `shouldBe` 0 - parseRecord encoded `shouldBe` Just record - T.count "nominal-mapping " workspaceEncoded `shouldBe` 7 - T.count "nominal-equality " workspaceEncoded `shouldSatisfy` (>= 2) - T.count "\nmapping " workspaceEncoded `shouldBe` 0 - parseWorkspaceRecord workspaceEncoded `shouldBe` Just workspaceRecord - - it "reports bound-ID decoder tightening and makes binding provenance replay-visible" $ do - current <- specOf "test/fixtures/nominal-scalars.keiro" - let unbound = current {specIds = [declaration {idBinding = Nothing} | declaration <- specIds 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] - ReplayImpact.replayImpact current bumped `shouldSatisfy` \case - ReplayImpact.ReplayAffected impacts -> - maybe False (\impact -> Set.member "NominalsRecorded" (ReplayImpact.eventTypes impact) && includeSnapshotStreams impact) (Map.lookup "NominalLedger" impacts) - ReplayImpact.ReplayNeutral -> False - case [aggregate | NAggregate aggregate <- specNodes current] of - aggregate : _ -> do - aggregateFoldSurface current aggregate `shouldSatisfy` T.isInfixOf "nominal-equality-use:" - aggregateFoldSurface current aggregate `shouldNotBe` aggregateFoldSurface bumped aggregate - [] -> expectationFailure "expected nominal aggregate" - - describe "historical codec comparison" $ do - it "treats object-key order as RFC 8785 parity" $ do - let historical = object ["z" .= (1 :: Int), "a" .= (2 :: Int)] - generated = object ["a" .= (2 :: Int), "z" .= (1 :: Int)] - classifyObservation (EncodeObservation "ordered-object" historical generated) - `shouldBe` Right JsonParity - it "classifies an omitted key versus explicit null as version work at that pointer" $ do - let historical = object [] - generated = object ["description" .= Aeson.Null] - classifyObservation (EncodeObservation "absent-description" historical generated) - `shouldBe` Right (RequiresVersionWork (EncodedValueDifference (JsonPointer "/description") historical generated)) - it "classifies generated rejection of a historical value as version work" $ - classifyObservation - ( DecodeObservation - "legacy.json" - (object ["tag" .= ("legacy" :: T.Text)]) - (DecodedShape (object ["tag" .= ("legacy" :: T.Text)])) - (DecodeFailed "unknown tag") - ) - `shouldBe` Right (RequiresVersionWork (GeneratedDecodeRejected "unknown tag")) - it "treats historical-codec rejection as invalid input rather than parity" $ - classifyObservation - ( DecodeObservation - "corrupt.json" - Aeson.Null - (DecodeFailed "not historical data") - (DecodeFailed "not generated data") - ) - `shouldBe` Left (HistoricalCodecRejected "corrupt.json" "not historical data") - it "reports uncovered union arms separately by corpus origin" $ do - let canonical = DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical") - local = DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local_file") - report = compareReport comparisonProvenance [] [] [canonical, local] [ObservedBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local_file")] - crCoverageGaps report - `shouldBe` [CoverageGap HistoricalGolden (JsonPointer "/location") (UnionArm "canonical")] - reportSucceeded report `shouldBe` False - it "derives optional, null, and union-arm observations from a generated branch schema" $ do - let schema = - BranchRecord - [ BranchField "description" True (BranchOptional BranchScalar), - BranchField "location" False (BranchUnion "tag" "contents" [BranchArm "local" (Just BranchScalar), BranchArm "canonical" Nothing]) - ] - historical = object ["location" .= object ["tag" .= ("canonical" :: T.Text)]] - observedBranchesFor HistoricalGolden schema historical - `shouldBe` [ ObservedBranch HistoricalGolden (JsonPointer "/description") OptionalMissing, - ObservedBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical") - ] - let declared = declaredBranchesFor HistoricalGolden schema - forM_ - [ DeclaredBranch HistoricalGolden (JsonPointer "/description") OptionalMissing, - DeclaredBranch HistoricalGolden (JsonPointer "/description") OptionalPresent, - DeclaredBranch HistoricalGolden (JsonPointer "/description") ExplicitNull, - DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local"), - DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical") - ] - (\branch -> declared `shouldContain` [branch]) - it "round-trips the stable machine report" $ do - let observation = EncodeObservation "parity" (object ["a" .= (1 :: Int)]) (object ["a" .= (1 :: Int)]) - report = compareReport comparisonProvenance [] [observation] [] [] - Aeson.eitherDecode (Aeson.encode report) `shouldBe` Right report - it "atomically writes and replaces the machine report" $ - withTempDirectory "keiro-dsl-codec-compare" $ \out -> do - let path = out "report.json" - firstReport = compareReport comparisonProvenance [] [] [] [] - secondReport = compareReport comparisonProvenance [HistoricalGoldenUnreadable "bad.json" "bad JSON"] [] [] [] - writeCompareReportAtomic path firstReport `shouldReturn` Right () - Aeson.eitherDecodeFileStrict path `shouldReturn` Right firstReport - writeCompareReportAtomic path secondReport `shouldReturn` Right () - Aeson.eitherDecodeFileStrict path `shouldReturn` Right secondReport - - describe "historical codec comparison scaffold" $ do - it "emits an opt-in non-production runner without entering the ordinary module registry" $ do - spec <- specOf "test/fixtures/structural-conformance.keiro" - let ctx = defaultContext (specContext spec) - planned = codecComparisonModule ctx spec "ArtifactInfo" - ordinary = scaffoldModules ctx spec - case planned of - Left err -> expectationFailure (T.unpack err) - Right comparisonModule -> do - modulePath comparisonModule - `shouldBe` "Generated/StructuralConformance/Structural/CodecCompare/ArtifactInfo.hs" - moduleText comparisonModule `shouldSatisfy` T.isInfixOf codecComparisonBanner - moduleText comparisonModule `shouldSatisfy` T.isInfixOf "Generated.StructuralConformance.ArtifactCatalog.Codec qualified as GeneratedCodec" - moduleText comparisonModule `shouldSatisfy` T.isInfixOf "branchSchema = BranchRecord" - map modulePath ordinary `shouldNotContain` [modulePath comparisonModule] - it "refuses opaque selections rather than upgrading their claim" $ do - spec <- specOf "test/fixtures/structural-conformance.keiro" - codecComparisonModule (defaultContext (specContext spec)) spec "VendorGeometry" - `shouldSatisfy` either (T.isInfixOf "is opaque") (const False) - - describe "structural/opaque coverage reporting" $ do - it "reports mapped private-event roots and consumer-json register boundaries without a percentage" $ do - spec <- specOf "test/fixtures/structural-conformance.keiro" - report <- shouldResolveCoverage "structural-conformance.keiro" spec - Coverage.privateEventPayloads (Coverage.coverageSummary report) - `shouldBe` Coverage.CoverageCounts 2 1 1 0 - Coverage.snapshotRegisters (Coverage.coverageSummary report) - `shouldBe` Coverage.CoverageCounts 2 1 1 0 - map Coverage.opaqueMappedType (Coverage.coverageOpaqueBoundaries report) - `shouldBe` ["VendorGeometry"] - map Coverage.snapshotEncoding (Coverage.coverageSnapshotBoundaries report) - `shouldBe` ["consumer-json-cache", "consumer-json-cache"] - map Coverage.snapshotInvalidation (Coverage.coverageSnapshotBoundaries report) - `shouldBe` ["tracked-by-mapped-wire-fingerprint", "tracked-by-mapped-wire-fingerprint"] - map Coverage.findingCode (Coverage.coverageFindings report) - `shouldBe` [CoverageOpaqueSurface] - map Coverage.findingSeverity (Coverage.coverageFindings report) - `shouldBe` [Warning] - case Aeson.toJSON report of - Aeson.Object values -> - forM_ ["spec", "roots", "opaqueBoundaries", "snapshotBoundaries", "unsupportedSurfaces"] $ - \key -> KeyMap.member key values `shouldBe` True - value -> expectationFailure ("coverage report was not an object: " <> show value) - it "reports explicit Json leaves by their complete persisted path" $ do - spec <- withMetadataJson <$> specOf "test/fixtures/structural-conformance.keiro" - report <- shouldResolveCoverage "structural-conformance-json.keiro" spec - Coverage.jsonBoundaries (Coverage.privateEventPayloads (Coverage.coverageSummary report)) - `shouldBe` 1 - map Coverage.jsonPath (Coverage.coverageJsonBoundaries report) - `shouldBe` ["ArtifactCatalog event ArtifactRecorded .artifact : ArtifactInfo .metadata : ArtifactMetadata .note"] - it "keeps a zero-opaque spec advisory-free and makes rejection explicitly opt-in" $ do - original <- specOf "test/fixtures/structural-conformance.keiro" - clear <- shouldResolveCoverage "structural-only.keiro" (withoutVendorGeometry original) - Coverage.opaqueRoots (Coverage.privateEventPayloads (Coverage.coverageSummary clear)) `shouldBe` 0 - Coverage.coverageOpaqueBoundaries clear `shouldBe` [] - Coverage.coverageFindings clear `shouldBe` [] - opaque <- shouldResolveCoverage "structural-conformance.keiro" original - Coverage.coverageSucceeded opaque `shouldBe` True - let gated = Coverage.failOnOpaque opaque - Coverage.coverageSucceeded gated `shouldBe` False - map Coverage.findingCode (Coverage.coverageFindings gated) - `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueGateExceeded] - map Coverage.findingSeverity (Coverage.coverageFindings gated) - `shouldBe` [Warning, Error] - it "diffs named opaque boundaries and fails only an explicitly gated increase" $ do - newSpec <- specOf "test/fixtures/structural-conformance.keiro" - report <- case Coverage.coverageDiffReport "structural-conformance.keiro" "HEAD" (withoutVendorGeometry newSpec) newSpec of - Left err -> expectationFailure (show err) >> fail "unreachable" - Right value -> pure value - fmap Coverage.opaqueBoundaryDelta (Coverage.coverageDelta report) `shouldBe` Just 1 - fmap (map Coverage.opaqueMappedType . Coverage.addedOpaqueBoundaries) (Coverage.coverageDelta report) - `shouldBe` Just ["VendorGeometry"] - map Coverage.findingCode (Coverage.coverageFindings report) - `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueBoundaryAdded] - Coverage.coverageSucceeded report `shouldBe` True - let gated = Coverage.failOnOpaqueIncrease report - Coverage.coverageSucceeded gated `shouldBe` False - map Coverage.findingCode (Coverage.coverageFindings gated) - `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueBoundaryAdded, CoverageOpaqueGateExceeded] - it "appends the six stable coverage and comparison registry codes" $ - map - show - [ CoverageOpaqueSurface, - CoverageOpaqueBoundaryAdded, - CoverageOpaqueGateExceeded, - CodecCompareDifference, - CodecCompareCoverageGap, - CodecCompareInvalidInput - ] - `shouldBe` [ "CoverageOpaqueSurface", - "CoverageOpaqueBoundaryAdded", - "CoverageOpaqueGateExceeded", - "CodecCompareDifference", - "CodecCompareCoverageGap", - "CodecCompareInvalidInput" - ] - - describe "parse . pretty round-trip" $ - do - it "re-parses any generated spec to an equal AST (modulo source locations)" $ - checkCoverage $ - forAll genSpec $ \s -> - let families = map nodeTag (specNodes s) - roundTrip = parseSpec "" (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 "" (renderSpec emptyStatesSpec) `shouldBe` Right emptyStatesSpec - it "separates transition emit clauses from following nodes" $ do - spec <- parseInlineSpec "" 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 - parseSpec "" (renderSpec 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", AggregateGuardCapabilityUnsupported) - ] - 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 - generated = - [ moduleText generatedModule - | generatedModule <- scaffoldAggregate (defaultContext (specContext spec)) spec aggregate, - Keiro.Dsl.Scaffold.kind generatedModule == Generated - ] - domain = generatedTextEndingIn "Domain.hs" (scaffoldAggregate (defaultContext (specContext spec)) spec aggregate) - 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"] - generated `shouldSatisfy` all (not . T.isInfixOf "error") - generated `shouldSatisfy` all (not . T.isInfixOf "getCurrentTime") - generated `shouldSatisfy` all (not . T.isInfixOf "iso8601ParseM") - it "canonicalizes Time and UTCTime across pretty, diff, and fold identity" $ do - source <- readTestText "test/fixtures/aggregate-scalars.keiro" - canonical <- parseInlineSpec "