diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,69 @@ ## [Unreleased] +## 0.10.0.0 — 2026-08-03 + +### Breaking Changes + +- `Keiro.Dsl.AggregateType` no longer exports `aggregateHaskellType` or + `aggregateImports`. A resolved aggregate type now yields the typed + `AggregateHaskellSource` returned by `aggregateConsumerHaskellSource`, read + through `aggregateSourceReferences` and `aggregateSourceStaticImports` and + rendered with `renderAggregateHaskellSource`, so consumer-owned types flow + into the import planner instead of being flattened into module-qualified + text. +- `Keiro.Dsl.ScaffoldRun`'s `Refusal` gained the `DuplicateConformanceFactKeys` + and `ConformancePackageRefusal` constructors, and `ScaffoldReport` gained the + `reportConformancePackage` field. Exhaustive matches and literal report + construction must be updated. +- `Keiro.Dsl.Workspace`'s `WorkspaceManifest` gained the `wmfRuntimePackage` + and `wmfRuntimePackageLoc` fields. +- The generated build manifest now emits the complete Cabal fragment: a + `default-language: GHC2024` line, an `OverloadedStrings` `default-extensions` + block, and — when a service conformance facade is generated — an + `exposed-modules` block that removes the facade from `other-modules`. + Consumers must repaste the fragment rather than merging only the module and + dependency blocks. + +### New Features + +- A configured Keiro service now generates at most one local conformance + package. `scaffold` emits a service-level conformance facade + (`.Conformance`) in the consumer's runtime package and a + separate runnable conformance package whose runner imports only that facade, + so per-node harness modules stay out of the consumer's public API. See + ADR 20. +- The runtime Cabal package is now explicit build metadata. A workspace + manifest may carry an optional `runtime-package ` clause, and + `keiro-dsl scaffold` accepts `--runtime-package PACKAGE`, which takes + precedence over the manifest value. The name is validated against Cabal's + package-name grammar and is never inferred from the service name, directory, + or nearby Cabal files. New module `Keiro.Dsl.RuntimePackage` exports + `RuntimePackageName`, `mkRuntimePackageName`, and `isCabalPackageName`. +- New modules `Keiro.Dsl.ServiceHarness` and `Keiro.Dsl.ConformancePackage` + expose the facade and package planning surfaces. +- Generated Haskell now has an explicit, checked language contract. The + manifest owns the `GHC2024` + `OverloadedStrings` baseline, and overwriteable + generated modules declare specialized pragmas locally only when their emitted + syntax needs them, drawn from a closed set (`BlockArguments`, + `DeriveAnyClass`, `DuplicateRecordFields`, `OverloadedLabels`, + `OverloadedRecordDot`, `QualifiedDo`, `TemplateHaskell`, `TypeFamilies`). + Tracked generated output is independently checked against that set. See + ADR 19. + +### Other Changes + +- Generated event codecs now derive one named event-type allow-list per + aggregate and render unknown-event diagnostics from that same value, so the + diagnostic text can no longer drift from the accepted set. +- Generated structural record fields and union payloads now use minimal + precedence-correct parentheses without changing schema or wire semantics. +- Generated Haskell now plans consumer-owned imports once per module. Unique + type names use explicit unqualified imports; collisions, external values, + constructors, generated shapes, and binding APIs use deterministic short + qualified aliases. Imports are merged, deduplicated, and sorted without + changing wire schemas, fingerprints, provenance, or create-once ownership. + ## 0.9.0.0 — 2026-08-02 ### Breaking Changes @@ -112,6 +175,15 @@ 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. + +### Other Changes + +- Generated build manifests now declare the complete consumer compilation + contract: `default-language: GHC2024` and `OverloadedStrings` as the sole + default extension, followed by the module and dependency blocks. Generated + modules emit specialized local LANGUAGE pragmas only when their syntax needs + them. Re-scaffold before compiling under the narrower advertised profile; + create-once hand-owned files keep their existing local pragmas. ## 0.8.0.0 — 2026-08-01 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -24,14 +24,15 @@ import Keiro.Dsl.Parser (parseSource, renderParseFailure) import Keiro.Dsl.PrettyPrint (renderSource, renderSpec) import Keiro.Dsl.ReplayImpact (renderReplayImpact, replayImpactServices) +import Keiro.Dsl.RuntimePackage (RuntimePackageName, mkRuntimePackageName) import Keiro.Dsl.Scaffold (Context (..), ScaffoldModule (..), codecComparisonBanner, codecComparisonModule) -import Keiro.Dsl.ScaffoldRun (executeServiceScaffold, planServiceScaffoldWithGoldens, renderRefusals, renderScaffoldReport) +import Keiro.Dsl.ScaffoldRun (executeServiceScaffoldWithRuntimePackage, planServiceScaffoldWithRuntimePackageAndGoldens, renderRefusals, renderScaffoldReport) import Keiro.Dsl.SemanticContract (CheckedService (..), checkedSource) import Keiro.Dsl.Skeleton (skeletonFor) import Keiro.Dsl.Validate (Diagnostic (..), Severity (..), renderDiagnostic, validateService) import Keiro.Dsl.Workspace (ContentSource (..), LineMap (..), OwnershipIndex (..), WorkspaceDiagnostic (..), WorkspaceFailure, WorkspaceManifest (..), WorkspaceMember (..), WorkspaceMemberRef (..), WorkspaceSpec (..), checkWorkspace, checkedWorkspace, fileContentSource, isWorkspacePath, loadWorkspace, nodeOwner, parseWorkspaceManifest, renderWorkspaceDiagnostic, renderWorkspaceFailure, renderWorkspaceManifest) import Keiro.Dsl.WorkspaceDiff (WorkspaceChange (..), WorkspaceMeta (..), diffWorkspaces, renderWorkspaceFinding, workspaceDiffReport) -import Keiro.Dsl.WorkspaceScaffold (executeWorkspaceScaffold, planWorkspaceScaffoldWithGoldens, renderWorkspaceScaffoldReport) +import Keiro.Dsl.WorkspaceScaffold (executeWorkspaceScaffold, planWorkspaceScaffoldWithRuntimePackageAndGoldens, renderWorkspaceScaffoldReport) import Options.Applicative import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist) import System.Exit (ExitCode (..), exitFailure) @@ -45,7 +46,7 @@ | Check FilePath Bool Bool (Maybe CheckCoverageOptions) | Inspect FilePath InspectionFormat | BehaviorObligations FilePath BehaviorFormat - | Scaffold FilePath FilePath (Maybe String) Bool Bool (Maybe FilePath) (Maybe (String, FilePath)) + | Scaffold FilePath FilePath (Maybe String) (Maybe RuntimePackageName) Bool Bool (Maybe FilePath) (Maybe (String, FilePath)) | Diff FilePath String (Maybe FilePath) (Maybe FilePath) [CompatibilitySurface] Bool (Maybe FilePath) (Maybe DiffCoverageOptions) | New String @@ -91,7 +92,7 @@ (info (BehaviorObligations <$> fileArg <*> behaviorFormatOpt <**> helper) (progDesc "List static aggregate behavior obligations for a .keiro file or workspace")) <> command "scaffold" - (info (Scaffold <$> fileArg <*> outOpt <*> optional moduleRootOpt <*> collocateSwitch <*> forceGeneratedOverwriteSwitch <*> optional goldensOpt <*> codecComparisonOpts <**> helper) (progDesc "Emit the generated layer + typed holes from a .keiro file")) + (info (Scaffold <$> fileArg <*> outOpt <*> optional moduleRootOpt <*> optional runtimePackageOpt <*> collocateSwitch <*> forceGeneratedOverwriteSwitch <*> optional goldensOpt <*> codecComparisonOpts <**> helper) (progDesc "Emit the generated layer + typed holes from a .keiro file")) <> command "diff" (info (Diff <$> fileArg <*> sinceOpt <*> optional emitGoldensOpt <*> optional replayImpactOutOpt <*> many gateOpt <*> explainSwitch <*> optional reportOutOpt <*> diffCoverageOptions <**> helper) (progDesc "Classify spec changes since a git ref as per-surface compatibility vectors; exit non-zero on any gated BREAKING surface")) @@ -106,6 +107,15 @@ moduleRootOpt :: Parser String moduleRootOpt = strOption (long "module-root" <> metavar "PREFIX" <> help "Namespace prefix for emitted modules, e.g. Acme or Acme.Services (overrides the spec's module clause)") +runtimePackageOpt :: Parser RuntimePackageName +runtimePackageOpt = + option + ( eitherReader $ \raw -> case mkRuntimePackageName (T.pack raw) of + Left message -> Left (T.unpack message) + Right packageName -> Right packageName + ) + (long "runtime-package" <> metavar "PACKAGE" <> help "Cabal package that compiles the generated service runtime (overrides the workspace manifest)") + collocateSwitch :: Parser Bool collocateSwitch = switch (long "collocate" <> help "Place the generated layer as a leaf under the domain (..Generated) instead of a parallel Generated.* tree") @@ -202,8 +212,8 @@ | isWorkspacePath fp = runWorkspaceInspect fp format run (BehaviorObligations fp format) | isWorkspacePath fp = runWorkspaceBehaviorObligations fp format -run (Scaffold fp out cliRoot cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest) - | isWorkspacePath fp = runWorkspaceScaffold fp out cliRoot cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest +run (Scaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest) + | isWorkspacePath fp = runWorkspaceScaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest run (Diff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions) | isWorkspacePath fp = runWorkspaceDiff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions run (Parse fp) = do @@ -238,7 +248,7 @@ coverageOk <- runCheckCoverage fp spec coverageOptions when (coverageOk && not emit && not explainBindings) (putStrLn "OK") when (not coverageOk) exitFailure -run (Scaffold fp out cliRoot cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest) = do +run (Scaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest) = do input <- TIO.readFile fp case parseSource fp input of Left failure -> do @@ -255,7 +265,7 @@ let ctx = mkContext cliRoot cliCollocate spec goldenRoot = fromMaybe (takeDirectory fp "golden-payloads") cliGoldens goldens <- loadGoldenPayloads goldenRoot spec - case (planServiceScaffoldWithGoldens goldens ctx service, traverse (\(name, _) -> codecComparisonModule ctx spec (T.pack name)) comparisonRequest) of + case (planServiceScaffoldWithRuntimePackageAndGoldens goldens cliRuntimePackage ctx service, traverse (\(name, _) -> codecComparisonModule ctx spec (T.pack name)) comparisonRequest) of (Left refusals, _) -> do mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals) exitFailure @@ -265,7 +275,7 @@ case comparisonReady of Left comparisonError -> TIO.hPutStrLn stderr comparisonError >> exitFailure Right () -> do - result <- executeServiceScaffold out forceGeneratedOverwrite fp (parsedSourceLanguage parsedSource) ctx service modules + result <- executeServiceScaffoldWithRuntimePackage cliRuntimePackage out forceGeneratedOverwrite fp (parsedSourceLanguage parsedSource) ctx service modules case result of Left refusals -> do mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals) @@ -478,12 +488,13 @@ FilePath -> FilePath -> Maybe String -> + Maybe RuntimePackageName -> Bool -> Bool -> Maybe FilePath -> Maybe (String, FilePath) -> IO () -runWorkspaceScaffold fp out cliRoot cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest = do +runWorkspaceScaffold fp out cliRoot cliRuntimePackage cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest = do loaded <- loadWorkspace (fileContentSource (takeDirectory fp)) fp case loaded of Left failure -> do @@ -497,9 +508,12 @@ when (any ((== Error) . wdSeverity) diags) exitFailure let spec = checkedSpec (checkedWorkspace workspace) ctx = workspaceContext cliRoot cliCollocate workspace + effectiveRuntimePackage = case cliRuntimePackage of + Just packageName -> Just packageName + Nothing -> wsRuntimePackage workspace goldenRoot = fromMaybe (takeDirectory fp "golden-payloads") cliGoldens goldens <- loadGoldenPayloads goldenRoot spec - case ( planWorkspaceScaffoldWithGoldens goldens goldenRoot ctx workspace, + case ( planWorkspaceScaffoldWithRuntimePackageAndGoldens goldens effectiveRuntimePackage goldenRoot ctx workspace, traverse (\(name, _) -> codecComparisonModule ctx spec (T.pack name)) comparisonRequest ) of (Left refusals, _) -> do 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.9.0.0 +version: 0.10.0.0 synopsis: Typed specification toolchain for keiro services description: keiro-dsl is the toolchain over a typed `.keiro` specification of a keiro @@ -29,6 +29,10 @@ OverloadedLabels OverloadedStrings +common generated-output + default-language: GHC2024 + default-extensions: OverloadedStrings + library import: warnings, shared hs-source-dirs: src @@ -38,6 +42,7 @@ Keiro.Dsl.BehaviorCoverage Keiro.Dsl.CanonicalEncoding Keiro.Dsl.CodecCompare + Keiro.Dsl.ConformancePackage Keiro.Dsl.Coverage Keiro.Dsl.Diff Keiro.Dsl.DiffReport @@ -59,10 +64,12 @@ Keiro.Dsl.PrettyPrint Keiro.Dsl.ReadModelShape Keiro.Dsl.ReplayImpact + Keiro.Dsl.RuntimePackage Keiro.Dsl.Scaffold Keiro.Dsl.ScaffoldRecord Keiro.Dsl.ScaffoldRun Keiro.Dsl.SemanticContract + Keiro.Dsl.ServiceHarness Keiro.Dsl.Skeleton Keiro.Dsl.Source Keiro.Dsl.Syntax @@ -76,6 +83,8 @@ other-modules: Keiro.Dsl.Frontend.Internal + Keiro.Dsl.GeneratedHaskellLanguage + Keiro.Dsl.HaskellImport Keiro.Dsl.Parser.Aggregate Keiro.Dsl.Parser.Coordination Keiro.Dsl.Parser.Core @@ -91,20 +100,20 @@ Paths_keiro_dsl build-depends: - , aeson >=2.2.1 && <2.3 - , base >=4.21 && <5 - , bytestring >=0.12 && <0.13 - , containers >=0.6 && <0.8 - , directory >=1.3 && <1.4 - , filepath >=1.4 && <1.6 - , 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 - , prettyprinter >=1.7 && <1.8 - , text >=2.1 && <2.2 - , time >=1.12 && <1.15 + , aeson >=2.2.1 && <2.3 + , base >=4.21 && <5 + , bytestring >=0.12 && <0.13 + , containers >=0.6 && <0.8 + , directory >=1.3 && <1.4 + , filepath >=1.4 && <1.6 + , keiki >=0.8 && <0.9 + , keiro-core ^>=0.10.0.0 + , megaparsec >=9.6 && <9.9 + , mmzk-typeid >=0.7 && <0.8 + , parser-combinators >=1.3 && <1.4 + , prettyprinter >=1.7 && <1.8 + , text >=2.1 && <2.2 + , time >=1.12 && <1.15 executable keiro-dsl import: warnings, shared @@ -149,13 +158,25 @@ , QuickCheck >=2.14 , text >=2.1 && <2.2 +test-suite keiro-dsl-import-planning-test + import: warnings, shared + type: exitcode-stdio-1.0 + hs-source-dirs: test/import-planning src + main-is: Main.hs + other-modules: Keiro.Dsl.HaskellImport + build-depends: + , base >=4.21 && <5 + , containers >=0.6 && <0.8 + , hspec >=2.11 + , text >=2.1 && <2.2 + -- Conformance: proves the scaffolded Generated modules plus a hand-filled -- Holes.hs compile against keiki/keiro and that the filled transducer passes -- keiki's validator and the codec round-trips. The Generated.* modules under -- test/conformance/ are byte-identical to `keiro-dsl scaffold` output (pinned -- by the scaffold-conformance test in keiro-dsl-test). test-suite keiro-dsl-conformance - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance main-is: Main.hs @@ -183,7 +204,7 @@ -- symbolic equality/ordering, codecs, snapshots, forward/replay equality, -- Natural JSON boundaries, canonical identity, and opaque arithmetic audit. test-suite keiro-dsl-conformance-aggregate-scalars - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-aggregate-scalars main-is: Main.hs @@ -209,7 +230,7 @@ -- transition ownership, explicit Hole opacity/fold identity, and concrete, -- symbolic, codec-replay, and snapshot-invalidation agreement. test-suite keiro-dsl-conformance-aggregate-scalar-expressions - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-scalar-expressions main-is: Main.hs @@ -242,7 +263,7 @@ , time >=1.12 && <1.15 test-suite keiro-dsl-conformance-behavior-complete - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-behavior-complete main-is: Main.hs @@ -277,7 +298,7 @@ -- EP-158: consumer-owned direct IDs, enums, and nominal scalar wrappers, -- checked KindID decoding, total bindings, projections, and snapshot caches. test-suite keiro-dsl-conformance-nominal-scalars - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-nominal-scalars main-is: Main.hs @@ -311,7 +332,7 @@ -- and round-trips both generated event codecs, so duplicate nominal types fail -- at compile time rather than escaping a path-only scaffold assertion. test-suite keiro-dsl-conformance-workspace-nominals - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-workspace-nominals main-is: Main.hs @@ -348,7 +369,7 @@ -- codecs, generated projection witnesses, opaque boundaries, fixture branch -- coverage, current payload goldens, and mapped-register replay equality. test-suite keiro-dsl-conformance-structural - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-structural main-is: Main.hs @@ -380,11 +401,47 @@ , text >=2.1 && <2.2 , time >=1.12 && <1.15 +-- Plan 184: colliding consumer type occurrences, local-name conflicts, and +-- repeated binding/shape references compile with deterministic short aliases. +test-suite keiro-dsl-conformance-import-planning + import: warnings, generated-output + type: exitcode-stdio-1.0 + hs-source-dirs: test/conformance-import-planning + main-is: Main.hs + other-modules: + Generated.ImportPlanningCollisions.CollisionLedger.BehaviorContract + Generated.ImportPlanningCollisions.CollisionLedger.Codec + Generated.ImportPlanningCollisions.CollisionLedger.Domain + Generated.ImportPlanningCollisions.CollisionLedger.EventStream + Generated.ImportPlanningCollisions.CollisionLedger.Harness + Generated.ImportPlanningCollisions.CollisionLedger.Projection + Generated.ImportPlanningCollisions.CollisionLedger.Transducer + Generated.ImportPlanningCollisions.NominalProjections + Generated.ImportPlanningCollisions.ReplayAudit + Generated.ImportPlanningCollisions.Structural.Shape.Details + Generated.ImportPlanningCollisions.StructuralProjections + ImportPlanning.Bindings + ImportPlanning.Consumer.Domain + ImportPlanning.Consumer.Invoice.Types + ImportPlanning.Consumer.Order.Types + ImportPlanning.Consumer.Shared.Types + ImportPlanningCollisions.CollisionLedger.BehaviorHoles + + build-depends: + , aeson >=2.2 && <2.3 + , base >=4.21 && <5 + , bytestring >=0.12 && <0.13 + , containers >=0.6 && <0.8 + , keiki >=0.8 && <0.9 + , keiro + , text >=2.1 && <2.2 + , time >=1.12 && <1.15 + -- Plan 152 / Experiment B: a consumer-owned historical codec and finite JSON -- corpus compared with the generated structural codec. The comparison module -- is opt-in tooling output and is not part of the production scaffold record. test-suite keiro-dsl-conformance-codec-compare - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-codec-compare test/conformance-structural @@ -419,7 +476,7 @@ -- forward/replay register comparisons catch state divergence missed by the -- pre-existing validator, codec round-trip, and accept assertions. test-suite keiro-dsl-conformance-replay - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-replay main-is: Main.hs @@ -470,7 +527,7 @@ -- defaultStateCodec and stream-construction guards, with the captured codec -- identity checked against keiki's regFileShapeHash. test-suite keiro-dsl-conformance-snapshot - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-snapshot main-is: Main.hs @@ -495,7 +552,7 @@ -- committed tree. Compiling the union proves a starter that passes `check` -- cannot emit syntactically or type-invalid Haskell. test-suite keiro-dsl-conformance-skeletons - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-skeletons main-is: Main.hs @@ -583,7 +640,7 @@ -- notation, scaffolded + hand-filled, compiling against keiki/keiro with a green -- spec-derived harness — proof the authoring loop closes on a non-corpus spec. test-suite keiro-dsl-conformance-coldstart - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-coldstart main-is: Main.hs @@ -610,7 +667,7 @@ -- canonical text JSON, field-path-aware rejection, and the complete generated -- dependency set. test-suite keiro-dsl-conformance-contract - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-contract main-is: Main.hs @@ -625,7 +682,7 @@ -- 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 + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-contract-v1-compat main-is: Main.hs @@ -639,7 +696,7 @@ -- 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 - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-intake-runtime main-is: Main.hs @@ -653,7 +710,7 @@ -- inbox dedupe + a filled inbox transaction runner and outbox IntegrationProducer -- — compiled against the live keiro runtime (Inbox / Outbox / Kiroku.Store). test-suite keiro-dsl-conformance-intake-full - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-intake-full main-is: Main.hs @@ -672,7 +729,7 @@ -- EP-4 publisher runtime conformance: the scaffolded Publisher config compiled -- against the LIVE Keiro.Outbox.Types (OrderingPolicy / BackoffSchedule). test-suite keiro-dsl-conformance-publisher-runtime - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-publisher-runtime main-is: Main.hs @@ -684,7 +741,7 @@ -- pgmq Job codec conformance (EP-5): the scaffolded self-contained Job payload -- record + field->wire codec, compiled + round-tripped. test-suite keiro-dsl-conformance-queue - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-queue main-is: Main.hs @@ -702,7 +759,7 @@ -- EP-5 pgmq runtime conformance: the scaffolded QueuePolicy (RetryPolicy + -- JobOutcome disposition) compiled against the LIVE Keiro.PGMQ.Job runtime. test-suite keiro-dsl-conformance-queue-runtime - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-queue-runtime main-is: Main.hs @@ -726,7 +783,7 @@ -- registration/rebuild helpers, AsyncProjection, facts harness, and a filled -- qualified-table query compiled against the live Keiro.ReadModel API. test-suite keiro-dsl-conformance-readmodel-runtime - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-readmodel-runtime main-is: Main.hs @@ -748,7 +805,7 @@ -- Job codec + retry policy + a filled worker handler assembled into a live -- Keiro.PGMQ.Job.Job value — compiled against keiro-pgmq. test-suite keiro-dsl-conformance-dispatch-full - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-dispatch-full main-is: Main.hs @@ -769,7 +826,7 @@ -- Workflow facts harness (EP-6): the scaffolded self-contained WorkflowFacts -- module asserted against a hand-written expectation (mutation-pinnable). test-suite keiro-dsl-conformance-workflow - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-workflow main-is: Main.hs @@ -782,7 +839,7 @@ -- (WorkflowName + awakeable-id derivation) compiled against the LIVE -- Keiro.Workflow; pins the await<->signal id match over deterministicAwakeableId. test-suite keiro-dsl-conformance-workflow-runtime - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-workflow-runtime main-is: Main.hs @@ -799,7 +856,7 @@ -- Surge (saga) + Hospital (target) aggregates with filled transducers, plus a -- filled ProcessManager handle — compiled against the live keiro/keiki runtime. test-suite keiro-dsl-conformance-process-full - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-process-full main-is: Main.hs @@ -836,7 +893,7 @@ -- WorkflowRuntime + a filled ordered step/await body — compiled against the -- live Keiro.Workflow effect. test-suite keiro-dsl-conformance-workflow-full - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-workflow-full main-is: Main.hs @@ -856,7 +913,7 @@ -- deterministic wiring (timer-request builder + fire disposition) compiled -- against the LIVE keiro runtime (Keiro.Timer / Keiro.Command), not just text. test-suite keiro-dsl-conformance-process-runtime - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-process-runtime main-is: Main.hs @@ -884,7 +941,7 @@ -- EP-108 router runtime conformance: generated policy lowering and the live -- target-keyed deterministic id contract. test-suite keiro-dsl-conformance-router-runtime - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-router-runtime main-is: Main.hs @@ -902,7 +959,7 @@ -- EP-108 generated router-facts harness with hand-written expectations. test-suite keiro-dsl-conformance-router - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-router main-is: Main.hs @@ -912,7 +969,7 @@ -- EP-108 filled-router conformance: scaffolded Page aggregate plus a filled -- resolver and Router value compiled against the live API. test-suite keiro-dsl-conformance-router-full - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-router-full main-is: Main.hs @@ -941,11 +998,12 @@ -- The component compiles generated output and hand-owned fills together and -- runs the aggregate, readmodel, router-policy, and live Router assertions. test-suite keiro-dsl-conformance-newsurface - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-newsurface main-is: Main.hs other-modules: + Generated.TransferRouting.Conformance Generated.TransferRouting.Hospital.Codec Generated.TransferRouting.Hospital.Domain Generated.TransferRouting.Hospital.EventStream @@ -980,7 +1038,7 @@ -- faithfully. (The runtime-coupled Process/ProcessHoles modules are emitted to -- disk but not in this component; their live conformance is the M5 step.) test-suite keiro-dsl-conformance-process - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-process main-is: Main.hs @@ -995,7 +1053,7 @@ -- assertion). These sources are raw `keiro-dsl scaffold` output of -- reservation-v2.keiro plus a hand-filled Holes.hs. test-suite keiro-dsl-conformance-v2 - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-v2 main-is: Main.hs @@ -1023,7 +1081,7 @@ -- rejects malformed current input while its explicitly internal event-replay -- seam preserves identical malformed text from a legacy payload. test-suite keiro-dsl-conformance-id-domain-migration - import: warnings, shared + import: warnings, generated-output type: exitcode-stdio-1.0 hs-source-dirs: test/conformance-id-domain-migration main-is: Main.hs 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 @@ -18,8 +18,11 @@ aggregateCapability, aggregateCanonicalName, typeExprCanonicalName, - aggregateHaskellType, - aggregateImports, + AggregateHaskellSource, + aggregateConsumerHaskellSource, + aggregateSourceReferences, + aggregateSourceStaticImports, + renderAggregateHaskellSource, aggregatePackages, aggregateSampleHaskell, ResolvedRegisterInitial (..), @@ -41,6 +44,7 @@ import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds) import Data.Time.Format.ISO8601 (iso8601ParseM) import Keiro.Dsl.Grammar +import Keiro.Dsl.HaskellImport import Keiro.Dsl.NominalType import Keiro.Dsl.TypeGraph import Numeric.Natural (Natural) @@ -230,39 +234,46 @@ TMap value -> "Map(" <> typeExprCanonicalName value <> ")" TRef name -> name -aggregateHaskellType :: AggregateSymbols -> ResolvedAggregateType -> Text -aggregateHaskellType symbols resolved = case resolved of - AggregateTime -> "UTCTime" - AggregateNominal nominal -> case resolvedNominalOwnership nominal of - GeneratedNominal -> resolvedNominalName nominal - ConsumerNominal binding -> renderHaskellSource (consumerNominalHaskell binding) - AggregateMapped key -> case Map.lookup key (symbolMapped symbols) of - Just declaration -> renderHaskellSource (mappedHaskell declaration) - Nothing -> unMappedKey key - _ -> aggregateCanonicalName resolved - where - mappedHaskell (ResolvedStructural declaration _) = sdHaskell declaration - mappedHaskell (ResolvedOpaque declaration) = odHaskell declaration - renderHaskellSource source = hsModule source <> "." <> hsType source +data AggregateHaskellSource = AggregateHaskellSource + { aggregateSourceBuiltin :: !(Maybe Text), + aggregateSourceReference :: !(Maybe HaskellReference), + aggregateSourceStaticImports :: !(Set Text) + } -aggregateImports :: AggregateSymbols -> ResolvedAggregateType -> Set Text -aggregateImports symbols resolved = case resolved of - AggregateTime -> - Set.fromList - [ "Data.Time.Calendar (fromGregorian)", - "Data.Time.Clock (UTCTime(..), picosecondsToDiffTime)" - ] - AggregateNatural -> Set.singleton "Numeric.Natural (Natural)" +aggregateConsumerHaskellSource :: AggregateSymbols -> ResolvedAggregateType -> AggregateHaskellSource +aggregateConsumerHaskellSource symbols resolved = case resolved of + AggregateTime -> builtin "UTCTime" timeImports + AggregateNatural -> builtin "Natural" (Set.singleton "Numeric.Natural (Natural)") AggregateNominal nominal -> case resolvedNominalOwnership nominal of - GeneratedNominal -> Set.empty - ConsumerNominal binding -> Set.singleton (hsModule (consumerNominalHaskell binding) <> " qualified") + GeneratedNominal -> builtin (resolvedNominalName nominal) Set.empty + ConsumerNominal binding -> external (consumerNominalHaskell binding) AggregateMapped key -> case Map.lookup key (symbolMapped symbols) of - Just declaration -> Set.singleton (hsModule (mappedHaskell declaration) <> " qualified") - Nothing -> Set.empty - _ -> Set.empty + Just declaration -> external (mappedHaskell declaration) + Nothing -> builtin (unMappedKey key) Set.empty + _ -> builtin (aggregateCanonicalName resolved) Set.empty where + builtin name imports = AggregateHaskellSource (Just name) Nothing imports + external source = + AggregateHaskellSource + Nothing + (Just (HaskellReference (hsModule source) (hsType source) TypeNamespace PreferUnqualified)) + Set.empty mappedHaskell (ResolvedStructural declaration _) = sdHaskell declaration mappedHaskell (ResolvedOpaque declaration) = odHaskell declaration + timeImports = + Set.fromList + [ "Data.Time.Calendar (fromGregorian)", + "Data.Time.Clock (UTCTime(..), picosecondsToDiffTime)" + ] + +aggregateSourceReferences :: AggregateHaskellSource -> Set HaskellReference +aggregateSourceReferences source = maybe Set.empty Set.singleton (aggregateSourceReference source) + +renderAggregateHaskellSource :: HaskellImportPlan -> AggregateHaskellSource -> Either HaskellImportError Text +renderAggregateHaskellSource plan source = case (aggregateSourceBuiltin source, aggregateSourceReference source) of + (Just builtin, Nothing) -> pure builtin + (Nothing, Just reference) -> renderPlannedReference plan reference + _ -> error "invalid aggregate Haskell source description" aggregatePackages :: AggregateSymbols -> ResolvedAggregateType -> Set Text aggregatePackages symbols resolved = case resolved of diff --git a/src/Keiro/Dsl/ConformancePackage.hs b/src/Keiro/Dsl/ConformancePackage.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/ConformancePackage.hs @@ -0,0 +1,551 @@ +-- | Planning and safe filesystem execution for the one runnable conformance +-- package generated per checked service. +module Keiro.Dsl.ConformancePackage + ( ConformanceServiceKey (..), + ConformanceFile (..), + ConformancePackagePlan (..), + ConformancePackageFailure (..), + ConformancePackageRecord (..), + ConformanceFactSide (..), + DuplicateFactKey (..), + ConformanceFactResult (..), + ConformanceWriteDisposition (..), + ConformanceStaleFile (..), + PreparedConformancePackage, + ConformancePackageReport (..), + cabaliseConformanceService, + conformancePackageDirectory, + conformanceRecordFileName, + planConformancePackage, + parseConformancePackageRecord, + renderConformancePackageRecord, + preflightConformancePackage, + executePreparedConformancePackage, + compareConformanceFacts, + renderConformancePackageFailure, + renderConformancePackageReport, + ) +where + +import Control.Monad (forM) +import Data.Char (isAlphaNum, isAscii, ord) +import Data.List (groupBy, sortOn) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Keiro.Dsl.RuntimePackage (RuntimePackageName (..), isCabalPackageName, mkRuntimePackageName) +import Keiro.Dsl.Scaffold (ModuleKind (..), generatedBannerFor, isGeneratedBannerLine) +import Keiro.Dsl.SemanticContract (CheckedService (..)) +import Keiro.Dsl.ServiceHarness (serviceConformanceFactValues) +import Numeric (showHex) +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.FilePath (isAbsolute, splitDirectories, takeDirectory, ()) + +data ConformanceServiceKey + = WorkspaceConformanceService !Text + | StandaloneConformanceService !Text + deriving stock (Eq, Ord, Show) + +data ConformanceFile = ConformanceFile + { conformanceFilePath :: !FilePath, + conformanceFileText :: !Text, + conformanceFileKind :: !ModuleKind + } + deriving stock (Eq, Show) + +data ConformancePackagePlan = ConformancePackagePlan + { cppServiceKey :: !ConformanceServiceKey, + cppDirectory :: !FilePath, + cppPackageName :: !Text, + cppRuntimePackage :: !RuntimePackageName, + cppFacadeModule :: !Text, + cppFiles :: ![ConformanceFile] + } + deriving stock (Eq, Show) + +data ConformanceFactSide = ExpectedFact | ActualFact + deriving stock (Eq, Ord, Show) + +data DuplicateFactKey = DuplicateFactKey + { duplicateFactSide :: !ConformanceFactSide, + duplicateFactKey :: !String + } + deriving stock (Eq, Ord, Show) + +data ConformanceFactResult + = ConformanceFactMatch !String !String + | ConformanceFactMismatch !String !String !String + | ConformanceFactMissing !String !String + | ConformanceFactUnexpected !String !String + deriving stock (Eq, Ord, Show) + +data ConformancePackageFailure + = UnsafeConformanceServiceKey !Text + | UnsafeConformancePath !FilePath + | ConformancePathCollision ![FilePath] + | PackageDuplicateFactKeys ![DuplicateFactKey] + | ConformanceGeneratedBannerMissing ![FilePath] + | InvalidConformancePackageRecord !FilePath + | ConformancePackageRecordMismatch !FilePath + deriving stock (Eq, Show) + +data ConformancePackageRecord = ConformancePackageRecord + { cprSchema :: !Int, + cprServiceKey :: !ConformanceServiceKey, + cprRuntimePackage :: !RuntimePackageName, + cprFacadeModule :: !Text, + cprFiles :: ![(ModuleKind, FilePath)] + } + deriving stock (Eq, Show) + +data ConformanceWriteDisposition = ConformanceCreated | ConformanceOverwritten | ConformanceSkipped | ConformanceUnchanged + deriving stock (Eq, Show) + +data ConformanceStaleFile = ConformanceStaleFile + { conformanceStaleKind :: !ModuleKind, + conformanceStalePath :: !FilePath, + conformanceStaleBannerPresent :: !(Maybe Bool) + } + deriving stock (Eq, Show) + +data PreparedConformancePackage = PreparedConformancePackage + { preparedRoot :: !FilePath, + preparedPlan :: !ConformancePackagePlan, + preparedStale :: ![ConformanceStaleFile] + } + deriving stock (Eq, Show) + +data ConformancePackageReport = ConformancePackageReport + { conformanceReportRoot :: !FilePath, + conformanceReportPlan :: !ConformancePackagePlan, + conformanceReportDispositions :: ![(ConformanceFile, ConformanceWriteDisposition)], + conformanceReportStale :: ![ConformanceStaleFile] + } + deriving stock (Eq, Show) + +conformanceRecordFileName :: FilePath +conformanceRecordFileName = "keiro-dsl-conformance-record.txt" + +conformancePackageDirectory :: ConformanceServiceKey -> FilePath +conformancePackageDirectory = \case + WorkspaceConformanceService service -> "keiro-dsl-conformance.workspace." <> T.unpack service + StandaloneConformanceService context -> "keiro-dsl-conformance." <> T.unpack context + +-- | Produce a collision-safe Cabal fragment. Ordinary lowercase Cabal names, +-- including hyphenated names, stay readable; every other spelling is encoded +-- character by character so @_@ and @-@ (and case) can never alias. +cabaliseConformanceService :: Text -> Text +cabaliseConformanceService service + | isCabalPackageName service, + T.toLower service == service = + service + | otherwise = "x-" <> T.intercalate "-" (map encodeCharacter (T.unpack service)) + where + encodeCharacter character = "c" <> T.pack (showHex (ord character) "") + +planConformancePackage :: ConformanceServiceKey -> RuntimePackageName -> Text -> CheckedService -> Either [ConformancePackageFailure] ConformancePackagePlan +planConformancePackage serviceKey runtimePackage facadeModule service + | not (safeServiceKey serviceKey) = Left [UnsafeConformanceServiceKey (serviceKeyText serviceKey)] + | not (null unsafePaths) = Left (map UnsafeConformancePath unsafePaths) + | not (null collisions) = Left (map ConformancePathCollision collisions) + | not (null duplicateFacts) = Left [PackageDuplicateFactKeys duplicateFacts] + | otherwise = Right plan + where + serviceName = serviceKeyText serviceKey + packageName = "keiro-" <> cabaliseConformanceService serviceName <> "-conformance" + packageDirectory = conformancePackageDirectory serviceKey + banner = generatedBannerFor (checkedLanguageContract service) ("conformance package " <> renderServiceKey serviceKey) + factValues = sortOn fst (serviceConformanceFactValues service) + duplicateFacts = duplicateKeys ActualFact [(T.unpack key, T.unpack value) | (key, value) <- factValues] + cabalPath = T.unpack packageName <> ".cabal" + baseFiles = + [ ConformanceFile cabalPath (renderCabal banner packageName runtimePackage serviceName) Generated, + ConformanceFile "src/Main.hs" (renderMain banner facadeModule) Generated, + ConformanceFile "src/KeiroConformance/Expectations.hs" (renderExpectations factValues) HoleStub + ] + recordRows = [(conformanceFileKind file, conformanceFilePath file) | file <- baseFiles] <> [(Generated, conformanceRecordFileName)] + record = + ConformancePackageRecord + { cprSchema = 1, + cprServiceKey = serviceKey, + cprRuntimePackage = runtimePackage, + cprFacadeModule = facadeModule, + cprFiles = recordRows + } + recordFile = ConformanceFile conformanceRecordFileName (banner <> "\n" <> renderConformancePackageRecord record) Generated + files = baseFiles <> [recordFile] + paths = packageDirectory : map conformanceFilePath files + unsafePaths = filter (not . safeRelativePath) paths + collisions = + [ entries + | entries <- Map.elems (Map.fromListWith (<>) [(T.toCaseFold (T.pack path), [path]) | path <- map conformanceFilePath files]), + length entries > 1 + ] + plan = + ConformancePackagePlan + { cppServiceKey = serviceKey, + cppDirectory = packageDirectory, + cppPackageName = packageName, + cppRuntimePackage = runtimePackage, + cppFacadeModule = facadeModule, + cppFiles = files + } + +renderCabal :: Text -> Text -> RuntimePackageName -> Text -> Text +renderCabal banner packageName runtimePackage serviceName = + T.unlines + [ "cabal-version: 3.0", + banner, + "name: " <> packageName, + "version: 0.0.0.0", + "synopsis: Generated conformance runner for Keiro service " <> serviceName, + "license: BSD-3-Clause", + "build-type: Simple", + "", + "test-suite conformance", + " type: exitcode-stdio-1.0", + " hs-source-dirs: src", + " main-is: Main.hs", + " other-modules: KeiroConformance.Expectations", + " build-depends:", + " base >=4.18 && <5", + " , " <> unRuntimePackageName runtimePackage, + " default-language: GHC2024", + " default-extensions: OverloadedStrings" + ] + +renderMain :: Text -> Text -> Text +renderMain banner facadeModule = + T.unlines + [ banner, + "module Main (main) where", + "", + "import Control.Monad (when)", + "import Data.List (group, groupBy, sort, sortOn)", + "import " <> facadeModule <> " (runServiceConformanceChecks, serviceConformanceFacts)", + "import KeiroConformance.Expectations (expectedServiceConformanceFacts)", + "import System.Exit (exitFailure)", + "", + "data FactResult", + " = FactMatch String String", + " | FactMismatch String String String", + " | FactMissing String String", + " | FactUnexpected String String", + "", + "newtype UniqueFactMap = UniqueFactMap [(String, String)]", + "", + "main :: IO ()", + "main = do", + " checks <- runServiceConformanceChecks", + " mapM_ renderCheck checks", + " case compareFacts expectedServiceConformanceFacts serviceConformanceFacts of", + " Left duplicates -> do", + " mapM_ (putStrLn . (\"FAIL duplicate conformance fact key: \" <>)) duplicates", + " exitFailure", + " Right facts -> do", + " mapM_ renderFact facts", + " when (any (not . snd) checks || any factFailed facts) exitFailure", + "", + "renderCheck :: (String, Bool) -> IO ()", + "renderCheck (key, passed) = putStrLn ((if passed then \"PASS \" else \"FAIL \") <> key)", + "", + "renderFact :: FactResult -> IO ()", + "renderFact result = putStrLn (case result of", + " FactMatch key _ -> \"PASS \" <> key", + " FactMismatch key expected actual -> \"FAIL \" <> key <> \" expected=\" <> show expected <> \" actual=\" <> show actual", + " FactMissing key expected -> \"FAIL \" <> key <> \" expected=\" <> show expected <> \" actual=\"", + " FactUnexpected key actual -> \"FAIL \" <> key <> \" expected= actual=\" <> show actual)", + "", + "factFailed :: FactResult -> Bool", + "factFailed FactMatch {} = False", + "factFailed _ = True", + "", + "compareFacts :: [(String, String)] -> [(String, String)] -> Either [String] [FactResult]", + "compareFacts expected actual = do", + " expectedMap <- uniqueFactMap \"expected\" expected", + " actualMap <- uniqueFactMap \"actual\" actual", + " pure [compareKey key expectedMap actualMap | key <- factKeys expectedMap actualMap]", + "", + "uniqueFactMap :: String -> [(String, String)] -> Either [String] UniqueFactMap", + "uniqueFactMap side facts =", + " case [side <> \"/\" <> fst first | entries@(first : _) <- groupBy sameKey (sortOn fst facts), length entries > 1] of", + " [] -> Right (UniqueFactMap (sortOn fst facts))", + " duplicates -> Left duplicates", + " where", + " sameKey left right = fst left == fst right", + "", + "factKeys :: UniqueFactMap -> UniqueFactMap -> [String]", + "factKeys (UniqueFactMap expected) (UniqueFactMap actual) = [key | key : _ <- group (sort (map fst expected <> map fst actual))]", + "", + "compareKey :: String -> UniqueFactMap -> UniqueFactMap -> FactResult", + "compareKey key (UniqueFactMap expected) (UniqueFactMap actual) =", + " case (lookup key expected, lookup key actual) of", + " (Just expectedValue, Just actualValue)", + " | expectedValue == actualValue -> FactMatch key actualValue", + " | otherwise -> FactMismatch key expectedValue actualValue", + " (Just expectedValue, Nothing) -> FactMissing key expectedValue", + " (Nothing, Just actualValue) -> FactUnexpected key actualValue", + " (Nothing, Nothing) -> error \"factKeys returned a key absent from both validated maps\"" + ] + +renderExpectations :: [(Text, Text)] -> Text +renderExpectations facts = + T.unlines $ + [ "-- Created once by keiro-dsl. This module is application-owned; review and edit it to accept conformance changes.", + "module KeiroConformance.Expectations (expectedServiceConformanceFacts) where", + "", + "expectedServiceConformanceFacts :: [(String, String)]" + ] + <> case facts of + [] -> ["expectedServiceConformanceFacts = []"] + _ -> + ["expectedServiceConformanceFacts ="] + <> [ (if index == (0 :: Int) then " [ " else " , ") <> "(" <> haskellString key <> ", " <> haskellString value <> ")" + | (index, (key, value)) <- zip [0 ..] facts + ] + <> [" ]"] + where + haskellString = T.pack . show . T.unpack + +renderConformancePackageRecord :: ConformancePackageRecord -> Text +renderConformancePackageRecord record = + T.unlines $ + [ "schema " <> tshow (cprSchema record), + "service-key " <> renderServiceKey (cprServiceKey record), + "runtime-package " <> unRuntimePackageName (cprRuntimePackage record), + "facade-module " <> cprFacadeModule record + ] + <> ["file " <> kindLabel fileKind <> " " <> T.pack path | (fileKind, path) <- cprFiles record] + where + kindLabel Generated = "generated" + kindLabel HoleStub = "create-once" + +parseConformancePackageRecord :: Text -> Maybe ConformancePackageRecord +parseConformancePackageRecord input = do + schema <- exactlyOne [value | ["schema", raw] <- rows, Just value <- [readInt raw]] + serviceKey <- exactlyOne [value | "service-key" : rest <- rows, Just value <- [parseServiceKey rest]] + runtimePackage <- exactlyOne [value | ["runtime-package", raw] <- rows, Right value <- [mkRuntimePackageName raw]] + facadeModule <- exactlyOne [value | ["facade-module", value] <- rows] + files <- traverse parseFile [row | row@(keyword : _) <- rows, keyword == "file"] + let knownRows = 4 + length files + if schema == 1 && knownRows == length rows && safeServiceKey serviceKey && safeFiles files + then + Just + ConformancePackageRecord + { cprSchema = schema, + cprServiceKey = serviceKey, + cprRuntimePackage = runtimePackage, + cprFacadeModule = facadeModule, + cprFiles = files + } + else Nothing + where + rows = [T.words line | line <- T.lines input, let stripped = T.strip line, not (T.null stripped), not (isGeneratedBannerLine stripped)] + parseServiceKey ["workspace", value] = Just (WorkspaceConformanceService value) + parseServiceKey ["standalone", value] = Just (StandaloneConformanceService value) + parseServiceKey _ = Nothing + parseFile ["file", "generated", path] = Just (Generated, T.unpack path) + parseFile ["file", "create-once", path] = Just (HoleStub, T.unpack path) + parseFile _ = Nothing + safeFiles files = + all (safeRelativePath . snd) files + && length files == Set.size (Set.fromList (map (T.toCaseFold . T.pack . snd) files)) + readInt raw = case reads (T.unpack raw) of + [(value, "")] -> Just value + _ -> Nothing + +preflightConformancePackage :: FilePath -> Bool -> ConformancePackagePlan -> IO (Either [ConformancePackageFailure] PreparedConformancePackage) +preflightConformancePackage out forceGeneratedOverwrite plan = do + bannerless <- if forceGeneratedOverwrite then pure [] else missingPackageBanners root (cppFiles plan) + previousResult <- readPreviousRecord root forceGeneratedOverwrite bannerless plan + case [ConformanceGeneratedBannerMissing (map (cppDirectory plan ) bannerless) | not (null bannerless)] <> either id (const []) previousResult of + failures@(_ : _) -> pure (Left failures) + [] -> do + let previous = either (const Nothing) id previousResult + stale <- maybe (pure []) (stalePackageFiles root (map conformanceFilePath (cppFiles plan))) previous + pure (Right PreparedConformancePackage {preparedRoot = root, preparedPlan = plan, preparedStale = stale}) + where + root = out cppDirectory plan + +readPreviousRecord :: FilePath -> Bool -> [FilePath] -> ConformancePackagePlan -> IO (Either [ConformancePackageFailure] (Maybe ConformancePackageRecord)) +readPreviousRecord root forceGeneratedOverwrite bannerless plan = do + let path = root conformanceRecordFileName + exists <- doesFileExist path + if not exists || conformanceRecordFileName `elem` bannerless || forceGeneratedOverwrite + then pure (Right Nothing) + else do + parsed <- parseConformancePackageRecord <$> TIO.readFile path + pure $ case parsed of + Nothing -> Left [InvalidConformancePackageRecord (cppDirectory plan conformanceRecordFileName)] + Just record + | cprServiceKey record == cppServiceKey plan -> Right (Just record) + | otherwise -> Left [ConformancePackageRecordMismatch (cppDirectory plan conformanceRecordFileName)] + +missingPackageBanners :: FilePath -> [ConformanceFile] -> IO [FilePath] +missingPackageBanners root files = fmap concat . forM generated $ \file -> do + let path = root conformanceFilePath file + exists <- doesFileExist path + if not exists + then pure [] + else do + contents <- TIO.readFile path + pure [conformanceFilePath file | not (any isGeneratedBannerLine (T.lines contents))] + where + generated = [file | file <- files, conformanceFileKind file == Generated] + +stalePackageFiles :: FilePath -> [FilePath] -> ConformancePackageRecord -> IO [ConformanceStaleFile] +stalePackageFiles root current record = fmap concat . forM removed $ \(fileKind, path) -> do + exists <- doesFileExist (root path) + if not exists + then pure [] + else do + evidence <- case fileKind of + HoleStub -> pure Nothing + Generated -> do + contents <- TIO.readFile (root path) + pure (Just (any isGeneratedBannerLine (T.lines contents))) + pure [ConformanceStaleFile fileKind path evidence] + where + currentSet = Set.fromList current + removed = [(fileKind, path) | (fileKind, path) <- cprFiles record, path `Set.notMember` currentSet] + +executePreparedConformancePackage :: PreparedConformancePackage -> IO ConformancePackageReport +executePreparedConformancePackage prepared = do + dispositions <- traverse (writeConformanceFile (preparedRoot prepared)) (cppFiles plan) + pure + ConformancePackageReport + { conformanceReportRoot = preparedRoot prepared, + conformanceReportPlan = plan, + conformanceReportDispositions = dispositions, + conformanceReportStale = preparedStale prepared + } + where + plan = preparedPlan prepared + +writeConformanceFile :: FilePath -> ConformanceFile -> IO (ConformanceFile, ConformanceWriteDisposition) +writeConformanceFile root file = do + let path = root conformanceFilePath file + exists <- doesFileExist path + case conformanceFileKind file of + HoleStub + | exists -> pure (file, ConformanceSkipped) + | otherwise -> write path ConformanceCreated + Generated + | exists -> do + existing <- TIO.readFile path + if existing == conformanceFileText file + then pure (file, ConformanceUnchanged) + else write path ConformanceOverwritten + | otherwise -> write path ConformanceCreated + where + write path disposition = do + createDirectoryIfMissing True (takeDirectory path) + TIO.writeFile path (conformanceFileText file) + pure (file, disposition) + +compareConformanceFacts :: [(String, String)] -> [(String, String)] -> Either [DuplicateFactKey] [ConformanceFactResult] +compareConformanceFacts expected actual = + case duplicateKeys ExpectedFact expected <> duplicateKeys ActualFact actual of + duplicates@(_ : _) -> Left duplicates + [] -> Right (map compareKey allKeys) + where + expectedMap = Map.fromList expected + actualMap = Map.fromList actual + allKeys = Set.toAscList (Map.keysSet expectedMap <> Map.keysSet actualMap) + compareKey key = case (Map.lookup key expectedMap, Map.lookup key actualMap) of + (Just expectedValue, Just actualValue) + | expectedValue == actualValue -> ConformanceFactMatch key actualValue + | otherwise -> ConformanceFactMismatch key expectedValue actualValue + (Just expectedValue, Nothing) -> ConformanceFactMissing key expectedValue + (Nothing, Just actualValue) -> ConformanceFactUnexpected key actualValue + (Nothing, Nothing) -> error "compareConformanceFacts union key missing from both maps" + +duplicateKeys :: ConformanceFactSide -> [(String, String)] -> [DuplicateFactKey] +duplicateKeys side facts = + [ DuplicateFactKey side key + | entries@((key, _) : _) <- groupBy (\left right -> fst left == fst right) (sortOn fst facts), + length entries > 1 + ] + +renderConformancePackageFailure :: ConformancePackageFailure -> [Text] +renderConformancePackageFailure = \case + UnsafeConformanceServiceKey key -> ["error: unsafe conformance service key '" <> key <> "' -- refusing to scaffold; nothing was written"] + UnsafeConformancePath path -> ["error: unsafe conformance package path -- refusing to scaffold; nothing was written", " " <> T.pack path] + ConformancePathCollision paths -> ["error: conformance package path collision -- refusing to scaffold; nothing was written"] <> map (" " <>) (map T.pack paths) + PackageDuplicateFactKeys duplicates -> + ["error: duplicate conformance fact keys -- refusing to scaffold; nothing was written"] + <> [" " <> sideLabel (duplicateFactSide duplicate) <> "/" <> T.pack (duplicateFactKey duplicate) | duplicate <- duplicates] + ConformanceGeneratedBannerMissing paths -> + ["error: refusing to overwrite generated conformance package files without a recognized '-- @generated' banner"] + <> map (" " <>) (map T.pack paths) + <> ["nothing was written"] + InvalidConformancePackageRecord path -> ["error: invalid generated conformance package record -- refusing to scaffold; nothing was written", " " <> T.pack path] + ConformancePackageRecordMismatch path -> ["error: conformance package record belongs to a different service -- refusing to scaffold; nothing was written", " " <> T.pack path] + where + sideLabel ExpectedFact = "expected" + sideLabel ActualFact = "actual" + +renderConformancePackageReport :: ConformancePackageReport -> [Text] +renderConformancePackageReport report = + [ "conformance-package: " <> T.pack cabalPath, + "conformance-target: cabal test " <> cppPackageName plan + ] + <> [ "conformance-file: " <> T.pack (root conformanceFilePath file) <> " " <> dispositionTag disposition + | (file, disposition) <- dispositions, + conformanceFileKind file == Generated, + conformanceFilePath file /= conformanceRecordFileName + ] + <> ["expectations: " <> T.pack (root conformanceFilePath file) <> " " <> dispositionTag disposition | (file, disposition) <- dispositions, conformanceFileKind file == HoleStub] + <> ["conformance-record: " <> T.pack (root conformanceRecordFileName) <> " " <> dispositionTag disposition | (file, disposition) <- dispositions, conformanceFilePath file == conformanceRecordFileName] + <> staleLines + where + plan = conformanceReportPlan report + root = conformanceReportRoot report + dispositions = conformanceReportDispositions report + cabalPath = root T.unpack (cppPackageName plan) <> ".cabal" + dispositionTag ConformanceCreated = "(created)" + dispositionTag ConformanceOverwritten = "(overwritten)" + dispositionTag ConformanceSkipped = "(skipped: already present)" + dispositionTag ConformanceUnchanged = "(unchanged)" + staleLines = case conformanceReportStale report of + [] -> [] + stale -> + ["conformance-stale: " <> tshow (length stale) <> " file(s) are no longer produced; keiro-dsl never deletes files."] + <> [" " <> staleKindLabel (conformanceStaleKind file) <> " " <> T.pack (root conformanceStalePath file) <> staleEvidence file | file <- stale] + staleKindLabel Generated = "generated" + staleKindLabel HoleStub = "create-once" + staleEvidence file = case conformanceStaleBannerPresent file of + Nothing -> " (hand-owned; preserve and review)" + Just True -> " (recognized generated banner present; review before deleting)" + Just False -> " (generated banner missing; preserve and review)" + +safeServiceKey :: ConformanceServiceKey -> Bool +safeServiceKey key = case T.uncons (serviceKeyText key) of + Nothing -> False + Just (first, rest) -> asciiAlphaNum first && T.all wireCharacter rest + where + asciiAlphaNum character = isAscii character && isAlphaNum character + wireCharacter character = asciiAlphaNum character || character == '_' || character == '-' + +safeRelativePath :: FilePath -> Bool +safeRelativePath path = + not (null path) + && not (isAbsolute path) + && all (\component -> component /= ".." && component /= "." && not (null component)) (splitDirectories path) + +serviceKeyText :: ConformanceServiceKey -> Text +serviceKeyText (WorkspaceConformanceService service) = service +serviceKeyText (StandaloneConformanceService context) = context + +renderServiceKey :: ConformanceServiceKey -> Text +renderServiceKey (WorkspaceConformanceService service) = "workspace " <> service +renderServiceKey (StandaloneConformanceService context) = "standalone " <> context + +exactlyOne :: [a] -> Maybe a +exactlyOne [value] = Just value +exactlyOne _ = Nothing + +tshow :: (Show a) => a -> Text +tshow = T.pack . show diff --git a/src/Keiro/Dsl/GeneratedHaskellLanguage.hs b/src/Keiro/Dsl/GeneratedHaskellLanguage.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/GeneratedHaskellLanguage.hs @@ -0,0 +1,48 @@ +-- | The Haskell language contract for overwriteable generated modules. +-- +-- The manifest and conformance build profile publish the shared baseline. +-- Syntax outside that baseline must be requested through the closed extension +-- type and rendered as a module-local pragma. +module Keiro.Dsl.GeneratedHaskellLanguage + ( GeneratedHaskellExtension (..), + generatedHaskellDefaultLanguage, + generatedHaskellDefaultExtensions, + renderGeneratedLanguagePragmas, + ) +where + +import Data.List (nub, sort) +import Data.Text (Text) + +data GeneratedHaskellExtension + = ExtBlockArguments + | ExtDeriveAnyClass + | ExtDuplicateRecordFields + | ExtOverloadedLabels + | ExtOverloadedRecordDot + | ExtQualifiedDo + | ExtTemplateHaskell + | ExtTypeFamilies + deriving (Eq, Ord, Show) + +generatedHaskellDefaultLanguage :: Text +generatedHaskellDefaultLanguage = "GHC2024" + +generatedHaskellDefaultExtensions :: [Text] +generatedHaskellDefaultExtensions = ["OverloadedStrings"] + +renderGeneratedLanguagePragmas :: [GeneratedHaskellExtension] -> [Text] +renderGeneratedLanguagePragmas = map renderPragma . sort . nub . map extensionName + where + renderPragma name = "{-# LANGUAGE " <> name <> " #-}" + +extensionName :: GeneratedHaskellExtension -> Text +extensionName extension = case extension of + ExtBlockArguments -> "BlockArguments" + ExtDeriveAnyClass -> "DeriveAnyClass" + ExtDuplicateRecordFields -> "DuplicateRecordFields" + ExtOverloadedLabels -> "OverloadedLabels" + ExtOverloadedRecordDot -> "OverloadedRecordDot" + ExtQualifiedDo -> "QualifiedDo" + ExtTemplateHaskell -> "TemplateHaskell" + ExtTypeFamilies -> "TypeFamilies" 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 @@ -30,6 +30,9 @@ harnessRouter, harnessReadModel, harnessWorkflow, + processHarnessFactValues, + routerHarnessFactValues, + workflowHarnessFactValues, ) where @@ -40,8 +43,10 @@ import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.AggregateType +import Keiro.Dsl.GeneratedHaskellLanguage import Keiro.Dsl.Goldens (GoldenPayload (..)) import Keiro.Dsl.Grammar +import Keiro.Dsl.HaskellImport import Keiro.Dsl.IdDomain (idDomainContractFor, idDomainSampleText) import Keiro.Dsl.NominalType import Keiro.Dsl.ReadModelShape (deriveShapeHash, registryNameFor, subscriptionNameFor) @@ -127,26 +132,29 @@ emitRouterHarness :: Text -> RouterNode -> Text emitRouterHarness genPrefix router = - nl + nl $ [ generatedBanner, "module " <> genPrefix <> ".RouterHarness (routerHarnessValues) where", "", "routerHarnessValues :: [(String, String)]", - "routerHarnessValues =", - " [ (\"routerName\", " <> hs (rtName router) <> ")", - " , (\"keyField\", " <> hs (corrField (rtKey router)) <> ")", - " , (\"resolveSource\", " <> hs resolveSource <> ")", - " , (\"resolveRow\", " <> hs (T.intercalate "," (rvRow (rtResolve router))) <> ")", - " , (\"dispatchCommand\", " <> hs (rdCommand dispatch) <> ")", - " , (\"dispatchIdInputs\", \"(name, key, sourceEventId, targetStreamName, occurrence)\")", - " , (\"onDuplicate\", " <> hs (showDisp (onDuplicate disposition)) <> ")", - " , (\"onFailed\", " <> hs (showDisp (onFailed disposition)) <> ")", - " , (\"rejectedPolicy\", " <> hs (showPolicy (rtRejected router)) <> ")", - " , (\"poisonPolicy\", " <> hs (showPolicy (rtPoison router)) <> ")", - " ]" + "routerHarnessValues =" ] + <> renderFactValues (routerHarnessFactValues router) + +routerHarnessFactValues :: RouterNode -> [(Text, Text)] +routerHarnessFactValues router = + [ ("routerName", rtName router), + ("keyField", corrField (rtKey router)), + ("resolveSource", resolveSource), + ("resolveRow", T.intercalate "," (rvRow (rtResolve router))), + ("dispatchCommand", rdCommand dispatch), + ("dispatchIdInputs", "(name, key, sourceEventId, targetStreamName, occurrence)"), + ("onDuplicate", showDisp (onDuplicate disposition)), + ("onFailed", showDisp (onFailed disposition)), + ("rejectedPolicy", showPolicy (rtRejected router)), + ("poisonPolicy", showPolicy (rtPoison router)) + ] where - hs = tshow dispatch = rtDispatch router disposition = rdDisposition dispatch resolveSource = case rvSource (rtResolve router) of @@ -173,7 +181,7 @@ emitReadModelHarness genPrefix ctx readModel = nl [ generatedBanner, - "module " <> genPrefix <> ".ReadModelHarness (readModelFacts, runReadModelFacts) where", + "module " <> genPrefix <> ".ReadModelHarness (readModelFacts, readModelFactResults, runReadModelFacts) where", "", "-- | (fact, expected from notation, actual shared derivation/lowering).", "readModelFacts :: [(String, String, String)]", @@ -186,6 +194,10 @@ " , (\"strongScope\", " <> tshow scope <> ", " <> tshow scope <> ")", " ]", "", + "readModelFactResults :: [(String, Bool)]", + "readModelFactResults =", + " [(fact, expected == actual) | (fact, expected, actual) <- readModelFacts]", + "", "runReadModelFacts :: IO Bool", "runReadModelFacts = do", " let failures = [(fact, expected, actual) | (fact, expected, actual) <- readModelFacts, expected /= actual]", @@ -215,7 +227,7 @@ emitProcessHarness :: Text -> ProcessNode -> Text emitProcessHarness genPrefix p = - nl + nl $ [ generatedBanner, "module " <> genPrefix <> ".ProcessHarness (processHarnessValues) where", "", @@ -226,24 +238,27 @@ "-- 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)) <> ")", - " , (\"timerIdPrefix\", " <> hs (idePrefix (tmId timer)) <> ")", - " , (\"firedEventIdPrefix\", " <> hs (idePrefix (fireFiredEventId timer')) <> ")", - " , (\"dispatchIdUserField\", \"none\")", - " , (\"onReject\", " <> hs (showFireOutcome (onReject fd)) <> ")", - " , (\"onAmbiguous\", " <> hs (showFireOutcome (onAmbiguous fd)) <> ")", - " , (\"onFailed\", " <> hs (showDisp (onFailed (firstDispDisposition p))) <> ")", - " , (\"rejectedPolicy\", " <> hs (showPolicy (procRejected p)) <> ")", - " , (\"poisonPolicy\", " <> hs (showPolicy (procPoison p)) <> ")", - " , (\"maxAttempts\", " <> hs (tInt (tmMaxAttempts timer)) <> ")", - " ]" + "processHarnessValues =" ] + <> renderFactValues (processHarnessFactValues p) + +processHarnessFactValues :: ProcessNode -> [(Text, Text)] +processHarnessFactValues p = + [ ("fireAtField", faField (tmFireAt timer)), + ("timerIdPrefix", idePrefix (tmId timer)), + ("firedEventIdPrefix", idePrefix (fireFiredEventId timer')), + ("dispatchIdUserField", "none"), + ("onReject", showFireOutcome (onReject fd)), + ("onAmbiguous", showFireOutcome (onAmbiguous fd)), + ("onFailed", showDisp (onFailed (firstDispDisposition p))), + ("rejectedPolicy", showPolicy (procRejected p)), + ("poisonPolicy", showPolicy (procPoison p)), + ("maxAttempts", tInt (tmMaxAttempts timer)) + ] where timer = procTimer p timer' = tmFire timer fd = fireDisposition timer' - hs = tshow firstDispDisposition :: ProcessNode -> DispatchDisposition firstDispDisposition p = case hDispatch (procHandle p) of @@ -300,7 +315,7 @@ emitWorkflowFacts genPrefix w = nl [ generatedBanner, - "module " <> genPrefix <> ".WorkflowFacts (WorkflowFacts (..), workflowFacts) where", + "module " <> genPrefix <> ".WorkflowFacts (WorkflowFacts (..), workflowFacts, workflowFactValues) where", "", "-- | The workflow's deterministic decisions, pinned as typed pure facts.", "-- A driver asserts them against a hand-written expectation, so a spec", @@ -324,7 +339,18 @@ " , workflowFactBody = " <> stringList (map bodyTag (wfBody w)), " , workflowFactAwaitLabels = " <> stringList (workflowAwaitLabels (wfBody w)), " , workflowFactPatchIds = " <> stringList (workflowPatchIds (wfBody w)), - " }" + " }", + "", + "-- | Base-library projection used by the service-level conformance facade.", + "workflowFactValues :: [(String, String)]", + "workflowFactValues =", + " [ (\"name\", workflowFactName workflowFacts)", + " , (\"idVia\", workflowFactIdVia workflowFacts)", + " , (\"idField\", workflowFactIdField workflowFacts)", + " , (\"body\", show (workflowFactBody workflowFacts))", + " , (\"awaits\", show (workflowFactAwaitLabels workflowFacts))", + " , (\"patches\", show (workflowFactPatchIds workflowFacts))", + " ]" ] where hs = tshow @@ -336,6 +362,30 @@ bodyTag (WfPatch patchId items _) = "patch:" <> patchId <> "(" <> T.intercalate "," (map bodyTag items) <> ")" bodyTag (WfContinueAsNew seedType _) = "continueAsNew:" <> seedType +workflowHarnessFactValues :: WorkflowNode -> [(Text, Text)] +workflowHarnessFactValues workflow = + [ ("name", wfStable workflow), + ("idVia", wfIdVia workflow), + ("idField", maybe "input" id (wfIdField workflow)), + ("body", T.pack (show (map (T.unpack . bodyTag) (wfBody workflow)))), + ("awaits", T.pack (show (map T.unpack (workflowAwaitLabels (wfBody workflow))))), + ("patches", T.pack (show (map T.unpack (workflowPatchIds (wfBody workflow))))) + ] + where + bodyTag (WfStep label _ _) = "step:" <> label + bodyTag (WfAwait label _ _) = "await:" <> label + bodyTag (WfSleep label _ _) = "sleep:" <> label + bodyTag (WfChild label _ _ _) = "child:" <> label + bodyTag (WfPatch patchId items _) = "patch:" <> patchId <> "(" <> T.intercalate "," (map bodyTag items) <> ")" + bodyTag (WfContinueAsNew seedType _) = "continueAsNew:" <> seedType + +renderFactValues :: [(Text, Text)] -> [Text] +renderFactValues facts = + [ (if index == (0 :: Int) then " [ " else " , ") <> "(" <> tshow label <> ", " <> tshow value <> ")" + | (index, (label, value)) <- zip [0 ..] facts + ] + <> [" ]"] + -- | Emit the workflow's deterministic id derivation compiled against the LIVE -- @Keiro.Workflow@: the 'WorkflowName' and the awakeable-id function (the actual -- 'deterministicAwakeableId'). A signal operation deriving the SAME (name, id, @@ -401,24 +451,12 @@ emitHarness :: [GoldenPayload] -> Agg -> Text emitHarness goldens a = nl $ - [ "{-# LANGUAGE DataKinds #-}", - "{-# LANGUAGE OverloadedLabels #-}" - ] - ++ ["{-# LANGUAGE TypeApplications #-}" | hasMappedHarness a] + renderGeneratedLanguagePragmas [ExtOverloadedLabels | not (null replayTransitions) && not (null (aRegs a))] ++ [ generatedBanner, "module " <> aGenPrefix a <> ".Harness (harnessAssertions) where", - "", - "import " <> aGenPrefix a <> ".Domain", - "import " <> aGenPrefix a <> ".Codec (encode" <> nm <> "Event, parse" <> nm <> "Event" <> codecValueImport <> mappedCodecHarnessExports a <> ")", - transducerImport a, - "import Keiki.Core (" <> T.intercalate ", " coreImports <> ")", - codecDecodeRawImport + "" ] - ++ generatedNominalTypeImportsForService (aggregateCheckedService a) (aContext a) (generatedNominalHarnessTypes a) - ++ mappedHarnessImports a - ++ nominalHarnessImports a - ++ aggregateHarnessImports a - ++ goldenImports + ++ harnessImports ++ [ "", "-- | (label, passed). A driver runs these and exits non-zero on any False,", "-- naming the failing assertion. Filling a hole wrongly turns a specific", @@ -491,6 +529,20 @@ "import Data.Text.Encoding (encodeUtf8)" ] else [] + harnessImports = + unique $ + [ "import " <> aGenPrefix a <> ".Domain", + "import " <> aGenPrefix a <> ".Codec (encode" <> nm <> "Event, parse" <> nm <> "Event" <> codecValueImport <> mappedCodecHarnessExports a <> ")", + transducerImport a, + "import Keiki.Core (" <> T.intercalate ", " coreImports <> ")", + codecDecodeRawImport + ] + ++ generatedNominalTypeImportsForService (aggregateCheckedService a) (aContext a) (generatedNominalHarnessTypes a) + ++ mappedHarnessImports a + ++ nominalHarnessImports a + ++ aggregateHarnessImports a + ++ T.lines (renderPlannedImports (harnessImportPlan a)) + ++ goldenImports upcastLabel event source = case goldenFor goldens event of @@ -679,11 +731,14 @@ where fallback = sampleValue aggregate fieldName fieldType matchesRegister register = rrName register == fieldName && rrType register == fieldType - regInitialValueForHarness owner register = case rrType register of - AggregateNominal nominal -> case resolvedNominalOwnership nominal of - ConsumerNominal {} -> renderRegisterInitial (rrInitial register) - GeneratedNominal -> fromMaybe (renderRegisterInitial (rrInitial register)) (generatedIdSampleHaskell owner nominal) - _ -> renderRegisterInitial (rrInitial register) + regInitialValueForHarness owner register = case rrInitial register of + InitialNominal _ value -> renderHarnessReference owner (harnessQualifiedValueReference value) + InitialMapped _ value -> renderHarnessReference owner (harnessQualifiedValueReference value) + _ -> case rrType register of + AggregateNominal nominal -> case resolvedNominalOwnership nominal of + ConsumerNominal {} -> renderRegisterInitial (rrInitial register) + GeneratedNominal -> fromMaybe (renderRegisterInitial (rrInitial register)) (generatedIdSampleHaskell owner nominal) + _ -> renderRegisterInitial (rrInitial register) guardEquatesCommandAndRegister :: Transition -> Text -> Bool guardEquatesCommandAndRegister transition fieldName = maybe False containsEquality (tGuard transition) @@ -703,13 +758,18 @@ | GeneratedNominal <- resolvedNominalOwnership nominal, Just sample <- generatedIdSampleHaskell a nominal -> sample + AggregateNominal nominal + | ConsumerNominal binding <- resolvedNominalOwnership nominal -> + "(nominalFixtureDomain (NonEmpty.head (nominalFixtureCases " + <> renderHarnessReference a (harnessQualifiedValueReference (consumerNominalFixtures binding)) + <> ")))" _ -> fallback where fallback = case fieldCat a ty of IdCat -> aggregateSampleHaskell (aSymbols a) fieldName ty EnumCat -> aggregateSampleHaskell (aSymbols a) fieldName ty - MappedStructuralCat declaration _ -> fixtureSample (sdFixtures declaration) - MappedOpaqueCat declaration -> fixtureSample (odFixtures declaration) + MappedStructuralCat declaration _ -> fixtureSample a (sdFixtures declaration) + MappedOpaqueCat declaration -> fixtureSample a (odFixtures declaration) OtherCat -> case ty of AggregateVertex vertexType | vertexType == aVertexType a -> initialVertex a @@ -721,7 +781,7 @@ [ "import " <> imported | resolvedType <- map snd (concatMap rcFields (aCommands aggregate <> aEvents aggregate)), AggregateTime <- [resolvedType], - imported <- Set.toAscList (aggregateImports (aSymbols aggregate) resolvedType) + imported <- Set.toAscList (aggregateSourceStaticImports (aggregateConsumerHaskellSource (aSymbols aggregate) resolvedType)) ] nominalHarnessImports :: Agg -> [Text] @@ -735,20 +795,10 @@ then [] else ["import Data.KindID qualified as KindID", "import Data.Text qualified as T", "import Keiro.Codec.IdDomain (typeIdV7Domain, validateIdDomainText)"] ) - <> ["import " <> moduleName <> " qualified" | moduleName <- unique (fixtureModules <> bindingModules)] <> ["import " <> nominalProjectionModule (aContext aggregate) <> " qualified as NominalProjections" | not (null (nominalScalarHarnessTypes aggregate)) || not (null enforcedIds)] where nominals = consumerNominalHarnessTypes aggregate enforcedIds = enforcedConsumerNominalIdHarnessTypes aggregate - bindings = [binding | nominal <- nominals, ConsumerNominal binding <- [resolvedNominalOwnership nominal]] - fixtureModules = - [ fst (splitQualifiedHarness (unQualifiedValueName (consumerNominalFixtures binding))) - | binding <- bindings - ] - bindingModules = - [ fst (splitQualifiedHarness (unQualifiedValueName (consumerNominalBinding binding))) - | binding <- bindings - ] hasNominalHarness :: Agg -> Bool hasNominalHarness = not . null . consumerNominalHarnessTypes @@ -817,8 +867,8 @@ <> idDomainAssertions name bindingName fixtures nominal where name = resolvedNominalName nominal - bindingName = unQualifiedValueName (consumerNominalBinding binding) - fixtureName = unQualifiedValueName (consumerNominalFixtures binding) + bindingName = renderHarnessReference aggregate (harnessQualifiedValueReference (consumerNominalBinding binding)) + fixtureName = renderHarnessReference aggregate (harnessQualifiedValueReference (consumerNominalFixtures binding)) fixtures = "(NonEmpty.toList (nominalFixtureCases " <> fixtureName <> "))" idDomainAssertions name bindingName fixtures nominal = case resolvedNominalRepresentation nominal of IdRepresentation prefix @@ -891,23 +941,9 @@ "import Keiki.Shape (CanonicalTypeName (..))", "import Keiro.Codec.Structural (FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, bindingToShape)" ] - ++ map (\moduleName -> "import " <> moduleName <> " qualified") (unique (modules <> bindingModules <> shapeModules <> consumerModules)) ++ ["import " <> structuralProjectionModuleName (aContext aggregate) <> " qualified as StructuralProjections" | not (null (mappedProjectionSpecs aggregate))] where fixtures = [mappedFixtures declaration | declaration <- mappedHarnessDeclarationsResolved aggregate] - modules = unique [fst (splitQualifiedHarness (unQualifiedValueName qualified)) | qualified <- fixtures] - bindingModules = - [ fst (splitQualifiedHarness (unQualifiedValueName (sdBinding declaration))) - | ResolvedStructural declaration _ <- mappedHarnessDeclarationsResolved aggregate - ] - shapeModules = - [ structuralShapeModuleName (aContext aggregate) (sdName declaration) - | ResolvedStructural declaration _ <- mappedHarnessDeclarationsResolved aggregate - ] - consumerModules = - [ hsModule (sdHaskell declaration) - | ResolvedStructural declaration _ <- mappedHarnessDeclarationsResolved aggregate - ] mappedCodecHarnessExports :: Agg -> Text mappedCodecHarnessExports aggregate = @@ -916,15 +952,131 @@ | ResolvedStructural declaration _ <- codecMappedDeclarations aggregate ] -fixtureSample :: QualifiedValueName -> Text -fixtureSample qualified = - "(snd (NonEmpty.head (fixtureCases " <> unQualifiedValueName qualified <> ")))" +fixtureSample :: Agg -> QualifiedValueName -> Text +fixtureSample aggregate qualified = + "(snd (NonEmpty.head (fixtureCases " <> renderHarnessReference aggregate (harnessQualifiedValueReference qualified) <> ")))" splitQualifiedHarness :: Text -> (Text, Text) splitQualifiedHarness value = let (prefix, name) = T.breakOnEnd "." value in (T.dropEnd 1 prefix, name) +harnessImportPlan :: Agg -> HaskellImportPlan +harnessImportPlan aggregate = + either + (error . ("validated harness import planning failed: " <>) . show) + id + ( planHaskellImports + ImportEnvironment + { targetModule = aGenPrefix aggregate <> ".Harness", + localNames = + Set.fromList + [ aName aggregate <> "Command", + aName aggregate <> "Event", + aName aggregate <> "Regs", + aVertexType aggregate + ], + reservedQualifiers = harnessReservedQualifiers + } + references + ) + where + resolvedTypes = + map snd (concatMap rcFields (aCommands aggregate <> aEvents aggregate)) + <> map rrType (aRegs aggregate) + aggregateReferences = + Set.unions + [ aggregateSourceReferences (aggregateConsumerHaskellSource (aSymbols aggregate) resolvedType) + | resolvedType <- resolvedTypes + ] + consumerNominalReferences = + Set.fromList + [ reference + | nominal <- consumerNominalHarnessTypes aggregate, + ConsumerNominal binding <- [resolvedNominalOwnership nominal], + reference <- + harnessTypeReference (consumerNominalHaskell binding) + : map + harnessQualifiedValueReference + ( consumerNominalBinding binding + : consumerNominalFixtures binding + : maybeToListHarness (consumerNominalInitial binding) + ) + ] + mappedReferences = + Set.fromList + [ reference + | declaration <- mappedHarnessDeclarationsResolved aggregate, + reference <- case declaration of + ResolvedStructural structural _ -> + harnessTypeReference (sdHaskell structural) + : map + harnessQualifiedValueReference + (sdBinding structural : sdFixtures structural : maybeToListHarness (sdInitial structural)) + ResolvedOpaque opaque -> + harnessTypeReference (odHaskell opaque) + : map + harnessQualifiedValueReference + (odFixtures opaque : maybeToListHarness (odInitial opaque)) + ] + shapeReferences = + Set.fromList + [ reference + | ResolvedStructural declaration shape <- mappedHarnessDeclarationsResolved aggregate, + reference <- structuralShapeHarnessReferences (aContext aggregate) declaration shape + ] + projectionReferences = + Set.fromList + [ HaskellReference shapeModule selector ValueNamespace RequireQualified + | projection <- mappedProjectionSpecs aggregate, + (shapeModule, selector) <- spSelectors projection + ] + references = aggregateReferences <> consumerNominalReferences <> mappedReferences <> shapeReferences <> projectionReferences + +harnessTypeReference :: HaskellSource -> HaskellReference +harnessTypeReference source = + HaskellReference (hsModule source) (hsType source) TypeNamespace PreferUnqualified + +harnessQualifiedValueReference :: QualifiedValueName -> HaskellReference +harnessQualifiedValueReference qualified = + HaskellReference moduleName valueName ValueNamespace RequireQualified + where + (moduleName, valueName) = splitQualifiedHarness (unQualifiedValueName qualified) + +structuralShapeHarnessReferences :: Context -> StructuralDecl -> ResolvedMappedShape -> [HaskellReference] +structuralShapeHarnessReferences context declaration = + foldMappedShape + MappedShapeAlgebra + { onRecord = \constructor _ fields -> constructorRef constructor : map (valueRef . rwfHaskell) fields, + onEnum = map (constructorRef . weCtor), + onUnion = \_ -> map (constructorRef . rwaCtor) + } + where + moduleName = structuralShapeModuleName context (sdName declaration) + constructorRef constructor = HaskellReference moduleName constructor ConstructorNamespace RequireQualified + valueRef value = HaskellReference moduleName value ValueNamespace RequireQualified + +renderHarnessReference :: Agg -> HaskellReference -> Text +renderHarnessReference aggregate reference = + either + (error . ("validated harness reference failed: " <>) . show) + id + (renderPlannedReference (harnessImportPlan aggregate) reference) + +harnessReservedQualifiers :: Set.Set Text +harnessReservedQualifiers = + Set.fromList + [ "Aeson", + "AesonKey", + "AesonKeyMap", + "KindID", + "Map", + "NominalProjections", + "NonEmpty", + "StructuralProjections", + "T" + ] + unique :: (Eq value) => [value] -> [value] unique = foldr (\value values -> if value `elem` values then values else value : values) [] @@ -1017,7 +1169,7 @@ Map.lookup key (tgDeclarations graph) bindingAssertionDecl :: Agg -> (StructuralDecl, ResolvedMappedShape) -> [Text] -bindingAssertionDecl _aggregate (declaration, _shape) = +bindingAssertionDecl aggregate (declaration, _shape) = [ "", valueName <> " :: [(String, Bool)]", valueName <> " =", @@ -1035,12 +1187,12 @@ where valueName = lowerFirst (sdName declaration) <> "BindingAssertions" canonical = unCanonicalTypeId (sdCanonical declaration) - consumerType = hsModule (sdHaskell declaration) <> "." <> hsType (sdHaskell declaration) - binding = unQualifiedValueName (sdBinding declaration) - fixtures = unQualifiedValueName (sdFixtures declaration) + consumerType = renderHarnessReference aggregate (harnessTypeReference (sdHaskell declaration)) + binding = renderHarnessReference aggregate (harnessQualifiedValueReference (sdBinding declaration)) + fixtures = renderHarnessReference aggregate (harnessQualifiedValueReference (sdFixtures declaration)) opaqueAssertionDecl :: Agg -> OpaqueDecl -> [Text] -opaqueAssertionDecl _aggregate declaration = +opaqueAssertionDecl aggregate declaration = [ "", valueName <> " :: [(String, Bool)]", valueName <> " =", @@ -1054,7 +1206,7 @@ where valueName = lowerFirst (odName declaration) <> "OpaqueAssertions" label = unCodecIdentity (odCodecIdentity declaration) <> "@" <> unCodecVersion (odCodecVersion declaration) - fixtures = unQualifiedValueName (odFixtures declaration) + fixtures = renderHarnessReference aggregate (harnessQualifiedValueReference (odFixtures declaration)) coverageDecl :: Agg -> (StructuralDecl, ResolvedMappedShape) -> [Text] coverageDecl aggregate (declaration, shape) = @@ -1069,31 +1221,31 @@ _ -> T.intercalate " && " obligations <> "\n where\n shapes = map (bindingToShape " <> binding <> " . snd) (NonEmpty.toList (fixtureCases " <> fixtures <> "))" where shapeModule = structuralShapeModuleName (aContext aggregate) (sdName declaration) - binding = unQualifiedValueName (sdBinding declaration) - fixtures = unQualifiedValueName (sdFixtures declaration) + binding = renderHarnessReference aggregate (harnessQualifiedValueReference (sdBinding declaration)) + fixtures = renderHarnessReference aggregate (harnessQualifiedValueReference (sdFixtures declaration)) obligations = case shape of - RRecord _ _ fields -> concatMap (recordFieldObligation shapeModule) fields + RRecord _ _ fields -> concatMap (recordFieldObligation aggregate shapeModule) fields REnum entries -> - [ "any (\\case " <> shapeModule <> "." <> weCtor entry <> " -> True; _ -> False) shapes" + [ "any (\\case " <> renderHarnessReference aggregate (HaskellReference shapeModule (weCtor entry) ConstructorNamespace RequireQualified) <> " -> True; _ -> False) shapes" | entry <- entries ] - RUnion _ arms -> concatMap (unionArmObligations shapeModule) arms + RUnion _ arms -> concatMap (unionArmObligations aggregate shapeModule) arms -recordFieldObligation :: Text -> ResolvedWireField -> [Text] -recordFieldObligation shapeModule field = case rwfType field of +recordFieldObligation :: Agg -> Text -> ResolvedWireField -> [Text] +recordFieldObligation aggregate shapeModule field = case rwfType field of ROptional _ -> [ "any (isNothing . " <> selector <> ") shapes", "any (isJust . " <> selector <> ") shapes" ] _ -> [] where - selector = shapeModule <> "." <> rwfHaskell field + selector = renderHarnessReference aggregate (HaskellReference shapeModule (rwfHaskell field) ValueNamespace RequireQualified) -unionArmObligations :: Text -> ResolvedWireArm -> [Text] -unionArmObligations shapeModule arm = +unionArmObligations :: Agg -> Text -> ResolvedWireArm -> [Text] +unionArmObligations aggregate shapeModule arm = ["any (\\case " <> patternText <> " -> True; _ -> False) shapes"] <> optionalPayload where - constructor = shapeModule <> "." <> rwaCtor arm + constructor = renderHarnessReference aggregate (HaskellReference shapeModule (rwaCtor arm) ConstructorNamespace RequireQualified) patternText = constructor <> maybe "" (const "{}") (rwaPayload arm) optionalPayload = case rwaPayload arm of Just (ROptional _) -> @@ -1113,7 +1265,7 @@ ] where valueName = mappedEventAssertionName event fieldName - fixtures = unQualifiedValueName (mappedFixtures declaration) + fixtures = renderHarnessReference aggregate (harnessQualifiedValueReference (mappedFixtures declaration)) eventExpression = ctorExprWithOverride aggregate event fieldName "mappedValue" mappedEventAssertionName :: ResolvedCtor -> Text -> Text @@ -1135,11 +1287,11 @@ wirePolicyAssertions aggregate (declaration, shape) = case shape of RRecord _ unknownFields fields -> concatMap (recordMissingAssertions aggregate declaration) [field | field <- fields, rwfPresence field == POptional] - <> [unknownFieldAssertion declaration unknownFields] - REnum entries -> map (enumArmAssertion declaration) entries <> [enumUnknownAssertion declaration] + <> [unknownFieldAssertion aggregate declaration unknownFields] + REnum entries -> map (enumArmAssertion aggregate declaration) entries <> [enumUnknownAssertion declaration] RUnion encoding arms -> - map (unionArmAssertion declaration encoding) arms - <> [unknownFieldAssertion declaration (ueUnknownFields encoding)] + map (unionArmAssertion aggregate declaration encoding) arms + <> [unknownFieldAssertion aggregate declaration (ueUnknownFields encoding)] recordMissingAssertions :: Agg -> StructuralDecl -> ResolvedWireField -> [Text] recordMissingAssertions aggregate declaration field = @@ -1178,7 +1330,7 @@ canonical = unCanonicalTypeId (sdCanonical declaration) encoder = "encode" <> sdName declaration <> "Mapped" decoder = "decode" <> sdName declaration <> "Mapped" - fixtures = unQualifiedValueName (sdFixtures declaration) + fixtures = renderHarnessReference aggregate (harnessQualifiedValueReference (sdFixtures declaration)) encodedSample = encoder <> " (snd (NonEmpty.head (fixtureCases " <> fixtures <> ")))" nullExpectation = case rwfType field of ROptional _ -> "isRight" @@ -1201,8 +1353,8 @@ _ -> "error \"non-reference constructor default\"" Nothing -> "error \"optional field lacks on-missing policy\"" -unknownFieldAssertion :: StructuralDecl -> UnknownFields -> Text -unknownFieldAssertion declaration policy = +unknownFieldAssertion :: Agg -> StructuralDecl -> UnknownFields -> Text +unknownFieldAssertion aggregate declaration policy = "(\"wire policy unknown fields: " <> unCanonicalTypeId (sdCanonical declaration) <> "\", all (\\(_, value) -> " @@ -1212,15 +1364,15 @@ <> "Mapped (insertObjectField \"__keiro_unknown\" (Aeson.Bool True) (encode" <> sdName declaration <> "Mapped value)))) (NonEmpty.toList (fixtureCases " - <> unQualifiedValueName (sdFixtures declaration) + <> renderHarnessReference aggregate (harnessQualifiedValueReference (sdFixtures declaration)) <> ")))" where expectation = case policy of RejectUnknown -> "isLeft" IgnoreUnknown -> "isRight" -enumArmAssertion :: StructuralDecl -> WireEnum -> Text -enumArmAssertion declaration entry = +enumArmAssertion :: Agg -> StructuralDecl -> WireEnum -> Text +enumArmAssertion aggregate declaration entry = "(\"wire enum arm: " <> unCanonicalTypeId (sdCanonical declaration) <> "/" @@ -1234,7 +1386,7 @@ <> "Mapped (Aeson.String " <> tshow (weTag entry) <> ") == Right value) (NonEmpty.toList (fixtureCases " - <> unQualifiedValueName (sdFixtures declaration) + <> renderHarnessReference aggregate (harnessQualifiedValueReference (sdFixtures declaration)) <> ")))" enumUnknownAssertion :: StructuralDecl -> Text @@ -1245,8 +1397,8 @@ <> sdName declaration <> "Mapped (Aeson.String \"__keiro_unknown\")))" -unionArmAssertion :: StructuralDecl -> UnionEncoding -> ResolvedWireArm -> Text -unionArmAssertion declaration encoding arm = +unionArmAssertion :: Agg -> StructuralDecl -> UnionEncoding -> ResolvedWireArm -> Text +unionArmAssertion aggregate declaration encoding arm = "(\"wire union arm: " <> unCanonicalTypeId (sdCanonical declaration) <> "/" @@ -1262,7 +1414,7 @@ <> "Mapped (encode" <> sdName declaration <> "Mapped value) == Right value) (NonEmpty.toList (fixtureCases " - <> unQualifiedValueName (sdFixtures declaration) + <> renderHarnessReference aggregate (harnessQualifiedValueReference (sdFixtures declaration)) <> ")))" wirePolicyHelpers :: [(StructuralDecl, ResolvedMappedShape)] -> [Text] @@ -1315,19 +1467,24 @@ <> "\", all (\\(_, owner) -> fieldWitnessAgrees StructuralProjections." <> spWitness spec <> " (\\referenceOwner -> " - <> projectionGetter "referenceOwner" spec + <> projectionGetter aggregate "referenceOwner" spec <> ") owner) (NonEmpty.toList (fixtureCases " <> ownerFixtures spec <> ")))" ownerFixtures spec = case find (\(declaration, _) -> sdCanonical declaration == spCanonical spec) structural of - Just (declaration, _) -> unQualifiedValueName (sdFixtures declaration) + Just (declaration, _) -> renderHarnessReference aggregate (harnessQualifiedValueReference (sdFixtures declaration)) Nothing -> "error \"projection owner fixtures missing\"" -projectionGetter :: Text -> StructuralProjection -> Text -projectionGetter owner spec = +projectionGetter :: Agg -> Text -> StructuralProjection -> Text +projectionGetter aggregate owner spec = foldl - (\value (shapeModule, selector) -> shapeModule <> "." <> selector <> " (" <> value <> ")") - ("bindingToShape " <> unQualifiedValueName (spBinding spec) <> " " <> owner) + ( \value (shapeModule, selector) -> + renderHarnessReference aggregate (HaskellReference shapeModule selector ValueNamespace RequireQualified) + <> " (" + <> value + <> ")" + ) + ("bindingToShape " <> renderHarnessReference aggregate (harnessQualifiedValueReference (spBinding spec)) <> " " <> owner) (spSelectors spec) maybeToListHarness :: Maybe value -> [value] diff --git a/src/Keiro/Dsl/HaskellImport.hs b/src/Keiro/Dsl/HaskellImport.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/HaskellImport.hs @@ -0,0 +1,272 @@ +-- | Deterministic imports and external references for generated Haskell. +-- +-- A renderer supplies every external reference needed by one target module. +-- This module makes all qualification choices over that complete set so the +-- resulting aliases and bytes do not depend on declaration traversal order. +module Keiro.Dsl.HaskellImport + ( HaskellNamespace (..), + QualificationPreference (..), + HaskellReference (..), + ImportEnvironment (..), + HaskellImportError (..), + HaskellImportPlan, + planHaskellImports, + renderPlannedImports, + renderPlannedReference, + ) +where + +import Data.Foldable (traverse_) +import Data.List (find) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T + +data HaskellNamespace + = TypeNamespace + | ValueNamespace + | ConstructorNamespace + deriving stock (Eq, Ord, Show) + +data QualificationPreference + = PreferUnqualified + | RequireQualified + deriving stock (Eq, Ord, Show) + +data HaskellReference = HaskellReference + { referenceModule :: !Text, + referenceName :: !Text, + referenceNamespace :: !HaskellNamespace, + referenceQualification :: !QualificationPreference + } + deriving stock (Eq, Ord, Show) + +data ImportEnvironment = ImportEnvironment + { targetModule :: !Text, + localNames :: !(Set Text), + reservedQualifiers :: !(Set Text) + } + deriving stock (Eq, Show) + +data HaskellImportError + = InvalidHaskellModule !Text !Text + | InvalidHaskellOccurrence !Text !HaskellNamespace !Text + | HaskellSelfImport !Text + | ImpossibleHaskellAlias !Text !(Set Text) + | MissingHaskellReference !Text !HaskellReference + deriving stock (Eq, Show) + +data HaskellImportPlan = HaskellImportPlan + { importPlanTargetModule :: !Text, + importPlanDeclarations :: !(Set Text), + importPlanReferences :: !(Map HaskellReference Text) + } + +planHaskellImports :: ImportEnvironment -> Set HaskellReference -> Either HaskellImportError HaskellImportPlan +planHaskellImports environment references = do + validateModuleName target target + traverse_ (validateReference target) orderedReferences + aliases <- allocateAliases environment unqualifiedNames qualifiedModules + plannedReferences <- Map.fromList <$> traverse (renderReference aliases) orderedReferences + pure + HaskellImportPlan + { importPlanTargetModule = target, + importPlanDeclarations = explicitDeclarations <> qualifiedDeclarations aliases, + importPlanReferences = plannedReferences + } + where + target = targetModule environment + orderedReferences = Set.toAscList references + occurrenceOwners = + Map.fromListWith + (<>) + [ (referenceName reference, Set.singleton (referenceModule reference, referenceName reference)) + | reference <- orderedReferences, + referenceNamespace reference == TypeNamespace, + referenceQualification reference == PreferUnqualified + ] + unqualified reference = + referenceNamespace reference == TypeNamespace + && referenceQualification reference == PreferUnqualified + && Set.notMember (referenceName reference) (localNames environment) + && Set.notMember (referenceName reference) (reservedQualifiers environment) + && maybe False ((== 1) . Set.size) (Map.lookup (referenceName reference) occurrenceOwners) + unqualifiedReferences = Set.filter unqualified references + unqualifiedNames = Set.map referenceName unqualifiedReferences + qualifiedModules = + Set.map referenceModule (references `Set.difference` unqualifiedReferences) + explicitImports = + Map.fromListWith + (<>) + [ (referenceModule reference, Set.singleton (referenceName reference)) + | reference <- Set.toAscList unqualifiedReferences + ] + explicitDeclarations = + Set.fromList + [ "import " <> moduleName <> " (" <> T.intercalate ", " (Set.toAscList names) <> ")" + | (moduleName, names) <- Map.toAscList explicitImports + ] + qualifiedDeclarations aliases = + Set.fromList + [ "import " <> moduleName <> " qualified as " <> alias + | (moduleName, alias) <- Map.toAscList aliases + ] + renderReference aliases reference + | Set.member reference unqualifiedReferences = pure (reference, referenceName reference) + | otherwise = case Map.lookup (referenceModule reference) aliases of + Nothing -> Left (ImpossibleHaskellAlias target (Set.singleton (referenceModule reference))) + Just alias -> pure (reference, alias <> "." <> referenceName reference) + +renderPlannedImports :: HaskellImportPlan -> Text +renderPlannedImports = T.intercalate "\n" . Set.toAscList . importPlanDeclarations + +renderPlannedReference :: HaskellImportPlan -> HaskellReference -> Either HaskellImportError Text +renderPlannedReference plan reference = + maybe + (Left (MissingHaskellReference (importPlanTargetModule plan) reference)) + Right + (Map.lookup reference (importPlanReferences plan)) + +allocateAliases :: ImportEnvironment -> Set Text -> Set Text -> Either HaskellImportError (Map Text Text) +allocateAliases environment unqualifiedNames modules = do + let moduleCandidates = Map.fromSet suffixCandidates modules + candidateOwners = + Map.fromListWith + (<>) + [ (candidate, Set.singleton moduleName) + | (moduleName, candidates) <- Map.toAscList moduleCandidates, + candidate <- candidates + ] + occupied = reservedQualifiers environment <> localNames environment <> unqualifiedNames + choose moduleName candidates = + case find (isAvailable moduleName candidateOwners occupied) candidates of + Just candidate -> candidate + Nothing -> T.intercalate "_" (moduleComponents moduleName) + aliases = Map.mapWithKey choose moduleCandidates + ownersByAlias = + Map.fromListWith + (<>) + [ (alias, Set.singleton moduleName) + | (moduleName, alias) <- Map.toAscList aliases + ] + impossibleModules = + Set.unions + [ owners + | (alias, owners) <- Map.toAscList ownersByAlias, + Set.member alias occupied || Set.size owners /= 1 || not (validUpperIdentifier alias) + ] + if Set.null impossibleModules + then pure aliases + else Left (ImpossibleHaskellAlias (targetModule environment) impossibleModules) + +isAvailable :: Text -> Map Text (Set Text) -> Set Text -> Text -> Bool +isAvailable moduleName candidateOwners occupied candidate = + Set.notMember candidate occupied + && Map.lookup candidate candidateOwners == Just (Set.singleton moduleName) + && validUpperIdentifier candidate + +suffixCandidates :: Text -> [Text] +suffixCandidates moduleName = + [ T.concat (drop (componentCount - suffixLength) components) + | suffixLength <- [1 .. componentCount] + ] + where + components = moduleComponents moduleName + componentCount = length components + +moduleComponents :: Text -> [Text] +moduleComponents = T.splitOn "." + +validateReference :: Text -> HaskellReference -> Either HaskellImportError () +validateReference target reference = do + validateModuleName target (referenceModule reference) + if referenceModule reference == target + then Left (HaskellSelfImport target) + else pure () + if validOccurrence (referenceNamespace reference) (referenceName reference) + then pure () + else Left (InvalidHaskellOccurrence target (referenceNamespace reference) (referenceName reference)) + +validateModuleName :: Text -> Text -> Either HaskellImportError () +validateModuleName target candidate + | not (null components) && all validUpperIdentifier components = pure () + | otherwise = Left (InvalidHaskellModule target candidate) + where + components = moduleComponents candidate + +validOccurrence :: HaskellNamespace -> Text -> Bool +validOccurrence namespace name = + not (Set.member name haskellKeywords) + && case namespace of + TypeNamespace -> validUpperIdentifier name + ConstructorNamespace -> validUpperIdentifier name + ValueNamespace -> validLowerIdentifier name + +validUpperIdentifier :: Text -> Bool +validUpperIdentifier name = case T.uncons name of + Just (first, rest) -> asciiUpper first && T.all identifierTail rest + Nothing -> False + +validLowerIdentifier :: Text -> Bool +validLowerIdentifier name = case T.uncons name of + Just (first, rest) -> (asciiLower first || first == '_') && T.all identifierTail rest + Nothing -> False + +identifierTail :: Char -> Bool +identifierTail character = + asciiUpper character + || asciiLower character + || asciiDigit character + || character == '_' + || character == '\'' + +asciiUpper :: Char -> Bool +asciiUpper character = character >= 'A' && character <= 'Z' + +asciiLower :: Char -> Bool +asciiLower character = character >= 'a' && character <= 'z' + +asciiDigit :: Char -> Bool +asciiDigit character = character >= '0' && character <= '9' + +haskellKeywords :: Set Text +haskellKeywords = + Set.fromList + [ "as", + "case", + "class", + "data", + "default", + "deriving", + "do", + "else", + "family", + "foreign", + "forall", + "if", + "import", + "in", + "infix", + "infixl", + "infixr", + "instance", + "let", + "mdo", + "module", + "newtype", + "of", + "proc", + "qualified", + "rec", + "safe", + "signature", + "stock", + "then", + "type", + "unsafe", + "via", + "where" + ] 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 @@ -29,6 +29,7 @@ module Keiro.Dsl.Manifest ( renderManifest, renderManifestForService, + renderManifestForServiceWithFacade, manifestDependencies, manifestDependenciesForService, moduleNameOf, @@ -40,6 +41,7 @@ import Data.Text (Text) import Data.Text qualified as T import Keiro.Dsl.AggregateType +import Keiro.Dsl.GeneratedHaskellLanguage (generatedHaskellDefaultExtensions, generatedHaskellDefaultLanguage) import Keiro.Dsl.Grammar import Keiro.Dsl.IdDomain (contractIdDomainContractFor) import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), consumerPlan) @@ -57,17 +59,29 @@ -- 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 = +renderManifestForService = renderManifestForServiceWithFacade Nothing + +-- | Configured manifest renderer. The service facade is the runtime library's +-- one generated public module; every other generated and hand-owned module +-- remains in @other-modules@. Passing 'Nothing' preserves the historical bytes. +renderManifestForServiceWithFacade :: Maybe Text -> Text -> [ScaffoldModule] -> CheckedService -> Text +renderManifestForServiceWithFacade facadeModule specName mods service = T.unlines $ [ "-- keiro-dsl build manifest for " <> specName, - "-- Paste the two blocks below into the consuming Cabal stanza.", + "-- Paste the complete fragment below into the consuming Cabal stanza.", "-- The generated layer is overwritten on every scaffold; hole modules are", "-- create-if-absent (filled by hand).", "", - "other-modules:" + "default-language: " <> generatedHaskellDefaultLanguage, + "default-extensions:" ] - ++ map (" " <>) (sort (map (moduleNameOf . modulePath) mods)) + ++ map (" " <>) generatedHaskellDefaultExtensions + ++ exposedBlock ++ [ "", + "other-modules:" + ] + ++ map (" " <>) otherModules + ++ [ "", "build-depends:" ] ++ map (" , " <>) (manifestDependenciesForService service) @@ -75,6 +89,13 @@ where spec = checkedSpec service plan = consumerPlan spec + moduleNames = sort (map (moduleNameOf . modulePath) mods) + otherModules = case facadeModule of + Nothing -> moduleNames + Just facade -> filter (/= facade) moduleNames + exposedBlock = case facadeModule of + Nothing -> [] + Just facade -> ["", "exposed-modules:", " " <> facade] consumerBlocks | null (consumerMappings plan) = [] | otherwise = diff --git a/src/Keiro/Dsl/RuntimePackage.hs b/src/Keiro/Dsl/RuntimePackage.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/RuntimePackage.hs @@ -0,0 +1,40 @@ +-- | Explicit Cabal package identity for the service runtime that compiles +-- generated Keiro modules. +module Keiro.Dsl.RuntimePackage + ( RuntimePackageName (..), + mkRuntimePackageName, + isCabalPackageName, + ) +where + +import Data.Char (isAscii, isDigit, isLetter) +import Data.Text (Text) +import Data.Text qualified as T + +-- | A package name accepted by Cabal's component grammar. Keiro keeps this +-- distinct from a service name because the two identities need not agree. +newtype RuntimePackageName = RuntimePackageName + { unRuntimePackageName :: Text + } + deriving stock (Eq, Ord, Show) + +-- | Validate and construct an explicit runtime package name. +mkRuntimePackageName :: Text -> Either Text RuntimePackageName +mkRuntimePackageName packageName + | isCabalPackageName packageName = Right (RuntimePackageName packageName) + | otherwise = Left ("runtime package '" <> packageName <> "' does not follow Cabal package-name grammar") + +-- | The package-name rule shared by mapped Haskell sources and the runtime +-- package setting. Every hyphen-separated component is non-empty, contains +-- only ASCII letters and digits, and contains at least one letter. +isCabalPackageName :: Text -> Bool +isCabalPackageName packageName = + not (null components) && all validComponent components + where + components = T.splitOn "-" packageName + validComponent component = + not (T.null component) + && T.all asciiAlphaNum component + && T.any asciiLetter component + asciiAlphaNum c = isAscii c && (isLetter c || isDigit c) + asciiLetter c = isAscii c && isLetter c 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 @@ -24,5407 +24,5747 @@ 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, + contextGeneratedPrefix, + holePrefixFor, + generatedNominalModule, + NominalUseSite (..), + NominalGenerationOwner (..), + planNominalGeneration, + planNominalGenerationForService, + generatedNominalsInTypes, + generatedNominalTypeImports, + generatedNominalTypeImportsForService, + generatedIdSampleHaskell, + scaffoldReplayAudit, + scaffoldStructural, + scaffoldStructuralForService, + scaffoldStructuralOwners, + scaffoldStructuralOwnersForService, + codecComparisonModule, + codecComparisonBanner, + bindingSkeletonModules, + bindingSkeletonOwners, + scaffoldAggregateForService, + scaffoldAggregate, + obsoleteGeneratedOutputHooks, + scaffoldProcess, + scaffoldRouter, + scaffoldContract, + scaffoldContractForService, + scaffoldIntake, + scaffoldPublisher, + scaffoldWorkqueue, + scaffoldReadModel, + scaffoldRefusals, + windowSeconds, + + -- * Firewall self-check (M3) + FirewallSurface (..), + firewallSurface, + firewallBreaches, + + -- * Internal resolution, shared with "Keiro.Dsl.Harness" + Agg (..), + aggregateCheckedService, + ResolvedRegister (..), + ResolvedCtor (..), + StructuralProjection (..), + resolveAggForService, + resolveAgg, + nominalEqualityUsedInGeneratedExpressions, + projectionSpecs, + resolveProjectionModules, + nominalProjectionModule, + codecMappedDeclarations, + FieldCat (..), + fieldCat, + vertexCtor, + initialVertex, + firstEnumCtor, + lowerFirst, + pascal, + pascalFromKebab, + generatedBanner, + generatedBannerFor, + isGeneratedBannerLine, + stampGeneratedModule, + stampGeneratedModules, + ) +where + +import Data.Char (isAlpha, isAlphaNum, isDigit, isUpper, 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.GeneratedHaskellLanguage +import Keiro.Dsl.Grammar +import Keiro.Dsl.HaskellImport +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 generated-layer namespace shared by modules emitted once for a whole +-- service context, such as Nominals, ReplayAudit, and Conformance. +contextGeneratedPrefix :: Context -> Text +contextGeneratedPrefix ctx = case placement ctx of + GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx + CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated" + +-- | The hand-owned (hole) namespace for a node: @\.\.\@ — +-- the same for both placement styles (holes always sit beside the domain). +holePrefixFor :: Context -> Text -> Text +holePrefixFor ctx node = rootPrefix ctx <> ctxPascalOf ctx <> "." <> node + +-- | The one context-level Haskell owner for generated IDs and enums. +generatedNominalModule :: Context -> Text +generatedNominalModule ctx = contextGeneratedPrefix ctx <> ".Nominals" + +-- | The root namespace prefix, dot-terminated, or @""@ when no root is set. +rootPrefix :: Context -> Text +rootPrefix ctx = case moduleRoot ctx of r | T.null r -> ""; r -> r <> "." + +-- | The context name in PascalCase, e.g. @hospital-capacity@ -> @HospitalCapacity@. +ctxPascalOf :: Context -> Text +ctxPascalOf = pascalFromKebab . contextName + +-------------------------------------------------------------------------------- +-- Firewall self-check (M3) +-------------------------------------------------------------------------------- + +-- | The canonical keiki surface forbidden in generated modules. Symbolic +-- operators are matched as maximal Haskell symbol tokens, identifiers as complete +-- tokens, qualifiers by their leading module alias, and imports structurally. +data FirewallSurface = FirewallSurface + { forbiddenSymbolic :: ![Text], + forbiddenIdents :: ![Text], + forbiddenQualifiers :: ![Text], + forbiddenImports :: ![Text], + restrictedImports :: ![(Text, [Text])] + } + deriving stock (Eq, Show) + +firewallSurface :: FirewallSurface +firewallSurface = + FirewallSurface + { forbiddenSymbolic = [".==", "./=", ".<", ".<=", ".>", ".>=", ".&&", ".||", ".+", ".-", ".*", "=:", "*:"], + forbiddenIdents = ["lit", "pnot", "tadd", "tsub", "tmul"], + forbiddenQualifiers = ["B"], + forbiddenImports = ["Keiki.Builder", "Keiki.Operators", "Keiki.Symbolic"], + -- Generated aggregate modules use the first two names; generated + -- harnesses validate, step, and replay filled holes register by register. + restrictedImports = + [ ( "Keiki.Core", + [ "RegFile", + "HsPred", + "FieldProjection", + "ExactFieldProjection", + "FieldWitness", + "fieldWitness", + "exactFieldWitness", + "fieldWitnessAgrees", + "applyEventsEither", + "defaultValidationOptions", + "step", + "validateTransducer", + "EdgeMode", + "EdgeRef", + "StepSuccess", + "StepFailure", + "ReplayEventSpan", + "ReplayAttribution", + "ReplaySuccess", + "applyEventsDetailedEither", + "stepDetailedEither", + "!" + ] + ) + ] + } + +-- | Scan generated modules for firewall breaches, returning every offending +-- @(module path, token, 1-based line number)@. Only modules whose 'kind' is +-- 'Generated' are scanned. Strings and comments are skipped, symbol runs use +-- maximal munch, and keiki imports are checked independently of token spelling. +firewallBreaches :: [ScaffoldModule] -> [(FilePath, Text, Int)] +firewallBreaches mods = + [ (modulePath m, breach, n) + | m <- mods, + kind m == Generated, + not (authoritativeScalarModule (modulePath m)), + (n, line) <- zip [1 ..] (T.lines (moduleText m)), + breach <- lineBreaches line + ] + +-- The version-2 aggregate transducer is the narrow, intentional exception to +-- the generated symbolic-operator firewall: it is precisely the generated +-- authority that constructs Keiki terms. Every other generated module remains +-- subject to the original firewall. +authoritativeScalarModule :: FilePath -> Bool +authoritativeScalarModule path = "/Transducer.hs" `isSuffixOf` path + +lineBreaches :: Text -> [Text] +lineBreaches line = case importModule line of + Just _ -> importBreaches line + Nothing -> tokenBreaches (codeTokens line) + where + tokenBreaches = mapMaybe breachFor + breachFor (IdentToken ident) + | ident `elem` forbiddenIdents firewallSurface = Just ident + breachFor (QualifiedToken qualifier) + | qualifier `elem` forbiddenQualifiers firewallSurface = Just (qualifier <> ".*") + breachFor (SymbolToken symbol) + | symbol `elem` forbiddenSymbolic firewallSurface = Just symbol + breachFor _ = Nothing + +data CodeToken = IdentToken !Text | QualifiedToken !Text | SymbolToken !Text + +codeTokens :: Text -> [CodeToken] +codeTokens = go . T.unpack + where + go [] = [] + go ('-' : '-' : _) = [] + go ('"' : rest) = go (dropString rest) + go ('\'' : rest) = go (dropChar rest) + go (c : rest) + | isIdentStart c = + let (identTail, afterIdent) = span isIdentContinue rest + ident = T.pack (c : identTail) + in case afterIdent of + '.' : next : more + | isUpper c && isIdentStart next -> + let (_member, afterMember) = span isIdentContinue more + in QualifiedToken ident : go afterMember + _ -> IdentToken ident : go afterIdent + | isSymbolChar c = + let (symbolTail, afterSymbol) = span isSymbolChar rest + in SymbolToken (T.pack (c : symbolTail)) : go afterSymbol + | otherwise = go rest + isIdentStart c = isAlpha c || c == '_' + isIdentContinue c = isAlphaNum c || c == '_' || c == '\'' + isSymbolChar c = c `elem` ("!#$%&*+./<=>?@\\^|-~:" :: String) + dropString [] = [] + dropString ('\\' : _escaped : rest) = dropString rest + dropString ('"' : rest) = rest + dropString (_ : rest) = dropString rest + dropChar [] = [] + dropChar ('\\' : _escaped : rest) = dropChar rest + dropChar ('\'' : rest) = rest + dropChar (_ : rest) = dropChar rest + +importBreaches :: Text -> [Text] +importBreaches line = case importModule line of + Nothing -> [] + Just imported + | imported `elem` forbiddenImports firewallSurface -> ["import:" <> imported] + | Just allowed <- lookup imported (restrictedImports firewallSurface), + not (hasAllowedExplicitImportList allowed line) -> + ["import:" <> imported] + | otherwise -> [] + +importModule :: Text -> Maybe Text +importModule line = case T.words (T.strip line) of + "import" : rest -> find (T.isPrefixOf "Keiki.") rest + _ -> Nothing + +hasAllowedExplicitImportList :: [Text] -> Text -> Bool +hasAllowedExplicitImportList allowed line = + case (T.breakOn "(" line, T.breakOnEnd ")" line) of + ((_, open), (close, _)) + | not (T.null open) && not (T.null close) -> + let inside = T.takeWhile (/= ')') (T.drop 1 open) + names = filter (not . T.null) (T.split (not . isAlphaNum) inside) + in all (`elem` allowed) names + _ -> False + +-------------------------------------------------------------------------------- +-- Derived naming +-------------------------------------------------------------------------------- + +-- | Resolved, denormalized view of an aggregate used by every emitter. +data Agg = Agg + { aContext :: !Context, + aLanguageContract :: !EffectiveLanguageContract, + aSpec :: !Spec, + aAggregate :: !Aggregate, + aCtxPascal :: !Text, + aName :: !Text, + aLoc :: !Loc, + aVertexType :: !Text, + aIds :: ![IdDecl], + aEnums :: ![EnumDecl], + aRegs :: ![ResolvedRegister], + aStates :: ![StateDecl], + aCommands :: ![ResolvedCtor], + aEvents :: ![ResolvedCtor], + -- | Generated IDs and enums used by this aggregate, in stable name order. + aGeneratedNominals :: ![ResolvedNominalType], + aTransitions :: ![Transition], + aOutputMappings :: !(Map.Map (Int, Int) EventOutputMapping), + aWire :: !WireSpec, + aProjection :: !(Maybe ProjectionSpec), + aSnapshot :: !(Maybe SnapshotSpec), + aFoldFingerprint :: !Text, + aReadModels :: ![ReadModelNode], + aTypeGraph :: !(Maybe TypeGraph), + aSymbols :: !AggregateSymbols, + -- | e.g. @Generated.HospitalCapacity.Reservation@ + aGenPrefix :: !Text, + -- | e.g. @HospitalCapacity.Reservation@ + aHolePrefix :: !Text + } + +aggregateCheckedService :: Agg -> CheckedService +aggregateCheckedService aggregate = + CheckedService + { checkedLanguageContract = aLanguageContract aggregate, + checkedSpec = aSpec aggregate + } + +data ResolvedRegister = ResolvedRegister + { rrName :: !Name, + rrType :: !ResolvedAggregateType, + rrInitial :: !ResolvedRegisterInitial, + rrLoc :: !Loc + } + deriving stock (Eq, Show) + +-- | A command or event constructor with its fully-resolved field 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, ())", + renderPlannedImports importPlan, + "", + "compareWithHistorical :: HistoricalCodec " <> domainType <> " -> FilePath -> IO CompareReport", + "compareWithHistorical historicalCodec goldenDirectory = do", + " names <- sort . filter ((== \".json\") . takeExtension) <$> listDirectory goldenDirectory", + " files <- filterM doesFileExist [goldenDirectory name | name <- names]", + " loaded <- traverse (loadGolden historicalCodec) files", + " let inputIssues = [issue | Left issue <- loaded]", + " entries = [entry | Right entry <- loaded]", + " typedCases = NonEmpty.toList (fixtureCases " <> fixtureReference <> ")", + " encodeObservations =", + " [ EncodeObservation label (hcEncode historicalCodec value) (GeneratedCodec.encode" <> name <> "Mapped value)", + " | (label, value) <- typedCases", + " ]", + " decodeObservations = [observation | (observation, _) <- entries]", + " typedObserved =", + " concat", + " [ observedBranchesFor FromBinding branchSchema (GeneratedCodec.encode" <> name <> "Mapped value)", + " | (_, value) <- typedCases", + " ]", + " historicalObserved =", + " concat [observedBranchesFor HistoricalGolden branchSchema value | (_, values) <- entries, value <- values]", + " declared = declaredBranchesFor FromBinding branchSchema <> declaredBranchesFor HistoricalGolden branchSchema", + " provenance =", + " CompareProvenance", + " { cpHistoricalCodecIdentity = hcIdentity historicalCodec", + " , cpHistoricalCodecVersion = hcVersion historicalCodec", + " , cpCanonicalType = CanonicalTypeId " <> tshow (unCanonicalTypeId (sdCanonical declaration)), + " , cpBindingSymbol = QualifiedValueName " <> tshow (unQualifiedValueName (sdBinding declaration)), + " , cpBindingVersion = BindingVersion " <> tshow (unBindingVersion (sdBindingVersion declaration)), + " , cpWireFingerprint = " <> tshow (wireFingerprint graph name), + " }", + " pure (compareReport provenance inputIssues (encodeObservations <> decodeObservations) declared (typedObserved <> historicalObserved))", + "", + "loadGolden :: HistoricalCodec " <> domainType <> " -> FilePath -> IO (Either CompareInputIssue (CompareObservation, [Value]))", + "loadGolden historicalCodec path = do", + " decoded <- Aeson.eitherDecodeFileStrict path", + " pure $ case decoded of", + " Left reason -> Left (HistoricalGoldenUnreadable path (fromString reason))", + " Right inputValue ->", + " let historicalDecoded = hcDecode historicalCodec inputValue", + " historicalOutcome = normalizeDecode historicalDecoded", + " generatedOutcome = normalizeDecode (GeneratedCodec.decode" <> name <> "Mapped inputValue)", + " observation = DecodeObservation path inputValue historicalOutcome generatedOutcome", + " coveredValues = case historicalDecoded of", + " Right value -> [inputValue, GeneratedCodec.encode" <> name <> "Mapped value]", + " Left _ -> []", + " in Right (observation, coveredValues)", + "", + "normalizeDecode :: Either Text " <> domainType <> " -> DecodeOutcome", + "normalizeDecode = either DecodeFailed (DecodedShape . GeneratedCodec.encode" <> name <> "Mapped)", + "", + "fromString :: String -> Text", + "fromString = Data.Text.pack", + "", + "branchSchema :: BranchSchema", + "branchSchema = " <> renderBranchSchema (branchSchemaFor graph (ResolvedStructural declaration shape)) + ] + where + name = sdName declaration + domainType = renderReferenceOrDie importPlan (haskellTypeReference (sdHaskell declaration)) + codecModule = genPrefixFor ctx (aggName owner) <> ".Codec" + fixtureReference = renderReferenceOrDie importPlan (qualifiedValueReference (sdFixtures declaration)) + importPlan = + planImportsOrDie + moduleName + Set.empty + ( Set.fromList + [ haskellTypeReference (sdHaskell declaration), + qualifiedValueReference (sdFixtures declaration) + ] + ) + +branchSchemaFor :: TypeGraph -> ResolvedMappedDecl -> BranchSchema +branchSchemaFor graph = + foldMappedDecl + MappedDeclAlgebra + { onStructuralDecl = \_ shape -> + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ fields -> + BranchRecord + [ BranchField + (rwfKey field) + (rwfPresence field == POptional) + (branchExpr graph (rwfType field)) + | field <- fields + ], + onEnum = const BranchScalar, + onUnion = \encoding arms -> + BranchUnion + (ueTagField encoding) + (ueContentsField encoding) + [BranchArm (rwaTag arm) (branchExpr graph <$> rwaPayload arm) | arm <- arms] + } + shape, + onOpaqueDecl = const BranchScalar + } + +branchExpr :: TypeGraph -> ResolvedTypeExpr -> BranchSchema +branchExpr graph = + foldTypeExpr + TypeExprAlgebra + { onText = BranchScalar, + onInt = BranchScalar, + onInteger = BranchScalar, + onBool = BranchScalar, + onNatural = BranchScalar, + onTime = BranchScalar, + onJson = BranchScalar, + onOptional = BranchOptional, + onList = BranchList, + onMap = BranchMap, + onRef = \key -> maybe BranchScalar (branchSchemaFor graph) (Map.lookup key (tgDeclarations graph)) + } + +renderBranchSchema :: BranchSchema -> Text +renderBranchSchema schema = case schema of + BranchScalar -> "BranchScalar" + BranchOptional nested -> "BranchOptional (" <> renderBranchSchema nested <> ")" + BranchList nested -> "BranchList (" <> renderBranchSchema nested <> ")" + BranchMap nested -> "BranchMap (" <> renderBranchSchema nested <> ")" + BranchRecord fields -> + "BranchRecord [" + <> T.intercalate + ", " + [ "BranchField " + <> tshow (bfWireKey field) + <> " " + <> (if bfPresenceOptional field then "True" else "False") + <> " (" + <> renderBranchSchema (bfSchema field) + <> ")" + | field <- fields + ] + <> "]" + BranchUnion tagField contentsField arms -> + "BranchUnion " + <> tshow tagField + <> " " + <> tshow contentsField + <> " [" + <> T.intercalate + ", " + [ "BranchArm " + <> tshow (baWireTag arm) + <> " " + <> maybe "Nothing" (\nested -> "(Just (" <> renderBranchSchema nested <> "))") (baPayloadSchema arm) + | arm <- arms + ] + <> "]" + +-- | Emit one create-once consumer module per distinct qualified obligation +-- owner. Multiple mapped declarations may intentionally share a leaf binding +-- module, so grouping happens by module rather than by declaration. +bindingSkeletonModules :: Context -> Spec -> TypeGraph -> [ScaffoldModule] +bindingSkeletonModules ctx spec graph = map fst (bindingSkeletonOwners ctx spec graph) + +-- | 'bindingSkeletonModules' paired with the mapped declarations whose +-- obligations each skeleton carries, in first-appearance order. A skeleton shared +-- by declarations from different member files therefore names all of them, which +-- is what lets whole-workspace scaffolding treat it as context-level rather than +-- attributing it to an arbitrary member. +bindingSkeletonOwners :: Context -> Spec -> TypeGraph -> [(ScaffoldModule, [Name])] +bindingSkeletonOwners ctx spec graph = case bindingObligations spec of + Left _ -> [] + Right obligations -> + [ (emitBindingSkeleton ctx spec graph owner entries, nub (map obligationMappedName entries)) + | (owner, entries) <- Map.toAscList (Map.fromListWith (<>) [(obligationModule obligation, [obligation]) | obligation <- obligations]) + ] + +emitBindingSkeleton :: Context -> Spec -> TypeGraph -> Text -> [BindingObligation] -> ScaffoldModule +emitBindingSkeleton ctx spec graph owner obligations = + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" owner <> ".hs"), + moduleText = + nl $ + [ "{-# LANGUAGE DataKinds #-}", + "{-# LANGUAGE LambdaCase #-}", + "", + "-- This is a HAND-OWNED consumer binding skeleton. keiro-dsl creates it once", + "-- and never overwrites it. Fill each HOLE and run the generated harness.", + "module " <> owner <> " (" + ] + <> exportLines + <> [") where", ""] + <> importLines + <> [""] + <> intercalateBlank (map renderObligation obligations), + kind = HoleStub, + origin = "consumer binding skeleton " <> owner + } + where + exportLines = + [ (if index == (0 :: Int) then " " else " , ") <> obligationSymbol obligation + | (index, obligation) <- zip [0 ..] obligations + ] + importPlan = bindingSkeletonImportPlan ctx spec graph owner obligations + importLines = + sort . nub $ + map ("import " <>) staticImports + <> T.lines (renderPlannedImports importPlan) + staticImports = + sort . nub $ + [ "Keiro.Codec.Structural (FixtureCases, StructuralBinding (..))" + | any (\obligation -> obligationCategory obligation == "structural" && obligationKind obligation `elem` [BindingValue, FixtureValue]) obligations + ] + <> [ "Keiro.Codec.Nominal (NominalBinding (..), NominalFixtureCases)" + | any ((/= "structural") . obligationCategory) obligations + ] + <> [ "Data.KindID (KindID)" + | obligation <- obligations, + Just (nominal, _) <- [nominalFor obligation], + IdRepresentation {} <- [resolvedNominalRepresentation nominal] + ] + <> [ "Data.Text (Text)" + | obligation <- obligations, + Just (nominal, _) <- [nominalFor obligation], + ScalarRepresentation NominalText <- [resolvedNominalRepresentation nominal] + ] + <> [ "Data.Time (UTCTime)" + | obligation <- obligations, + Just (nominal, _) <- [nominalFor obligation], + ScalarRepresentation NominalTime <- [resolvedNominalRepresentation nominal] + ] + <> [ "Numeric.Natural (Natural)" + | obligation <- obligations, + Just (nominal, _) <- [nominalFor obligation], + ScalarRepresentation NominalNatural <- [resolvedNominalRepresentation nominal] + ] + renderObligation obligation = case structuralFor obligation of + Nothing -> case nominalFor obligation of + Just (nominal, binding) -> renderNominalObligation nominal binding obligation + Nothing -> ["-- HOLE: declaration disappeared before skeleton rendering"] + Just (declaration, shape) -> case obligationKind obligation of + BindingValue -> renderBinding importPlan ctx declaration shape obligation + FixtureValue -> + [ "-- HOLE: provide deterministic labelled conformance fixtures for " <> sdName declaration, + renderStructuralObligationSignature importPlan declaration obligation, + obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> sdName declaration <> " fixtures") + ] + InitialValue -> + [ "-- HOLE: provide the initial register value for " <> sdName declaration, + renderStructuralObligationSignature importPlan declaration obligation, + obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> sdName declaration <> " initial value") + ] + structuralFor obligation = case Map.lookup (MappedKey (obligationMappedName obligation)) (tgDeclarations graph) of + Just (ResolvedStructural declaration shape) -> Just (declaration, shape) + _ -> Nothing + nominalFor obligation = do + registry <- either (const Nothing) Just (resolveNominalTypes spec) + nominal <- lookupNominalType (obligationMappedName obligation) registry + binding <- case resolvedNominalOwnership nominal of + ConsumerNominal value -> Just value + GeneratedNominal -> Nothing + pure (nominal, binding) + renderNominalObligation nominal binding obligation = case obligationKind obligation of + BindingValue -> + [ "-- HOLE: complete both total directions; the generated codec remains wire authority.", + renderNominalObligationSignature importPlan ctx nominal binding obligation, + obligationSymbol obligation <> " =", + " NominalBinding", + " { nominalToRepresentation = \\_domainValue -> error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " nominalToRepresentation"), + " , nominalFromRepresentation = \\_representationValue -> error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " nominalFromRepresentation"), + " }" + ] + FixtureValue -> + [ "-- HOLE: provide deterministic labelled expected-wire fixtures for " <> resolvedNominalName nominal, + renderNominalObligationSignature importPlan ctx nominal binding obligation, + obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " fixtures") + ] + InitialValue -> + [ "-- HOLE: provide the initial register value for " <> resolvedNominalName nominal, + renderNominalObligationSignature importPlan ctx nominal binding obligation, + obligationSymbol obligation <> " = error " <> tshow ("HOLE: fill " <> resolvedNominalName nominal <> " initial value") + ] + intercalateBlank [] = [] + intercalateBlank (section : rest) = section <> concatMap ("" :) rest + +renderBinding :: HaskellImportPlan -> Context -> StructuralDecl -> ResolvedMappedShape -> BindingObligation -> [Text] +renderBinding importPlan ctx declaration shape obligation = + [ "-- HOLE: complete both total directions; wire policy remains in the generated codec.", + obligationSymbol obligation <> " :: StructuralBinding " <> domainType <> " " <> shapeType, + obligationSymbol obligation <> " =", + " StructuralBinding", + " { bindingToShape = \\case" + ] + <> indentCases (bindingCases True) + <> [" , bindingFromShape = \\case"] + <> indentCases (bindingCases False) + <> [" }"] + where + domainType = renderReferenceOrDie importPlan (haskellTypeReference (sdHaskell declaration)) + shapeModuleName = structuralShapeModule ctx (sdName declaration) + shapeType = renderReferenceOrDie importPlan (qualifiedTypeReference shapeModuleName (sdName declaration <> "Shape")) + domainCtor constructor = renderReferenceOrDie importPlan (constructorReference (hsModule (sdHaskell declaration)) constructor) + shapeCtor constructor = renderReferenceOrDie importPlan (constructorReference shapeModuleName constructor) + indentCases = map (" " <>) + bindingCases toShapeDirection = + foldMappedShape + MappedShapeAlgebra + { onRecord = \constructor _ fields -> [recordCase toShapeDirection constructor fields], + onEnum = \entries -> map (enumCase toShapeDirection . weCtor) entries, + onUnion = \_ arms -> map (unionCase toShapeDirection) arms + } + shape + recordCase toShapeDirection constructor fields = + sourceCtor + <> arguments variables + <> " -> " + <> targetCtor + <> arguments (map (holeFor toShapeDirection . rwfHaskell) fields) + where + variables = map (("_" <>) . (<> "Value") . rwfHaskell) fields + sourceCtor = if toShapeDirection then domainCtor constructor else shapeCtor constructor + targetCtor = if toShapeDirection then shapeCtor constructor else domainCtor constructor + enumCase toShapeDirection constructor = + sourceCtor <> " -> " <> holeFor toShapeDirection constructor + where + sourceCtor = if toShapeDirection then domainCtor constructor else shapeCtor constructor + unionCase toShapeDirection arm = + sourceCtor + <> maybe "" (const " _payloadValue") (rwaPayload arm) + <> " -> " + <> case rwaPayload arm of + Nothing -> holeFor toShapeDirection (rwaCtor arm) + Just _ -> targetCtor <> " " <> holeFor toShapeDirection (rwaCtor arm <> ".payload") + where + sourceCtor = if toShapeDirection then domainCtor (rwaCtor arm) else shapeCtor (rwaCtor arm) + targetCtor = if toShapeDirection then shapeCtor (rwaCtor arm) else domainCtor (rwaCtor arm) + arguments [] = "" + arguments values = " " <> T.unwords values + holeFor toShapeDirection fieldName = + "(error " + <> tshow + ( "HOLE: fill " + <> sdName declaration + <> (if toShapeDirection then " bindingToShape." else " bindingFromShape.") + <> fieldName + ) + <> ")" + +bindingSkeletonImportPlan :: Context -> Spec -> TypeGraph -> Text -> [BindingObligation] -> HaskellImportPlan +bindingSkeletonImportPlan ctx spec graph owner obligations = + planImportsOrDie owner (Set.fromList (map obligationSymbol obligations)) (Set.fromList (concatMap obligationReferences obligations)) + where + obligationReferences obligation = case Map.lookup (MappedKey (obligationMappedName obligation)) (tgDeclarations graph) of + Just (ResolvedStructural declaration shape) -> + haskellTypeReference (sdHaskell declaration) + : [ qualifiedTypeReference shapeModuleName (sdName declaration <> "Shape") + | obligationKind obligation == BindingValue + ] + <> [ reference + | obligationKind obligation == BindingValue, + constructor <- structuralConstructorNames shape, + reference <- + [ constructorReference (hsModule (sdHaskell declaration)) constructor, + constructorReference shapeModuleName constructor + ] + ] + where + shapeModuleName = structuralShapeModule ctx (sdName declaration) + _ -> case nominalForName (obligationMappedName obligation) of + Just (nominal, binding) -> + haskellTypeReference (consumerNominalHaskell binding) + : [ qualifiedTypeReference + (nominalRepresentationModule ctx (resolvedNominalName nominal)) + (resolvedNominalName nominal <> "Representation") + | obligationKind obligation == BindingValue, + EnumRepresentation {} <- [resolvedNominalRepresentation nominal] + ] + Nothing -> [] + nominalForName name = do + registry <- either (const Nothing) Just (resolveNominalTypes spec) + nominal <- lookupNominalType name registry + binding <- case resolvedNominalOwnership nominal of + ConsumerNominal value -> Just value + GeneratedNominal -> Nothing + pure (nominal, binding) + +structuralConstructorNames :: ResolvedMappedShape -> [Text] +structuralConstructorNames = + foldMappedShape + MappedShapeAlgebra + { onRecord = \constructor _ _ -> [constructor], + onEnum = map weCtor, + onUnion = \_ -> map rwaCtor + } + +structuralShapeReferences :: Context -> StructuralDecl -> ResolvedMappedShape -> [HaskellReference] +structuralShapeReferences ctx declaration shape = + qualifiedTypeReference moduleName (sdName declaration <> "Shape") + : [constructorReference moduleName constructor | constructor <- structuralConstructorNames shape] + <> [ HaskellReference moduleName selector ValueNamespace RequireQualified + | selector <- structuralSelectorNames shape + ] + where + moduleName = structuralShapeModule ctx (sdName declaration) + +structuralSelectorNames :: ResolvedMappedShape -> [Text] +structuralSelectorNames = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ -> map rwfHaskell, + onEnum = const [], + onUnion = \_ _ -> [] + } + +nominalRepresentationEncoderReference :: Context -> ResolvedNominalType -> HaskellReference +nominalRepresentationEncoderReference ctx nominal = + HaskellReference + (nominalRepresentationModule ctx name) + (lowerFirst name <> "RepresentationText") + ValueNamespace + RequireQualified + where + name = resolvedNominalName nominal + +nominalRepresentationConstructorReference :: Context -> ResolvedNominalType -> Text -> HaskellReference +nominalRepresentationConstructorReference ctx nominal constructor = + HaskellReference + (nominalRepresentationModule ctx (resolvedNominalName nominal)) + constructor + ConstructorNamespace + RequireQualified + +renderStructuralObligationSignature :: HaskellImportPlan -> StructuralDecl -> BindingObligation -> Text +renderStructuralObligationSignature importPlan declaration obligation = + obligationSymbol obligation + <> " :: " + <> case obligationKind obligation of + BindingValue -> error "structural binding signatures are rendered with renderBinding" + FixtureValue -> "FixtureCases " <> domainType + InitialValue -> domainType + where + domainType = renderReferenceOrDie importPlan (haskellTypeReference (sdHaskell declaration)) + +renderNominalObligationSignature :: HaskellImportPlan -> Context -> ResolvedNominalType -> ConsumerNominalBinding -> BindingObligation -> Text +renderNominalObligationSignature importPlan ctx nominal binding obligation = + obligationSymbol obligation + <> " :: " + <> case obligationKind obligation of + BindingValue -> "NominalBinding " <> domainType <> " " <> representationType + FixtureValue -> "NominalFixtureCases " <> domainType + InitialValue -> domainType + where + domainType = renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding)) + representationType = case resolvedNominalRepresentation nominal of + IdRepresentation prefix -> "(KindID " <> tshow prefix <> ")" + EnumRepresentation {} -> + renderReferenceOrDie + importPlan + ( qualifiedTypeReference + (nominalRepresentationModule ctx (resolvedNominalName nominal)) + (resolvedNominalName nominal <> "Representation") + ) + ScalarRepresentation NominalText -> "Text" + ScalarRepresentation NominalInt -> "Int" + ScalarRepresentation NominalNatural -> "Natural" + ScalarRepresentation NominalBool -> "Bool" + ScalarRepresentation NominalTime -> "UTCTime" + +qualifiedTypeReference :: Text -> Text -> HaskellReference +qualifiedTypeReference moduleName typeName = + HaskellReference moduleName typeName TypeNamespace RequireQualified + +constructorReference :: Text -> Text -> HaskellReference +constructorReference moduleName constructor = + HaskellReference moduleName constructor ConstructorNamespace RequireQualified + +shapeModule :: Context -> TypeGraph -> (StructuralDecl, ResolvedMappedShape) -> ScaffoldModule +shapeModule ctx graph (declaration, shape) = + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" (structuralShapeModule ctx (sdName declaration)) <> ".hs"), + moduleText = emitShape ctx graph declaration shape, + kind = Generated, + origin = nodeOrigin "mapped structural" (sdName declaration) (sdLoc declaration) + } + +structuralPrefix :: Context -> Text +structuralPrefix ctx = case placement ctx of + GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".Structural" + CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.Structural" + +structuralShapeModule :: Context -> Name -> Text +structuralShapeModule ctx name = structuralPrefix ctx <> ".Shape." <> name + +nominalRepresentationModule :: Context -> Name -> Text +nominalRepresentationModule ctx name = case placement ctx of + GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".Nominal.Shape." <> name + CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Nominal.Shape." <> name <> ".Generated" + +-- | Emit the one generated nominal authority for the complete context. The +-- empty declaration attribution is intentional: in a workspace this module is +-- context-level even when all declarations currently happen to live in one +-- member, so moving that member cannot move Haskell type ownership. +generatedNominalOwners :: Context -> CheckedService -> [(ScaffoldModule, [Name])] +generatedNominalOwners ctx service = case planNominalGenerationForService ctx service of + Left _ -> [] + Right [] -> [] + Right owners -> + [ ( ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" (generatedNominalModule ctx) <> ".hs"), + moduleText = emitGeneratedNominals languageContract ctx owners, + kind = Generated, + origin = "context " <> specContext spec <> " generated nominal declarations" + }, + [] + ) + ] + <> [ ( ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" (generatedNominalInternalModule ctx) <> ".hs"), + moduleText = emitGeneratedNominalInternals ctx enforcingIds, + kind = Generated, + origin = "context " <> specContext spec <> " generated nominal ID internals" + }, + [] + ) + | not (null enforcingIds) + ] + where + enforcingIds = + [ (nominal, contract) + | owner <- owners, + let nominal = nominalDeclaration owner, + IdRepresentation prefix <- [resolvedNominalRepresentation nominal], + Just contract <- [idDomainContractFor languageContract prefix] + ] + where + spec = checkedSpec service + languageContract = checkedLanguageContract service + +generatedNominalInternalModule :: Context -> Text +generatedNominalInternalModule ctx = generatedNominalModule ctx <> ".Internal" + +emitGeneratedNominals :: EffectiveLanguageContract -> Context -> [NominalGenerationOwner] -> Text +emitGeneratedNominals languageContract ctx owners = + nl + ( renderGeneratedLanguagePragmas localExtensions + <> [ generatedBanner, + moduleHeader, + "", + "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 [] + localExtensions = + [ExtDeriveAnyClass | any (nominalUsesDeriveAnyClass . nominalDeclaration) owners] + <> [ExtTypeFamilies | usesEquality] + 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 + nominalUsesDeriveAnyClass nominal = case resolvedNominalRepresentation nominal of + IdRepresentation prefix -> not (isJust (idDomainContractFor languageContract prefix)) + EnumRepresentation {} -> True + ScalarRepresentation {} -> False + +emitGeneratedNominal :: EffectiveLanguageContract -> Bool -> ResolvedNominalType -> Text +emitGeneratedNominal languageContract equalityUsed nominal = case resolvedNominalRepresentation nominal of + IdRepresentation prefix + | Just _ <- idDomainContractFor languageContract prefix -> + nl $ + ["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 + [ 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 + [ generatedBanner, + "module " <> moduleName <> " (" <> representationType <> " (..), " <> encoderName <> ") where", + "", + "import Data.Text (Text)", + "import GHC.Generics (Generic)", + "", + "data " <> representationType <> " = " <> T.intercalate " | " (map fst (NE.toList constructors)), + " deriving stock (Eq, Generic, Ord, Show, Enum, Bounded)", + "", + encoderName <> " :: " <> representationType <> " -> Text", + encoderName <> " = \\case", + nl [" " <> constructor <> " -> " <> tshow wire | (constructor, wire) <- NE.toList constructors] + ], + kind = Generated, + origin = nodeOrigin "bound nominal enum representation" (resolvedNominalName nominal) (resolvedNominalLoc nominal) + } + where + moduleName = nominalRepresentationModule ctx (resolvedNominalName nominal) + representationType = resolvedNominalName nominal <> "Representation" + encoderName = lowerFirst (resolvedNominalName nominal) <> "RepresentationText" + +nominalProjectionModule :: Context -> Text +nominalProjectionModule ctx = case placement ctx of + GeneratedPrefix -> rootPrefix ctx <> "Generated." <> ctxPascalOf ctx <> ".NominalProjections" + CollocatedLeaf -> rootPrefix ctx <> ctxPascalOf ctx <> ".Generated.NominalProjections" + +nominalProjectionOwners :: Context -> CheckedService -> [(ScaffoldModule, [Name])] +nominalProjectionOwners ctx service = case nominalProjectionTypes spec of + [] -> [] + nominals -> + [ ( ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" (nominalProjectionModule ctx) <> ".hs"), + moduleText = emitNominalProjections (checkedLanguageContract service) ctx nominals, + kind = Generated, + origin = "context " <> specContext spec <> " nominal scalar projection facade" + }, + [] + ) + ] + where + spec = checkedSpec service + +nominalProjectionTypes :: Spec -> [ResolvedNominalType] +nominalProjectionTypes spec = + Map.elems . Map.fromList $ + [ (resolvedNominalName nominal, nominal) + | aggregate <- [value | NAggregate value <- specNodes spec], + resolved <- registerTypes aggregate <> commandTypes aggregate, + AggregateNominal nominal <- [resolved], + ConsumerNominal {} <- [resolvedNominalOwnership nominal] + ] + where + symbols = aggregateSymbols spec + registerTypes aggregate = + [ resolved + | register <- aggRegs aggregate, + Right resolved <- [resolveAggregateType symbols (regLoc register) RegisterUse (regType register)] + ] + commandTypes aggregate = + [ resolved + | command <- aggCommands aggregate, + field <- cmdFields command, + Right resolved <- [inferAggregateFieldType symbols aggregate CommandFieldUse field] + ] + +emitNominalProjections :: EffectiveLanguageContract -> Context -> [ResolvedNominalType] -> Text +emitNominalProjections languageContract ctx nominals = + nl $ + renderGeneratedLanguagePragmas [ExtTypeFamilies] + <> [ generatedBanner, + "module " <> moduleName <> " where", + "" + ] + <> map ("import " <>) imports + <> T.lines (renderPlannedImports importPlan) + <> [""] + <> [T.intercalate "\n\n" (map emitNominalProjection nominals)] + where + moduleName = nominalProjectionModule ctx + imports = + sort . nub $ + [ "Keiki.Core (ExactFieldProjection (..), FieldProjection (..), FieldWitness, exactFieldWitness, fieldWitness)", + "Keiro.Codec.Nominal (nominalFromRepresentation, nominalToRepresentation)" + ] + <> ["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 + importPlan = + planImportsOrDie + moduleName + ( Set.fromList + [ tagName + | nominal <- nominals, + tagName <- case resolvedNominalRepresentation nominal of + ScalarRepresentation {} -> [resolvedNominalName nominal <> "NominalProjection"] + IdRepresentation {} -> [nominalEqualityTagName nominal] + EnumRepresentation {} -> [nominalEqualityTagName nominal] + ] + ) + ( Set.fromList + [ reference + | nominal <- nominals, + ConsumerNominal binding <- [resolvedNominalOwnership nominal], + reference <- + [ haskellTypeReference (consumerNominalHaskell binding), + qualifiedValueReference (consumerNominalBinding binding) + ] + <> case resolvedNominalRepresentation nominal of + EnumRepresentation constructors -> + HaskellReference representationModule (lowerFirst (resolvedNominalName nominal) <> "RepresentationText") ValueNamespace RequireQualified + : [ HaskellReference representationModule constructor ConstructorNamespace RequireQualified + | (constructor, _) <- NE.toList constructors + ] + where + representationModule = nominalRepresentationModule ctx (resolvedNominalName nominal) + _ -> [] + ] + ) + emitNominalProjection nominal = case resolvedNominalOwnership nominal of + GeneratedNominal -> "" + ConsumerNominal binding -> case resolvedNominalRepresentation nominal of + ScalarRepresentation {} -> emitScalarProjection nominal binding + IdRepresentation prefix -> emitConsumerIdProjection nominal binding prefix + EnumRepresentation constructors -> emitConsumerEnumProjection nominal binding constructors + emitScalarProjection nominal binding = + nl + [ "data " <> tagName, + "", + "instance FieldProjection " <> tagName <> " where", + " type FieldName " <> tagName <> " = " <> tshow name, + " type FieldOwner " <> tagName <> " = " <> renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding)), + " type FieldResult " <> tagName <> " = " <> scalarHaskellType (resolvedNominalRepresentation nominal), + " fieldShapeId _ = " <> tshow (unCanonicalTypeId (consumerNominalCanonical binding)), + " projectFieldValue _ = nominalToRepresentation " <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)), + "", + witnessName <> " :: FieldWitness " <> tagName, + witnessName <> " = fieldWitness @" <> tagName + ] + where + name = resolvedNominalName nominal + tagName = name <> "NominalProjection" + witnessName = lowerFirst name <> "Witness" + emitConsumerIdProjection nominal binding prefix = + nl + ( patternLines + <> [ "", + "data " <> tagName, + "", + "instance FieldProjection " <> tagName <> " where", + " type FieldName " <> tagName <> " = " <> tshow name, + " type FieldOwner " <> tagName <> " = " <> ownerType, + " type FieldResult " <> tagName <> " = Text", + " fieldShapeId _ = " <> tshow equalityIdentity, + " projectFieldValue _ = KindID.toText . nominalToRepresentation " <> bindingName, + "", + "instance ExactFieldProjection " <> tagName <> " where", + " fieldProjectionDomain _ = textProjectionDomain " <> patternName, + " reconstructFieldOwner _ value" + ] + <> validationGuard + <> [ " | not (matchesTextPattern " <> patternName <> " value) = Nothing", + " | otherwise = case KindID.parseText @" <> tshow prefix <> " value of", + " Left _ -> Nothing", + " Right representation -> Just (nominalFromRepresentation " <> bindingName <> " representation)", + "", + witnessName <> " :: FieldWitness " <> tagName, + witnessName <> " = exactFieldWitness @" <> tagName + ] + ) + where + name = resolvedNominalName nominal + tagName = nominalEqualityTagName nominal + witnessName = nominalEqualityWitnessName nominal + patternName = lowerFirst name <> "EqualityPattern" + ownerType = renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding)) + bindingName = renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)) + equalityIdentity = fromMaybe (error "consumer ID equality contract missing") (nominalEqualityIdentityForService languageContract nominal) + enforced = isJust (idDomainContractFor languageContract prefix) + patternLines + | enforced = + [ patternName <> " :: TextPattern", + patternName <> " = either (error . show) id (idDomainTextPattern (typeIdV7Domain " <> tshow prefix <> "))" + ] + | otherwise = + [ patternName <> " :: TextPattern", + patternName <> " = either (error . show) id $ do", + " prefix <- textLiteral " <> tshow (prefix <> "_"), + " leading <- textCharSet ('0' :| \"1234567\")", + " crockford <- textCharSet ('0' :| \"123456789abcdefghjkmnpqrstvwxyz\")", + " suffix <- textRepeatBetween 25 25 crockford", + " pure (textConcat (prefix :| [leading, suffix]))" + ] + validationGuard = + [ " | Left _ <- validateIdDomainText (typeIdV7Domain " <> tshow prefix <> ") value = Nothing" + | enforced + ] + emitConsumerEnumProjection nominal binding constructors = + nl $ + [ "data " <> tagName, + "", + "instance FieldProjection " <> tagName <> " where", + " type FieldName " <> tagName <> " = " <> tshow name, + " type FieldOwner " <> tagName <> " = " <> ownerType, + " type FieldResult " <> tagName <> " = Text", + " fieldShapeId _ = " <> tshow equalityIdentity, + " projectFieldValue _ = " <> encoderName <> " . nominalToRepresentation " <> bindingName, + "", + "instance ExactFieldProjection " <> tagName <> " where", + " fieldProjectionDomain _ = finiteProjectionDomain (" <> renderNonEmpty (map (tshow . snd) (NE.toList constructors)) <> ")", + " reconstructFieldOwner _ = \\case" + ] + <> [ " " <> tshow wire <> " -> Just (nominalFromRepresentation " <> bindingName <> " " <> representationConstructor constructor <> ")" + | (constructor, wire) <- NE.toList constructors + ] + <> [ " _ -> Nothing", + "", + witnessName <> " :: FieldWitness " <> tagName, + witnessName <> " = exactFieldWitness @" <> tagName + ] + where + name = resolvedNominalName nominal + tagName = nominalEqualityTagName nominal + witnessName = nominalEqualityWitnessName nominal + ownerType = renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding)) + bindingName = renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)) + representationModule = nominalRepresentationModule ctx name + encoderName = renderReferenceOrDie importPlan (HaskellReference representationModule (lowerFirst name <> "RepresentationText") ValueNamespace RequireQualified) + representationConstructor constructor = renderReferenceOrDie importPlan (HaskellReference representationModule constructor ConstructorNamespace RequireQualified) + equalityIdentity = fromMaybe (error "consumer enum equality contract missing") (nominalEqualityIdentityForService languageContract nominal) + scalarHaskellType representation = case representation of + ScalarRepresentation NominalText -> "Text" + ScalarRepresentation NominalInt -> "Int" + ScalarRepresentation NominalNatural -> "Natural" + ScalarRepresentation NominalBool -> "Bool" + ScalarRepresentation NominalTime -> "UTCTime" + IdRepresentation {} -> "()" + EnumRepresentation {} -> "()" + +structuralProjectionModule :: Context -> Text +structuralProjectionModule ctx = structuralPrefix ctx <> "Projections" + +emitShape :: Context -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text +emitShape ctx graph declaration shape = + nl $ + languagePragmas + <> [ generatedBanner, + "module " <> moduleName <> " (" <> shapeType <> " (..)) where", + "" + ] + <> map ("import " <>) imports + <> T.lines (renderPlannedImports importPlan) + <> ["" | not (null imports) || not (T.null (renderPlannedImports importPlan))] + <> [shapeDeclaration] + where + moduleName = structuralShapeModule ctx (sdName declaration) + shapeType = sdName declaration <> "Shape" + requirements = shapeRequirements ctx graph shape + languagePragmas = renderGeneratedLanguagePragmas [] + imports = + sort . nub $ + ["Data.Aeson (Value)" | ReqJson `elem` requirements] + <> ["Data.Map.Strict (Map)" | ReqMap `elem` requirements] + <> ["Data.Text (Text)" | ReqText `elem` requirements] + <> ["Data.Time (UTCTime)" | ReqTime `elem` requirements] + <> ["GHC.Generics (Generic)"] + <> ["Numeric.Natural (Natural)" | ReqNatural `elem` requirements] + shapeDeclaration = + foldMappedShape + MappedShapeAlgebra + { onRecord = \constructor _ fields -> + nl $ + ["data " <> shapeType <> " = " <> constructor] + <> recordFields + [ (rwfHaskell field, renderShapeType importPlan ctx graph (rwfType field)) + | field <- fields + ] + <> [" deriving stock (Eq, Generic, Show)"], + onEnum = \entries -> + "data " + <> shapeType + <> " = " + <> T.intercalate " | " (map weCtor entries) + <> "\n deriving stock (Eq, Generic, Show)", + onUnion = \_ arms -> + nl $ + case arms of + [] -> ["data " <> shapeType <> " = " <> shapeType <> "Empty", " deriving stock (Eq, Generic, Show)"] + firstArm : rest -> + ["data " <> shapeType <> " = " <> renderArm firstArm] + <> [" | " <> renderArm arm | arm <- rest] + <> [" deriving stock (Eq, Generic, Show)"] + } + shape + renderArm arm = rwaCtor arm <> maybe "" ((" !" <>) . renderShapeType importPlan ctx graph) (rwaPayload arm) + importPlan = + planImportsOrDie + moduleName + (Set.singleton shapeType) + (Set.fromList [reference | ReqReference reference <- requirements]) + +data ShapeRequirement + = ReqJson + | ReqMap + | ReqText + | ReqTime + | ReqNatural + | ReqReference !HaskellReference + deriving stock (Eq, Ord, Show) + +shapeRequirements :: Context -> TypeGraph -> ResolvedMappedShape -> [ShapeRequirement] +shapeRequirements ctx graph = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ fields -> concatMap (exprRequirements ctx graph . rwfType) fields, + onEnum = const [], + onUnion = \_ arms -> concatMap (maybe [] (exprRequirements ctx graph) . rwaPayload) arms + } + +exprRequirements :: Context -> TypeGraph -> ResolvedTypeExpr -> [ShapeRequirement] +exprRequirements ctx graph = + foldTypeExpr + TypeExprAlgebra + { onText = [ReqText], + onInt = [], + onInteger = [], + onBool = [], + onNatural = [ReqNatural], + onTime = [ReqTime], + onJson = [ReqJson], + onOptional = id, + onList = id, + onMap = (ReqMap :) . (ReqText :), + onRef = \key -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural declaration _) -> + [ ReqReference + ( HaskellReference + (structuralShapeModule ctx (sdName declaration)) + (sdName declaration <> "Shape") + TypeNamespace + RequireQualified + ) + ] + Just (ResolvedOpaque declaration) -> [ReqReference (haskellTypeReference (odHaskell declaration))] + Nothing -> [] + } + +renderShapeType :: HaskellImportPlan -> Context -> TypeGraph -> ResolvedTypeExpr -> Text +renderShapeType importPlan ctx graph = + renderStrictOrApplicationArgument + . foldTypeExpr + TypeExprAlgebra + { onText = atomicShapeType "Text", + onInt = atomicShapeType "Int", + onInteger = atomicShapeType "Integer", + onBool = atomicShapeType "Bool", + onNatural = atomicShapeType "Natural", + onTime = atomicShapeType "UTCTime", + onJson = atomicShapeType "Value", + onOptional = applicationShapeType . ("Maybe " <>) . renderStrictOrApplicationArgument, + onList = atomicShapeType . ("[" <>) . (<> "]") . renderedShapeTypeText, + onMap = applicationShapeType . ("Map Text " <>) . renderStrictOrApplicationArgument, + onRef = + atomicShapeType . \key -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural nested _) -> + renderReferenceOrDie + importPlan + (HaskellReference (structuralShapeModule ctx (sdName nested)) (sdName nested <> "Shape") TypeNamespace RequireQualified) + Just (ResolvedOpaque opaque) -> + renderReferenceOrDie importPlan (haskellTypeReference (odHaskell opaque)) + Nothing -> "()" + } + +data ShapeTypePrecedence + = AtomicShapeType + | ApplicationShapeType + +data RenderedShapeType = RenderedShapeType + { renderedShapeTypePrecedence :: !ShapeTypePrecedence, + renderedShapeTypeText :: !Text + } + +atomicShapeType :: Text -> RenderedShapeType +atomicShapeType = RenderedShapeType AtomicShapeType + +applicationShapeType :: Text -> RenderedShapeType +applicationShapeType = RenderedShapeType ApplicationShapeType + +renderStrictOrApplicationArgument :: RenderedShapeType -> Text +renderStrictOrApplicationArgument rendered = case renderedShapeTypePrecedence rendered of + AtomicShapeType -> renderedShapeTypeText rendered + ApplicationShapeType -> "(" <> renderedShapeTypeText rendered <> ")" + +data StructuralProjection = StructuralProjection + { spTag :: !Text, + spWitness :: !Text, + spPointer :: !Text, + spOwner :: !HaskellSource, + spResult :: !Text, + spCanonical :: !CanonicalTypeId, + spBinding :: !QualifiedValueName, + spSelectors :: ![(Text, Text)] + } + deriving stock (Eq, Show) + +projectionSpecs :: TypeGraph -> [StructuralProjection] +projectionSpecs graph = + sortOn spTag . allocateProjectionNames . concat $ + [ projectionsForRoot graph declaration shape + | ResolvedStructural declaration shape <- Map.elems (tgDeclarations graph) + ] + +projectionsForRoot :: TypeGraph -> StructuralDecl -> ResolvedMappedShape -> [StructuralProjection] +projectionsForRoot graph root rootShape = case rootShape of + RRecord _ _ fields -> concatMap (walkField [] []) fields + REnum {} -> [] + RUnion {} -> [] + where + walkField keys selectors field + | rwfPresence field /= PRequired = [] + | otherwise = case projectionScalar (rwfType field) of + Just result -> [mkProjection (keys <> [rwfKey field]) (selectors <> [(shapeModuleForOwner, rwfHaskell field)]) result] + Nothing -> case rwfType field of + RRef key -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural nested (RRecord _ _ nestedFields)) -> + concatMap + (walkNested nested (keys <> [rwfKey field]) (selectors <> [(shapeModuleForOwner, rwfHaskell field)])) + nestedFields + _ -> [] + _ -> [] + where + shapeModuleForOwner = "__SHAPE__." <> sdName root + + walkNested owner keys selectors field + | rwfPresence field /= PRequired = [] + | otherwise = case projectionScalar (rwfType field) of + Just result -> [mkProjection (keys <> [rwfKey field]) (selectors <> [(shapeModuleFor owner, rwfHaskell field)]) result] + Nothing -> case rwfType field of + RRef key -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural nested (RRecord _ _ nestedFields)) -> + concatMap + (walkNested nested (keys <> [rwfKey field]) (selectors <> [(shapeModuleFor owner, rwfHaskell field)])) + nestedFields + _ -> [] + _ -> [] + + -- Context is supplied when rendering; this marker is replaced there. + shapeModuleFor declaration = "__SHAPE__." <> sdName declaration + mkProjection keys selectors result = + StructuralProjection + { spTag = nameStem <> "Projection", + spWitness = lowerFirst nameStem <> "Witness", + spPointer = pointer, + spOwner = sdHaskell root, + spResult = result, + spCanonical = sdCanonical root, + spBinding = sdBinding root, + spSelectors = selectors + } + where + pointer = T.concat ["/" <> escapePointer key | key <- keys] + nameStem = projectionNameStem (sdName root) pointer + +projectionScalar :: ResolvedTypeExpr -> Maybe Text +projectionScalar = \case + RText -> Just "Text" + RInt -> Just "Int" + RInteger -> Just "Integer" + RBool -> Just "Bool" + RTime -> Just "UTCTime" + RNatural -> Just "Natural" + RJson -> Nothing + ROptional {} -> Nothing + RList {} -> Nothing + RMap {} -> Nothing + RRef {} -> Nothing + +escapePointer :: Text -> Text +escapePointer = T.replace "/" "~1" . T.replace "~" "~0" + +projectionNameStem :: Name -> Text -> Text +projectionNameStem owner pointer = + pascal owner + <> T.concat + [ normaliseAliasPart (unescapePointer segment) + | segment <- filter (not . T.null) (T.splitOn "/" pointer) + ] + +-- | Add a stable digest only when two distinct wire paths normalize to the +-- same Haskell name. Digest collisions receive a deterministic ordinal, so the +-- emitter never produces duplicate declarations even in that unlikely case. +allocateProjectionNames :: [StructuralProjection] -> [StructuralProjection] +allocateProjectionNames specs = concatMap allocateGroup groups + where + groups = groupBy (\left right -> spTag left == spTag right) (sortOn spTag specs) + allocateGroup [spec] = [spec] + allocateGroup collided = reverse named + where + ordered = sortOn projectionIdentity collided + digest spec = T.take 8 (fnv1a64 (projectionIdentity spec)) + digestCounts = Map.fromListWith (+) [(digest spec, 1 :: Int) | spec <- ordered] + (_, named) = foldl allocate (Map.empty, []) ordered + allocate (seen, allocated) spec = + let shortDigest = digest spec + occurrence = Map.findWithDefault 0 shortDigest seen + 1 + suffix = + shortDigest + <> if Map.findWithDefault 0 shortDigest digestCounts == 1 + then "" + else tshow' occurrence + in (Map.insert shortDigest occurrence seen, renameWithSuffix suffix spec : allocated) + projectionIdentity spec = unCanonicalTypeId (spCanonical spec) <> "#" <> spPointer spec + renameWithSuffix suffix spec = + spec + { spTag = nameStem <> suffix <> "Projection", + spWitness = lowerFirst nameStem <> suffix <> "Witness" + } + where + nameStem = fromMaybe (spTag spec) (T.stripSuffix "Projection" (spTag spec)) + +projectionWitnessName :: TypeGraph -> MappedKey -> Text -> Maybe Text +projectionWitnessName graph owner pointer = do + ResolvedStructural declaration _ <- Map.lookup owner (tgDeclarations graph) + spWitness + <$> find + (\spec -> spCanonical spec == sdCanonical declaration && spPointer spec == pointer) + (projectionSpecs graph) + +emitStructuralProjections :: Context -> TypeGraph -> Text +emitStructuralProjections ctx graph = + nl $ + renderGeneratedLanguagePragmas [ExtTypeFamilies] + <> [ 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)" + ] + <> T.lines (renderPlannedImports importPlan) + <> concatMap renderProjection specs + where + moduleName = structuralProjectionModule ctx + specs = map (resolveProjectionModules ctx) (projectionSpecs graph) + importPlan = + planImportsOrDie + moduleName + (Set.fromList (map spTag specs)) + ( Set.fromList + ( [haskellTypeReference (spOwner spec) | spec <- specs] + <> [qualifiedValueReference (spBinding spec) | spec <- specs] + <> [ HaskellReference shapeModuleName selector ValueNamespace RequireQualified + | spec <- specs, + (shapeModuleName, selector) <- spSelectors spec + ] + ) + ) + renderProjection spec = + [ "", + "data " <> spTag spec, + "", + "instance FieldProjection " <> spTag spec <> " where", + " type FieldName " <> spTag spec <> " = " <> tshow (spPointer spec), + " type FieldOwner " <> spTag spec <> " = " <> renderReferenceOrDie importPlan (haskellTypeReference (spOwner spec)), + " type FieldResult " <> spTag spec <> " = " <> spResult spec, + " fieldShapeId _ = " <> tshow (unCanonicalTypeId (spCanonical spec)), + " projectFieldValue _ owner = " <> renderGetter spec, + "", + spWitness spec <> " :: FieldWitness " <> spTag spec, + spWitness spec <> " = fieldWitness @" <> spTag spec + ] + renderGetter spec = + foldl + ( \value (shapeModuleName, selector) -> + renderReferenceOrDie importPlan (HaskellReference shapeModuleName selector ValueNamespace RequireQualified) + <> " (" + <> value + <> ")" + ) + ("bindingToShape " <> renderReferenceOrDie importPlan (qualifiedValueReference (spBinding spec)) <> " owner") + (spSelectors spec) + +resolveProjectionModules :: Context -> StructuralProjection -> StructuralProjection +resolveProjectionModules ctx spec = + spec + { spSelectors = + [ (replaceModule marker, selector) + | (marker, selector) <- spSelectors spec + ] + } + where + replaceModule marker + | Just name <- T.stripPrefix "__SHAPE__." marker = structuralShapeModule ctx name + | otherwise = structuralShapeModule ctx (lastSegment marker) + +haskellTypeReference :: HaskellSource -> HaskellReference +haskellTypeReference source = + HaskellReference (hsModule source) (hsType source) TypeNamespace PreferUnqualified + +qualifiedValueReference :: QualifiedValueName -> HaskellReference +qualifiedValueReference qualified = + HaskellReference moduleName valueName ValueNamespace RequireQualified + where + (moduleName, valueName) = splitQualified (unQualifiedValueName qualified) + +renderReferenceOrDie :: HaskellImportPlan -> HaskellReference -> Text +renderReferenceOrDie importPlan = + either + (error . ("validated Haskell reference failed: " <>) . show) + id + . renderPlannedReference importPlan + +planImportsOrDie :: Text -> Set.Set Text -> Set.Set HaskellReference -> HaskellImportPlan +planImportsOrDie target localDeclarations = + either + (error . ("validated Haskell import planning failed: " <>) . show) + id + . planHaskellImports + ImportEnvironment + { targetModule = target, + localNames = localDeclarations, + reservedQualifiers = rendererReservedQualifiers + } + +rendererReservedQualifiers :: Set.Set Text +rendererReservedQualifiers = + Set.fromList + [ "Aeson", + "AesonKey", + "AesonKeyMap", + "B", + "GeneratedNominals", + "Holes", + "K", + "Key", + "KeyMap", + "KindID", + "Map", + "NominalProjections", + "NonEmpty", + "S", + "Set", + "StructuralProjections", + "T" + ] + +splitQualified :: Text -> (Text, Text) +splitQualified value = + let (prefix, name) = T.breakOnEnd "." value + in (T.dropEnd 1 prefix, name) + +lastSegment :: Text -> Text +lastSegment = snd . T.breakOnEnd "." + +-- | Emit all modules for one aggregate. The 'Spec' is needed for the shared +-- id\/enum declarations. +scaffoldAggregate :: Context -> Spec -> Aggregate -> [ScaffoldModule] +scaffoldAggregate ctx spec = scaffoldAggregateForService ctx (legacyCheckedService spec) + +-- | Emit all modules for one aggregate after selecting the effective semantic +-- contract. This is the normal source/workspace generation entry point. +scaffoldAggregateForService :: Context -> CheckedService -> Aggregate -> [ScaffoldModule] +scaffoldAggregateForService ctx service agg = + [ genModule a "Domain" (emitDomain a), + genModule a "Codec" (emitCodec a) + ] + ++ ( if hasVersion2Ownership a + then + [ genModule a "Transducer" (emitGeneratedTransducer a), + genModule a "BehaviorContract" (emitBehaviorContract a), + behaviorHoleModule a + ] + else [] + ) + ++ [ genModule a "EventStream" (emitEventStream a), + genModule a "Projection" (emitProjection a) + ] + ++ [holeModule a (emitHoles a) | aggregateNeedsHoleModule a] + where + a = resolveAggForService ctx service agg + +aggregateNeedsHoleModule :: Agg -> Bool +aggregateNeedsHoleModule aggregate + | hasVersion2Ownership aggregate = not (null (version2HoleExports aggregate)) + | otherwise = True + +-- | The generated behavioral contract is deliberately separate from both the +-- authoritative transducer and the create-once witness list. Regeneration can +-- replace this module freely while stale textual keys in @BehaviorHoles@ keep +-- compiling and are reported by reconciliation. +emitBehaviorContract :: Agg -> Text +emitBehaviorContract aggregate = + nl $ + renderGeneratedLanguagePragmas [ExtOverloadedLabels | not (null (aRegs aggregate))] + <> [ "{-# 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" + emitReplayAudit = + nl $ + renderGeneratedLanguagePragmas [] + <> [ generatedBanner, + "--", + "-- Deployment contract:", + "-- * replay-neutral diff: no data audit is required;", + "-- * affected diff: run AuditTargeted with the emitted affected set", + "-- against a production copy under the candidate binary;", + "-- * one-time runtime cutover: run AuditFull;", + "-- * any non-zero audit exit blocks deployment.", + "module " <> moduleName <> " (auditTargets) where", + "" + ] + ++ [ "import " <> genPrefixFor ctx (aggName aggregate) <> ".EventStream qualified as " <> aggName aggregate + | aggregate <- aggregates + ] + ++ [ "import Keiro.ReplayAudit (AuditTarget (..), SomeAuditTarget (..), streamInCategory)", + "import Keiro.Stream qualified as Stream", + "", + "auditTargets :: [SomeAuditTarget]", + "auditTargets =" + ] + ++ concat + [ [ if index == (0 :: Int) then " [ SomeAuditTarget" else " , SomeAuditTarget", + " AuditTarget", + " { eventStream = " <> aggregateName <> "." <> lowerFirst aggregateName <> "EventStream", + " , category = Stream.categoryText " <> aggregateName <> "." <> lowerFirst aggregateName <> "Category", + " , mkStream = streamInCategory (Stream.categoryText " <> aggregateName <> "." <> lowerFirst aggregateName <> "Category)", + " }" + ] + | (index, aggregate) <- zip [0 ..] aggregates, + let aggregateName = aggName aggregate + ] + ++ [" ]"] + +genModule :: Agg -> Text -> Text -> ScaffoldModule +genModule a name body = + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" (aGenPrefix a) <> "/" <> name <> ".hs"), + moduleText = body, + kind = Generated, + origin = nodeOrigin "aggregate" (aName a) (aLoc a) + } + +holeModule :: Agg -> Text -> ScaffoldModule +holeModule a body = + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" (aHolePrefix a) <> "/" <> "Holes.hs"), + moduleText = body, + kind = HoleStub, + origin = nodeOrigin "aggregate" (aName a) (aLoc a) + } + +-------------------------------------------------------------------------------- +-- Integration contract (EP-4): a self-contained payload ADT + codec +-------------------------------------------------------------------------------- + +-- | Emit the deterministic, symbol-free contract layer: a payload ADT +-- (per-event records), the topic constants, the @messageType@ discriminator, and a +-- strict encode\/decode keyed by it. Self-contained (base\/text\/aeson), so it +-- compiles standalone — the cross-service schema both producer and consumer agree +-- on. No keiki symbolic operator (firewall holds). +scaffoldContract :: Context -> ContractNode -> [ScaffoldModule] +scaffoldContract ctx = scaffoldContractWithLanguage ctx (effectiveLanguageContract LegacyUnversioned) + +-- | Emit a contract under the checked service's released semantic contract. +-- Language versions 1 through 3 retain the legacy Text representation; only +-- runtime semantics 3 lowers declared TypeID fields to prefix-indexed KindIDs. +scaffoldContractForService :: Context -> CheckedService -> ContractNode -> [ScaffoldModule] +scaffoldContractForService ctx service = scaffoldContractWithLanguage ctx (checkedLanguageContract service) + +scaffoldContractWithLanguage :: Context -> EffectiveLanguageContract -> ContractNode -> [ScaffoldModule] +scaffoldContractWithLanguage ctx languageContract c = + [ ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Contract.hs"), + moduleText = emitContractGen languageContract genPrefix c, + kind = Generated, + origin = nodeOrigin "contract" (ctrName c) (ctrLoc c) + } + ] + where + genPrefix = genPrefixFor ctx (pascal (ctrName c)) + +emitContractGen :: EffectiveLanguageContract -> Text -> ContractNode -> Text +emitContractGen languageContract genPrefix c = + ( nl $ + pragmas + ++ [generatedBanner] + ++ moduleHeader + ++ [ "", + "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 = + renderGeneratedLanguagePragmas + ( [ExtDuplicateRecordFields | contractNeedsDuplicateRecordFields c] + <> [ExtOverloadedRecordDot | contractUsesRecordDot c] + ) + typedKindIdImports + | hasTypedTypeIds = ["import Data.KindID (KindID)", "import qualified Data.KindID as KindID"] + | otherwise = [] + moduleHeader = + [ "module " <> genPrefix <> ".Contract", + " ( " <> payloadTy <> " (..)" + ] + ++ [" , " <> ceName event <> "Data (..)" | event <- ctrEvents c] + ++ [" , " <> lowerFirst alias <> "Topic" | (alias, _) <- ctrTopics c] + ++ [ " , messageTypeOf", + " , encode" <> payloadTy, + " , parse" <> payloadTy, + " ) where" + ] + topicConstants + | hasTypedTypeIds = + [ T.intercalate + "\n\n" + [lowerFirst alias <> "Topic :: Text\n" <> lowerFirst alias <> "Topic = " <> tshow topic | (alias, topic) <- ctrTopics c] + ] + | otherwise = [lowerFirst alias <> "Topic :: Text\n" <> lowerFirst alias <> "Topic = " <> tshow topic | (alias, topic) <- ctrTopics c] + isTypedTypeId (CTypeId prefix) = isJust (contractIdDomainContractFor languageContract prefix) + isTypedTypeId _ = False + aesonTypesImport = "import Data.Aeson.Types (Parser, explicitParseField, parseEither)" + encodeArm e = + [ " " <> ceName e <> " payload ->", + " object" + ] + ++ objectEntriesFor ((tshow (ctrDiscriminator c) <> " .= (" <> tshow (ceName e) <> " :: Text)") : map encodeField (ceFields e)) + ++ [" ]"] + lead 0 kv = " [ " <> kv + lead _ kv = " , " <> kv + objectEntriesFor entries + | hasTypedTypeIds = + [ (if index == 0 then " [ " else " ") + <> entry + <> if index < length entries - 1 then "," else "" + | (index, entry) <- zip [(0 :: Int) ..] entries + ] + | otherwise = [lead index entry | (index, entry) <- zip [(0 :: Int) ..] entries] + decodeArm e = + [" " <> tshow (ceName e) <> " ->"] + ++ case ceFields e of + [] -> [" pure (" <> ceName e <> " " <> ceName e <> "Data)"] + fields -> + [ " " <> ceName e, + " <$> ( " <> ceName e <> "Data" + ] + ++ [ (if index == 0 then " <$> " else " <*> ") <> decodeField field + | (index, field) <- zip [(0 :: Int) ..] fields + ] + ++ [" )"] + encodeField field = + tshow (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) + +contractNeedsDuplicateRecordFields :: ContractNode -> Bool +contractNeedsDuplicateRecordFields = hasDuplicateNames . concatMap (map cfName . ceFields) . ctrEvents + +contractUsesRecordDot :: ContractNode -> Bool +contractUsesRecordDot = any (not . null . ceFields) . ctrEvents + +emitPayloadAdt :: EffectiveLanguageContract -> Text -> [ContractEvent] -> Text +emitPayloadAdt languageContract tyName events = + sectionsOf [map dataRecord events, [sumDecl]] + where + hasTypedTypeIds = any (any (isTypedTypeId . cfType) . ceFields) events + isTypedTypeId (CTypeId prefix) = isJust (contractIdDomainContractFor languageContract prefix) + isTypedTypeId _ = False + hsType CText = "Text" + hsType CInt = "Int" + hsType (CTypeId prefix) + | isJust (contractIdDomainContractFor languageContract prefix) = "(KindID " <> tshow prefix <> ")" + | otherwise = "Text" + dataRecord e = + "data " + <> ceName e + <> "Data = " + <> ceName e + <> (if hasTypedTypeIds then "Data {" else "Data { ") + <> T.intercalate ", " [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 $ + renderGeneratedLanguagePragmas [] + <> [ generatedBanner, + "module " <> genPrefix <> ".Inbox", + " ( InboxFailure (..)", + " , " <> outcomeType <> " (..)", + " , " <> dispositionType <> " (..)", + " , inboxDedupePolicy", + " , inboxPersistence", + " , inboxDispositionFor", + " , inboxDisposition", + " ) where", + "", + "import Data.Text (Text)", + "import Keiro.Inbox.Types (InboxDedupePolicy (..), InboxPersistence (..), InboxResult (..), RetryDelay (..))", + "", + "-- The dedupe policy (hole-kind 4), lowered to the live InboxDedupePolicy.", + "inboxDedupePolicy :: InboxDedupePolicy", + "inboxDedupePolicy = " <> inkDedupePolicy i, + "", + "-- | Success-path envelope retention passed to runInboxTransactionWith.", + "-- Failures always retain their full operator-facing dead-letter envelope.", + "-- Dedupe-only success rows decode with an empty payload.", + "inboxPersistence :: InboxPersistence", + "inboxPersistence = " <> persistenceCtor (inkPersist i), + "", + "-- Runtime failure detail retained when the inbox wrapper reports a failed handler attempt.", + "data InboxFailure = InboxFailure", + " { inboxFailureReason :: !Text", + " , inboxFailureAttempt :: !(Maybe Int)", + " }", + " deriving stock (Eq, Show)", + "", + "-- Every classification named by the spec. Keeping this closed makes the", + "-- generated table exhaustive and gives handler holes typed inputs.", + "data " <> outcomeType, + " = " <> T.intercalate "\n | " outcomeConstructors, + " deriving stock (Eq, Show)", + "", + "-- The service's declared acknowledgement decision, including its details.", + "data " <> dispositionType, + " = InboxAccept", + " | InboxRetryAfter !RetryDelay !(Maybe InboxFailure)", + " | InboxDeadLetter !(Maybe Text) !(Maybe InboxFailure)", + " deriving stock (Eq, Show)", + "", + "-- The complete disposition table (hole-kind 2).", + "inboxDispositionFor :: " <> outcomeType <> " -> " <> dispositionType, + "inboxDispositionFor outcome = case outcome of" + ] + ++ [" " <> outcomeConstructor (drOutcome row) <> " -> " <> actionExpression (drAction row) | row <- inkDisposition i] + ++ [ "", + "-- Lower the LIVE Keiro.Inbox.Types.InboxResult without an open fallback.", + "inboxDisposition :: InboxResult a -> " <> dispositionType, + "inboxDisposition r = case r of", + " InboxProcessed _ -> inboxDispositionFor " <> outcomeConstructor "processed", + " InboxDuplicate -> inboxDispositionFor " <> outcomeConstructor "duplicate", + " InboxInProgress -> inboxDispositionFor " <> outcomeConstructor "inProgress", + " InboxPreviouslyFailed failureReason ->", + " maybe (inboxDispositionFor " <> outcomeConstructor "previouslyFailed" <> ")", + " (\\reason -> attachFailure (InboxFailure reason Nothing) (inboxDispositionFor " <> outcomeConstructor "previouslyFailed" <> "))", + " failureReason", + " InboxHandlerFailed reason attempts ->", + " attachFailure (InboxFailure reason (Just attempts)) (inboxDispositionFor " <> outcomeConstructor "storeFailed" <> ")", + "", + "attachFailure :: InboxFailure -> " <> dispositionType <> " -> " <> dispositionType, + "attachFailure failure disposition = case disposition of", + " InboxRetryAfter delay _ -> InboxRetryAfter delay (Just failure)", + " InboxDeadLetter reason _ -> InboxDeadLetter reason (Just failure)", + " InboxAccept -> InboxAccept" + ] + where + stem = pascal (inkName i) + outcomeType = stem <> "Outcome" + dispositionType = stem <> "Disposition" + outcomeConstructor = (stem <>) . pascal + outcomeConstructors = map (outcomeConstructor . drOutcome) (inkDisposition i) + actionExpression IAckOk = "InboxAccept" + actionExpression (IRetry win) = "InboxRetryAfter (RetryDelay " <> windowText win <> ") Nothing" + actionExpression (IDeadLetter mr) = "InboxDeadLetter " <> maybe "Nothing" (\reason -> "(Just " <> tshow reason <> ")") mr <> " Nothing" + persistenceCtor InkPersistFull = "PersistFullEnvelope" + persistenceCtor InkPersistDedupeOnly = "PersistDedupeOnly" + +-------------------------------------------------------------------------------- +-- Integration publisher (EP-4): config vs the live Keiro.Outbox runtime +-------------------------------------------------------------------------------- + +-- | Emit the publisher's at-least-once policy compiled against the LIVE +-- @Keiro.Outbox.Types@: the ordering policy (a real 'OrderingPolicy'), the backoff +-- curve (a real 'BackoffSchedule'), and the max-attempts ceiling. Firewall holds. +scaffoldPublisher :: Context -> PublisherNode -> [ScaffoldModule] +scaffoldPublisher ctx pb = + [ ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Publisher.hs"), + moduleText = emitPublisherGen genPrefix pb, + kind = Generated, + origin = nodeOrigin "publisher" (pubName pb) (pubLoc pb) + } + ] + where + genPrefix = genPrefixFor ctx (pascal (pubName pb)) + +emitPublisherGen :: Text -> PublisherNode -> Text +emitPublisherGen genPrefix pb = + nl + [ generatedBanner, + "module " <> genPrefix <> ".Publisher", + " ( publisherOrdering", + " , publisherBackoff", + " , publisherMaxAttempts", + " ) where", + "", + "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 $ + renderGeneratedLanguagePragmas [ExtOverloadedRecordDot | workqueueUsesRecordDot w] + <> [ generatedBanner, + "module " <> genPrefix <> ".Queue", + " ( " <> payloadTy <> " (..)", + " , encode" <> payloadTy, + " , parse" <> payloadTy, + " , queuePhysical, queueDlq, queueTable", + groupKeyExport, + " ) where", + "", + "import Data.Aeson (Value, object, withObject, (.:), (.=))", + "import Data.Aeson.Types (parseEither)", + "import Data.Text (Text)", + "import qualified Data.Text as T", + "", + "queuePhysical, queueDlq, queueTable :: Text", + "queuePhysical = " <> tshow (wqPhysical w), + "queueDlq = " <> tshow (wqDlq w), + "queueTable = " <> tshow (wqTable w), + "" + ] + ++ groupKeyLines + ++ [ "data " <> payloadTy <> " = " <> payloadTy, + " { " <> T.intercalate "\n , " [wqfName f <> " :: !" <> hsType (wqfType f) | f <- wqPayload w], + " }", + " deriving stock (Eq, Show)", + "", + "encode" <> payloadTy <> " :: " <> payloadTy <> " -> Value", + "encode" <> payloadTy <> " p =", + " object" + ] + ++ [lead i (tshow (wqfWire f) <> " .= p." <> wqfName f) | (i, f) <- zip [(0 :: Int) ..] (wqPayload w)] + ++ [ " ]", + "", + "parse" <> payloadTy <> " :: Value -> Either Text " <> payloadTy, + "parse" <> payloadTy <> " = mapLeftText . parseEither (withObject " <> tshow payloadTy <> " go)", + " where", + " go o = " <> payloadTy <> fieldApps (wqPayload w), + "", + "mapLeftText :: Either String b -> Either Text b", + "mapLeftText = either (Left . T.pack) Right" + ] + where + payloadTy = wqPayloadName w + groupKeyExport = case wqGroupKey w of + Nothing -> "" + Just groupKey + | gkVia groupKey == "raw" -> " , groupKeyField, groupKeyFor" + | otherwise -> " , groupKeyField" + groupKeyLines = case wqGroupKey w of + Nothing -> [] + Just groupKey -> common <> derivationLines groupKey + where + common = + [ "groupKeyField :: Text", + "groupKeyField = " <> tshow (gkField groupKey), + "" + ] + derivationLines key + | gkVia key == "raw" = + [ "groupKeyFor :: " <> payloadTy <> " -> Text", + "groupKeyFor payload = payload." <> gkField key, + "" + ] + | otherwise = + [ "-- Opaque group-key derivation '" <> gkVia key <> "' remains hand-owned.", + "-- Captured fixture: " <> fromMaybe "" (gkFixture key), + "" + ] + hsType "bool" = "Bool" + hsType "int" = "Int" + hsType _ = "Text" + lead 0 kv = " [ " <> kv + lead _ kv = " , " <> kv + fieldApps [] = "" + fieldApps fs = " <$> " <> T.intercalate " <*> " ["o .: " <> tshow (wqfWire f) | f <- fs] + +workqueueUsesRecordDot :: WorkqueueNode -> Bool +workqueueUsesRecordDot workqueue = + not (null (wqPayload workqueue)) + || maybe False ((== "raw") . gkVia) (wqGroupKey workqueue) + +-- | Emit the versioned PGMQ envelope adapter. The payload record remains +-- symbol-free and dependency-light in Queue.hs; this runtime-facing module is +-- the opt-in assembly point applications import into their Job values. +emitQueueCodec :: Text -> WorkqueueNode -> Text +emitQueueCodec genPrefix w = + nl + [ generatedBanner, + "-- | Versioned job payload envelope: @{\\\"v\\\",\\\"t\\\",\\\"data\\\"}@.", + "--", + "-- Deploy workers before producers when raising its schema version. Do not", + "-- adopt this codec on a non-empty bare-payload queue without draining it", + "-- (or supplying a transitional codec), or in-flight messages will", + "-- dead-letter. This is telemetry-neutral:", + "-- docs/adr/0001-keiro-pgmq-job-processing-telemetry-contract.md owns", + "-- spans and acknowledgement vocabulary.", + "module " <> genPrefix <> ".QueueCodec (" <> stem <> "PayloadCodec, " <> stem <> "JobCodec) where", + "", + "import Data.List.NonEmpty (NonEmpty (..))", + "import Keiro.Codec (Codec (..), EventType (..))", + "import Keiro.PGMQ.Codec (JobCodec, keiroJobCodec)", + "import " <> genPrefix <> ".Queue (" <> payloadTy <> ", encode" <> payloadTy <> ", parse" <> payloadTy <> ")", + "", + stem <> "PayloadCodec :: Codec " <> payloadTy, + stem <> "PayloadCodec =", + " Codec", + " { eventTypes = EventType " <> tshow payloadTy <> " :| []", + " , eventType = \\_ -> EventType " <> tshow payloadTy, + " , schemaVersion = 1", + " , encode = encode" <> payloadTy, + " , decode = \\_ -> parse" <> payloadTy, + " , upcasters = []", + " }", + "", + stem <> "JobCodec :: JobCodec " <> payloadTy, + stem <> "JobCodec = keiroJobCodec " <> stem <> "PayloadCodec" + ] + where + payloadTy = wqPayloadName w + stem = lowerFirst (T.concat (map pascal (T.splitOn "_" (wqName w)))) + +-- | Emit the pgmq retry policy + JobOutcome disposition compiled against the +-- LIVE @Keiro.PGMQ.Job@ runtime (RetryPolicy / JobOutcome / RetryDelay). This pins +-- the dangerous inversions over the runtime types: storeFailure ⇒ Retry (transient) +-- and decodeFailure ⇒ Dead (poison). +emitQueuePolicy :: Text -> WorkqueueNode -> Text +emitQueuePolicy genPrefix w = + nl $ + [ generatedBanner, + "module " <> genPrefix <> ".QueuePolicy", + " ( " <> outcomeType <> " (..)", + " , retryPolicy, jobOutcomeFor", + " , jobOrdering, jobTuningFor, queueProvision", + " ) where", + "", + "import Keiro.PGMQ.Job (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 $ + renderGeneratedLanguagePragmas [ExtOverloadedRecordDot | rmFeed readModel == RmSubscription] + <> [ generatedBanner, + "module " <> readModelModule <> ".ReadModel", + " ( " <> T.intercalate "\n , " exports, + " ) where", + "", + "import Data.Functor (void)", + "import Effectful (Eff, (:>))", + "import " <> tableModule <> " (" <> qualifiedName <> ")", + "import " <> readModelHolePrefix <> ".ReadModelHoles (" <> T.intercalate ", " holeImports <> ")" + ] + ++ asyncImports + ++ [ "import Keiro.ReadModel (ConsistencyMode (..), ReadModel (..), ReadModelMetadata, StrongScope (..), registerReadModel)", + "import Keiro.ReadModel.Rebuild qualified as Rebuild", + "import Kiroku.Store.Effect (Store)", + "import Kiroku.Store.Types (" <> kirokuTypes <> ")", + "", + readModelName <> " :: ReadModel " <> queryInputType <> " " <> queryResultType, + readModelName <> " =", + " ReadModel", + " { name = " <> tshow registryName, + " , tableName = " <> tshow (rmTable readModel), + " , schema = " <> tshow (rmSchema readModel), + " , subscriptionName = " <> tshow subscriptionName, + " , version = " <> tshow' (rmVersion readModel), + " , shapeHash = " <> tshow (rmShape readModel), + " , defaultConsistency = " <> consistencyExpr (rmConsistency readModel), + " , strongScope = " <> scopeExpr (rmScope readModel), + " , query = " <> queryName, + " }", + "", + "-- Call once at projection startup before serving queries.", + registerName <> " :: (Store :> es) => Eff es ()", + registerName <> " =", + " void (registerReadModel " <> tshow registryName <> " " <> tshow' (rmVersion readModel) <> " " <> tshow (rmShape readModel) <> ")", + "", + startName <> " :: (Store :> es) => GlobalPosition -> Eff es ReadModelMetadata", + startName <> " =", + " Rebuild.startRebuild " <> readModelName <> " " <> projectionNames, + "", + finishName <> " :: (Store :> es) => GlobalPosition -> Eff es (Either Rebuild.RebuildError ReadModelMetadata)", + finishName <> " =", + " Rebuild.finishRebuild " <> readModelName <> " " <> projectionNames, + "", + abandonName <> " :: (Store :> es) => Eff es ReadModelMetadata", + abandonName <> " = Rebuild.abandonRebuild " <> readModelName + ] + ++ asyncDefinition + where + registryName = registryNameFor (contextName ctx) readModel + subscriptionName = subscriptionNameFor (contextName ctx) readModel + asyncName = registryName <> "-async" + readModelName = stem <> "ReadModel" + qualifiedName = stem <> "QualifiedTable" + registerName = "register" <> pascal stem + startName = "start" <> pascal stem <> "Rebuild" + finishName = "finish" <> pascal stem <> "Rebuild" + abandonName = "abandon" <> pascal stem <> "Rebuild" + asyncValueName = stem <> "AsyncProjection" + queryInputType = pascal stem <> "QueryInput" + queryResultType = pascal stem <> "QueryResult" + queryName = stem <> "Query" + applyName = "apply" <> pascal stem + exports = + [ readModelName, + qualifiedName, + registerName, + startName, + finishName, + abandonName + ] + ++ [asyncValueName | rmFeed readModel == RmSubscription] + holeImports = [queryInputType, queryResultType, queryName] ++ [applyName | rmFeed readModel == RmSubscription] + asyncImports = case rmFeed readModel of + RmInline -> [] + RmSubscription -> ["import Keiro.Projection (AsyncProjection (..))"] + kirokuTypes = case rmFeed readModel of + RmInline -> "GlobalPosition" + RmSubscription -> "GlobalPosition, RecordedEvent (..)" + projectionNames = case rmFeed readModel of + RmInline -> "[]" + RmSubscription -> "[" <> tshow asyncName <> "]" + asyncDefinition = case rmFeed readModel of + RmInline -> [] + RmSubscription -> + [ "", + asyncValueName <> " :: AsyncProjection", + asyncValueName <> " =", + " AsyncProjection", + " { name = " <> tshow asyncName, + " , readModelName = " <> tshow registryName, + " , subscriptionName = " <> tshow subscriptionName, + " , applyRecorded = " <> applyName, + " , idempotencyKey = \\recorded -> recorded.eventId", + " }" + ] + consistencyExpr Strong = "Strong" + consistencyExpr Eventual = "Eventual" + scopeExpr Nothing = "EntireLog" + scopeExpr (Just RmEntireLog) = "EntireLog" + scopeExpr (Just (RmCategory categoryName)) = "CategoryHead " <> tshow categoryName + +emitReadModelHoles :: Text -> Text -> Text -> ReadModelNode -> Text +emitReadModelHoles tableModule readModelHolePrefix stem readModel = + nl $ + [ "-- This is a HAND-OWNED hole module. keiro-dsl creates it once and never overwrites it.", + "module " <> readModelHolePrefix <> ".ReadModelHoles", + " ( " <> T.intercalate "\n , " exports, + " ) where", + "", + "import " <> tableModule <> " (" <> qualifiedName <> ")", + "import Hasql.Transaction qualified as Tx" + ] + ++ ["import Kiroku.Store.Types (RecordedEvent(..))" | rmFeed readModel == RmSubscription] + ++ [ "", + "-- HOLE: replace these aliases with the real query input and result types.", + "type " <> queryInputType <> " = ()", + "type " <> queryResultType <> " = ()", + "", + "-- HOLE: query " <> qualifiedTableLiteral readModel <> " via " <> qualifiedName <> "; never rely on search_path.", + "-- Declared columns:" + ] + ++ map (("-- " <>) . readModelColumnDoc) (rmColumns readModel) + ++ [ queryName <> " :: " <> queryInputType <> " -> Tx.Transaction " <> queryResultType, + queryName <> " _input = " <> qualifiedName <> " `seq` error " <> tshow ("HOLE: fill " <> rmName readModel <> " query") + ] + ++ applyStub + where + qualifiedName = stem <> "QualifiedTable" + queryInputType = pascal stem <> "QueryInput" + queryResultType = pascal stem <> "QueryResult" + queryName = stem <> "Query" + applyName = "apply" <> pascal stem + exports = [queryInputType, queryResultType, queryName] ++ [applyName | rmFeed readModel == RmSubscription] + applyStub = case rmFeed readModel of + RmInline -> [] + RmSubscription -> + [ "", + "-- HOLE: apply one recorded event; runtime deduplication makes redelivery safe.", + applyName <> " :: RecordedEvent -> Tx.Transaction ()", + applyName <> " _recorded = error " <> tshow ("HOLE: fill " <> rmName readModel <> " async apply") + ] + +qualifiedTableLiteral :: ReadModelNode -> Text +qualifiedTableLiteral readModel = quoteSqlIdentifier (rmSchema readModel) <> "." <> quoteSqlIdentifier (rmTable readModel) + +quoteSqlIdentifier :: Text -> Text +quoteSqlIdentifier identifier = "\"" <> T.replace "\"" "\"\"" identifier <> "\"" + +readModelColumnDoc :: RmColumn -> Text +readModelColumnDoc columnDecl = + rmcName columnDecl + <> " " + <> rmcType columnDecl + <> if rmcRequired columnDecl then " NOT NULL" else "" + +-------------------------------------------------------------------------------- +-- Router + shared worker-policy lowering (EP-108) +-------------------------------------------------------------------------------- + +scaffoldRouter :: Context -> RouterNode -> [ScaffoldModule] +scaffoldRouter ctx router = + [ ScaffoldModule + { modulePath = modulePathFor genPrefix "Router", + moduleText = emitRouterGen genPrefix router, + kind = Generated, + origin = routerOrigin + }, + ScaffoldModule + { modulePath = modulePathFor holePrefix "RouterHoles", + moduleText = emitRouterHoles holePrefix router, + kind = HoleStub, + origin = routerOrigin + } + ] + where + genPrefix = genPrefixFor ctx (rtId router) + holePrefix = holePrefixFor ctx (rtId router) + routerOrigin = nodeOrigin "router" (rtId router) (rtLoc router) + +emitRouterGen :: Text -> RouterNode -> Text +emitRouterGen genPrefix router = + nl $ + [ generatedBanner, + "module " <> genPrefix <> ".Router", + " ( " <> stem <> "Name", + " , " <> stem <> "WorkerOptions", + " ) where", + "", + "import Data.Text (Text)" + ] + ++ workerPolicyImports (rtPoison router) + ++ [ "", + "-- The STABLE router name. It participates in every target-keyed", + "-- deterministicRouterCommandId; renaming it re-keys replayed dispatches.", + stem <> "Name :: Text", + stem <> "Name = " <> tshow (rtName router), + "", + "-- Runtime-owned dispatch id inputs: (name, key, sourceEventId,", + "-- targetStreamName, occurrence). Target-keyed, not positional.", + "", + "-- Node-level worker policy lowered from the spec. Pass this value to", + "-- Keiro.Router.runRouterWorkerWith; do not silently use defaultWorkerOptions." + ] + ++ workerOptionsLines (stem <> "WorkerOptions") (rtRejected router) (rtPoison router) + where + stem = lowerFirst (rtId router) + +emitRouterHoles :: Text -> RouterNode -> Text +emitRouterHoles holePrefix router = + nl + [ "-- HAND-OWNED hole module for the router's behaviour-bearing bodies.", + "-- keiro-dsl creates it once and never overwrites it.", + "module " <> holePrefix <> ".RouterHoles () where", + "", + "-- HOLE resolve :: " <> inName (rtInput router) <> " -> Eff es [PMCommand targetCommand]", + "-- Spec source: " <> resolveSourceText (rvSource (rtResolve router)) <> ".", + "-- The spec's 'stable' keyword acknowledges that retry attempts accumulate", + "-- the UNION of resolved target identities. Keep the recipient set stable", + "-- for a source event whenever an exact recipient set matters.", + "-- HOLE router value: assemble Keiro.Router.Router with name = " <> lowerFirst (rtId router) <> "Name,", + "-- key, resolve, targetEventStream, and targetProjections; run it with", + "-- runRouterWorkerWith " <> lowerFirst (rtId router) <> "WorkerOptions.", + "-- HOLE targetProjections: spec projections = " <> renderNames (rtProjections router) <> ".", + "-- NOTE on-duplicate AckOk is sound because Keiro.Router confirms a duplicate", + "-- event id against the TARGET stream via confirmBenignDuplicate before", + "-- returning PMCommandDuplicate. Hand-rolled dispatch paths must do likewise." + ] + where + renderNames names = "[" <> T.intercalate ", " names <> "]" + +resolveSourceText :: ResolveSource -> Text +resolveSourceText (ResolveReadModel name) = "read-model " <> name <> " (typically Keiro.ReadModel.runQuery)" +resolveSourceText ResolveHole = "typed resolver hole" + +workerPolicyImports :: PolicyChoice -> [Text] +workerPolicyImports poison = + [ "import Keiro.ProcessManager (PoisonPolicy (..), RejectedCommandPolicy (..), WorkerOptions (..))", + "import Shibuya.Core.Ack (RetryDelay (..))" + ] + ++ if poison == PolHalt + then [] + else ["import Effectful (Eff)", "import Shibuya.Core.Types (Envelope)"] + +workerOptionsLines :: Text -> PolicyChoice -> PolicyChoice -> [Text] +workerOptionsLines valueName rejected poison = + [ valueName <> signature, + valueName <> argument <> " =", + " WorkerOptions", + " { poisonPolicy = " <> poisonExpr <> ",", + " rejectedCommandPolicy = " <> rejectedExpr rejected <> ",", + " transientRetryDelay = RetryDelay 5, -- matches defaultWorkerOptions; runtime tuning", + " metrics = Nothing -- runtime configuration; install at call site", + " }" + ] + where + signature = case poison of + PolHalt -> " :: WorkerOptions es msg" + _ -> " :: (Envelope msg -> Eff es ()) -> WorkerOptions es msg" + argument = case poison of + PolHalt -> "" + _ -> " poisonCallback" + poisonExpr = case poison of + PolHalt -> "PoisonHalt" + PolDeadLetter -> "PoisonDeadLetter poisonCallback" + PolSkip -> "PoisonSkip poisonCallback" + rejectedExpr = \case + PolHalt -> "RejectedHalt" + PolDeadLetter -> "RejectedDeadLetter" + PolSkip -> "RejectedSkip" + +-------------------------------------------------------------------------------- +-- Process manager + durable timer (EP-3) +-------------------------------------------------------------------------------- + +-- | Emit the symbol-free deterministic wiring for a process manager + its timer +-- into a @Generated@ module, plus a create-if-absent @ProcessHoles@ module for the +-- behaviour-bearing bodies (the @handle@ reaction, the deadline window, and the +-- fire command). The @Generated@ module contains no keiki symbolic operator (the +-- saga's transducer is the separate aggregate hole), so the firewall invariant +-- holds. The timer worker uses the spec's @max-attempts@ ceiling, never the +-- dangerous @defaultTimerWorkerOptions@ (@Nothing@) default. +scaffoldProcess :: Context -> ProcessNode -> [ScaffoldModule] +scaffoldProcess ctx p = + [ ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" genPrefix <> "/Process.hs"), + moduleText = emitProcessGen sagaGenPrefix genPrefix holePrefix p, + kind = Generated, + origin = nodeOrigin "process" (procId p) (procLoc p) + }, + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" holePrefix <> "/ProcessHoles.hs"), + moduleText = emitProcessHoles genPrefix holePrefix p, + kind = HoleStub, + origin = nodeOrigin "process" (procId p) (procLoc p) + } + ] + where + genPrefix = genPrefixFor ctx (procId p) + holePrefix = holePrefixFor ctx (procId p) + sagaGenPrefix = genPrefixFor ctx (pascal (sagaAgg (procSaga p))) + +emitProcessGen :: Text -> Text -> Text -> ProcessNode -> Text +emitProcessGen sagaGenPrefix genPrefix _holePrefix p = + nl $ + [ generatedBanner, + "module " <> genPrefix <> ".Process", + " ( " <> lo <> "ProcessName", + " , " <> lo <> "Category", + " , " <> lo <> "ProcessWorkerOptions", + " , " <> lo <> "TimerRequest", + " , " <> lo <> "FireOutcome", + " ) where", + "", + "import Data.Aeson (Value, object, (.=))", + "import Data.Text (Text)", + "import qualified Data.Text as T", + "import Data.Time (UTCTime)", + "import Data.UUID (UUID)", + "import qualified Data.UUID.V5 as UUID.V5", + "import " <> sagaGenPrefix <> ".EventStream (" <> sagaEventStreamType <> ")", + "import Keiro.Command (CommandError (..))", + "import Keiro.Stream qualified as Stream", + "import Keiro.Timer (TimerId (..), TimerRequest (..))" + ] + ++ workerPolicyImports (procPoison p) + ++ [ "", + "-- The define-once ProcessManager name (hole-kind 5: referenced, never retyped).", + lo <> "ProcessName :: Text", + lo <> "ProcessName = " <> tshow (procName p), + "", + "-- The validated saga stream category (hole-kind 5: referenced, never retyped).", + "-- Saga streams are '-' via Keiro.Stream.entityStream.", + "-- categoryUnsafe is safe here because keiro-dsl check proved the literal legal.", + lo <> "Category :: Stream.StreamCategory " <> sagaEventStreamType, + lo <> "Category = Stream.categoryUnsafe " <> tshow categoryName, + "", + "-- Node-level worker policy lowered from the spec. Pass this value to", + "-- Keiro.ProcessManager.runProcessManagerWorkerWith." + ] + ++ workerOptionsLines (lo <> "ProcessWorkerOptions") (procRejected p) (procPoison p) + ++ [ "", + "-- The deterministic timer-request builder: id derived from the correlation", + "-- key (hole-kind 1), processManagerName referenced, payload from the spec.", + "-- (timer id derived as uuidv5 of " <> tshow (idePrefix (tmId timer)) <> " <> correlationId)", + lo <> "TimerRequest :: Text -> UTCTime -> TimerRequest", + lo <> "TimerRequest correlationId fireAtTime =", + " TimerRequest", + " { timerId = TimerId (namedUuid (" <> tshow (idePrefix (tmId timer)) <> " <> correlationId))", + " , processManagerName = " <> lo <> "ProcessName", + " , correlationId = correlationId", + " , fireAt = fireAtTime", + " , payload = " <> payloadExpr (tmPayload timer), + " }", + "", + "-- The timer-fire disposition table (hole-kind 2), derived from the spec.", + "-- on-reject => " <> showOutcome (onReject fd) <> " is the benign inversion.", + "-- A duplicate append reaches on-error unless it is confirmed against the", + "-- target stream. Use Keiro.ProcessManager.confirmBenignDuplicate:", + "-- StreamName -> EventId -> CommandError -> Eff es Bool", + "-- Fold True into the duplicate result and surface False as the failure.", + lo <> "FireOutcome :: Either CommandError a -> Maybe ()", + lo <> "FireOutcome result = case result of", + " Right{} -> " <> outcomeToMaybe (onOk fd), + " Left CommandRejected -> " <> outcomeToMaybe (onReject fd), + " Left (CommandAmbiguous _) -> " <> outcomeToMaybe (onAmbiguous fd) <> " -- explicit definition-bug arm", + " Left{} -> " <> outcomeToMaybe (onError fd), + "", + "-- max-attempts = " <> tshow' (tmMaxAttempts timer) <> ", dead-letter = " <> tshow (tmDeadLetter timer), + "-- (the timer worker must pass Just " <> tshow' (tmMaxAttempts timer) <> " to runTimerWorkerWith, never the", + "-- defaultTimerWorkerOptions Nothing ceiling that retries forever).", + "", + "-- deterministic v5 UUID of a correlation-keyed string (hole-kind 1).", + "namedUuid :: Text -> UUID", + "namedUuid v = UUID.V5.generateNamed UUID.V5.namespaceURL (map (fromIntegral . fromEnum) (T.unpack v))" + ] + where + lo = lowerFirst (procId p) + sagaEventStreamType = pascal (sagaAgg (procSaga p)) <> "EventStreamDef" + categoryName = staticCategory ("process " <> procId p) (sagaCategory (procSaga p)) + timer = procTimer p + fd = fireDisposition (tmFire timer) + +-- | The timer payload, restricted to the spec's literal (@name=\"value\"@) +-- bindings so it compiles in the deterministic builder. Bare fields and +-- ref-valued bindings are input-driven (the agent-written hole), not emitted. +payloadExpr :: [FieldBinding] -> Text +payloadExpr fs = case [b | b <- fs, isLiteral b] of + [] -> "object []" + lits -> "object [ " <> T.intercalate ", " (map kv lits) <> " ]" + where + isLiteral b = maybe False (const True) (fbValue b >>= stripWrappingQuotes) + kv b = tshow (fbName b) <> " .= (" <> maybe "\"\"" tshow (fbValue b >>= stripWrappingQuotes) <> " :: Value)" + stripWrappingQuotes value = T.stripPrefix "\"" value >>= T.stripSuffix "\"" + +showOutcome :: FireOutcome -> Text +showOutcome OFired = "Fired" +showOutcome ORetry = "Retry" + +outcomeToMaybe :: FireOutcome -> Text +outcomeToMaybe OFired = "Just () -- Fired" +outcomeToMaybe ORetry = "Nothing -- Retry" + +emitProcessHoles :: Text -> Text -> ProcessNode -> Text +emitProcessHoles _genPrefix holePrefix p = + nl + [ "-- HAND-OWNED hole module for the process manager's behaviour-bearing bodies.", + "-- keiro-dsl creates it once and never overwrites it.", + "module " <> holePrefix <> ".ProcessHoles () where", + "", + "-- HOLE handle: build the ProcessManagerAction (the self-advance", + "-- '" <> advCommand (hAdvance (procHandle p)) <> "', the dispatch(es), and the timer) from the input.", + "-- HOLE streams: build streamFor with entityStream " <> lowerFirst (procId p) <> "Category;", + "-- build target streams with entityStream " <> lowerFirst (procTarget p) <> "CommandCategory. Never concatenate raw stream names.", + "-- HOLE window: the deadline policy, e.g. surgeWindow :: NominalDiffTime;", + "-- surgeDeadline observedAt = addUTCTime surgeWindow observedAt (TIME INJECTED).", + "-- HOLE fire command: construct " <> fireCommand (tmFire (procTimer p)) <> " for the timer fire,", + "-- keyed by correlationId; the fired-event-id is the deterministic uuidv5 of", + "-- " <> tshow (idePrefix (fireFiredEventId (tmFire (procTimer p)))) <> " <> correlationId.", + "-- NOTE on-duplicate AckOk is sound because the runtime confirms a duplicate", + "-- event id against the TARGET stream via confirmBenignDuplicate before", + "-- returning PMCommandDuplicate. Its effective signature is:", + "-- StreamName -> EventId -> CommandError -> Eff es Bool", + "-- Hand-rolled paths must call it with the target stream and attempted event id,", + "-- fold True into the duplicate result, and surface False as the original failure.", + "-- Never pattern-match DuplicateEvent as success: event ids are globally unique." + ] + +-------------------------------------------------------------------------------- +-- Domain module +-------------------------------------------------------------------------------- + +emitDomain :: Agg -> Text +emitDomain a = + nl $ + renderGeneratedLanguagePragmas + ( [ExtDeriveAnyClass | hasSnapshot a] + <> [ExtDuplicateRecordFields | domainNeedsDuplicateRecordFields a] + <> [ExtTemplateHaskell] + ) + ++ [ generatedBanner, + "module " <> aGenPrefix a <> ".Domain where", + "" + ] + ++ ["import Data.Aeson (FromJSON, ToJSON)" | hasSnapshot a] + ++ [ "import Data.Proxy (Proxy (..))", + "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 " <>) (domainStaticImports a) + ++ T.lines (renderPlannedImports importPlan) + ++ [ "import Keiki.Generics.TH (deriveAggregateCtorsAll, deriveWireCtorsAll)", + "", + sectionsOf + [ [emitVertex a], + map (emitRecord importPlan a) (aCommands a), + [emitSum (aName a <> "Command") (aCommands a)], + map (emitRecord importPlan a) (aEvents a), + [emitSum (aName a <> "Event") (aEvents a)], + [emitRegsType importPlan a, emitInitialRegs importPlan a], + [ "$(deriveAggregateCtorsAll ''" <> aName a <> "Command ''" <> aName a <> "Regs)", + "", + "$(deriveWireCtorsAll ''" <> aName a <> "Event)" + ] + ] + ] + where + importPlan = domainImportPlan a + +domainNeedsDuplicateRecordFields :: Agg -> Bool +domainNeedsDuplicateRecordFields aggregate = hasDuplicateNames selectorNames + where + commandSelectors = concatMap (map fst . rcFields) (aCommands aggregate) + eventSelectors = concatMap (map fst . rcFields) (aEvents aggregate) + registerSelectors = map rrName (aRegs aggregate) + -- deriveWireCtorsAll creates one event TermFields record that repeats each + -- payload selector, so every field-bearing event contributes twice. + selectorNames = commandSelectors <> eventSelectors <> eventSelectors <> registerSelectors + +hasDuplicateNames :: [Text] -> Bool +hasDuplicateNames names = length names /= Set.size (Set.fromList names) + +hasSnapshot :: Agg -> Bool +hasSnapshot = maybe False (const True) . aSnapshot + +emitVertex :: Agg -> Text +emitVertex a = + nl $ + [ "data " <> aVertexType a <> " = " <> T.intercalate " | " (map (vertexCtor a . stName) (aStates a)), + " deriving stock (Generic, Eq, Ord, Show, Enum, Bounded)" + ] + ++ [" deriving anyclass (ToJSON, FromJSON)" | hasSnapshot a] + ++ [ line + | hasSnapshot a, + line <- + [ "instance CanonicalStateShape " <> aVertexType a, + "instance CanonicalTypeName " <> aVertexType a + ] + ] + +emitRecord :: HaskellImportPlan -> Agg -> ResolvedCtor -> Text +emitRecord importPlan a rc = + nl $ + [ "data " <> rcName rc <> "Data = " <> rcName rc <> "Data" + ] + ++ recordFields [(name, renderDomainType importPlan 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 :: HaskellImportPlan -> Agg -> Text +emitRegsType importPlan a = + nl $ + ["type " <> aName a <> "Regs ="] + ++ regListLines importPlan a (aRegs a) + +regListLines :: HaskellImportPlan -> Agg -> [ResolvedRegister] -> [Text] +regListLines _ _ [] = [" '[]"] +regListLines importPlan a rs = + [ lead i <> "'(" <> tshow (rrName r) <> ", " <> renderDomainType importPlan a (rrType r) <> ")" + | (i, r) <- zip [(0 :: Int) ..] rs + ] + ++ [" ]"] + where + lead 0 = " '[ " + lead _ = " , " + +emitInitialRegs :: HaskellImportPlan -> Agg -> Text +emitInitialRegs importPlan a = + nl $ + [ "initial" <> aName a <> "Regs :: RegFile " <> aName a <> "Regs", + "initial" <> aName a <> "Regs =" + ] + ++ chain (aRegs a) + where + chain [] = [" RNil"] + chain rs = + [ " RCons (Proxy @" <> tshow (rrName r) <> ") " <> regInitialValue importPlan a r <> " $" + | r <- init rs + ] + ++ [" RCons (Proxy @" <> tshow (rrName lastR) <> ") " <> regInitialValue importPlan a lastR <> " RNil"] + where + lastR = last rs + +-- | The Haskell initial value for a register, by the category of its type. +regInitialValue :: HaskellImportPlan -> Agg -> ResolvedRegister -> Text +regInitialValue importPlan aggregate register = case rrInitial register of + InitialId name -> case find ((== name) . resolvedNominalName) (aGeneratedNominals aggregate) >>= generatedIdSampleHaskell aggregate of + Just value -> value + Nothing -> renderRegisterInitial (rrInitial register) + InitialNominal _ value -> renderReferenceOrDie importPlan (qualifiedValueReference value) + InitialMapped _ value -> renderReferenceOrDie importPlan (qualifiedValueReference value) + _ -> renderRegisterInitial (rrInitial register) + +domainImportPlan :: Agg -> HaskellImportPlan +domainImportPlan aggregate = + planImportsOrDie + (aGenPrefix aggregate <> ".Domain") + localDeclarations + (Set.unions (map aggregateSourceReferences (domainAggregateSources aggregate)) <> initialReferences) + where + localDeclarations = + Set.fromList + ( [ aVertexType aggregate, + aName aggregate <> "Command", + aName aggregate <> "Event", + aName aggregate <> "Regs" + ] + <> [rcName constructor <> "Data" | constructor <- aCommands aggregate <> aEvents aggregate] + <> map resolvedNominalName (aGeneratedNominals aggregate) + ) + initialReferences = + Set.fromList + ( [ qualifiedValueReference initialValue + | declaration <- mappedUses aggregate, + initialValue <- maybeToListText (mappedInitial declaration) + ] + <> [ qualifiedValueReference initialValue + | resolvedType <- aggregateTypes aggregate, + AggregateNominal nominal <- [resolvedType], + ConsumerNominal binding <- [resolvedNominalOwnership nominal], + initialValue <- maybeToListText (consumerNominalInitial binding) + ] + ) + +domainStaticImports :: Agg -> [Text] +domainStaticImports = Set.toAscList . Set.unions . map aggregateSourceStaticImports . domainAggregateSources + +domainAggregateSources :: Agg -> [AggregateHaskellSource] +domainAggregateSources aggregate = + map (aggregateConsumerHaskellSource (aSymbols aggregate)) (aggregateTypes aggregate) + +aggregateTypes :: Agg -> [ResolvedAggregateType] +aggregateTypes aggregate = + map snd (concatMap rcFields (aCommands aggregate <> aEvents aggregate)) <> map rrType (aRegs aggregate) + +mappedUses :: Agg -> [ResolvedMappedDecl] +mappedUses a = + [ declaration + | resolvedType <- + map snd (concatMap rcFields (aCommands a <> aEvents a)) + <> map rrType (aRegs a), + declaration <- maybeToListText (mappedDeclFor a resolvedType) + ] + +mappedDeclFor :: Agg -> ResolvedAggregateType -> Maybe ResolvedMappedDecl +mappedDeclFor a resolvedType = do + key <- case resolvedType of + AggregateMapped mappedKey -> Just mappedKey + _ -> Nothing + graph <- aTypeGraph a + Map.lookup key (tgDeclarations graph) + +mappedInitial :: ResolvedMappedDecl -> Maybe QualifiedValueName +mappedInitial (ResolvedStructural declaration _) = sdInitial declaration +mappedInitial (ResolvedOpaque declaration) = odInitial declaration + +renderDomainType :: HaskellImportPlan -> Agg -> ResolvedAggregateType -> Text +renderDomainType importPlan aggregate resolvedType = + either + (error . ("validated aggregate Haskell reference failed: " <>) . show) + id + (renderAggregateHaskellSource importPlan (aggregateConsumerHaskellSource (aSymbols aggregate) resolvedType)) + +maybeToListText :: Maybe value -> [value] +maybeToListText = maybe [] pure + +-------------------------------------------------------------------------------- +-- Codec module +-------------------------------------------------------------------------------- + +emitCodec :: Agg -> Text +emitCodec a = + nl $ + renderGeneratedLanguagePragmas [ExtOverloadedRecordDot | codecUsesRecordDot a] + ++ [ generatedBanner, + "module " <> aGenPrefix a <> ".Codec (", + " " <> lowerFirst (aName a) <> "Codec,", + " parse" <> aName a <> "Event,", + " encode" <> aName a <> "Event," + ] + ++ concatMap mappedExports (codecMappedDeclarations a) + ++ [ ") where", + "", + "import " <> aGenPrefix a <> ".Domain" + ] + ++ generatedNominalCodecImports (aggregateCheckedService a) (aContext a) (codecGeneratedNominals a) + ++ ( 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 (..))", + "import Data.List.NonEmpty qualified as 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] + ++ T.lines (renderPlannedImports importPlan) + ++ [ "", + emitEnumParsers a, + emitConsumerNominalParsers importPlan a + ] + ++ [emitMappedCodecs importPlan a | hasMappedCodec a] + ++ [ "", + emitEventTypes a, + "", + emitCodecValue a, + "", + emitEncode importPlan a, + "", + emitDecode importPlan a, + "", + "mapLeftText :: Either String b -> Either Text b", + "mapLeftText = either (Left . T.pack) Right", + "", + "_renderEventTypes :: NonEmpty EventType -> String", + "_renderEventTypes =", + " T.unpack", + " . T.intercalate \", \"", + " . map (\\(EventType eventTypeName) -> eventTypeName)", + " . NonEmpty.toList" + ] + ++ ( 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 + importPlan = codecImportPlan a + mappedExports (ResolvedStructural declaration _) = + [ " encode" <> sdName declaration <> "Mapped,", + " decode" <> sdName declaration <> "Mapped," + ] + mappedExports ResolvedOpaque {} = [] + +codecUsesRecordDot :: Agg -> Bool +codecUsesRecordDot = any (not . null . rcFields) . aEvents + +hasMappedCodec :: Agg -> Bool +hasMappedCodec = not . null . codecMappedDeclarations + +hasConsumerNominalCodec :: Agg -> Bool +hasConsumerNominalCodec = not . null . codecConsumerNominals + +hasConsumerNominalIdCodec :: Agg -> Bool +hasConsumerNominalIdCodec aggregate = + any + (\nominal -> case resolvedNominalRepresentation nominal of IdRepresentation {} -> True; _ -> False) + (codecConsumerNominals aggregate) + +hasEnforcedConsumerNominalIdCodec :: Agg -> Bool +hasEnforcedConsumerNominalIdCodec aggregate = + any + ( \nominal -> case resolvedNominalRepresentation nominal of + IdRepresentation prefix -> isJust (idDomainContractFor (aLanguageContract aggregate) prefix) + _ -> False + ) + (codecConsumerNominals aggregate) + +emitEnumParsers :: Agg -> Text +emitEnumParsers a = + sectionsOf + [ [emitEnumParser nominal | nominal <- codecGeneratedNominals a, EnumRepresentation {} <- [resolvedNominalRepresentation nominal]] + ] + +emitEnumParser :: ResolvedNominalType -> Text +emitEnumParser nominal = case resolvedNominalRepresentation nominal of + EnumRepresentation constructors -> + nl $ + [ "parse" <> name <> " :: Text -> Parser " <> name, + "parse" <> name <> " = \\case" + ] + ++ [" " <> tshow wire <> " -> pure " <> constructor | (constructor, wire) <- NE.toList constructors] + ++ [" tag -> " <> renderUnknownFailure name "tag" (map snd (NE.toList constructors))] + _ -> error "non-enum reached generated enum parser emission" + where + name = resolvedNominalName nominal + +emitConsumerNominalParsers :: HaskellImportPlan -> Agg -> Text +emitConsumerNominalParsers importPlan aggregate = sectionsOf [map emitParser (codecConsumerNominals aggregate)] + where + emitParser nominal = case (resolvedNominalRepresentation nominal, resolvedNominalOwnership nominal) of + (IdRepresentation prefix, ConsumerNominal binding) -> + nl $ + [ parserName nominal <> " :: Text -> Parser " <> renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding)) + ] + <> parserBody nominal prefix binding + (EnumRepresentation constructors, ConsumerNominal binding) -> + nl $ + [ parserName nominal <> " :: Text -> Parser " <> renderReferenceOrDie importPlan (haskellTypeReference (consumerNominalHaskell binding)), + parserName nominal <> " = \\case" + ] + <> [ " " + <> tshow wire + <> " -> pure (nominalFromRepresentation " + <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)) + <> " " + <> renderReferenceOrDie importPlan (nominalRepresentationConstructorReference (aContext aggregate) nominal constructor) + <> ")" + | (constructor, wire) <- NE.toList constructors + ] + <> [" tag -> " <> renderUnknownFailure (resolvedNominalName nominal <> " wire value") "tag" (map snd (NE.toList constructors))] + _ -> "" + parserName nominal = "parse" <> resolvedNominalName nominal <> "Nominal" + parserBody nominal prefix binding = case idDomainContractFor (aLanguageContract aggregate) prefix of + Nothing -> + [ parserName nominal <> " input = case KindID.parseText @" <> tshow prefix <> " input of", + " Left reason -> fail (show reason)", + " Right representation -> pure (nominalFromRepresentation " <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)) <> " representation)" + ] + Just _ -> + [ parserName nominal <> " input = case validateIdDomainText (typeIdV7Domain " <> tshow prefix <> ") input of", + " Left reason -> fail (show reason)", + " Right () -> case KindID.parseText @" <> tshow prefix <> " input of", + " Left reason -> fail (show reason)", + " Right representation -> pure (nominalFromRepresentation " <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)) <> " representation)" + ] + +emitCodecValue :: Agg -> Text +emitCodecValue a = + nl $ + [ lowerFirst (aName a) <> "Codec :: Codec " <> aName a <> "Event", + lowerFirst (aName a) <> "Codec =", + " Codec", + " { eventTypes = " <> eventTypesName a, + " , eventType = \\case" + ] + ++ [" " <> rcName e <> "{} -> EventType " <> tshow (rcName e) | e <- aEvents a] + ++ [ " , schemaVersion = " <> tshow' (maxEventVersion a), + " , encode = encode" <> aName a <> "Event", + " , decode = parse" <> aName a <> "Event", + " , upcasters = " <> upcastersExpr a, + " }" + ] + ++ upcasterRungDecls a + +emitEventTypes :: Agg -> Text +emitEventTypes aggregate = + nl + [ eventTypesName aggregate <> " :: NonEmpty EventType", + eventTypesName aggregate <> " = " <> eventTypesExpr + ] + where + eventTypesExpr = case map rcName (aEvents aggregate) of + [] -> "error \"no events\"" + event : rest -> "EventType " <> tshow event <> " :| [" <> T.intercalate ", " (map (("EventType " <>) . tshow) rest) <> "]" + +eventTypesName :: Agg -> Text +eventTypesName aggregate = lowerFirst (aName aggregate) <> "EventTypes" + +-- | The codec's @schemaVersion@: the maximum declared event version (EP-2). +maxEventVersion :: Agg -> Int +maxEventVersion a = maximum (1 : map rcVersion (aEvents a)) + +-- | One @(sourceVersion, upcasterName)@ entry per event that declares an +-- @upcast from@. The upcaster name is per-event (e.g. @upcastFooV1@) and its +-- body is a hole in the hand-owned Holes module. +upcasterEntries :: Agg -> [(Int, Text, Text)] +upcasterEntries a = + [ (m, rcName e, "upcast" <> rcName e <> "V" <> tshow' m) + | e <- aEvents a, + Just m <- [rcUpcastFrom e] + ] + +upcastersExpr :: Agg -> Text +upcastersExpr a = + "[" <> T.intercalate ", " ["(" <> tshow' m <> ", upcastRungV" <> tshow' m <> ")" | (m, _) <- upcasterRungs a] <> "]" + +-- | Group event-specific holes into one migration rung per aggregate-global +-- source version. Event metadata stamps every kind with the aggregate's +-- schema version, so a rung must explicitly pass foreign event kinds through. +upcasterRungs :: Agg -> [(Int, [(Text, Text)])] +upcasterRungs a = + [ (source, [(eventName, fn) | (_, eventName, fn) <- entries]) + | entries@((source, _, _) : _) <- groupBy sameSource (sortOn firstSource (upcasterEntries a)) + ] + where + firstSource (source, _, _) = source + sameSource (source, _, _) (otherSource, _, _) = source == otherSource + +upcasterRungDecls :: Agg -> [Text] +upcasterRungDecls a = concatMap rung (upcasterRungs a) + where + rung (source, entries) = + [ "", + "upcastRungV" <> tshow' source <> " :: EventType -> Value -> Either Text Value" + ] + ++ [ "upcastRungV" <> tshow' source <> " (EventType " <> tshow eventName <> ") value = " <> fn <> " value" + | (eventName, fn) <- entries + ] + ++ [ "-- Kinds whose shape did not change at this rung pass through unchanged; their", + "-- stamped version is aggregate-global, not their own shape history.", + "upcastRungV" <> tshow' source <> " _ value = Right value" + ] + +-- | When the codec references upcasters, it imports their (hole) definitions +-- from the hand-owned Holes module. +upcasterImport :: Agg -> Text +upcasterImport a = case upcasterEntries a of + [] -> "" + es -> "import " <> aHolePrefix a <> ".Holes (" <> T.intercalate ", " [fn | (_, _, fn) <- es] <> ")" + +emitEncode :: HaskellImportPlan -> Agg -> Text +emitEncode importPlan a = + nl $ + [ "encode" <> aName a <> "Event :: " <> aName a <> "Event -> Value", + "encode" <> aName a <> "Event = \\case" + ] + ++ concatMap encodeArm (aEvents a) + where + encodeArm e = + [ " " <> rcName e <> " payload ->", + " object" + ] + ++ [ lead i <> kv + | (i, kv) <- zip [(0 :: Int) ..] (("\"kind\" .= (" <> tshow (rcName e) <> " :: Text)") : map encodeField (rcFields e)) + ] + ++ [" ]"] + lead 0 = " [ " + lead _ = " , " + encodeField (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 {} -> + renderReferenceOrDie importPlan (nominalRepresentationEncoderReference (aContext a) nominal) + <> " (nominalToRepresentation " + <> bindingName binding + <> " " + <> value + <> ")" + ScalarRepresentation {} -> "nominalToRepresentation " <> bindingName binding <> " " <> value + bindingName = renderReferenceOrDie importPlan . qualifiedValueReference . consumerNominalBinding + +emitDecode :: HaskellImportPlan -> Agg -> Text +emitDecode importPlan a = + nl $ + [ "parse" <> aName a <> "Event :: EventType -> Value -> Either Text " <> aName a <> "Event", + "parse" <> aName a <> "Event (EventType tag) = mapLeftText . parseEither (withObject " <> tshow (aName a <> "Event") <> " go)", + " where", + " go o = do", + " case tag of" + ] + ++ concatMap decodeArm (aEvents a) + ++ [" _ -> " <> renderUnknownEventTypeFailure a "tag"] + where + decodeArm e = + [" " <> tshow (rcName e) <> " ->"] + ++ case rcFields e of + [] -> [" pure (" <> rcName e <> " " <> rcName e <> "Data)"] + fields -> + [ " " <> rcName e, + " <$> ( " <> rcName e <> "Data" + ] + ++ [ (if index == 0 then " <$> " else " <*> ") <> decodeField field + | (index, field) <- zip [(0 :: Int) ..] fields + ] + ++ [" )"] + decodeField (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 " <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)) <> " <$> o .: " <> tshow name <> ")" + consumerNominalFieldParser fieldName nominal = + "explicitParseField (withText " + <> tshow (resolvedNominalName nominal) + <> " parse" + <> resolvedNominalName nominal + <> "Nominal) o " + <> tshow fieldName + +codecConsumerNominals :: Agg -> [ResolvedNominalType] +codecConsumerNominals aggregate = + Map.elems . Map.fromList $ + [ (resolvedNominalName nominal, nominal) + | event <- aEvents aggregate, + (_, AggregateNominal nominal) <- rcFields event, + ConsumerNominal {} <- [resolvedNominalOwnership nominal] + ] + +codecGeneratedNominals :: Agg -> [ResolvedNominalType] +codecGeneratedNominals aggregate = + generatedNominalsInTypes + [ resolvedType + | event <- aEvents aggregate, + (_, resolvedType) <- rcFields event + ] + +codecImportPlan :: Agg -> HaskellImportPlan +codecImportPlan aggregate = + planImportsOrDie + (aGenPrefix aggregate <> ".Codec") + (Set.fromList [aName aggregate <> "Event"]) + (Set.fromList (nominalReferences <> mappedReferences <> nominalRepresentationReferences <> shapeReferences)) + where + nominalReferences = + [ reference + | nominal <- codecConsumerNominals aggregate, + ConsumerNominal binding <- [resolvedNominalOwnership nominal], + reference <- + [ haskellTypeReference (consumerNominalHaskell binding), + qualifiedValueReference (consumerNominalBinding binding) + ] + ] + mappedReferences = + [ reference + | ResolvedStructural declaration _ <- codecMappedDeclarations aggregate, + reference <- + [ haskellTypeReference (sdHaskell declaration), + qualifiedValueReference (sdBinding declaration) + ] + ] + nominalRepresentationReferences = + [ reference + | nominal <- codecConsumerNominals aggregate, + EnumRepresentation constructors <- [resolvedNominalRepresentation nominal], + reference <- + nominalRepresentationEncoderReference (aContext aggregate) nominal + : [ nominalRepresentationConstructorReference (aContext aggregate) nominal constructor + | (constructor, _) <- NE.toList constructors + ] + ] + shapeReferences = + [ reference + | ResolvedStructural declaration shape <- codecMappedDeclarations aggregate, + reference <- structuralShapeReferences (aContext aggregate) declaration shape + ] + +codecNominalImports :: Agg -> [Text] +codecNominalImports _ = [] + +codecMappedImports :: Agg -> [Text] +codecMappedImports a = case aTypeGraph a of + Nothing -> [] + Just graph -> + sort . nub $ + [ hsModule (odHaskell declaration) <> " ()" + | ResolvedOpaque declaration <- codecMappedDeclarations a + ] + <> [ hsModule (odHaskell declaration) <> " ()" + | ResolvedStructural _ shape <- codecMappedDeclarations a, + key <- directShapeRefs shape, + Just (ResolvedOpaque declaration) <- [Map.lookup key (tgDeclarations graph)] + ] + +codecMappedDeclarations :: Agg -> [ResolvedMappedDecl] +codecMappedDeclarations a = case aTypeGraph a of + Nothing -> [] + Just graph -> + mapMaybe (\key -> Map.lookup key (tgDeclarations graph)) (sort (Map.keys selected)) + where + roots = + [ key + | event <- aEvents a, + (_, AggregateMapped key) <- rcFields event, + Map.member key (tgDeclarations graph) + ] + selected = + Map.fromList + [ (key, ()) + | root <- roots, + key <- root : maybe [] (Map.keys . Map.fromSet (const ())) (Map.lookup root (tgReachability graph)) + ] + +directShapeRefs :: ResolvedMappedShape -> [MappedKey] +directShapeRefs = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ fields -> concatMap (exprRefs . rwfType) fields, + onEnum = const [], + onUnion = \_ arms -> concatMap (maybe [] exprRefs . rwaPayload) arms + } + +exprRefs :: ResolvedTypeExpr -> [MappedKey] +exprRefs = + foldTypeExpr + TypeExprAlgebra + { onText = [], + onInt = [], + onInteger = [], + onBool = [], + onNatural = [], + onTime = [], + onJson = [], + onOptional = id, + onList = id, + onMap = id, + onRef = pure + } + +emitMappedCodecs :: HaskellImportPlan -> Agg -> Text +emitMappedCodecs importPlan a = case aTypeGraph a of + Nothing -> "" + Just graph -> + T.intercalate + "\n\n" + [ emitStructuralCodec importPlan a graph declaration shape + | ResolvedStructural declaration shape <- codecMappedDeclarations a + ] + +emitStructuralCodec :: HaskellImportPlan -> Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text +emitStructuralCodec importPlan a graph declaration shape = + nl + [ "encode" <> name <> "Mapped :: " <> consumerType <> " -> Value", + "encode" <> name <> "Mapped = encode" <> name <> "Shape . bindingToShape " <> binding, + "", + "parse" <> name <> "Mapped :: Value -> Parser " <> consumerType, + "parse" <> name <> "Mapped value = bindingFromShape " <> binding <> " <$> parse" <> name <> "Shape value", + "", + "decode" <> name <> "Mapped :: Value -> Either Text " <> consumerType, + "decode" <> name <> "Mapped = mapLeftText . parseEither parse" <> name <> "Mapped", + "", + "encode" <> name <> "Shape :: " <> shapeType <> " -> Value", + emitShapeEncoder importPlan a graph declaration shape, + "", + "parse" <> name <> "Shape :: Value -> Parser " <> shapeType, + emitShapeDecoder importPlan a graph declaration shape + ] + where + name = sdName declaration + consumerType = renderReferenceOrDie importPlan (haskellTypeReference (sdHaskell declaration)) + shapeType = renderReferenceOrDie importPlan (qualifiedTypeReference (structuralShapeModule (aContext a) name) (name <> "Shape")) + binding = renderReferenceOrDie importPlan (qualifiedValueReference (sdBinding declaration)) + +emitShapeEncoder :: HaskellImportPlan -> Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text +emitShapeEncoder importPlan a graph declaration = + foldMappedShape + MappedShapeAlgebra + { onRecord = \_ _ fields -> + nl $ + ["encode" <> name <> "Shape shape =", " object"] + <> objectEntries + [ tshow (rwfKey field) + <> " .= " + <> encodeShapeExpr a graph (rwfType field) (shapeValue (rwfHaskell field) <> " shape") + | field <- fields + ], + onEnum = \entries -> + nl $ + ["encode" <> name <> "Shape = \\case"] + <> [" " <> shapeConstructor (weCtor entry) <> " -> String " <> tshow (weTag entry) | entry <- entries], + onUnion = \encoding arms -> + nl $ + ["encode" <> name <> "Shape = \\case"] + <> concatMap (unionEncodeArm encoding) arms + } + where + name = sdName declaration + shapeModuleName = structuralShapeModule (aContext a) name + shapeConstructor constructor = renderReferenceOrDie importPlan (constructorReference shapeModuleName constructor) + shapeValue value = renderReferenceOrDie importPlan (HaskellReference shapeModuleName value ValueNamespace RequireQualified) + unionEncodeArm encoding arm = + [ " " <> shapeConstructor (rwaCtor arm) <> payloadPattern <> " ->", + " object" + ] + <> objectEntries + ( [tshow (ueTagField encoding) <> " .= (" <> tshow (rwaTag arm) <> " :: Text)"] + <> [ tshow (ueContentsField encoding) <> " .= " <> encodeShapeExpr a graph payload "payload" + | payload <- maybeToListText (rwaPayload arm) + ] + ) + where + payloadPattern = maybe "" (const " payload") (rwaPayload arm) + +emitShapeDecoder :: HaskellImportPlan -> Agg -> TypeGraph -> StructuralDecl -> ResolvedMappedShape -> Text +emitShapeDecoder importPlan a graph declaration = + foldMappedShape + MappedShapeAlgebra + { onRecord = \constructor unknownFields fields -> + nl $ + [ "parse" <> name <> "Shape = withObject " <> tshow (name <> "Shape") <> " $ \\objectValue -> do" + ] + <> rejectLine " " unknownFields (map rwfKey fields) "objectValue" + <> [ " " <> shapeConstructor constructor, + " <$> " <> T.intercalate "\n <*> " (map (decodeRecordField importPlan a graph) fields) + ], + onEnum = \entries -> + nl $ + [ "parse" <> name <> "Shape = withText " <> tshow (name <> "Shape") <> " $ \\tag -> case tag of" + ] + <> [" " <> tshow (weTag entry) <> " -> pure " <> shapeConstructor (weCtor entry) | entry <- entries] + <> [" 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 + shapeConstructor constructor = renderReferenceOrDie importPlan (constructorReference shapeModuleName constructor) + rejectLine _ IgnoreUnknown _ _ = [] + rejectLine indent RejectUnknown allowed objectName = + [indent <> "rejectUnknownFields " <> tshow name <> " " <> renderTextList allowed <> " " <> objectName] + unionDecodeArm encoding arm = + [" " <> tshow (rwaTag arm) <> " -> do"] + <> rejectLine " " (ueUnknownFields encoding) allowed "objectValue" + <> [ case rwaPayload arm of + Nothing -> " pure " <> shapeConstructor (rwaCtor arm) + Just payload -> + " " + <> shapeConstructor (rwaCtor arm) + <> " <$> explicitParseField (" + <> decodeShapeExpr a graph payload + <> ") objectValue " + <> tshow (ueContentsField encoding) + ] + where + allowed = ueTagField encoding : [ueContentsField encoding | rwaPayload arm /= Nothing] + +decodeRecordField :: HaskellImportPlan -> Agg -> TypeGraph -> ResolvedWireField -> Text +decodeRecordField importPlan a graph field = case rwfPresence field of + PRequired -> + "explicitParseField (" <> decoder <> ") objectValue " <> key + POptional -> + "(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 importPlan a graph (rwfType field) onMissing + +encodeShapeExpr :: Agg -> TypeGraph -> ResolvedTypeExpr -> Text -> Text +encodeShapeExpr _a graph expression value = + foldTypeExpr + TypeExprAlgebra + { onText = \v -> "toJSON (" <> v <> ")", + onInt = \v -> "toJSON (" <> v <> ")", + onInteger = \v -> "toJSON (" <> v <> ")", + onBool = \v -> "toJSON (" <> v <> ")", + onNatural = \v -> "toJSON (" <> v <> ")", + onTime = \v -> "toJSON (" <> v <> ")", + onJson = id, + onOptional = \encode v -> "maybe Null (\\item -> " <> encode "item" <> ") (" <> v <> ")", + onList = \encode v -> "toJSON (map (\\item -> " <> encode "item" <> ") (" <> v <> "))", + onMap = \encode v -> "toJSON (Map.map (\\item -> " <> encode "item" <> ") (" <> v <> "))", + onRef = \key v -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural nested _) -> "encode" <> sdName nested <> "Shape (" <> v <> ")" + Just (ResolvedOpaque _) -> "toJSON (" <> v <> ")" + Nothing -> "toJSON (" <> v <> ")" + } + expression + value + +decodeShapeExpr :: Agg -> TypeGraph -> ResolvedTypeExpr -> Text +decodeShapeExpr _a graph = + foldTypeExpr + TypeExprAlgebra + { onText = "parseJSON", + onInt = "parseJSON", + onInteger = "parseJSON", + onBool = "parseJSON", + onNatural = "parseJSON", + onTime = "parseJSON", + onJson = "pure", + onOptional = \decode -> "\\value -> case value of Null -> pure Nothing; other -> Just <$> " <> decode <> " other", + onList = \decode -> "\\value -> (parseJSON value :: Parser [Value]) >>= traverse (" <> decode <> ")", + onMap = \decode -> "\\value -> (parseJSON value :: Parser (Map Text Value)) >>= traverse (" <> decode <> ")", + onRef = \key -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural nested _) -> "parse" <> sdName nested <> "Shape" + Just (ResolvedOpaque _) -> "parseJSON" + Nothing -> "parseJSON" + } + +renderMissingDefault :: HaskellImportPlan -> Agg -> TypeGraph -> ResolvedTypeExpr -> OnMissing -> Text +renderMissingDefault importPlan a graph expression = \case + OmNull -> "Nothing" + OmText value -> tshow value + OmInt value -> T.pack (show value) + OmBool value -> if value then "True" else "False" + OmEmptyList -> "[]" + OmEmptyMap -> "Map.empty" + OmCtor constructor -> case expression of + RRef key -> case Map.lookup key (tgDeclarations graph) of + Just (ResolvedStructural declaration _) -> renderReferenceOrDie importPlan (constructorReference (structuralShapeModule (aContext a) (sdName declaration)) constructor) + _ -> constructor + _ -> constructor + +objectEntries :: [Text] -> [Text] +objectEntries entries = + [lead index <> entry | (index, entry) <- zip [(0 :: Int) ..] entries] + <> [" ]"] + where + lead 0 = " [ " + lead _ = " , " + +renderTextList :: [Text] -> Text +renderTextList values = "[" <> T.intercalate ", " (map tshow values) <> "]" + +-- | Emit a parser failure that names the rejected runtime value and the full, +-- deterministic wire set accepted at that point. +renderUnknownFailure :: Text -> Text -> [Text] -> Text +renderUnknownFailure label variable expected = + "fail (" + <> tshow ("unknown " <> label <> " ") + <> " <> show " + <> variable + <> " <> " + <> tshow ("; expected one of: " <> expectedText) + <> ")" + where + expectedText = case expected of + [] -> "" + values -> T.intercalate ", " values + +renderUnknownEventTypeFailure :: Agg -> Text -> Text +renderUnknownEventTypeFailure aggregate variable = + "fail (" + <> tshow "unknown event type " + <> " <> show " + <> variable + <> " <> " + <> tshow "; expected one of: " + <> " <> _renderEventTypes " + <> eventTypesName aggregate + <> ")" + +-------------------------------------------------------------------------------- +-- 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 :: HaskellImportPlan -> [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> Text +renderKeikiPredicate importPlan aliases aggregate transition = + renderedKeikiText . renderPredicate + where + renderPredicate expression = case typedScalarNode expression of + TypedEqual left right -> comparison ".==" left right + TypedNotEqual left right -> comparison "./=" left right + TypedCompare operator left right -> comparison (renderComparisonOperator operator) left right + TypedAnd left right -> boolean 3 RenderRight ".&&" left right + TypedOr left right -> boolean 2 RenderRight ".||" left right + _ -> + renderedInfix + 4 + RenderNonAssociative + ".==" + (renderKeikiTerm importPlan aliases aggregate transition expression) + (renderedAtom "K.lit True") + comparison operator left right = + renderedInfix + 4 + RenderNonAssociative + operator + (renderComparisonTerm importPlan aliases aggregate transition left) + (renderComparisonTerm importPlan aliases aggregate transition right) + boolean precedence associativity operator left right = + renderedInfix precedence associativity operator (renderPredicate left) (renderPredicate right) + +renderComparisonOperator :: CmpOp -> Text +renderComparisonOperator = \case + OpEq -> ".==" + OpNeq -> "./=" + OpLt -> ".<" + OpLe -> ".<=" + OpGt -> ".>" + OpGe -> ".>=" + +renderComparisonTerm :: HaskellImportPlan -> [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> RenderedKeikiExpr +renderComparisonTerm importPlan aliases aggregate transition expression = case (typedScalarType expression, typedScalarNode expression) of + (AggregateNominal nominal, TypedRoot provenance) + | nominalComparisonProjection nominal -> + renderedAtom (projectionAliasFor aliases (NominalProjectionAlias nominal provenance)) + (AggregateNominal nominal, TypedLiteral (ScalarEnumValue _ constructor)) -> + renderedAtom ("K.lit (" <> tshow (enumWireFor nominal constructor) <> " :: Text)") + (AggregateNominal _, TypedLiteral (ScalarIdValue _ value)) -> + renderedAtom ("K.lit (" <> tshow value <> " :: Text)") + _ -> renderKeikiTerm importPlan aliases aggregate transition expression + +nominalComparisonProjection :: ResolvedNominalType -> Bool +nominalComparisonProjection nominal = case resolvedNominalRepresentation nominal of + IdRepresentation {} -> True + EnumRepresentation {} -> True + ScalarRepresentation {} -> case resolvedNominalOwnership nominal of + ConsumerNominal {} -> True + GeneratedNominal -> False + +enumWireFor :: ResolvedNominalType -> Name -> Text +enumWireFor nominal constructor = case resolvedNominalRepresentation nominal of + EnumRepresentation constructors -> fromMaybe (error "validated enum literal lost its wire spelling") (lookup constructor (NE.toList constructors)) + _ -> error "validated enum literal lost its enum representation" + +renderNominalProjectionTerm :: HaskellImportPlan -> Agg -> Transition -> ResolvedNominalType -> ScalarRootProvenance -> Text +renderNominalProjectionTerm importPlan aggregate transition nominal provenance = case provenance of + ScalarRegisterRoot registerName ownerType -> + "K.regProj " + <> projectionQualifier + <> "." + <> witness + <> " (#" + <> registerName + <> " :: K.Index " + <> aName aggregate + <> "Regs " + <> renderDomainType importPlan aggregate ownerType + <> ")" + ScalarCommandRoot fieldName ownerType -> + "K.inpProj " + <> projectionQualifier + <> "." + <> witness + <> " inCtor" + <> tCommand transition + <> " (#" + <> fieldName + <> " :: K.Index (" + <> commandFieldsType transition + <> ") " + <> renderDomainType importPlan aggregate ownerType + <> ")" + where + projectionQualifier = case resolvedNominalOwnership nominal of + GeneratedNominal -> "GeneratedNominals" + ConsumerNominal {} -> "NominalProjections" + witness = case resolvedNominalRepresentation nominal of + ScalarRepresentation {} -> lowerFirst (resolvedNominalName nominal) <> "Witness" + IdRepresentation {} -> nominalEqualityWitnessName nominal + EnumRepresentation {} -> nominalEqualityWitnessName nominal + +renderKeikiTerm :: HaskellImportPlan -> [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> RenderedKeikiExpr +renderKeikiTerm importPlan aliases aggregate transition expression = case typedScalarNode expression of + TypedLiteral value -> renderedAtom (renderKeikiLiteral importPlan aggregate (typedScalarType expression) value) + TypedRoot (ScalarRegisterRoot registerName _) -> renderedAtom ("B.reg @" <> tshow registerName) + TypedRoot (ScalarCommandRoot fieldName _) -> renderedAtom ("d." <> fieldName) + TypedProject provenance projection -> + renderedAtom (projectionAliasFor aliases (StructuralProjectionAlias provenance projection)) + TypedAdd _ left right -> arithmetic 6 ".+" left right + TypedSubtract _ left right -> arithmetic 6 ".-" left right + TypedMultiply _ left right -> arithmetic 7 ".*" left right + TypedEqual {} -> impossiblePredicate + TypedNotEqual {} -> impossiblePredicate + TypedCompare {} -> impossiblePredicate + TypedAnd {} -> impossiblePredicate + TypedOr {} -> impossiblePredicate + where + arithmetic precedence operator left right = + renderedInfix + precedence + RenderLeft + operator + (renderKeikiTerm importPlan aliases aggregate transition left) + (renderKeikiTerm importPlan aliases aggregate transition right) + impossiblePredicate = error "predicate-valued Boolean expressions cannot be lowered as register terms" + +renderStructuralProjectionTerm :: HaskellImportPlan -> Agg -> Transition -> ScalarRootProvenance -> ResolvedScalarProjection -> Text +renderStructuralProjectionTerm importPlan aggregate transition provenance projection = case provenance of + ScalarRegisterRoot registerName ownerType -> + "K.regProj StructuralProjections." + <> witness + <> " (#" + <> registerName + <> " :: K.Index " + <> aName aggregate + <> "Regs " + <> renderDomainType importPlan aggregate ownerType + <> ")" + ScalarCommandRoot fieldName ownerType -> + "K.inpProj StructuralProjections." + <> witness + <> " inCtor" + <> tCommand transition + <> " (#" + <> fieldName + <> " :: K.Index (" + <> commandFieldsType transition + <> ") " + <> renderDomainType importPlan aggregate ownerType + <> ")" + where + witness = + fromMaybe + (error ("resolved structural projection witness disappeared: " <> show projection)) + (aTypeGraph aggregate >>= \graph -> projectionWitnessName graph (scalarProjectionOwner projection) (scalarProjectionPointer projection)) + +renderKeikiLiteral :: HaskellImportPlan -> Agg -> ResolvedAggregateType -> ScalarValue -> Text +renderKeikiLiteral importPlan aggregate scalarType = \case + ScalarTextValue value -> "K.lit (" <> tshow value <> " :: Text)" + ScalarIntValue value -> "K.lit (" <> tshow' value <> " :: Int)" + ScalarIntegerValue value -> "K.lit (" <> T.pack (show value) <> " :: Integer)" + ScalarNaturalValue value -> "K.lit (" <> T.pack (show value) <> " :: Natural)" + ScalarBoolValue value -> "K.lit " <> if value then "True" else "False" + ScalarTimeValue value -> "K.lit " <> renderRegisterInitial (InitialTime value) + ScalarEnumValue _typeName constructor -> case scalarType of + AggregateNominal nominal -> case resolvedNominalOwnership nominal of + GeneratedNominal -> "K.lit " <> constructor + ConsumerNominal binding -> + "K.lit (nominalFromRepresentation " + <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)) + <> " " + <> renderReferenceOrDie importPlan (nominalRepresentationConstructorReference (aContext aggregate) nominal constructor) + <> ")" + _ -> error "validated enum literal lost its nominal type" + ScalarIdValue typeName value -> case scalarType of + AggregateNominal nominal -> case resolvedNominalOwnership nominal of + GeneratedNominal -> case idDomainContractFor (aLanguageContract aggregate) =<< idPrefixOf nominal of + Nothing -> "K.lit (" <> typeName <> " " <> tshow value <> ")" + Just _ -> + "K.lit (case parse" + <> typeName + <> " " + <> tshow value + <> " of Right parsed -> parsed; Left _ -> error \"validated ID literal failed to parse\")" + ConsumerNominal binding -> case resolvedNominalRepresentation nominal of + IdRepresentation prefix -> + "K.lit (nominalFromRepresentation " + <> renderReferenceOrDie importPlan (qualifiedValueReference (consumerNominalBinding binding)) + <> " (case KindID.parseText @" + <> tshow prefix + <> " " + <> tshow value + <> " of Right parsed -> parsed; Left _ -> error \"validated ID literal failed to parse\"))" + _ -> error "validated ID literal lost its ID representation" + _ -> error "validated ID literal lost its nominal type" + where + idPrefixOf nominal = case resolvedNominalRepresentation nominal of + IdRepresentation prefix -> Just prefix + _ -> Nothing + +generatedIdSampleHaskell :: Agg -> ResolvedNominalType -> Maybe Text +generatedIdSampleHaskell aggregate nominal = do + prefix <- case resolvedNominalRepresentation nominal of + IdRepresentation value -> Just value + _ -> Nothing + contract <- idDomainContractFor (aLanguageContract aggregate) prefix + let name = resolvedNominalName nominal + sample = idDomainSampleText contract + pure + ( "(case parse" + <> name + <> " " + <> tshow sample + <> " of Right parsed -> parsed; Left _ -> error \"generated valid ID sample failed to parse\")" + ) + +emitGeneratedTransducer :: Agg -> Text +emitGeneratedTransducer aggregate = + nl $ + renderGeneratedLanguagePragmas + ( [ExtBlockArguments, ExtQualifiedDo] + <> [ExtOverloadedLabels | not (null projectionAliases)] + <> [ExtOverloadedRecordDot | transducerUsesRecordDot aggregate] + ) + ++ [ generatedBanner, + "module " <> aGenPrefix aggregate <> ".Transducer", + " ( " <> lowerFirst (aName aggregate) <> "Transducer", + " , " <> lowerFirst (aName aggregate) <> "FoldFingerprint", + " , BehaviorOwnership (..)", + " , " <> lowerFirst (aName aggregate) <> "PredicateVerifications", + " ) where", + "", + "import " <> aGenPrefix aggregate <> ".Domain", + "import Data.Text (Text)" + ] + ++ ["import Data.Time.Calendar (fromGregorian)" | expressionUsesTimeLiteral] + ++ ["import Data.Time.Clock (UTCTime (..), picosecondsToDiffTime)" | expressionUsesTimeLiteral] + ++ ["import Numeric.Natural (Natural)" | expressionUsesNaturalLiteral] + ++ generatedNominalTypeImportsForService (aggregateCheckedService aggregate) (aContext aggregate) generatedExpressionNominals + ++ structuralProjectionImport + ++ generatedNominalProjectionImport + ++ consumerNominalProjectionImport + ++ consumerImports + ++ ["import Data.KindID qualified as KindID" | expressionUsesConsumerIdLiteral] + ++ ["import Keiro.Codec.Nominal (nominalFromRepresentation)" | expressionUsesConsumerNominalLiteral] + ++ [ "import Keiki.Builder qualified as B", + "import Keiki.Core (" <> T.intercalate ", " keikiCoreImports <> ")", + "import Keiki.Core qualified as K", + "import Keiki.Symbolic qualified as S" + ] + ++ ["import " <> aHolePrefix aggregate <> ".Holes qualified as Holes" | transducerUsesHoles aggregate] + ++ ["import Data.Text qualified as T" | anyHoleOwned aggregate] + ++ ["import Keiki.Builder ((=:))" | any (not . null . tWrites . snd) (transitionEntries aggregate)] + ++ ["import Keiki.Generics (RegFieldsOf)" | not (null projectionAliases)] + ++ ["import Keiro.Snapshot.Codec (FoldVersion (..))" | anyHoleOwned aggregate] + ++ [ "", + lowerFirst (aName aggregate) <> "Transducer", + " :: SymTransducer", + " (HsPred " <> aName aggregate <> "Regs " <> aName aggregate <> "Command)", + " " <> aName aggregate <> "Regs", + " " <> aVertexType aggregate, + " " <> aName aggregate <> "Command", + " " <> aName aggregate <> "Event", + lowerFirst (aName aggregate) <> "Transducer =", + " B.buildTransducer " <> initialVertex aggregate <> " initial" <> aName aggregate <> "Regs isTerminal do", + nl (concatMap (generatedFromBlock importPlan aggregate resolvedTransitions) (groupTransitionEntriesBySource aggregate)), + " where", + " isTerminal = \\case", + nl [" " <> vertexCtor aggregate (stName state) <> " -> True" | state <- aStates aggregate, stTerminal state], + " _ -> False", + "", + lowerFirst (aName aggregate) <> "FoldFingerprint :: Text", + lowerFirst (aName aggregate) <> "FoldFingerprint = " <> foldFingerprintExpression aggregate, + "", + "data BehaviorOwnership = GeneratedOwned | HoleOwned", + " deriving stock (Eq, Show)", + "", + "-- Every checked transition predicate is audited through Keiki's conservative", + "-- symbolic verifier. Opaque Hole terms remain explicitly unverified.", + lowerFirst (aName aggregate) <> "PredicateVerifications :: IO [(Text, BehaviorOwnership, S.PredicateVerification)]", + lowerFirst (aName aggregate) <> "PredicateVerifications = sequence", + nl (renderVerificationList aggregate), + " where", + " verifyTransition label owner source edgeIndex =", + " case drop edgeIndex (K.edgesOut " <> lowerFirst (aName aggregate) <> "Transducer source) of", + " K.Edge predicate _ _ _ _ : _ -> (\\result -> (label, owner, result)) <$> S.verifyPredicate predicate", + " [] -> pure (label, owner, S.UnverifiedSolverFailure \"generated transition edge missing\")" + ] + where + resolvedTransitions = resolvedGeneratedTransitions aggregate + resolvedExpressions = generatedTransitionExpressions resolvedTransitions + projectionAliases = concatMap projectionAliasesForTransition resolvedTransitions + projectionTargets = map projectionAliasTarget projectionAliases + structuralProjectionImport = + [ "import " <> structuralProjectionModule (aContext aggregate) <> " qualified as StructuralProjections" + | any isStructuralProjection projectionTargets + ] + generatedNominalProjectionImport = + [ "import " <> generatedNominalModule (aContext aggregate) <> " qualified as GeneratedNominals" + | any isGeneratedNominalProjection projectionTargets + ] + consumerNominalProjectionImport = + [ "import " <> nominalProjectionModule (aContext aggregate) <> " qualified as NominalProjections" + | any isConsumerNominalProjection projectionTargets + ] + consumerImports = + T.lines (renderPlannedImports importPlan) + expressionImportTypes = nub (concatMap typedExpressionImportTypes resolvedExpressions) + consumerLiteralNominals = nub [nominal | expression <- resolvedExpressions, nominal <- typedConsumerLiteralNominals expression] + importPlan = transducerImportPlan aggregate expressionImportTypes consumerLiteralNominals + 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 + +transducerUsesRecordDot :: Agg -> Bool +transducerUsesRecordDot aggregate = + any expressionUsesCommandRoot (resolvedGeneratedExpressions aggregate) + || any generatedOutputUsesCommandField generatedOutputs + where + generatedOutputs = + [ outputMappingFor aggregate transitionIndex emitIndex + | (transitionIndex, transition) <- transitionEntries aggregate, + tImplementation transition == GeneratedImplementation, + emitIndex <- [1 .. length (tEmits transition)] + ] + generatedOutputUsesCommandField (GeneratedCommandIdentity _ fields) = not (null fields) + generatedOutputUsesCommandField HandOwnedEventOutput {} = False + expressionUsesCommandRoot = anyTypedExpression isCommandRoot + isCommandRoot expression = case typedScalarNode expression of + TypedRoot ScalarCommandRoot {} -> True + _ -> False + +transducerImportPlan :: Agg -> [ResolvedAggregateType] -> [ResolvedNominalType] -> HaskellImportPlan +transducerImportPlan aggregate importedTypes literalNominals = + planImportsOrDie + (aGenPrefix aggregate <> ".Transducer") + (Set.fromList [aName aggregate <> "Regs", aName aggregate <> "Command", aName aggregate <> "Event"]) + ( Set.unions + [ aggregateSourceReferences (aggregateConsumerHaskellSource (aSymbols aggregate) resolvedType) + | resolvedType <- importedTypes + ] + <> Set.fromList + [ reference + | nominal <- literalNominals, + ConsumerNominal binding <- [resolvedNominalOwnership nominal], + reference <- + qualifiedValueReference (consumerNominalBinding binding) + : case resolvedNominalRepresentation nominal of + EnumRepresentation constructors -> + [ nominalRepresentationConstructorReference (aContext aggregate) nominal constructor + | (constructor, _) <- NE.toList constructors + ] + _ -> [] + ] + ) + +typedExpressionImportTypes :: TypedScalarExpr -> [ResolvedAggregateType] +typedExpressionImportTypes expression = own <> concatMap typedExpressionImportTypes (typedExpressionChildren expression) + where + own = case typedScalarNode expression of + TypedLiteral {} -> [typedScalarType expression] + TypedRoot provenance -> [scalarRootType provenance] + TypedProject provenance _ -> [scalarRootType provenance] + _ -> [] + +scalarRootType :: ScalarRootProvenance -> ResolvedAggregateType +scalarRootType = \case + ScalarRegisterRoot _ resolvedType -> resolvedType + ScalarCommandRoot _ resolvedType -> resolvedType + +isStructuralProjection :: ProjectionAliasTarget -> Bool +isStructuralProjection StructuralProjectionAlias {} = True +isStructuralProjection NominalProjectionAlias {} = False + +isGeneratedNominalProjection :: ProjectionAliasTarget -> Bool +isGeneratedNominalProjection (NominalProjectionAlias nominal _) = resolvedNominalOwnership nominal == GeneratedNominal +isGeneratedNominalProjection StructuralProjectionAlias {} = False + +isConsumerNominalProjection :: ProjectionAliasTarget -> Bool +isConsumerNominalProjection (NominalProjectionAlias nominal _) = case resolvedNominalOwnership nominal of + ConsumerNominal {} -> True + GeneratedNominal -> False +isConsumerNominalProjection StructuralProjectionAlias {} = False + +expressionOperatorOrder :: [Text] +expressionOperatorOrder = [".*", ".+", ".-", ".==", "./=", ".<", ".<=", ".>", ".>=", ".&&", ".||"] + +generatedTransitionOperators :: ResolvedGeneratedTransition -> [Text] +generatedTransitionOperators resolved = + maybe [] predicateOperators (resolvedTransitionGuard resolved) + <> concatMap (termOperators . snd) (resolvedTransitionWrites resolved) + where + predicateOperators expression = case typedScalarNode expression of + TypedEqual left right -> ".==" : termOperators left <> termOperators right + TypedNotEqual left right -> "./=" : termOperators left <> termOperators right + TypedCompare operator left right -> renderComparisonOperator operator : termOperators left <> termOperators right + TypedAnd left right -> ".&&" : predicateOperators left <> predicateOperators right + TypedOr left right -> ".||" : predicateOperators left <> predicateOperators right + _ -> ".==" : termOperators expression + termOperators expression = case typedScalarNode expression of + TypedAdd _ left right -> ".+" : termOperators left <> termOperators right + TypedSubtract _ left right -> ".-" : termOperators left <> termOperators right + TypedMultiply _ left right -> ".*" : termOperators left <> termOperators right + _ -> concatMap termOperators (typedExpressionChildren expression) + +anyHoleOwned :: Agg -> Bool +anyHoleOwned = any ((== HoleImplementation) . tImplementation) . aTransitions + +transducerUsesHoles :: Agg -> Bool +transducerUsesHoles aggregate = + anyHoleOwned aggregate + || any isHandOwned (Map.elems (aOutputMappings aggregate)) + where + isHandOwned HandOwnedEventOutput {} = True + isHandOwned GeneratedCommandIdentity {} = False + +renderVerificationList :: Agg -> [Text] +renderVerificationList aggregate = + [ (if listIndex == (0 :: Int) then " [ " else " , ") + <> "verifyTransition " + <> tshow (transitionStem transitionIndex transition) + <> " " + <> ownership + <> " " + <> vertexCtor aggregate source + <> " " + <> tshow' edgeIndex + | (listIndex, (source, edgeIndex, transitionIndex, transition)) <- zip [0 ..] entries, + let ownership = case tImplementation transition of + GeneratedImplementation -> "GeneratedOwned" + HoleImplementation -> "HoleOwned" + LegacyHoleImplementation -> error "legacy transition reached version-2 verification generation" + ] + <> [" ]"] + where + entries = + [ (source, edgeIndex, transitionIndex, transition) + | (source, transitions) <- 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 :: HaskellImportPlan -> Agg -> [ResolvedGeneratedTransition] -> (Text, [(Int, Transition)]) -> [Text] +generatedFromBlock importPlan aggregate resolvedTransitions (source, transitions) = + [" B.from " <> vertexCtor aggregate source <> " do"] + ++ concatMap (uncurry (generatedOnCmdBlock importPlan aggregate resolvedTransitions)) transitions + +generatedOnCmdBlock :: HaskellImportPlan -> Agg -> [ResolvedGeneratedTransition] -> Int -> Transition -> [Text] +generatedOnCmdBlock importPlan aggregate resolvedTransitions index transition = + [" B.onCmd inCtor" <> tCommand transition <> " $ \\" <> payloadBinder <> " -> B.do"] + ++ projectionBindingLines + ++ [" B.replayOnly" | tMode transition == TmReplayOnly] + ++ generatedBehavior + ++ outputLines + ++ [" B.noEmit" | null (tEmits transition)] + ++ [" B.goto " <> vertexCtor aggregate (tGoto transition)] + where + generatedBehavior = case tImplementation transition of + GeneratedImplementation -> + maybe [] (renderGuardLines importPlan aliases aggregate transition) (resolvedTransitionGuard resolved) + ++ [ " B.slot @" <> tshow registerName <> " =: " <> renderAssignmentOperand (renderKeikiTerm importPlan aliases aggregate transition expression) + | (registerName, expression) <- resolvedTransitionWrites resolved + ] + HoleImplementation -> [" Holes." <> holeFunctionName index transition <> " d"] + LegacyHoleImplementation -> error "legacy transition reached version-2 transducer generation" + resolved = + fromMaybe + (error ("resolved generated transition disappeared: " <> show index)) + (find ((== index) . resolvedTransitionIndex) resolvedTransitions) + aliases + | tImplementation transition == GeneratedImplementation = projectionAliasesForTransition resolved + | otherwise = [] + projectionBindingLines = case aliases of + [] -> [] + firstAlias : remainingAliases -> + [" let " <> renderProjectionAliasBinding importPlan aggregate transition firstAlias] + <> [" " <> renderProjectionAliasBinding importPlan aggregate transition alias | alias <- remainingAliases] + outputLines = + concat + [ generatedOutputLines aggregate index transition emitIndex eventName + | (emitIndex, eventName) <- zip [1 ..] (tEmits transition) + ] + payloadBinder + | payloadIsUsed = "d" + | otherwise = "_d" + payloadIsUsed = case tImplementation transition of + GeneratedImplementation -> + isJust (resolvedTransitionGuard resolved) + || not (null (resolvedTransitionWrites resolved)) + || any outputUsesPayload (zip [1 ..] (tEmits transition)) + HoleImplementation -> True + LegacyHoleImplementation -> True + outputUsesPayload (emitIndex, _) = case outputMappingFor aggregate index emitIndex of + GeneratedCommandIdentity _ fields -> not (null fields) + HandOwnedEventOutput {} -> True + +renderProjectionAliasBinding :: HaskellImportPlan -> Agg -> Transition -> ProjectionAlias -> Text +renderProjectionAliasBinding importPlan aggregate transition alias = + projectionAliasName alias <> " = " <> case projectionAliasTarget alias of + StructuralProjectionAlias provenance projection -> renderStructuralProjectionTerm importPlan aggregate transition provenance projection + NominalProjectionAlias nominal provenance -> renderNominalProjectionTerm importPlan aggregate transition nominal provenance + +renderGuardLines :: HaskellImportPlan -> [ProjectionAlias] -> Agg -> Transition -> TypedScalarExpr -> [Text] +renderGuardLines importPlan aliases aggregate transition expression = + [" B.requireGuard $"] + <> [" " <> line | line <- T.lines readable] + where + readable = + T.replace " .|| " "\n.|| " + . T.replace " .&& " "\n.&& " + $ renderKeikiPredicate importPlan aliases aggregate transition expression + +renderAssignmentOperand :: RenderedKeikiExpr -> Text +renderAssignmentOperand expression + | renderedKeikiPrecedence expression <= 6 = "(" <> renderedKeikiText expression <> ")" + | otherwise = renderedKeikiText expression + +generatedOutputLines :: Agg -> Int -> Transition -> Int -> Name -> [Text] +generatedOutputLines aggregate transitionIndex transition emitIndex eventName = + case outputMappingFor aggregate transitionIndex emitIndex of + GeneratedCommandIdentity _ 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 (renderGeneratedLanguagePragmas [] <> [generatedBanner, "module " <> aGenPrefix a <> ".Projection () where"]) + Just p -> + nl + [ generatedBanner, "module " <> aGenPrefix a <> ".Projection", " ( " <> lowerFirst (projTable p) <> "Projection", " , " <> lowerFirst (projTable p) <> "StatusFor", 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 @@ -14,9 +14,12 @@ scaffoldModulesWithGoldens, planServiceScaffold, planServiceScaffoldWithGoldens, + planServiceScaffoldWithRuntimePackage, + planServiceScaffoldWithRuntimePackageAndGoldens, planScaffold, planScaffoldWithGoldens, executeServiceScaffold, + executeServiceScaffoldWithRuntimePackage, executeScaffold, executeScaffoldWithLanguage, renderRefusals, @@ -45,6 +48,16 @@ import Data.Text qualified as T import Data.Text.IO qualified as TIO import Keiro.Dsl.BehaviorCoverage (BehaviorDerivationError, BehaviorKey (..), BehaviorRecordRow (..), behaviorRecordRows, deriveBehaviorRequirements) +import Keiro.Dsl.ConformancePackage + ( ConformancePackageFailure, + ConformancePackageReport, + ConformanceServiceKey (StandaloneConformanceService), + executePreparedConformancePackage, + planConformancePackage, + preflightConformancePackage, + renderConformancePackageFailure, + renderConformancePackageReport, + ) import Keiro.Dsl.ExplainBindings (BindingHole (..), BindingObligationKind (..), bindingHolesForService) import Keiro.Dsl.FoldFingerprint (FoldSurfaceError, aggregateFoldSurfaceForService, renderFoldSurfaceError) import Keiro.Dsl.Goldens (GoldenPayload) @@ -52,12 +65,14 @@ 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, renderManifestForService) +import Keiro.Dsl.Manifest (moduleNameOf, renderManifestForServiceWithFacade) import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), MappingIdentity (..), consumerPlan) import Keiro.Dsl.NominalType (nominalEqualityIdentitiesForService) +import Keiro.Dsl.RuntimePackage (RuntimePackageName) import Keiro.Dsl.Scaffold import Keiro.Dsl.ScaffoldRecord (ScaffoldRecord (..), parseRecord, recordFileName, renderRecord) import Keiro.Dsl.SemanticContract (CheckedService (..), checkedService, effectiveLanguageContract, legacyCheckedService) +import Keiro.Dsl.ServiceHarness (DuplicateServiceFactKey (..), serviceConformanceModuleName, serviceHarnessModule) import Keiro.Dsl.TypeGraph (MappedKey (..), TypeGraph (..), UseSite (..), resolveTypeGraph) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (takeDirectory, ()) @@ -85,6 +100,8 @@ | -- | Golden payload fixtures found beside a workspace member that the one -- workspace golden root does not have. Raised only by the workspace path. GoldenRootDivergence !FilePath ![FilePath] + | DuplicateConformanceFactKeys ![DuplicateServiceFactKey] + | ConformancePackageRefusal !ConformancePackageFailure deriving stock (Eq, Show) -- | What one module write did. 'Unchanged' is produced only by the workspace @@ -135,7 +152,8 @@ reportNewHoles :: ![BindingHole], reportAddedBehavior :: ![BehaviorRecordRow], reportRemovedBehavior :: ![BehaviorRecordRow], - reportObsoleteOutputHooks :: ![(Text, Text)] + reportObsoleteOutputHooks :: ![(Text, Text)], + reportConformancePackage :: !(Maybe ConformancePackageReport) } deriving stock (Eq, Show) @@ -177,21 +195,35 @@ -- | Run every pure refusal gate under the effective semantic contract. planServiceScaffold :: Context -> CheckedService -> Either [Refusal] [ScaffoldModule] -planServiceScaffold = planServiceScaffoldWithGoldens [] +planServiceScaffold = planServiceScaffoldWithRuntimePackage Nothing planServiceScaffoldWithGoldens :: [GoldenPayload] -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule] -planServiceScaffoldWithGoldens goldens ctx service = +planServiceScaffoldWithGoldens goldens = planServiceScaffoldWithRuntimePackageAndGoldens goldens Nothing + +-- | Add the one service-level conformance facade only when the runtime package +-- is explicitly configured. The package name itself is build metadata; facade +-- naming depends solely on the service context and placement policy. +planServiceScaffoldWithRuntimePackage :: Maybe RuntimePackageName -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule] +planServiceScaffoldWithRuntimePackage = planServiceScaffoldWithRuntimePackageAndGoldens [] + +planServiceScaffoldWithRuntimePackageAndGoldens :: [GoldenPayload] -> Maybe RuntimePackageName -> Context -> CheckedService -> Either [Refusal] [ScaffoldModule] +planServiceScaffoldWithRuntimePackageAndGoldens goldens runtimePackage ctx service = 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 + [] -> case facadeModules of + Left duplicates -> Left [DuplicateConformanceFactKeys duplicates] + Right facades -> + let modules = stampGeneratedModules (checkedLanguageContract service) (scaffoldServiceModulesWithGoldens goldens ctx service <> facades) + in case pureRefusals ctx spec modules of + [] -> Right modules + refusals -> Left refusals where spec = checkedSpec service + facadeModules = case runtimePackage of + Nothing -> Right [] + Just _ -> fmap pure (serviceHarnessModule ctx service) -- | Run every pure refusal gate. A successful result is the exact write set; -- a refusal has no write set and therefore cannot be accidentally executed. @@ -291,14 +323,31 @@ -- 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 plannedModules +executeServiceScaffold = executeServiceScaffoldWithRuntimePackage Nothing + +executeServiceScaffoldWithRuntimePackage :: Maybe RuntimePackageName -> FilePath -> Bool -> FilePath -> SourceLanguage -> Context -> CheckedService -> [ScaffoldModule] -> IO (Either [Refusal] ScaffoldReport) +executeServiceScaffoldWithRuntimePackage runtimePackage out forceGeneratedOverwrite specPath sourceLanguage ctx service plannedModules | effectiveLanguageContract sourceLanguage /= checkedLanguageContract service = pure (Left [SemanticContractMismatch "source provenance and checked service selected different effective language contracts"]) - | otherwise = executeCheckedScaffold + | otherwise = case packagePlan of + Left failures -> pure (Left (map ConformancePackageRefusal failures)) + Right Nothing -> executeCheckedScaffold Nothing + Right (Just plannedPackage) -> do + prepared <- preflightConformancePackage out forceGeneratedOverwrite plannedPackage + case prepared of + Left failures -> pure (Left (map ConformancePackageRefusal failures)) + Right packageReady -> executeCheckedScaffold (Just packageReady) where spec = checkedSpec service modules = stampGeneratedModules (checkedLanguageContract service) plannedModules - executeCheckedScaffold = + facadeModule = case runtimePackage of + Nothing -> Nothing + Just _ -> Just (serviceConformanceModuleName ctx) + packagePlan = + traverse + (\packageName -> planConformancePackage (StandaloneConformanceService (contextName ctx)) packageName (serviceConformanceModuleName ctx) service) + runtimePackage + executeCheckedScaffold preparedPackage = case deriveBehaviorRequirements spec of Left errors -> pure (Left [BehaviorRefusal errors]) Right requirements -> do @@ -323,8 +372,9 @@ createDirectoryIfMissing True out dispositions <- mapM (writeModule out) modules let manifestPath = out ("keiro-dsl-manifest." <> T.unpack (specContext spec) <> ".txt") - TIO.writeFile manifestPath (renderManifestForService (T.pack specPath) modules service) + TIO.writeFile manifestPath (renderManifestForServiceWithFacade facadeModule (T.pack specPath) modules service) TIO.writeFile recordPath (renderRecord (currentRecord specPath sourceLanguage ctx service modules currentBehavior)) + packageReport <- traverse executePreparedConformancePackage preparedPackage pure $ Right ScaffoldReport @@ -343,7 +393,8 @@ reportNewHoles = newHoles, reportAddedBehavior = addedBehavior, reportRemovedBehavior = removedBehavior, - reportObsoleteOutputHooks = obsoleteGeneratedOutputHooks spec + reportObsoleteOutputHooks = obsoleteGeneratedOutputHooks spec, + reportConformancePackage = packageReport } constraintPlan :: Spec -> ConsumerPlan -> [Text] @@ -520,6 +571,10 @@ " (a fixture the root lacks would be silently replaced by a synthesized stand-in)", "nothing was written" ] + render (DuplicateConformanceFactKeys duplicates) = + ["error: duplicate normalized service conformance fact keys -- refusing to scaffold; nothing was written"] + <> [" " <> duplicateServiceFactKey duplicate | duplicate <- duplicates] + render (ConformancePackageRefusal failure) = renderConformancePackageFailure failure renderScaffoldReport :: ScaffoldReport -> [Text] renderScaffoldReport report = @@ -540,6 +595,7 @@ <> behaviorDriftSection <> obsoleteOutputSection <> staleSection + <> maybe [] renderConformancePackageReport (reportConformancePackage report) where ctx = reportContext report dispositions = reportDispositions report diff --git a/src/Keiro/Dsl/ServiceHarness.hs b/src/Keiro/Dsl/ServiceHarness.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/ServiceHarness.hs @@ -0,0 +1,176 @@ +-- | One generated facade that normalizes every node-level harness in a checked +-- service into executable checks and review-owned facts. +module Keiro.Dsl.ServiceHarness + ( DuplicateServiceFactKey (..), + serviceConformanceModuleName, + serviceConformanceFactKeys, + serviceConformanceFactValues, + serviceHarnessModule, + ) +where + +import Data.List (group, sort, sortOn) +import Data.Text (Text) +import Data.Text qualified as T +import Keiro.Dsl.Grammar +import Keiro.Dsl.Harness (processHarnessFactValues, routerHarnessFactValues, workflowHarnessFactValues) +import Keiro.Dsl.Scaffold (Context, ModuleKind (Generated), ScaffoldModule (..), contextGeneratedPrefix, genPrefixFor, generatedBanner, pascal) +import Keiro.Dsl.SemanticContract (CheckedService (..)) +import Keiro.Dsl.Validate (nodeIdentity) + +-- | A fully qualified process, router, or workflow fact key that would occur +-- more than once in the generated facade. +newtype DuplicateServiceFactKey = DuplicateServiceFactKey + { duplicateServiceFactKey :: Text + } + deriving stock (Eq, Ord, Show) + +-- | The stable context-level facade module imported by the generated package. +serviceConformanceModuleName :: Context -> Text +serviceConformanceModuleName ctx = contextGeneratedPrefix ctx <> ".Conformance" + +-- | Every normalized expectation key in stable node-identity order. +serviceConformanceFactKeys :: CheckedService -> [Text] +serviceConformanceFactKeys service = + map fst (serviceConformanceFactValues service) + +-- | The create-once expectation baseline for all facts-producing nodes. +serviceConformanceFactValues :: CheckedService -> [(Text, Text)] +serviceConformanceFactValues service = + concatMap valuesForNode (serviceHarnessNodes service) + +-- | Emit exactly one facade, including an empty facade for a service with no +-- harness-producing nodes. Duplicate normalized expectation keys are refused +-- before a scaffold write set exists. +serviceHarnessModule :: Context -> CheckedService -> Either [DuplicateServiceFactKey] ScaffoldModule +serviceHarnessModule ctx service = case duplicateKeys of + [] -> Right facade + keys -> Left (map DuplicateServiceFactKey keys) + where + duplicateKeys = + [ key + | key : duplicate : _ <- group (sort (serviceConformanceFactKeys service)), + key == duplicate + ] + moduleName = serviceConformanceModuleName ctx + facade = + ScaffoldModule + { modulePath = T.unpack (T.replace "." "/" moduleName <> ".hs"), + moduleText = renderServiceHarness ctx service, + kind = Generated, + origin = "context " <> specContext (checkedSpec service) <> " service conformance facade" + } + +renderServiceHarness :: Context -> CheckedService -> Text +renderServiceHarness ctx service = + T.unlines $ + [ generatedBanner, + "module " <> serviceConformanceModuleName ctx, + " ( runServiceConformanceChecks", + " , serviceConformanceFacts", + " ) where" + ] + <> importLines + <> [""] + <> renderChecks checkSources + <> [""] + <> renderFacts factSources + where + indexed = zip [0 :: Int ..] (serviceHarnessNodes service) + importLines + | null indexed = [] + | otherwise = "" : map (renderImport ctx) indexed + checkSources = [(node, aliasFor index) | (index, node) <- indexed, producesChecks node] + factSources = [(node, aliasFor index) | (index, node) <- indexed, producesFacts node] + +renderImport :: Context -> (Int, Node) -> Text +renderImport ctx (index, node) = + "import " <> harnessModuleName ctx node <> " qualified as " <> aliasFor index + +aliasFor :: Int -> Text +aliasFor index = "Harness" <> T.pack (show index) + +harnessModuleName :: Context -> Node -> Text +harnessModuleName ctx = \case + NAggregate aggregate -> genPrefixFor ctx (aggName aggregate) <> ".Harness" + NProcess process -> genPrefixFor ctx (procId process) <> ".ProcessHarness" + NRouter router -> genPrefixFor ctx (rtId router) <> ".RouterHarness" + NReadModel readModel -> genPrefixFor ctx (pascal (rmName readModel)) <> ".ReadModelHarness" + NWorkflow workflow -> genPrefixFor ctx (wfId workflow) <> ".WorkflowFacts" + node -> error ("service harness requested a module for unsupported node " <> show (nodeIdentity node)) + +renderChecks :: [(Node, Text)] -> [Text] +renderChecks [] = + [ "runServiceConformanceChecks :: IO [(String, Bool)]", + "runServiceConformanceChecks = pure []" + ] +renderChecks sources = + [ "runServiceConformanceChecks :: IO [(String, Bool)]", + "runServiceConformanceChecks =", + " pure (" + ] + <> renderConcatenation (map checkExpression sources) + <> [" )"] + +checkExpression :: (Node, Text) -> Text +checkExpression (node, alias) = case node of + NAggregate aggregate -> + "[(\"aggregate/" <> aggName aggregate <> "/\" <> fact, passed) | (fact, passed) <- " <> alias <> ".harnessAssertions]" + NReadModel readModel -> + "[(\"readmodel/" <> rmName readModel <> "/\" <> fact, passed) | (fact, passed) <- " <> alias <> ".readModelFactResults]" + _ -> error "checkExpression called for a fact-only node" + +renderFacts :: [(Node, Text)] -> [Text] +renderFacts [] = + [ "serviceConformanceFacts :: [(String, String)]", + "serviceConformanceFacts = []" + ] +renderFacts sources = + [ "serviceConformanceFacts :: [(String, String)]", + "serviceConformanceFacts =" + ] + <> renderConcatenation (map factExpression sources) + +factExpression :: (Node, Text) -> Text +factExpression (node, alias) = + "[(\"" <> kindName <> "/" <> nodeName <> "/\" <> fact, value) | (fact, value) <- " <> alias <> "." <> valueName <> "]" + where + (kindName, nodeName, _) = nodeIdentity node + valueName = case node of + NProcess {} -> "processHarnessValues" + NRouter {} -> "routerHarnessValues" + NWorkflow {} -> "workflowFactValues" + _ -> error "factExpression called for a check-only node" + +renderConcatenation :: [Text] -> [Text] +renderConcatenation expressions = case expressions of + [] -> [] + first : rest -> (" " <> first) : [" <> " <> expression | expression <- rest] + +serviceHarnessNodes :: CheckedService -> [Node] +serviceHarnessNodes = + sortOn sortKey . filter (\node -> producesChecks node || producesFacts node) . specNodes . checkedSpec + where + sortKey node = let (kindName, nodeName, _) = nodeIdentity node in (kindName, nodeName) + +producesChecks :: Node -> Bool +producesChecks NAggregate {} = True +producesChecks NReadModel {} = True +producesChecks _ = False + +producesFacts :: Node -> Bool +producesFacts NProcess {} = True +producesFacts NRouter {} = True +producesFacts NWorkflow {} = True +producesFacts _ = False + +valuesForNode :: Node -> [(Text, Text)] +valuesForNode node = + [(kindName <> "/" <> nodeName <> "/" <> factName, value) | (factName, value) <- factValues] + where + (kindName, nodeName, _) = nodeIdentity node + factValues = case node of + NProcess process -> processHarnessFactValues process + NRouter router -> routerHarnessFactValues router + NWorkflow workflow -> workflowHarnessFactValues workflow + _ -> [] 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 @@ -40,6 +40,7 @@ import Keiro.Dsl.LanguageVersion (RuntimeCapability (..), runtimeProfileHasCapability) import Keiro.Dsl.NominalType qualified as Nominal import Keiro.Dsl.ReadModelShape (deriveShapeHash) +import Keiro.Dsl.RuntimePackage (isCabalPackageName) import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, effectiveRuntimeProfile, legacyCheckedService) import Keiro.Dsl.TypeGraph import Numeric (showHex) @@ -744,7 +745,7 @@ haskellRules declaration source = [ invalid declaration $ "Haskell package '" <> hsPackage source <> "' does not follow Cabal package-name grammar" - | not (cabalPackageName (hsPackage source)) + | not (isCabalPackageName (hsPackage source)) ] ++ [ invalid declaration $ "Haskell module '" <> hsModule source <> "' must be dot-separated Upper identifiers" | not (moduleNameSafe (hsModule source)) @@ -1060,16 +1061,6 @@ mappedGuardRules :: Spec -> TypeGraph -> [Diagnostic] mappedGuardRules _spec _graph = [] -cabalPackageName :: Text -> Bool -cabalPackageName packageName = - not (null components) && all validComponent components - where - components = T.splitOn "-" packageName - validComponent component = - not (T.null component) - && T.all asciiAlphaNum component - && T.any asciiLetter component - moduleNameSafe :: Text -> Bool moduleNameSafe moduleName = not (null components) && all constructorSafe components @@ -1088,12 +1079,6 @@ lowerIdentifierSafe name = case T.uncons name of Just (first, rest) -> asciiLower first && T.all asciiAlphaNumOrUnderscore rest && name `Set.notMember` haskellKeywords Nothing -> False - -asciiAlphaNum :: Char -> Bool -asciiAlphaNum c = asciiLetter c || (c >= '0' && c <= '9') - -asciiLetter :: Char -> Bool -asciiLetter c = asciiUpper c || asciiLower c asciiControl :: Char -> Bool asciiControl c = ord c < 32 || ord c == 127 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 @@ -36,6 +36,9 @@ ( -- * The workspace manifest WorkspaceManifest (..), WorkspaceMemberRef (..), + RuntimePackageName (..), + mkRuntimePackageName, + effectiveRuntimePackage, parseWorkspaceManifest, renderWorkspaceManifest, @@ -99,8 +102,9 @@ import Keiro.Dsl.Grammar import Keiro.Dsl.LanguageVersion (ParsedSource (..), SourceLanguage (..), SourceLanguageDiagnostic, effectiveLanguageVersion, languageVersionText) import Keiro.Dsl.Parser (ParseError, ParseFailure (..), parseSource, renderParseFailure) +import Keiro.Dsl.RuntimePackage (RuntimePackageName (..), mkRuntimePackageName) import Keiro.Dsl.Scaffold (Context (..)) -import Keiro.Dsl.ScaffoldRun (Refusal (..), planServiceScaffoldWithGoldens) +import Keiro.Dsl.ScaffoldRun (Refusal (..), planServiceScaffoldWithRuntimePackageAndGoldens) import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, checkedSource, effectiveLanguageContract) import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), Severity (..), nodeIdentity, validateService) import System.Directory (doesFileExist) @@ -123,6 +127,10 @@ { -- | The stable workspace identity, e.g. @demo-project@. wmfService :: !Text, wmfServiceLoc :: !Loc, + -- | The optional Cabal package that compiles this service's runtime. + wmfRuntimePackage :: !(Maybe RuntimePackageName), + -- | Meaningful only when 'wmfRuntimePackage' is 'Just'. + wmfRuntimePackageLoc :: !Loc, -- | The optional @module@ clause: the workspace's module-root authority. wmfModuleRoot :: !(Maybe Text), -- | Meaningful only when 'wmfModuleRoot' is 'Just'. @@ -210,12 +218,14 @@ -- | One source clause, tagged with the offset used to position its diagnostics. data Clause = ClService !Int !Loc !Text + | ClRuntimePackage !Int !Loc !Text | ClModule !Int !Loc !Text | ClLayout !Int !Loc !Placement | ClSpec !Int !Loc !Text clauseOffset :: Clause -> Int clauseOffset (ClService o _ _) = o +clauseOffset (ClRuntimePackage o _ _) = o clauseOffset (ClModule o _ _) = o clauseOffset (ClLayout o _ _) = o clauseOffset (ClSpec o _ _) = o @@ -244,6 +254,7 @@ pClause = choice [ mk ClService "service" pServiceName, + mk ClRuntimePackage "runtime-package" pPathToken, mk ClModule "module" pModulePrefix, mk ClLayout "layout" pPlacement, mk ClSpec "spec" pPathToken @@ -306,6 +317,12 @@ (service, serviceLoc) <- case [(name, loc) | ClService _ loc name <- clauses] of [one] -> pure one _ -> failAt (secondOffset [c | c@ClService {} <- clauses]) "duplicate 'service' clause: a workspace has exactly one identity" + (runtimePackage, runtimePackageLoc) <- case [(offset, loc, raw) | ClRuntimePackage offset loc raw <- clauses] of + [] -> pure (Nothing, Loc 0) + [(offset, loc, raw)] -> case mkRuntimePackageName raw of + Left reason -> failAt offset (T.unpack reason) + Right runtimeName -> pure (Just runtimeName, loc) + _ -> failAt (secondOffset [c | c@ClRuntimePackage {} <- clauses]) "duplicate 'runtime-package' clause" (moduleRoot, moduleLoc) <- case [(root, loc) | ClModule _ loc root <- clauses] of [] -> pure (Nothing, Loc 0) [(root, loc)] -> pure (Just root, loc) @@ -325,6 +342,8 @@ WorkspaceManifest { wmfService = service, wmfServiceLoc = serviceLoc, + wmfRuntimePackage = runtimePackage, + wmfRuntimePackageLoc = runtimePackageLoc, wmfModuleRoot = moduleRoot, wmfModuleRootLoc = moduleLoc, wmfLayout = layout, @@ -381,6 +400,7 @@ renderWorkspaceManifest manifest = T.intercalate "\n" $ ["service " <> wmfService manifest] + ++ maybe [] (\runtimeName -> ["runtime-package " <> unRuntimePackageName runtimeName]) (wmfRuntimePackage manifest) ++ maybe [] (\root -> ["module " <> root]) (wmfModuleRoot manifest) ++ maybe [] (\placement -> ["layout " <> renderPlacement placement]) (wmfLayout manifest) ++ [ "spec " <> T.pack (wmrPath member) @@ -391,6 +411,13 @@ renderPlacement GeneratedPrefix = "prefixed" renderPlacement CollocatedLeaf = "collocated" +-- | Select the CLI runtime-package override when present, otherwise the +-- workspace's persisted setting. +effectiveRuntimePackage :: Maybe RuntimePackageName -> WorkspaceManifest -> Maybe RuntimePackageName +effectiveRuntimePackage cli manifest = case cli of + Just runtimeName -> Just runtimeName + Nothing -> wmfRuntimePackage manifest + -------------------------------------------------------------------------------- -- Generic line relocation -------------------------------------------------------------------------------- @@ -636,6 +663,7 @@ wsLanguageContract :: !EffectiveLanguageContract, -- | The members' unanimous @context@. wsContext :: !Name, + wsRuntimePackage :: !(Maybe RuntimePackageName), wsModuleRoot :: !(Maybe Text), wsLayout :: !(Maybe Placement), -- | Canonical order. @@ -675,6 +703,7 @@ wsManifestPath = path, wsLanguageContract = checkedLanguageContract service, wsContext = specContext spec, + wsRuntimePackage = Nothing, wsModuleRoot = specModuleRoot spec, wsLayout = specLayout spec, wsMembers = @@ -1030,7 +1059,7 @@ -- An invalid merged spec is 'checkWorkspace''s report to make, and the -- planner is only designed to see specs that passed validation. | any ((== Error) . severity) (validateService (checkedWorkspace composed)) = [] - | otherwise = case planServiceScaffoldWithGoldens [] plannerContext (checkedWorkspace composed) of + | otherwise = case planServiceScaffoldWithRuntimePackageAndGoldens [] (wmfRuntimePackage manifest) plannerContext (checkedWorkspace composed) of Right _ -> [] Left plannerRefusals -> concatMap crossMemberCollision plannerRefusals crossMemberCollision (PathCollision path origins) = @@ -1075,6 +1104,7 @@ wsManifestPath = manifestPath, wsLanguageContract = effectiveLanguageContract effectiveSourceLanguage, wsContext = effectiveContext, + wsRuntimePackage = wmfRuntimePackage manifest, wsModuleRoot = effectiveModuleRoot, wsLayout = effectiveLayout, wsMembers = members, 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 @@ -34,6 +34,7 @@ WorkspacePlan (..), planWorkspaceScaffold, planWorkspaceScaffoldWithGoldens, + planWorkspaceScaffoldWithRuntimePackageAndGoldens, provenanceOwner, -- * Golden payload roots @@ -54,6 +55,15 @@ import Data.Text qualified as T import Data.Text.IO qualified as TIO import Keiro.Dsl.BehaviorCoverage (BehaviorKey (..), BehaviorRecordRow (..), attributeBehaviorOwner, behaviorRecordRows, deriveBehaviorRequirements) +import Keiro.Dsl.ConformancePackage + ( ConformancePackagePlan, + ConformancePackageReport, + ConformanceServiceKey (WorkspaceConformanceService), + executePreparedConformancePackage, + planConformancePackage, + preflightConformancePackage, + renderConformancePackageReport, + ) import Keiro.Dsl.ExplainBindings (BindingHole (..), bindingHolesForService) import Keiro.Dsl.FoldFingerprint (aggregateFoldSurfaceForService) import Keiro.Dsl.Goldens (GoldenPayload) @@ -61,9 +71,10 @@ 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, renderManifestForService) +import Keiro.Dsl.Manifest (moduleNameOf, renderManifestForServiceWithFacade) import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), consumerPlan) import Keiro.Dsl.NominalType (nominalEqualityIdentitiesForService) +import Keiro.Dsl.RuntimePackage (RuntimePackageName) import Keiro.Dsl.Scaffold import Keiro.Dsl.ScaffoldRun ( MappingDrift (..), @@ -82,6 +93,7 @@ staleAgainst, ) import Keiro.Dsl.SemanticContract (CheckedService (..)) +import Keiro.Dsl.ServiceHarness (DuplicateServiceFactKey, serviceConformanceModuleName, serviceHarnessModule) import Keiro.Dsl.Validate (nodeIdentity) import Keiro.Dsl.Workspace (WorkspaceMember (..), WorkspaceSpec (..), checkedWorkspace, declarationOwner, nodeOwner) import Keiro.Dsl.WorkspaceAdoption (MigrationReport (..), adoptedRows, adoptionReport, markLegacyRecordSuperseded, renderMigrationReport) @@ -113,6 +125,8 @@ { wpWorkspace :: !WorkspaceSpec, wpCheckedService :: !CheckedService, wpContext :: !Context, + wpRuntimePackage :: !(Maybe RuntimePackageName), + wpConformancePackage :: !(Maybe ConformancePackagePlan), -- | The one golden-payload root for the whole workspace. Carried here so -- execution can refuse a member-adjacent fixture the root lacks before it -- writes anything. @@ -139,23 +153,41 @@ WorkspaceSpec -> Either [Refusal] WorkspacePlan planWorkspaceScaffoldWithGoldens goldens goldenRoot ctx workspace = - 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 + planWorkspaceScaffoldWithRuntimePackageAndGoldens goldens (wsRuntimePackage workspace) goldenRoot ctx workspace + +planWorkspaceScaffoldWithRuntimePackageAndGoldens :: + [GoldenPayload] -> + Maybe RuntimePackageName -> + FilePath -> + Context -> + WorkspaceSpec -> + Either [Refusal] WorkspacePlan +planWorkspaceScaffoldWithRuntimePackageAndGoldens goldens runtimePackage goldenRoot ctx workspace = case workspaceModules goldens runtimePackage ctx workspace of + Left duplicates -> Left [DuplicateConformanceFactKeys duplicates] + Right tagged -> case packagePlan of + Left failures -> Left (map ConformancePackageRefusal failures) + Right plannedPackage -> 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, + wpRuntimePackage = runtimePackage, + wpConformancePackage = plannedPackage, + wpGoldenRoot = goldenRoot, + wpModules = tagged + } + refusals -> Left refusals where service = checkedWorkspace workspace merged = checkedSpec service - tagged = workspaceModules goldens ctx workspace + packagePlan = + traverse + (\packageName -> planConformancePackage (WorkspaceConformanceService (wsService workspace)) packageName (serviceConformanceModuleName ctx) service) + runtimePackage -- | The tagged module set, in exactly the order -- 'Keiro.Dsl.ScaffoldRun.scaffoldModulesWithGoldens' produces for the merged spec. @@ -165,14 +197,19 @@ -- ('scaffoldStructuralOwners') and nodes carry their own identity -- ('nodeIdentity'), both of which the workspace's ownership index resolves to a -- member file. -workspaceModules :: [GoldenPayload] -> Context -> WorkspaceSpec -> [(ScaffoldModule, ModuleProvenance)] -workspaceModules goldens ctx workspace = - [attributedStamped (declarationProvenance names) m | (m, names) <- scaffoldStructuralOwnersForService ctx service] - <> [attributedStamped ContextLevel m | m <- scaffoldReplayAudit ctx merged] - <> concat - [ map (attributedStamped (nodeProvenance node)) (emittersFor node) - | node <- specNodes merged - ] +workspaceModules :: [GoldenPayload] -> Maybe RuntimePackageName -> Context -> WorkspaceSpec -> Either [DuplicateServiceFactKey] [(ScaffoldModule, ModuleProvenance)] +workspaceModules goldens runtimePackage ctx workspace = do + facade <- case runtimePackage of + Nothing -> Right [] + Just _ -> fmap (\moduleValue -> [(stamp moduleValue, ContextLevel)]) (serviceHarnessModule ctx service) + pure $ + [attributedStamped (declarationProvenance names) m | (m, names) <- scaffoldStructuralOwnersForService ctx service] + <> [attributedStamped ContextLevel m | m <- scaffoldReplayAudit ctx merged] + <> concat + [ map (attributedStamped (nodeProvenance node)) (emittersFor node) + | node <- specNodes merged + ] + <> facade where service = checkedWorkspace workspace merged = checkedSpec service @@ -324,6 +361,7 @@ wsrAddedBehavior :: ![BehaviorRecordRow], wsrRemovedBehavior :: ![BehaviorRecordRow], wsrObsoleteOutputHooks :: ![(Text, Text)], + wsrConformancePackage :: !(Maybe ConformancePackageReport), -- | Present only on the run that adopted pre-workspace scaffold output. wsrMigration :: !(Maybe MigrationReport) } @@ -352,7 +390,11 @@ executeWorkspaceScaffold out forceGeneratedOverwrite plan = do stranded <- goldenRootDivergence (wpGoldenRoot plan) workspace bannerless <- if forceGeneratedOverwrite then pure [] else missingGeneratedBanners out modules - case stranded <> [MissingGeneratedBanner bannerless | not (null bannerless)] of + packagePreflight <- case wpConformancePackage plan of + Nothing -> pure (Right Nothing) + Just packagePlan -> fmap (fmap Just) (preflightConformancePackage out forceGeneratedOverwrite packagePlan) + let packageRefusals = either (map ConformancePackageRefusal) (const []) packagePreflight + case stranded <> [MissingGeneratedBanner bannerless | not (null bannerless)] <> packageRefusals of refusals@(_ : _) -> pure (Left refusals) [] -> do previous <- readWorkspaceRecord recordPath @@ -372,7 +414,7 @@ (addedBehavior, removedBehavior) = maybe (currentBehavior, []) (behaviorDrift currentBehavior . wrBehaviorRequirements) previous createDirectoryIfMissing True out dispositions <- traverse (writeWorkspaceModule out) (wpModules plan) - TIO.writeFile buildManifestPath (renderManifestForService (T.pack manifestName) modules (wpCheckedService plan)) + TIO.writeFile buildManifestPath (renderManifestForServiceWithFacade facadeModule (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. @@ -380,6 +422,9 @@ Just report -> adoptedRows report Nothing -> maybe [] wrAdopted previous TIO.writeFile recordPath (renderWorkspaceRecord (currentWorkspaceRecord plan adopted)) + packageReport <- case packagePreflight of + Right prepared -> traverse executePreparedConformancePackage prepared + Left _ -> pure Nothing case migration of Nothing -> pure () Just report -> do @@ -411,6 +456,7 @@ wsrAddedBehavior = addedBehavior, wsrRemovedBehavior = removedBehavior, wsrObsoleteOutputHooks = obsoleteGeneratedOutputHooks merged, + wsrConformancePackage = packageReport, wsrMigration = migration } where @@ -421,6 +467,9 @@ manifestName = takeFileName (wsManifestPath workspace) recordPath = out workspaceRecordFileName service buildManifestPath = out workspaceManifestFileName service + facadeModule = case wpRuntimePackage plan of + Nothing -> Nothing + Just _ -> Just (serviceConformanceModuleName (wpContext plan)) previousFiles previous = [(wrmKind row, wrmPath row) | row <- maybe [] wrModules previous] readWorkspaceRecord :: FilePath -> IO (Maybe WorkspaceRecord) @@ -572,6 +621,7 @@ <> obsoleteOutputSection <> ownershipSection <> staleSection + <> maybe [] renderConformancePackageReport (wsrConformancePackage report) where ctx = wsrContext report dispositions = wsrDispositions report diff --git a/test/Keiro/Dsl/ConformanceBaseline.hs b/test/Keiro/Dsl/ConformanceBaseline.hs --- a/test/Keiro/Dsl/ConformanceBaseline.hs +++ b/test/Keiro/Dsl/ConformanceBaseline.hs @@ -12,8 +12,9 @@ import Keiro.Dsl.Grammar (Spec (..)) import Keiro.Dsl.LanguageVersion (currentStableLanguageVersion, languageVersionNumber) import Keiro.Dsl.Parser (parseSource) +import Keiro.Dsl.RuntimePackage (RuntimePackageName (..)) import Keiro.Dsl.Scaffold (Context (..), ModuleKind (..), Placement (..), ScaffoldModule (..), defaultContext) -import Keiro.Dsl.ScaffoldRun (scaffoldServiceModules) +import Keiro.Dsl.ScaffoldRun (planServiceScaffoldWithRuntimePackage, scaffoldServiceModules) import Keiro.Dsl.SemanticContract (CheckedService (..), checkedSource) import Keiro.Dsl.Skeleton (skeletonFor) import Keiro.Dsl.Workspace (WorkspaceSpec (..), fileContentSource, loadWorkspace) @@ -164,6 +165,14 @@ "source" -> do source <- requiredSuiteSource suite generatedPathsForSource source + "source-with-conformance-facade" -> do + source <- requiredSuiteSource suite + sourceText <- readRepoText source + service <- parseCheckedSource source sourceText + modules <- case planServiceScaffoldWithRuntimePackage (Just (RuntimePackageName "conformance-runtime")) (defaultContext (specContext (checkedSpec service))) service of + Left refusals -> expectationFailure (show refusals) >> fail "stable configured source scaffold refusal" + Right value -> pure value + pure (generatedPaths modules) "workspace" -> do source <- requiredSuiteSource suite resolved <- resolveRepoFile ("keiro-dsl" source) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -30,6 +30,7 @@ import Keiro.Dsl.CanonicalEncoding (foldFingerprint128) import Keiro.Dsl.CodecCompare import Keiro.Dsl.ConformanceBaseline (conformanceBaselineSpec) +import Keiro.Dsl.ConformancePackage import Keiro.Dsl.Coverage qualified as Coverage import Keiro.Dsl.Diff (Change (..), ChangeKind (..), CompatibilitySurface (..), CompatibilityVector (..), FamilyDiff (..), Label (..), NodeFamily, RolloutConstraint (..), SurfaceVerdict (..), defaultGate, deriveLabel, familyRegistry, gateWith, gatedBreaking, isAdvisory, isBreaking, verdictFor) import Keiro.Dsl.Diff qualified as CheckedDiff @@ -47,7 +48,7 @@ import Keiro.Dsl.Harness (harnessFor, harnessForWithGoldens, harnessReadModel, harnessRouter, harnessWorkflow) import Keiro.Dsl.IdDomain (IdDomainContract (..), contractIdDomainContractFor, idDomainContractFor, idDomainIdentitiesForService) import Keiro.Dsl.LanguageVersion -import Keiro.Dsl.Manifest (manifestDependencies, manifestDependenciesForService, moduleNameOf, renderManifest, renderManifestForService) +import Keiro.Dsl.Manifest (manifestDependencies, manifestDependenciesForService, moduleNameOf, renderManifest, renderManifestForService, renderManifestForServiceWithFacade) import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), MappingIdentity (..), consumerPlan) import Keiro.Dsl.NominalType hiding (NominalInvalidHaskellSource, NominalInvalidIdPrefix, NominalInvalidIdentity, NominalMissingIngredient) import Keiro.Dsl.Parser (parseSource, parseSpec) @@ -55,10 +56,11 @@ import Keiro.Dsl.ReadModelShape (canonicalShape, deriveShapeHash, registryNameFor, subscriptionNameFor) import Keiro.Dsl.ReplayImpact (AggregateImpact (..), ReplayImpact (..)) import Keiro.Dsl.ReplayImpact qualified as ReplayImpact -import Keiro.Dsl.Scaffold (Context (..), ModuleKind (..), NominalGenerationOwner (..), NominalUseSite (..), ScaffoldModule (..), StructuralProjection (..), codecComparisonBanner, codecComparisonModule, defaultContext, firewallBreaches, genPrefixFor, generatedBanner, generatedBannerFor, generatedNominalModule, holePrefixFor, isGeneratedBannerLine, obsoleteGeneratedOutputHooks, planNominalGeneration, projectionSpecs, scaffoldAggregate, scaffoldContract, scaffoldContractForService, scaffoldIntake, scaffoldProcess, scaffoldPublisher, scaffoldReadModel, scaffoldRefusals, scaffoldReplayAudit, scaffoldRouter, scaffoldWorkqueue, windowSeconds) +import Keiro.Dsl.Scaffold (Context (..), ModuleKind (..), NominalGenerationOwner (..), NominalUseSite (..), ScaffoldModule (..), StructuralProjection (..), codecComparisonBanner, codecComparisonModule, defaultContext, firewallBreaches, genPrefixFor, generatedBanner, generatedBannerFor, generatedNominalModule, holePrefixFor, isGeneratedBannerLine, obsoleteGeneratedOutputHooks, planNominalGeneration, projectionSpecs, scaffoldAggregate, scaffoldContract, scaffoldContractForService, scaffoldIntake, scaffoldProcess, scaffoldPublisher, scaffoldReadModel, scaffoldRefusals, scaffoldReplayAudit, scaffoldRouter, scaffoldStructural, scaffoldWorkqueue, windowSeconds) import Keiro.Dsl.ScaffoldRecord (ScaffoldRecord (..), parseRecord, recordFileName, renderRecord) -import Keiro.Dsl.ScaffoldRun (MappingDrift (..), Refusal (..), ScaffoldReport (..), SourceLanguageDrift (..), StaleGeneratedEvidence (..), StaleModule (..), WriteDisposition (..), executeScaffold, executeScaffoldWithLanguage, executeServiceScaffold, planScaffold, planServiceScaffold, renderRefusals, renderScaffoldReport, scaffoldModules, scaffoldServiceModules) +import Keiro.Dsl.ScaffoldRun (MappingDrift (..), Refusal (..), ScaffoldReport (..), SourceLanguageDrift (..), StaleGeneratedEvidence (..), StaleModule (..), WriteDisposition (..), executeScaffold, executeScaffoldWithLanguage, executeServiceScaffold, executeServiceScaffoldWithRuntimePackage, planScaffold, planServiceScaffold, planServiceScaffoldWithRuntimePackage, renderRefusals, renderScaffoldReport, scaffoldModules, scaffoldServiceModules) import Keiro.Dsl.SemanticContract +import Keiro.Dsl.ServiceHarness import Keiro.Dsl.Skeleton (skeletonFor, skeletonKinds) import Keiro.Dsl.TypeGraph import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), Severity (..), derivedQueueTrio, renderDiagnostic, validateService, validateSpec) @@ -69,7 +71,7 @@ import Keiro.Dsl.WorkspaceRecord import Keiro.Dsl.WorkspaceScaffold import Paths_keiro_dsl qualified as Package -import System.Directory (createDirectory, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getTemporaryDirectory, listDirectory, removeFile, removePathForcibly) +import System.Directory (canonicalizePath, createDirectory, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getTemporaryDirectory, listDirectory, removeFile, removePathForcibly) import System.Environment (lookupEnv) import System.Exit (ExitCode (..)) import System.FilePath (takeDirectory, takeExtension, takeFileName, ()) @@ -1612,7 +1614,9 @@ 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` T.isInfixOf "import NominalConformance.Domain (AccountNumber, FeatureFlag, ObservedAt, OrderId, OrderStatus, RiskScore, SequenceNumber)" + moduleText domainModule `shouldSatisfy` T.isInfixOf "orderId :: !OrderId" + moduleText domainModule `shouldSatisfy` (not . T.isInfixOf "NominalConformance.Domain.OrderId") moduleText domainModule `shouldSatisfy` (not . T.isInfixOf "newtype OrderId") moduleText domainModule `shouldSatisfy` (not . T.isInfixOf "data OrderStatus =") moduleText codecModule `shouldSatisfy` T.isInfixOf "KindID.parseText @\"ord\"" @@ -1622,14 +1626,16 @@ 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 "type FieldOwner AccountNumberNominalProjection = AccountNumber" + moduleText projectionModule `shouldSatisfy` T.isInfixOf "projectFieldValue _ = nominalToRepresentation Bindings.accountNumberBinding" moduleText projectionModule `shouldSatisfy` T.isInfixOf "instance ExactFieldProjection OrderIdEqualityProjection" moduleText projectionModule `shouldSatisfy` T.isInfixOf "textProjectionDomain orderIdEqualityPattern" moduleText projectionModule `shouldSatisfy` T.isInfixOf "instance ExactFieldProjection OrderStatusEqualityProjection" moduleText projectionModule `shouldSatisfy` T.isInfixOf "finiteProjectionDomain (\"draft\" :| [\"submitted\"])" kind bindingModule `shouldBe` HoleStub - moduleText bindingModule `shouldSatisfy` T.isInfixOf "orderIdBinding :: NominalBinding NominalConformance.Domain.OrderId (KindID \"ord\")" + moduleText bindingModule `shouldSatisfy` T.isInfixOf "import NominalConformance.Domain (AccountNumber, FeatureFlag, ObservedAt, OrderId, OrderStatus, RiskScore, SequenceNumber)" + moduleText bindingModule `shouldSatisfy` T.isInfixOf "orderIdBinding :: NominalBinding OrderId (KindID \"ord\")" + moduleText bindingModule `shouldSatisfy` T.isInfixOf "orderStatusBinding :: NominalBinding OrderStatus ShapeOrderStatus.OrderStatusRepresentation" firewallBreaches modules `shouldBe` [] scaffoldModules ctx spec `shouldBe` modules manifestDependencies spec `shouldContain` ["mmzk-typeid", "nominal-conformance"] @@ -2011,12 +2017,14 @@ spec <- specOf "test/fixtures/aggregate-scalars.keiro" errorCodes spec `shouldBe` [] let aggregate = onlyAggregate spec + modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate generated = [ moduleText generatedModule - | generatedModule <- scaffoldAggregate (defaultContext (specContext spec)) spec aggregate, + | generatedModule <- modules, Keiro.Dsl.Scaffold.kind generatedModule == Generated ] - domain = generatedTextEndingIn "Domain.hs" (scaffoldAggregate (defaultContext (specContext spec)) spec aggregate) + domain = generatedTextEndingIn "Domain.hs" modules + codec = generatedTextEndingIn "Codec.hs" modules domain `shouldSatisfy` T.isInfixOf "observedAt :: !UTCTime" domain `shouldSatisfy` T.isInfixOf "revision :: !Natural" domain `shouldSatisfy` T.isInfixOf "UTCTime (fromGregorian 2026 1 2) (picosecondsToDiffTime 11045123456789012)" @@ -2025,9 +2033,24 @@ domain `shouldSatisfy` T.isInfixOf "import Numeric.Natural (Natural)" manifestDependencies spec `shouldContain` ["time"] manifestDependencies spec `shouldNotContain` ["keiki-codec-json"] + codec `shouldSatisfy` T.isInfixOf "scalarLedgerEventTypes :: NonEmpty EventType" + codec `shouldSatisfy` T.isInfixOf "eventTypes = scalarLedgerEventTypes" + codec `shouldSatisfy` T.isInfixOf "_renderEventTypes scalarLedgerEventTypes" + codec `shouldSatisfy` (not . T.isInfixOf "; expected one of: ScalarsRecorded\"") generated `shouldSatisfy` all (not . T.isInfixOf "error") generated `shouldSatisfy` all (not . T.isInfixOf "getCurrentTime") generated `shouldSatisfy` all (not . T.isInfixOf "iso8601ParseM") + it "keeps the event-list binding disjoint from the private formatter" $ do + source <- readTestText "test/fixtures/aggregate-scalars.keiro" + spec <- parseInlineSpec "" (T.replace "aggregate ScalarLedger" "aggregate Render" source) + let aggregate = onlyAggregate spec + modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate + codec = generatedTextEndingIn "Codec.hs" modules + codecLines = T.lines codec + codecLines `shouldContain` ["renderEventTypes :: NonEmpty EventType"] + codecLines `shouldContain` ["_renderEventTypes :: NonEmpty EventType -> String"] + codec `shouldSatisfy` T.isInfixOf "eventTypes = renderEventTypes" + codec `shouldSatisfy` T.isInfixOf "_renderEventTypes renderEventTypes" it "canonicalizes Time and UTCTime across pretty, diff, and fold identity" $ do source <- readTestText "test/fixtures/aggregate-scalars.keiro" canonical <- parseInlineSpec "