diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,121 @@ ## [Unreleased] +## 0.5.0.0 — 2026-07-31 + +### Breaking Changes + +- `DiagnosticCode` gains nine constructors: + `WorkspaceMemberUnreadable`, `WorkspaceMemberParseFailed`, + `WorkspaceContextMismatch`, `WorkspaceAuthorityConflict`, + `WorkspaceDuplicateDeclaration`, `WorkspaceDuplicateNodeName`, + `WorkspacePathCollision`, `OwnershipMoved`, and `WorkspaceAuthorityChanged`. + Additions are append-only, but exhaustive matches over the type must be + extended. +- `Keiro.Dsl.ScaffoldRun.Refusal` gains `GoldenRootDivergence`, raised only by + the workspace path when a golden payload fixture sits beside a member that + the one workspace golden root lacks. +- `Keiro.Dsl.ScaffoldRun.WriteDisposition` gains `Unchanged`, produced only by + the workspace write path when a Generated module's bytes already match. +- `Keiro.Dsl.DiffReport.Remedy` gains `RemedyRescaffoldWorkspace`. + +No behaviour of the single-file path changed: it keeps its context-keyed +record and manifest names, its report bytes, and its `Overwritten` +disposition, and no existing generated bytes moved. + +### New Features + +- Adds **service workspaces**: a `.keiro-workspace` manifest names a service and + lists its member `.keiro` files, and `keiro-dsl check ` validates + them as one service contract. Shared ids, enums, rules, and mapped structural + types resolve once across all members, so an aggregate in one file may use a + declaration or feed a read model owned by another. A single `.keiro` file is + unchanged and behaves as a one-member workspace. + + Membership is a set: member paths are normalized and canonically sorted, so + listing order changes neither the parsed manifest nor any output. Composition + refuses, before producing a graph, when members declare different contexts, + when a member's `module`/`layout` clause contradicts the manifest authority, + when a shared declaration or node is owned by two members (identical + duplicates never silently merge), or when two members claim generated module + paths that collide under case folding. One diagnostic can cite several files: + the primary location keeps the established + `:: error[]: ` shape and each further location + follows as an indented `note:` line. + + `check --emit`, `--explain-bindings`, `--coverage-report`, and + `--fail-on-opaque` all work against the merged whole-service graph, and + `keiro-dsl parse ` round-trips the manifest canonically. + Dispatch is by file extension, so every single-file branch is unchanged. + + New `Keiro.Dsl.Workspace` module; `Keiro.Dsl.Validate.nodeIdentity` is now + exported. Recorded as ADR-14. + +- **Whole-workspace scaffolding.** `keiro-dsl scaffold --out DIR` + emits the complete generated module set for every member in one invocation, + with unchanged flags. The set is emitted once from the merged spec, so the + structural projection facade and the replay-audit assembly are produced + exactly once from the complete graph, and every existing refusal gate runs + over the whole set. Both preflights — golden fixtures stranded beside a + member, and Generated paths lacking the `@generated` banner — are evaluated + across the whole workspace before the output directory is created, so a + failure in any member leaves the tree, the record, and the build manifest + byte-for-byte untouched. + + History is workspace-keyed (`workspace.`, a name a context can never + collide with), and each record row carries its producing member, so an + aggregate moved between member files is reported as an ownership move with + zero stale churn and zero content change. A Generated module whose bytes + already match is reported `(unchanged)` rather than rewritten, making + idempotence observable. Ownership is attributed structurally through the new + `scaffoldStructuralOwners` and `bindingSkeletonOwners` seams in + `Keiro.Dsl.Scaffold`, never by parsing the human-readable `origin` string. + + New `Keiro.Dsl.WorkspaceRecord` and `Keiro.Dsl.WorkspaceScaffold` modules; + `Keiro.Dsl.ScaffoldRun` now exports the gates and helpers the workspace path + reuses (`pureRefusals`, `missingGeneratedBanners`, `staleAgainst`, + `constraintPlan`, `mappingDrift`, `newBindingObligations`, + `obligationKindLabel`, `renderMappingIdentity`) so the two paths cannot + diverge on what counts as a refusal. + +- **Adoption of pre-workspace output.** The first whole-workspace scaffold into + a directory that already holds per-context output imports what is + attributable, reports everything, and claims nothing silently. A file is + claimed only with evidence — `record` when a legacy per-context record for + this workspace's effective context lists it, or `banner` when it sits at a + planned Generated path carrying the `@generated` banner while no surviving + record lists it. Hole paths are never claimed; everything else is listed as + unclaimed and left untouched, and a bannerless file at a planned Generated + path still refuses the run. Nothing is deleted or renamed: the superseded + legacy record gains one appended `superseded-by:` line that its own v1 parser + ignores. The migration report is persisted once as + `keiro-dsl-migration-report.workspace..txt`. New + `Keiro.Dsl.WorkspaceAdoption` module; recorded as ADR-15. + +- **Whole-workspace diffing.** `keiro-dsl diff --since ` + composes the historical workspace from the manifest and member blobs at that + revision through the same loader and diffs it against the working tree as one + service. Membership deltas are covered, and when the manifest itself does not + exist at the old revision an adoption baseline is composed from the current + membership and flagged in the report. + + Findings from the merged graph are annotated with the member file and line + that own the changed declaration and each use site, so a shared declaration's + blast radius is visible across files. The report carries workspace metadata + (service identity, manifest, `since`, old and new membership, adoption-baseline + flag), and replay-impact and coverage output are merged across members. Owner-map + and manifest-authority changes are reported as the non-blocking consumer-build + advisories `OwnershipMoved` and `WorkspaceAuthorityChanged`, classified + independently of wire evolution so they never mask a real wire finding. + + The `keiro-dsl/diff-report/1` JSON schema is preserved: single-file reports + keep their original bytes, and workspace inputs add a top-level `workspace` + object plus optional per-finding `declaration` and `useSites` keys, which + version-1 readers ignore. New `Keiro.Dsl.WorkspaceDiff` module; new + `Keiro.Dsl.DiffReport` exports `OwnedSite`, `WorkspaceChange`, + `WorkspaceMeta`, `WorkspaceDiffReport`, and `workspaceDiffReport`. ADR-4 is + amended with the composed-workspace diff boundary. + ## 0.4.0.1 — 2026-07-28 ### Other Changes diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -6,6 +6,7 @@ import Control.Monad (when) import Data.Aeson qualified as Aeson +import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Text.IO qualified as TIO @@ -22,10 +23,13 @@ import Keiro.Dsl.ScaffoldRun (executeScaffold, planScaffoldWithGoldens, renderRefusals, renderScaffoldReport) import Keiro.Dsl.Skeleton (skeletonFor) import Keiro.Dsl.Validate (Diagnostic (..), Severity (..), renderDiagnostic, validateSpec) +import Keiro.Dsl.Workspace (ContentSource (..), LineMap (..), OwnershipIndex (..), WorkspaceDiagnostic (..), WorkspaceFailure, WorkspaceManifest (..), WorkspaceMember (..), WorkspaceMemberRef (..), WorkspaceSpec (..), checkWorkspace, fileContentSource, isWorkspacePath, loadWorkspace, parseWorkspaceManifest, renderWorkspaceDiagnostic, renderWorkspaceFailure, renderWorkspaceManifest) +import Keiro.Dsl.WorkspaceDiff (WorkspaceChange (..), WorkspaceMeta (..), diffWorkspaces, renderWorkspaceFinding, workspaceDiffReport) +import Keiro.Dsl.WorkspaceScaffold (executeWorkspaceScaffold, planWorkspaceScaffoldWithGoldens, renderWorkspaceScaffoldReport) import Options.Applicative import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist) import System.Exit (ExitCode (..), exitFailure) -import System.FilePath (makeRelative, normalise, takeDirectory, ()) +import System.FilePath (isAbsolute, makeRelative, normalise, takeDirectory, takeFileName, ()) import System.IO (hPutStrLn, stderr) import System.Process (readProcessWithExitCode) @@ -141,12 +145,21 @@ sinceOpt = strOption (long "since" <> metavar "GIT-REF" <> help "Git ref to diff the spec against (e.g. HEAD, a tag, a branch)") fileArg :: Parser FilePath -fileArg = argument str (metavar "FILE" <> help "Path to a .keiro spec (use /dev/stdin for stdin)") +fileArg = argument str (metavar "FILE" <> help "Path to a .keiro spec or .keiro-workspace manifest (use /dev/stdin for stdin)") kindArg :: Parser String kindArg = argument str (metavar "KIND" <> help "Node kind to scaffold a starter spec for") run :: Command -> IO () +-- Workspace dispatch. A @FILE@ ending in @.keiro-workspace@ is a workspace +-- manifest; everything else takes the untouched single-file path below. +run (Parse fp) | isWorkspacePath fp = runWorkspaceParse fp +run (Check fp emit explainBindings coverageOptions) + | isWorkspacePath fp = runWorkspaceCheck fp emit explainBindings coverageOptions +run (Scaffold fp out cliRoot cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest) + | isWorkspacePath fp = runWorkspaceScaffold fp out cliRoot 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 input <- TIO.readFile fp case parseSpec fp input of @@ -245,6 +258,295 @@ mapM_ (\path -> Aeson.encodeFile path (diffReport effectiveGate changes)) reportOut coverageOk <- runDiffCoverage fp (T.pack ref) oldSpec newSpec coverageOptions if any (gatedBreaking effectiveGate) changes || not coverageOk then exitFailure else pure () + +{- | @parse@ on a workspace manifest: read it, parse it, and print it back in +canonical form (clauses in order, members codepoint-sorted). +-} +runWorkspaceParse :: FilePath -> IO () +runWorkspaceParse fp = do + input <- TIO.readFile fp + case parseWorkspaceManifest fp input of + Left err -> do + hPutStrLn stderr (T.unpack err) + exitFailure + Right manifest -> TIO.putStrLn (renderWorkspaceManifest manifest) + +{- | @check@ on a workspace manifest: compose the whole service from its member +@.keiro@ files and validate it as one contract. Diagnostics are rendered +against the member file and line that produced them, and a single diagnostic +may cite several files at once. + +The success options work against the merged graph, which is an ordinary 'Spec': +@--emit@ prints the canonical whole-service view, @--explain-bindings@ lists the +service's binding obligations, and the coverage options report on the merged +mapped-type graph with the manifest as the report's subject. +-} +runWorkspaceCheck :: FilePath -> Bool -> Bool -> Maybe CheckCoverageOptions -> IO () +runWorkspaceCheck fp emit explainBindings coverageOptions = do + loaded <- loadWorkspace (fileContentSource (takeDirectory fp)) fp + case loaded of + Left failure -> do + mapM_ (TIO.hPutStrLn stderr) (renderWorkspaceFailure fp failure) + exitFailure + Right workspace -> do + let diags = checkWorkspace workspace + spec = wsMergedSpec workspace + mapM_ (TIO.hPutStrLn stderr . renderWorkspaceDiagnostic fp) diags + if any ((== Error) . wdSeverity) diags + then exitFailure + else do + when emit (TIO.putStrLn (renderSpec spec)) + if explainBindings + then case bindingObligations spec of + Left graphErrors -> do + hPutStrLn stderr ("validated workspace did not resolve its mapped type graph: " <> show graphErrors) + exitFailure + Right obligations -> TIO.putStrLn (renderBindingObligations (wsContext workspace) obligations) + else pure () + coverageOk <- runCheckCoverage fp spec coverageOptions + when (coverageOk && not emit && not explainBindings) (putStrLn "OK") + when (not coverageOk) exitFailure + +{- | @scaffold@ on a workspace manifest: compose the whole service, then plan +and emit the complete module set for every member in one invocation. + +Every refusal — a member that will not parse, a cross-member conflict, a +validation error anywhere in the merged graph, a module-path collision, a golden +fixture stranded beside a member, a Generated target without the banner — is +raised before the first output byte changes, exactly as on the single-file path. + +The context is folded with the same precedence the single-file path uses: a CLI +flag beats the workspace authority, which (per EP-153) beats a member clause. +The single-file branch below is not touched, so existing users' bytes are +unchanged by construction. +-} +runWorkspaceScaffold :: + FilePath -> + FilePath -> + Maybe String -> + Bool -> + Bool -> + Maybe FilePath -> + Maybe (String, FilePath) -> + IO () +runWorkspaceScaffold fp out cliRoot cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest = do + loaded <- loadWorkspace (fileContentSource (takeDirectory fp)) fp + case loaded of + Left failure -> do + mapM_ (TIO.hPutStrLn stderr) (renderWorkspaceFailure fp failure) + exitFailure + Right workspace -> do + -- Validation gate: never scaffold an invalid service. Abort on any + -- error-severity diagnostic before writing a single module. + let diags = checkWorkspace workspace + mapM_ (TIO.hPutStrLn stderr . renderWorkspaceDiagnostic fp) diags + when (any ((== Error) . wdSeverity) diags) exitFailure + let spec = wsMergedSpec workspace + ctx = workspaceContext cliRoot cliCollocate workspace + goldenRoot = fromMaybe (takeDirectory fp "golden-payloads") cliGoldens + goldens <- loadGoldenPayloads goldenRoot spec + case ( planWorkspaceScaffoldWithGoldens goldens goldenRoot ctx workspace + , traverse (\(name, _) -> codecComparisonModule ctx spec (T.pack name)) comparisonRequest + ) of + (Left refusals, _) -> do + mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals) + exitFailure + (_, Left comparisonError) -> TIO.hPutStrLn stderr comparisonError >> exitFailure + (Right plan, Right comparisonModule) -> do + comparisonReady <- preflightComparison out comparisonRequest comparisonModule + case comparisonReady of + Left comparisonError -> TIO.hPutStrLn stderr comparisonError >> exitFailure + Right () -> do + result <- executeWorkspaceScaffold out forceGeneratedOverwrite plan + case result of + Left refusals -> do + mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals) + exitFailure + Right report -> do + mapM_ (TIO.hPutStrLn stderr) (renderWorkspaceScaffoldReport report) + writeComparison comparisonRequest comparisonModule + +{- | @diff@ on a workspace manifest: compose the working-tree service and the +service described by the manifest and member blobs at @--since@, then feed both +merged specs through the existing differ, replay-impact analysis, coverage +report, golden emission, and gates. + +The historical side is read exclusively through 'ContentSource'. In +particular, member paths are joined textually beneath the manifest's +repository-relative directory; they are never canonicalized because an old +member may no longer exist in the working tree. +-} +runWorkspaceDiff :: + FilePath -> + String -> + Maybe FilePath -> + Maybe FilePath -> + [CompatibilitySurface] -> + Bool -> + Maybe FilePath -> + Maybe DiffCoverageOptions -> + IO () +runWorkspaceDiff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions = do + let dir = takeDirectory fp + rootRes <- git dir ["rev-parse", "--show-toplevel"] + case rootRes of + Left err -> hPutStrLn stderr err >> exitFailure + Right rootRaw -> do + let repoRoot = trim rootRaw + absFp <- canonicalizePath fp + let relManifestPath = makeRelative repoRoot absFp + relManifestDir = takeDirectory relManifestPath + oldSource = gitContentSource repoRoot ref relManifestDir + refRes <- git repoRoot ["cat-file", "-e", ref <> "^{commit}"] + case refRes of + Left err -> hPutStrLn stderr err >> exitFailure + Right _ -> do + newLoaded <- loadWorkspace (fileContentSource dir) fp + case newLoaded of + Left failure -> printWorkspaceFailure fp failure + Right newWorkspace -> do + currentManifestText <- TIO.readFile fp + case parseWorkspaceManifest fp currentManifestText of + Left err -> hPutStrLn stderr (T.unpack err) >> exitFailure + Right currentManifest -> do + oldManifestRes <- git repoRoot ["show", ref <> ":" <> relManifestPath] + (adoptionBaseline, oldLoaded) <- case oldManifestRes of + Right _ -> do + loaded <- loadWorkspace oldSource fp + pure (False, loaded) + Left _ -> do + loaded <- loadAdoptionBaseline oldSource fp currentManifest newWorkspace + pure (True, loaded) + case oldLoaded of + Left failure -> do + printWorkspaceFailureLines fp failure + when adoptionBaseline $ + hPutStrLn stderr "workspace adoption baseline could not be composed; commit the workspace manifest before diffing across it, or fix the member files at the old revision" + exitFailure + Right oldWorkspace -> do + when adoptionBaseline $ + putStrLn + ( "workspace adoption baseline: " + <> fp + <> " does not exist at " + <> ref + <> "; composing the old service from the current members' blobs at " + <> ref + ) + let oldSpec = wsMergedSpec oldWorkspace + newSpec = wsMergedSpec newWorkspace + goldenRoot = fmap (workspaceGoldenRoot fp) emitGoldensRoot + written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) goldenRoot + mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written + let workspaceChanges = diffWorkspaces oldWorkspace newWorkspace + changes = map wcChange workspaceChanges + impact = replayImpact oldSpec newSpec + effectiveGate = gateWith gatedSurfaces + reportMeta = + WorkspaceMeta + { wmIdentity = wsService newWorkspace + , wmManifest = fp + , wmSince = T.pack ref + , wmMembersOld = map wmPath (wsMembers oldWorkspace) + , wmMembersNew = map wmPath (wsMembers newWorkspace) + , wmAdoptionBaseline = adoptionBaseline + } + mapM_ (TIO.putStrLn . renderWorkspaceFinding) workspaceChanges + when explain $ + mapM_ (TIO.putStrLn . renderExplainBlock) (filter shouldExplain changes) + TIO.putStrLn (renderReplayImpact impact) + mapM_ (`Aeson.encodeFile` impact) replayImpactOut + mapM_ (\path -> Aeson.encodeFile path (workspaceDiffReport reportMeta effectiveGate workspaceChanges)) reportOut + coverageOk <- runDiffCoverage fp (T.pack ref) oldSpec newSpec coverageOptions + if any (gatedBreaking effectiveGate) changes || not coverageOk then exitFailure else pure () + +-- | A @git show@ backed source rooted at a workspace manifest directory. +gitContentSource :: FilePath -> String -> FilePath -> ContentSource +gitContentSource repoRoot ref relManifestDir = + ContentSource + { csRead = \relative -> do + let relPath = normalise (relManifestDir relative) + result <- git repoRoot ["show", ref <> ":" <> relPath] + pure $ case result of + Left err -> Left (T.pack ("git show " <> ref <> ":" <> relPath <> " failed: " <> trim err)) + Right contents -> Right (T.pack contents) + } + +{- | Build the historical side for the commit that introduces a workspace +manifest. Current members absent from the old revision contribute no nodes; +members that do exist are still parsed and composed by the ordinary workspace +loader, so malformed or mutually inconsistent old specs remain hard refusals. +-} +loadAdoptionBaseline :: + ContentSource -> + FilePath -> + WorkspaceManifest -> + WorkspaceSpec -> + IO (Either WorkspaceFailure WorkspaceSpec) +loadAdoptionBaseline oldSource manifestPath currentManifest newWorkspace = do + present <- traverse presentAtRevision (NE.toList (wmfMembers currentManifest)) + case NE.nonEmpty [member | (member, True) <- present] of + Nothing -> pure (Right (emptyWorkspaceBaseline newWorkspace)) + Just members -> + let oldManifest = currentManifest{wmfMembers = members} + manifestName = takeFileName manifestPath + baselineSource = + ContentSource + { csRead = \relative -> + if relative == manifestName + then pure (Right (renderWorkspaceManifest oldManifest)) + else csRead oldSource relative + } + in loadWorkspace baselineSource manifestPath + where + presentAtRevision member = do + result <- csRead oldSource (wmrPath member) + pure (member, either (const False) (const True) result) + +-- | The sound old side when every current member is new at the adoption ref. +emptyWorkspaceBaseline :: WorkspaceSpec -> WorkspaceSpec +emptyWorkspaceBaseline workspace = + workspace + { wsMembers = [] + , wsMergedSpec = + (wsMergedSpec workspace) + { specIds = [] + , specEnums = [] + , specRules = [] + , specMapped = [] + , specNodes = [] + } + , wsLineMap = LineMap [] + , wsOwnership = OwnershipIndex mempty mempty + } + +workspaceGoldenRoot :: FilePath -> FilePath -> FilePath +workspaceGoldenRoot manifestPath requested + | isAbsolute requested = requested + | otherwise = normalise (takeDirectory manifestPath requested) + +printWorkspaceFailure :: FilePath -> WorkspaceFailure -> IO a +printWorkspaceFailure fp failure = printWorkspaceFailureLines fp failure >> exitFailure + +printWorkspaceFailureLines :: FilePath -> WorkspaceFailure -> IO () +printWorkspaceFailureLines fp = mapM_ (TIO.hPutStrLn stderr) . renderWorkspaceFailure fp + +{- | Fold the workspace's module-root and layout authority with the CLI +overrides to a 'Context'. Precedence is CLI flag > workspace authority > +built-in default; EP-153 already resolved the manifest-versus-member question +into 'wsModuleRoot' and 'wsLayout', so this mirrors 'mkContext' exactly one +level up. +-} +workspaceContext :: Maybe String -> Bool -> WorkspaceSpec -> Context +workspaceContext cliRoot cliCollocate workspace = + Context + { contextName = wsContext workspace + , moduleRoot = maybe (fromMaybe "" (wsModuleRoot workspace)) T.pack cliRoot + , placement = + if cliCollocate + then CollocatedLeaf + else fromMaybe GeneratedPrefix (wsLayout workspace) + } shouldExplain :: Change -> Bool shouldExplain Additive{} = False 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.4.0.1 +version: 0.5.0.0 synopsis: Typed specification toolchain for keiro services description: keiro-dsl is the toolchain over a typed `.keiro` specification of a keiro @@ -53,6 +53,11 @@ Keiro.Dsl.Skeleton Keiro.Dsl.TypeGraph Keiro.Dsl.Validate + Keiro.Dsl.Workspace + Keiro.Dsl.WorkspaceAdoption + Keiro.Dsl.WorkspaceDiff + Keiro.Dsl.WorkspaceRecord + Keiro.Dsl.WorkspaceScaffold build-depends: , aeson >=2.2.1 && <2.3 diff --git a/src/Keiro/Dsl/Diff.hs b/src/Keiro/Dsl/Diff.hs --- a/src/Keiro/Dsl/Diff.hs +++ b/src/Keiro/Dsl/Diff.hs @@ -28,6 +28,7 @@ publicContractContext, persistedIdentityContext, consumerBuildContext, + advisoryAt, changeContextRoot, changeContextPaths, classifyCompatibility, @@ -247,6 +248,7 @@ -} classifyCompatibility :: ChangeContext -> DiagnosticCode -> CompatibilityVector classifyCompatibility context code + | code `elem` [OwnershipMoved, WorkspaceAuthorityChanged] = mappedBuildVector | code == MappedFieldAddedWithDefault = mappedFieldAdditionVector context | code `elem` [MappedArmAdded, MappedEnumValueAdded] = mappedDirectionalAdditionVector context | code `elem` mappedWireBreakingCodes = mappedWireBreakingVector context @@ -1926,6 +1928,7 @@ | code `elem` publicCodes -> publicContractContext root paths | code `elem` queueCodes -> queueContext root paths | code `elem` identityCodes -> persistedIdentityContext root paths + | code `elem` [OwnershipMoved, WorkspaceAuthorityChanged] -> consumerBuildContext root paths | code == AggFoldSurfaceChanged -> snapshotContext root paths | code == EnumCtorAdded -> ChangeContext root paths ContextGeneral label | code `elem` privateCodes -> privateEventContext root paths diff --git a/src/Keiro/Dsl/DiffReport.hs b/src/Keiro/Dsl/DiffReport.hs --- a/src/Keiro/Dsl/DiffReport.hs +++ b/src/Keiro/Dsl/DiffReport.hs @@ -3,12 +3,19 @@ The JSON schema identifier is @keiro-dsl/diff-report/1@. Consumers must ignore unknown object keys. Vector keys and entries in the @paths@ array are append-only so later nested type-expression work can refine findings without -invalidating version-1 readers. +invalidating version-1 readers. Workspace inputs add a top-level @workspace@ +object and optional per-finding @declaration@ and @useSites@ keys; single-file +reports keep their original bytes. -} module Keiro.Dsl.DiffReport ( Remedy (..), DiffReport, diffReport, + OwnedSite (..), + WorkspaceChange (..), + WorkspaceMeta (..), + WorkspaceDiffReport, + workspaceDiffReport, remediationFor, renderRemedy, renderFinding, @@ -21,6 +28,7 @@ ) where import Data.Aeson (ToJSON (..), Value, object, (.=)) +import Data.Aeson.Types (Pair) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NonEmpty import Data.Set (Set) @@ -38,6 +46,7 @@ | RemedyReplayOnlyEdge | RemedyStateCodecBump | RemedyRecompileConsumers + | RemedyRescaffoldWorkspace | RemedyRunConformance | RemedyDoNotDeploy Text deriving stock (Eq, Show) @@ -51,6 +60,42 @@ diffReport :: Set CompatibilitySurface -> [Change] -> DiffReport diffReport = DiffReport +-- | One source location from a composed workspace's ownership index. +data OwnedSite = OwnedSite + { osFile :: !FilePath + , osLine :: !Int + } + deriving stock (Eq, Show) + +-- | A merged-graph finding enriched with declaration and use-site ownership. +data WorkspaceChange = WorkspaceChange + { wcChange :: !Change + , wcDeclarationSite :: !(Maybe OwnedSite) + , wcUseSites :: ![(Text, Maybe OwnedSite)] + } + deriving stock (Eq, Show) + +-- | Provenance for the two workspace graphs compared by one command. +data WorkspaceMeta = WorkspaceMeta + { wmIdentity :: !Text + , wmManifest :: !FilePath + , wmSince :: !Text + , wmMembersOld :: ![FilePath] + , wmMembersNew :: ![FilePath] + , wmAdoptionBaseline :: !Bool + } + deriving stock (Eq, Show) + +data WorkspaceDiffReport = WorkspaceDiffReport + { workspaceReportMeta :: !WorkspaceMeta + , workspaceReportGate :: !(Set CompatibilitySurface) + , workspaceReportFindings :: ![WorkspaceChange] + } + deriving stock (Eq, Show) + +workspaceDiffReport :: WorkspaceMeta -> Set CompatibilitySurface -> [WorkspaceChange] -> WorkspaceDiffReport +workspaceDiffReport = WorkspaceDiffReport + instance ToJSON DiffReport where toJSON report = object @@ -60,22 +105,63 @@ , "findings" .= map (findingValue (reportGate report)) (reportFindings report) ] +instance ToJSON WorkspaceDiffReport where + toJSON report = + object + [ "schema" .= ("keiro-dsl/diff-report/1" :: Text) + , "gate" .= map surfaceName (Set.toAscList (workspaceReportGate report)) + , "breaking" .= any (gatedBreaking (workspaceReportGate report) . wcChange) (workspaceReportFindings report) + , "findings" .= map (workspaceFindingValue (workspaceReportGate report)) (workspaceReportFindings report) + , "workspace" .= workspaceMetaValue (workspaceReportMeta report) + ] + findingValue :: Set CompatibilitySurface -> Change -> Value -findingValue gate change = +findingValue gate change = object (findingPairs gate change) + +workspaceFindingValue :: Set CompatibilitySurface -> WorkspaceChange -> Value +workspaceFindingValue gate workspaceChange = object - [ "label" .= labelName (deriveLabel gate (ckVector kind)) - , "node" .= ckNode kind - , "facet" .= ckFacet kind - , "subject" .= ckSubject kind - , "code" .= T.pack (show (ckCode kind)) - , "paths" .= ckPaths kind - , "vector" .= vectorValue (ckVector kind) - , "detail" .= ckDetail kind - , "remedies" .= map renderRemedy (NonEmpty.toList (remediationFor (ckContext kind) (ckCode kind))) - ] + ( findingPairs gate (wcChange workspaceChange) + <> maybe [] (\site -> ["declaration" .= ownedSiteValue site]) (wcDeclarationSite workspaceChange) + <> ["useSites" .= map useSiteValue (wcUseSites workspaceChange) | not (null (wcUseSites workspaceChange))] + ) + +findingPairs :: Set CompatibilitySurface -> Change -> [Pair] +findingPairs gate change = + [ "label" .= labelName (deriveLabel gate (ckVector kind)) + , "node" .= ckNode kind + , "facet" .= ckFacet kind + , "subject" .= ckSubject kind + , "code" .= T.pack (show (ckCode kind)) + , "paths" .= ckPaths kind + , "vector" .= vectorValue (ckVector kind) + , "detail" .= ckDetail kind + , "remedies" .= map renderRemedy (NonEmpty.toList (remediationFor (ckContext kind) (ckCode kind))) + ] where kind = changeKind change +ownedSiteValue :: OwnedSite -> Value +ownedSiteValue site = object ["file" .= osFile site, "line" .= osLine site] + +useSiteValue :: (Text, Maybe OwnedSite) -> Value +useSiteValue (path, site) = + object + ( ["path" .= path] + <> maybe [] (\owned -> ["file" .= osFile owned, "line" .= osLine owned]) site + ) + +workspaceMetaValue :: WorkspaceMeta -> Value +workspaceMetaValue meta = + object + [ "identity" .= wmIdentity meta + , "manifest" .= wmManifest meta + , "since" .= wmSince meta + , "membersOld" .= wmMembersOld meta + , "membersNew" .= wmMembersNew meta + , "adoptionBaseline" .= wmAdoptionBaseline meta + ] + vectorValue :: CompatibilityVector -> Value vectorValue vector = object @@ -90,6 +176,8 @@ remediationFor :: ChangeContext -> DiagnosticCode -> NonEmpty Remedy remediationFor context code + | code == OwnershipMoved = RemedyRescaffoldWorkspace :| [] + | code == WorkspaceAuthorityChanged = RemedyRescaffoldWorkspace :| [RemedyRecompileConsumers] | code == AggGuardTightened = RemedyReplayOnlyEdge :| [RemedyRunConformance] | code == AggFoldSurfaceChanged = RemedyStateCodecBump :| [RemedyRunConformance] | code `elem` mappedWireCodes = mappedWireRemedy @@ -208,6 +296,7 @@ RemedyReplayOnlyEdge -> "add the computed replay-only edge described by docs/adr/0002-replay-only-edges-are-the-sanctioned-remedy-for-guard-tightening.md" RemedyStateCodecBump -> "invalidate and rebuild snapshots by bumping state-codec version when automatic fingerprinting cannot see the change" RemedyRecompileConsumers -> "recompile every affected consumer against the generated interface" + RemedyRescaffoldWorkspace -> "re-run the whole-workspace scaffold so the record's ownership and golden roots follow the change" RemedyRunConformance -> "run the generated conformance and historical fixture suites" RemedyDoNotDeploy detail -> detail 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 @@ -27,9 +27,11 @@ holePrefixFor, scaffoldReplayAudit, scaffoldStructural, + scaffoldStructuralOwners, codecComparisonModule, codecComparisonBanner, bindingSkeletonModules, + bindingSkeletonOwners, scaffoldAggregate, scaffoldProcess, scaffoldRouter, @@ -396,21 +398,40 @@ schema-derived Keiki field witnesses; neither layer owns consumer behavior. -} scaffoldStructural :: Context -> Spec -> [ScaffoldModule] -scaffoldStructural ctx spec = case resolveTypeGraph spec of +scaffoldStructural ctx spec = map fst (scaffoldStructuralOwners ctx spec) + +{- | '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 = case resolveTypeGraph spec of Left _ -> [] - Right graph -> map (shapeModule ctx graph) structural <> projectionModules <> bindingSkeletonModules ctx spec graph + Right graph -> + [(shapeModule ctx graph entry, [sdName (fst entry)]) | entry <- structural] + <> projectionModules + <> 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" - } + [ ( 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)) ] @@ -637,10 +658,19 @@ module, so grouping happens by module rather than by declaration. -} bindingSkeletonModules :: Context -> Spec -> TypeGraph -> [ScaffoldModule] -bindingSkeletonModules ctx spec graph = case bindingObligations spec of +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 graph owner entries + [ (emitBindingSkeleton ctx graph owner entries, nub (map obligationMappedName entries)) | (owner, entries) <- Map.toAscList (Map.fromListWith (<>) [(obligationModule obligation, [obligation]) | obligation <- obligations]) ] 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,6 +14,19 @@ executeScaffold, renderRefusals, renderScaffoldReport, + + -- * Shared with whole-workspace scaffolding ("Keiro.Dsl.WorkspaceScaffold") + + -- + -- $shared + pureRefusals, + missingGeneratedBanners, + staleAgainst, + constraintPlan, + mappingDrift, + newBindingObligations, + obligationKindLabel, + renderMappingIdentity, ) where import Data.List (sortOn) @@ -34,15 +47,33 @@ import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (takeDirectory, ()) +{- $shared +These are the pieces whole-workspace scaffolding reuses verbatim rather than +reimplementing, so a workspace and a single spec can never disagree about what +counts as a refusal, what counts as stale, or how an identity renders. +"Keiro.Dsl.WorkspaceScaffold" cannot live in this module because +"Keiro.Dsl.Workspace" already imports it (its cross-member collision check asks +the planner), so the seam is exports rather than shared privates. +-} + data Refusal = PathCollision !FilePath ![Text] | FirewallBreach ![(FilePath, Text, Int)] | LoweringRefusal ![Text] | MissingGeneratedBanner ![FilePath] | ImportCycle ![Text] + | {- | 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] deriving stock (Eq, Show) -data WriteDisposition = Overwritten | Created | Skipped +{- | What one module write did. 'Unchanged' is produced only by the workspace +write path, which compares bytes before overwriting a Generated module so that +an idempotent re-run is observable in the report; the single-spec 'writeModule' +never produces it. +-} +data WriteDisposition = Overwritten | Created | Skipped | Unchanged deriving stock (Eq, Show) data StaleModule = StaleModule @@ -110,14 +141,25 @@ planScaffoldWithGoldens :: [GoldenPayload] -> Context -> Spec -> Either [Refusal] [ScaffoldModule] planScaffoldWithGoldens goldens ctx spec = let modules = scaffoldModulesWithGoldens goldens ctx spec - breaches = firewallBreaches modules - refusals = - collisionRefusals modules - <> dependencyRefusals ctx spec modules - <> [FirewallBreach breaches | not (null breaches)] - <> [LoweringRefusal lowering | let lowering = scaffoldRefusals spec, not (null lowering)] - in if null refusals then Right modules else Left refusals + in case pureRefusals ctx spec modules of + [] -> Right modules + refusals -> Left refusals +{- | Every pure refusal gate, over an already-built module set: case-folded path +collisions, generated\/consumer collisions and import cycles, firewall breaches, +and lowering refusals. Whole-workspace planning builds its module set from the +merged spec and then runs exactly this, so no gate can apply to one input shape +and not the other. +-} +pureRefusals :: Context -> Spec -> [ScaffoldModule] -> [Refusal] +pureRefusals ctx spec modules = + collisionRefusals modules + <> dependencyRefusals ctx spec modules + <> [FirewallBreach breaches | not (null breaches)] + <> [LoweringRefusal lowering | let lowering = scaffoldRefusals spec, not (null lowering)] + where + breaches = firewallBreaches modules + dependencyRefusals :: Context -> Spec -> [ScaffoldModule] -> [Refusal] dependencyRefusals ctx spec modules = collisionWithConsumers <> namespaceCycles where @@ -264,10 +306,17 @@ if exists then parseRecord <$> TIO.readFile path else pure Nothing existingStale :: FilePath -> [ScaffoldModule] -> ScaffoldRecord -> IO [StaleModule] -existingStale out modules record = fmap concat $ mapM stillExists removed +existingStale out modules record = staleAgainst out (map modulePath modules) (recFiles record) + +{- | The files a previous run recorded that the current plan no longer produces +and that are still on disk. keiro-dsl never deletes; this is what the report +lists for a human to review. +-} +staleAgainst :: FilePath -> [FilePath] -> [(ModuleKind, FilePath)] -> IO [StaleModule] +staleAgainst out currentPathList previous = fmap concat $ mapM stillExists removed where - currentPaths = Set.fromList (map modulePath modules) - removed = [(fileKind, path) | (fileKind, path) <- recFiles record, path `Set.notMember` currentPaths] + currentPaths = Set.fromList currentPathList + removed = [(fileKind, path) | (fileKind, path) <- previous, path `Set.notMember` currentPaths] stillExists (fileKind, path) = do exists <- doesFileExist (out path) pure [StaleModule fileKind path | exists] @@ -336,6 +385,14 @@ , " " <> T.intercalate " -> " path , " keep bindings in a leaf module that imports only Structural.Shape.* and Keiro.Codec.Structural" ] + render (GoldenRootDivergence root paths) = + [ "error: golden payload fixtures live beside a workspace member instead of under the workspace golden root -- refusing to scaffold" + ] + <> [" " <> T.pack path | path <- paths] + <> [ " move these files under " <> T.pack root <> "; keiro-dsl reads one golden root per workspace" + , " (a fixture the root lacks would be silently replaced by a synthesized stand-in)" + , "nothing was written" + ] renderScaffoldReport :: ScaffoldReport -> [Text] renderScaffoldReport report = @@ -367,6 +424,7 @@ dispositionTag Overwritten = "(overwritten)" dispositionTag Created = "(created)" dispositionTag Skipped = "(skipped: already present)" + dispositionTag Unchanged = "(unchanged)" pad name = name <> T.replicate (nameWidth - T.length name) " " generatedCount = length [() | (m, _) <- dispositions, kind m == Generated] harnesses = 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 @@ -16,6 +16,7 @@ validateSpec, derivedQueueTrio, sagaCategoryError, + nodeIdentity, ) where import Data.Bits (xor) @@ -261,6 +262,23 @@ | CodecCompareDifference | CodecCompareCoverageGap | CodecCompareInvalidInput + | -- MasterPlan 26 / EP-153: whole-service composition refusals, emitted by + -- "Keiro.Dsl.Workspace" when several @.keiro@ members are composed into + -- one service graph. They live in this registry, not a parallel enum, so + -- every gate stays correlatable by code (ADR 0004). Manifest syntax and + -- structure errors deliberately have no code here: like a @.keiro@ parse + -- error, they are refused before any graph exists to diagnose. + WorkspaceMemberUnreadable + | WorkspaceMemberParseFailed + | WorkspaceContextMismatch + | WorkspaceAuthorityConflict + | WorkspaceDuplicateDeclaration + | WorkspaceDuplicateNodeName + | WorkspacePathCollision + | -- MasterPlan 26 / EP-155: whole-workspace diff facts. These are + -- advisory consumer-build obligations, distinct from wire evolution. + OwnershipMoved + | WorkspaceAuthorityChanged deriving stock (Eq, Show) -- | A line-numbered, structured diagnostic. diff --git a/src/Keiro/Dsl/Workspace.hs b/src/Keiro/Dsl/Workspace.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/Workspace.hs @@ -0,0 +1,1300 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | Service workspaces: several complete @.keiro@ member files validated, +scaffolded, and diffed as __one service contract__. + +A /workspace manifest/ is a @.keiro-workspace@ file that names the service and +lists its member @.keiro@ files. It is deliberately a file rather than repeated +CLI flags: @keiro-dsl diff --since \@ must be able to reconstruct the +member set as it existed at an older git revision from git alone, and the +scaffold record needs one durable identity that outlives member renames. + +The manifest is line-oriented in the spirit of the member grammar: @#@ starts a +comment, blank lines are insignificant, and clause keywords drive structure. + +@ +# The demo-project service workspace. +service demo-project +module Demo.Modules.Project +layout collocated +spec domain/project-artifact.keiro +spec domain/project.keiro +spec domain/shared.keiro +@ + +Membership is a __set__: 'parseWorkspaceManifest' accepts @spec@ lines in any +order and canonically sorts them (codepoint order on the normalized relative +path), and 'renderWorkspaceManifest' always emits that canonical order. Source +order therefore never changes meaning or generated bytes. + +This module owns the workspace file format only; the member @.keiro@ grammar in +"Keiro.Dsl.Parser" is untouched. Note the unrelated "Keiro.Dsl.Manifest", which +is the /scaffold build manifest/ (the record of emitted modules) — every +identifier here carries a @Workspace@ prefix to keep the two apart. +-} +module Keiro.Dsl.Workspace ( + -- * The workspace manifest + WorkspaceManifest (..), + WorkspaceMemberRef (..), + parseWorkspaceManifest, + renderWorkspaceManifest, + + -- * Input dispatch + workspaceExtension, + isWorkspacePath, + + -- * Member paths + normalizeMemberPath, + + -- * Loading members + ContentSource (..), + fileContentSource, + loadWorkspace, + + -- * The composed service graph + WorkspaceSpec (..), + WorkspaceMember (..), + OwnershipIndex (..), + declarationOwner, + nodeOwner, + LineMap (..), + resolveWorkspaceLine, + composeWorkspace, + oneMemberWorkspace, + checkWorkspace, + + -- * Multi-file diagnostics + WorkspaceDiagnostic (..), + WorkspaceLocation (..), + WorkspaceFile (..), + WorkspaceFailure (..), + renderWorkspaceDiagnostic, + renderWorkspaceFailure, + workspaceDisplayPath, + + -- * Line relocation + relocateLocs, + collectLocs, +) where + +import Control.Exception qualified as Exception +import Data.Bifunctor (first) +import Data.Char (isAscii, isDigit, isLetter, toLower) +import Data.Functor.Const (Const (..)) +import Data.Functor.Identity (Identity (..)) +import Data.List (nub, sort, sortOn) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Data.Void (Void) +import GHC.Generics +import Keiro.Dsl.Grammar +import Keiro.Dsl.Parser (ParseError, parseSpec) +import Keiro.Dsl.Scaffold (Context (..)) +import Keiro.Dsl.ScaffoldRun (Refusal (..), planScaffoldWithGoldens) +import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), Severity (..), nodeIdentity, validateSpec) +import System.Directory (doesFileExist) +import System.FilePath (takeBaseName, takeDirectory, takeFileName, ()) +import Text.Megaparsec hiding (ParseError) +import Text.Megaparsec.Char (char, space1) +import Text.Megaparsec.Char.Lexer qualified as L +import Text.Read (readMaybe) + +{- | A parsed workspace manifest. Members are held in canonical order +(codepoint-sorted normalized paths), so two manifests that list the same +members in different source orders are 'Eq'-equal and render to identical +bytes. + +Unlike 'Keiro.Dsl.Grammar.Spec', which records no location for its +@context@\/@module@\/@layout@ clauses, this type keeps a 'Loc' per clause: the +workspace composer needs to cite a manifest clause line when a member +contradicts it. +-} +data WorkspaceManifest = WorkspaceManifest + { wmfService :: !Text + -- ^ The stable workspace identity, e.g. @demo-project@. + , wmfServiceLoc :: !Loc + , wmfModuleRoot :: !(Maybe Text) + -- ^ The optional @module@ clause: the workspace's module-root authority. + , wmfModuleRootLoc :: !Loc + -- ^ Meaningful only when 'wmfModuleRoot' is 'Just'. + , wmfLayout :: !(Maybe Placement) + -- ^ The optional @layout@ clause: the workspace's placement authority. + , wmfLayoutLoc :: !Loc + -- ^ Meaningful only when 'wmfLayout' is 'Just'. + , wmfMembers :: !(NonEmpty WorkspaceMemberRef) + -- ^ At least one member, in canonical order. + } + deriving stock (Eq, Show) + +-- | One @spec \@ line: the normalized manifest-relative member path. +data WorkspaceMemberRef = WorkspaceMemberRef + { wmrPath :: !FilePath + -- ^ Normalized: forward slashes, no @./@ segments, relative, ends in @.keiro@. + , wmrLoc :: !Loc + } + deriving stock (Eq, Show) + +-- | The file extension that marks a workspace manifest. +workspaceExtension :: String +workspaceExtension = ".keiro-workspace" + +{- | Does this @FILE@ argument name a workspace manifest? The test is on the +extension, case-insensitively, and never on the file's content: a file's role +must not depend on which parser happens to succeed, and a corrupted manifest +must produce a manifest parse error rather than a confusing @.keiro@ one. +-} +isWorkspacePath :: FilePath -> Bool +isWorkspacePath path = map toLower workspaceExtension `isSuffixOfString` map toLower path + where + isSuffixOfString needle haystack = length haystack > length needle && drop (length haystack - length needle) haystack == needle + +-------------------------------------------------------------------------------- +-- Member path normalization +-------------------------------------------------------------------------------- + +{- | Normalize and validate a @spec@ path token. Member paths must be relative, +use forward slashes, end in @.keiro@, and stay inside the manifest's directory +tree; @.\/@ segments are normalized away. A manifest may not list another +manifest (a @.keiro-workspace@ path fails the @.keiro@ suffix rule). + +The restrictions exist so a workspace can be reconstructed at an arbitrary git +revision with @git show \:\@: a path that escapes the +repository cannot be reconstructed at all. Every rule can be relaxed additively +later; none can be tightened without breaking users. + +Returns 'Left' with a human-readable reason, or 'Right' the normalized path. +-} +normalizeMemberPath :: Text -> Either Text FilePath +normalizeMemberPath raw + | T.null raw = Left "member path is empty" + | T.isPrefixOf "/" raw = Left ("member path must be relative, not absolute: '" <> raw <> "'") + | ".." `elem` segments = Left ("member path must not contain '..' segments: '" <> raw <> "'") + | null kept = Left ("member path is empty after normalization: '" <> raw <> "'") + | not (T.isSuffixOf ".keiro" normalized) = + Left ("member path must name a .keiro spec: '" <> raw <> "'") + | normalized == ".keiro" = Left ("member path must name a .keiro spec: '" <> raw <> "'") + | otherwise = Right (T.unpack normalized) + where + segments = T.splitOn "/" raw + kept = [s | s <- segments, not (T.null s), s /= "."] + normalized = T.intercalate "/" kept + +-------------------------------------------------------------------------------- +-- Parser +-------------------------------------------------------------------------------- + +type WP = Parsec Void Text + +{- | Parse a workspace manifest. The 'FilePath' is used only as the source name +in diagnostics (megaparsec's line reporting); it need not exist on disk. + +Duplicate clauses, a missing or misplaced @service@ clause, an empty member +list, an invalid member path, and duplicate members (including two paths equal +under Unicode case folding — macOS's default filesystem is case-insensitive, so +two such paths can silently be one file) are all rejected here, at the manifest +boundary, with the manifest path and line. +-} +parseWorkspaceManifest :: FilePath -> Text -> Either ParseError WorkspaceManifest +parseWorkspaceManifest src input = + case runParser (sc *> pManifest <* eof) src input of + Left bundle -> Left (T.pack (errorBundlePretty bundle)) + Right manifest -> Right manifest + +-- | One source clause, tagged with the offset used to position its diagnostics. +data Clause + = ClService !Int !Loc !Text + | ClModule !Int !Loc !Text + | ClLayout !Int !Loc !Placement + | ClSpec !Int !Loc !Text + +clauseOffset :: Clause -> Int +clauseOffset (ClService o _ _) = o +clauseOffset (ClModule o _ _) = o +clauseOffset (ClLayout o _ _) = o +clauseOffset (ClSpec o _ _) = o + +-- | Space consumer: spaces, newlines, and @#@ line comments are all whitespace. +sc :: WP () +sc = L.space space1 (L.skipLineComment "#") empty + +lexeme :: WP a -> WP a +lexeme = L.lexeme sc + +-- | A literal keyword not followed by an identifier character. +keyword :: Text -> WP () +keyword word = lexeme (try (chunk word *> notFollowedBy (satisfy pathChar))) + +getLoc :: WP Loc +getLoc = (Loc . unPos . sourceLine) <$> getSourcePos + +pManifest :: WP WorkspaceManifest +pManifest = do + startOffset <- getOffset + clauses <- many pClause + buildManifest startOffset clauses + +pClause :: WP Clause +pClause = + choice + [ mk ClService "service" pServiceName + , mk ClModule "module" pModulePrefix + , mk ClLayout "layout" pPlacement + , mk ClSpec "spec" pPathToken + ] + where + mk construct word value = try $ do + offset <- getOffset + loc <- getLoc + keyword word + construct offset loc <$> value + +{- | The workspace identity uses the member grammar's wire-word spelling: an +ASCII letter or digit, then letters, digits, @_@, and @-@ (e.g. @mori-project@). +-} +pServiceName :: WP Text +pServiceName = lexeme $ do + c <- satisfy asciiAlphaNum "workspace service name" + cs <- many (satisfy (\x -> asciiAlphaNum x || x == '_' || x == '-')) + pure (T.pack (c : cs)) + +{- | A dotted module prefix: one-or-more PascalCase segments joined by dots, +matching the member grammar's @module@ clause (e.g. @Demo.Modules.Project@). +-} +pModulePrefix :: WP Text +pModulePrefix = lexeme $ do + seg0 <- pSeg + segs <- many (char '.' *> pSeg) + pure (T.intercalate "." (seg0 : segs)) + where + pSeg = do + c <- satisfy (\x -> x >= 'A' && x <= 'Z') "PascalCase module segment" + cs <- many (satisfy (\x -> asciiAlphaNum x || x == '_')) + pure (T.pack (c : cs)) + +pPlacement :: WP Placement +pPlacement = + choice + [ GeneratedPrefix <$ keyword "prefixed" + , CollocatedLeaf <$ keyword "collocated" + ] + "'prefixed' or 'collocated'" + +-- | A relative path token: no spaces, no drive letters, no quoting. +pPathToken :: WP Text +pPathToken = lexeme (T.pack <$> some (satisfy pathChar)) "relative .keiro member path" + +pathChar :: Char -> Bool +pathChar c = asciiAlphaNum c || c == '.' || c == '_' || c == '-' || c == '/' + +asciiAlphaNum :: Char -> Bool +asciiAlphaNum c = isAscii c && (isLetter c || isDigit c) + +{- | Fold the parsed clauses into a manifest, rejecting every structural error +at the offending clause's own source position. +-} +buildManifest :: Int -> [Clause] -> WP WorkspaceManifest +buildManifest startOffset clauses = do + case clauses of + [] -> failAt startOffset "workspace manifest must begin with a 'service ' clause" + leading : _ -> case leading of + ClService{} -> pure () + other -> failAt (clauseOffset other) "the first clause of a workspace manifest must be 'service '" + (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" + (moduleRoot, moduleLoc) <- case [(root, loc) | ClModule _ loc root <- clauses] of + [] -> pure (Nothing, Loc 0) + [(root, loc)] -> pure (Just root, loc) + _ -> failAt (secondOffset [c | c@ClModule{} <- clauses]) "duplicate 'module' clause" + (layout, layoutLoc) <- case [(placement, loc) | ClLayout _ loc placement <- clauses] of + [] -> pure (Nothing, Loc 0) + [(placement, loc)] -> pure (Just placement, loc) + _ -> failAt (secondOffset [c | c@ClLayout{} <- clauses]) "duplicate 'layout' clause" + let specClauses = [(offset, loc, raw) | ClSpec offset loc raw <- clauses] + normalized <- traverse normalizeOne specClauses + case normalized of + [] -> failAt startOffset "workspace manifest must list at least one 'spec .keiro' member" + _ -> pure () + rejectDuplicates normalized + let sorted = sortOn (T.pack . snd3) normalized + pure + WorkspaceManifest + { wmfService = service + , wmfServiceLoc = serviceLoc + , wmfModuleRoot = moduleRoot + , wmfModuleRootLoc = moduleLoc + , wmfLayout = layout + , wmfLayoutLoc = layoutLoc + , wmfMembers = NE.fromList [WorkspaceMemberRef path loc | (_, path, loc) <- sorted] + } + where + snd3 (_, path, _) = path + normalizeOne (offset, loc, raw) = case normalizeMemberPath raw of + Left reason -> failAt offset (T.unpack reason) + Right path -> pure (offset, path, loc) + secondOffset cs = case cs of + _ : second : _ -> clauseOffset second + _ -> startOffset + +{- | Refuse a member listed twice, and a member listed under two spellings that +case-fold to the same path. Detecting a source file assigned to /two different/ +workspaces is deliberately out of scope here: one invocation sees one manifest, +and repository-wide manifest discovery is exactly the dynamic discovery this +design excludes. +-} +rejectDuplicates :: [(Int, FilePath, Loc)] -> WP () +rejectDuplicates entries = go [] entries + where + go _ [] = pure () + go seen ((offset, path, _) : rest) + | path `elem` map fst seen = + failAt offset ("duplicate workspace member '" <> path <> "': membership is a set") + | Just earlier <- lookup (T.toCaseFold (T.pack path)) (map swap seen) = + failAt + offset + ( "workspace members '" + <> earlier + <> "' and '" + <> path + <> "' differ only by case; on a case-insensitive filesystem they are one file" + ) + | otherwise = go ((path, T.toCaseFold (T.pack path)) : seen) rest + swap (path, folded) = (folded, path) + +-- | Fail with a plain message positioned at a specific source offset. +failAt :: Int -> String -> WP a +failAt offset message = setOffset offset >> fail message + +-------------------------------------------------------------------------------- +-- Renderer +-------------------------------------------------------------------------------- + +{- | Render a manifest in canonical form: @service@, then the optional @module@ +and @layout@ clauses, then the members in codepoint order, one per line, with +no trailing newline (comments are not preserved, exactly like the member +pretty-printer). @parse . render@ is the identity on the AST and +@render . parse . render@ is the identity on bytes. +-} +renderWorkspaceManifest :: WorkspaceManifest -> Text +renderWorkspaceManifest manifest = + T.intercalate "\n" $ + ["service " <> wmfService manifest] + ++ maybe [] (\root -> ["module " <> root]) (wmfModuleRoot manifest) + ++ maybe [] (\placement -> ["layout " <> renderPlacement placement]) (wmfLayout manifest) + ++ [ "spec " <> T.pack (wmrPath member) + | member <- sortOn (T.pack . wmrPath) (NE.toList (wmfMembers manifest)) + ] + +renderPlacement :: Placement -> Text +renderPlacement GeneratedPrefix = "prefixed" +renderPlacement CollocatedLeaf = "collocated" + +-------------------------------------------------------------------------------- +-- Generic line relocation +-------------------------------------------------------------------------------- + +{- | Everything in the AST that carries source lines. The generic default walks +a value's 'Generic' representation and applies the function at every 'Loc' +field, however deeply nested. + +The instance list below covers every type in "Keiro.Dsl.Grammar". Completeness +is compiler-enforced rather than reviewed by eye: the generic default demands a +'HasLocs' instance for each field type, so a new AST type is a build error here +until it is listed, and no 'Loc' can be silently missed. +-} +class HasLocs a where + traverseLocs :: (Applicative f) => (Loc -> f Loc) -> a -> f a + default traverseLocs :: (Generic a, GHasLocs (Rep a), Applicative f) => (Loc -> f Loc) -> a -> f a + traverseLocs f = fmap to . gtraverseLocs f . from + +class GHasLocs rep where + gtraverseLocs :: (Applicative f) => (Loc -> f Loc) -> rep p -> f (rep p) + +instance GHasLocs V1 where + gtraverseLocs _ = pure + +instance GHasLocs U1 where + gtraverseLocs _ = pure + +instance (GHasLocs a, GHasLocs b) => GHasLocs (a :*: b) where + gtraverseLocs f (a :*: b) = (:*:) <$> gtraverseLocs f a <*> gtraverseLocs f b + +instance (GHasLocs a, GHasLocs b) => GHasLocs (a :+: b) where + gtraverseLocs f (L1 a) = L1 <$> gtraverseLocs f a + gtraverseLocs f (R1 b) = R1 <$> gtraverseLocs f b + +instance (GHasLocs a) => GHasLocs (M1 i c a) where + gtraverseLocs f (M1 a) = M1 <$> gtraverseLocs f a + +instance (HasLocs c) => GHasLocs (K1 i c) where + gtraverseLocs f (K1 c) = K1 <$> traverseLocs f c + +-- The one interesting instance: this is where the function actually fires. +instance HasLocs Loc where + traverseLocs f = f + +-- Leaf types that carry no location. +instance HasLocs Int where + traverseLocs _ = pure + +instance HasLocs Integer where + traverseLocs _ = pure + +instance HasLocs Double where + traverseLocs _ = pure + +instance HasLocs Bool where + traverseLocs _ = pure + +instance HasLocs Char where + traverseLocs _ = pure + +instance HasLocs Text where + traverseLocs _ = pure + +instance (HasLocs a) => HasLocs [a] where + traverseLocs f = traverse (traverseLocs f) + +instance (HasLocs a) => HasLocs (Maybe a) where + traverseLocs f = traverse (traverseLocs f) + +instance (HasLocs a, HasLocs b) => HasLocs (a, b) where + traverseLocs f (a, b) = (,) <$> traverseLocs f a <*> traverseLocs f b + +instance (HasLocs a, HasLocs b) => HasLocs (Either a b) where + traverseLocs f (Left a) = Left <$> traverseLocs f a + traverseLocs f (Right b) = Right <$> traverseLocs f b + +{- | Rewrite every source line in a spec. This is a compiler line map, not +textual inclusion: only line numbers move, and 'Keiro.Dsl.Grammar.Loc''s 'Eq' +instance deliberately ignores the line, so relocation cannot change any +equality-based behavior. +-} +relocateLocs :: (Int -> Int) -> Spec -> Spec +relocateLocs shift = runIdentity . traverseLocs (Identity . Loc . shift . unLoc) + +{- | Every source line the spec's AST carries, in traversal order. Exists so a +test can prove 'relocateLocs' misses nothing: relocate by a known offset and +assert the collected multiset shifted exactly. +-} +collectLocs :: Spec -> [Int] +collectLocs = getConst . traverseLocs (\l -> Const [unLoc l]) + +-------------------------------------------------------------------------------- +-- Multi-file diagnostics +-------------------------------------------------------------------------------- + +{- | Which file a workspace diagnostic points at. Member paths are stored +manifest-relative — the canonical identity a scaffold record or diff report can +key on — and joined with the manifest's directory only at render time. +-} +data WorkspaceFile + = -- | The manifest itself. + WorkspaceManifestFile + | -- | A member, by its normalized manifest-relative path. + WorkspaceMemberFile !FilePath + deriving stock (Eq, Ord, Show) + +{- | One cited source position. 'wlRole' explains why a /secondary/ position is +relevant ("also declared here", "member declares context 'kotei'"); it is +unused for the primary position, which carries the diagnostic's own message. +-} +data WorkspaceLocation = WorkspaceLocation + { wlFile :: !WorkspaceFile + , wlLine :: !Int + , wlRole :: !Text + } + deriving stock (Eq, Show) + +{- | A diagnostic that can cite several files at once — the whole point of +whole-service checking. The first location is primary; the rest render as +indented notes. The code comes from the same append-only registry as +single-spec diagnostics ("Keiro.Dsl.Validate"), so every gate stays +correlatable by code. +-} +data WorkspaceDiagnostic = WorkspaceDiagnostic + { wdLocations :: !(NonEmpty WorkspaceLocation) + , wdSeverity :: !Severity + , wdCode :: !DiagnosticCode + , wdMessage :: !Text + } + deriving stock (Eq, Show) + +{- | Why a workspace could not be produced. The three constructors are the +three stages at which loading can stop: the manifest could not be read, it +could not be parsed, or the members were read but the service refused to +compose. +-} +data WorkspaceFailure + = WorkspaceManifestUnreadable !Text + | WorkspaceManifestUnparseable !ParseError + | WorkspaceRefused !(NonEmpty WorkspaceDiagnostic) + deriving stock (Eq, Show) + +{- | The clickable path for a cited file: the manifest as the user typed it, or +the manifest's directory joined with the member's relative path. +-} +workspaceDisplayPath :: FilePath -> WorkspaceFile -> FilePath +workspaceDisplayPath manifestPath = \case + WorkspaceManifestFile -> manifestPath + WorkspaceMemberFile relative -> + let dir = takeDirectory manifestPath + in if dir == "." then relative else dir relative + +{- | Render one diagnostic. The primary location keeps the established +single-file shape so existing consumers and greps keep working; each additional +location follows on an indented continuation line. + +@ +…/domain/shared.keiro:3: error[WorkspaceDuplicateDeclaration]: duplicate declaration 'ProjectId' … + …/domain/project.keiro:4: note: also declared here +@ +-} +renderWorkspaceDiagnostic :: FilePath -> WorkspaceDiagnostic -> Text +renderWorkspaceDiagnostic manifestPath diagnostic = + T.intercalate "\n" (primary : notes) + where + primaryLocation :| secondary = wdLocations diagnostic + primary = + renderAt primaryLocation + <> ": " + <> severityWord + <> "[" + <> T.pack (show (wdCode diagnostic)) + <> "]: " + <> wdMessage diagnostic + notes = [" " <> renderAt location <> ": note: " <> wlRole location | location <- secondary] + renderAt location = + T.pack (workspaceDisplayPath manifestPath (wlFile location)) + <> ":" + <> T.pack (show (wlLine location)) + severityWord = case wdSeverity diagnostic of Error -> "error"; Warning -> "warning" + +-- | Render a whole failure as the lines a command should print to stderr. +renderWorkspaceFailure :: FilePath -> WorkspaceFailure -> [Text] +renderWorkspaceFailure manifestPath = \case + WorkspaceManifestUnreadable reason -> + ["cannot read workspace manifest " <> T.pack manifestPath <> ": " <> reason] + WorkspaceManifestUnparseable err -> [err] + WorkspaceRefused diagnostics -> + map (renderWorkspaceDiagnostic manifestPath) (NE.toList diagnostics) + +-------------------------------------------------------------------------------- +-- The composed graph +-------------------------------------------------------------------------------- + +{- | Maps a merged-spec line back to the member that owns it. Each entry is +@(exclusiveLow, inclusiveHigh, memberPath)@: merged line @n@ belongs to the +entry with @low < n <= high@, and the member's own line is @n - low@. +-} +newtype LineMap = LineMap {lmRanges :: [(Int, Int, FilePath)]} + deriving stock (Eq, Show) + +{- | Where each shared declaration and each node was defined. Keys are +@(namespace, name)@ — namespaces are @id@, @enum@, @rule@, @mapped@ for +declarations and the node kind ("aggregate", "readmodel", …) for nodes, the +same keying the single-spec duplicate-node rule uses. Values are the owning +member's manifest-relative path and its /original/ (unrelocated) location. +-} +data OwnershipIndex = OwnershipIndex + { oiDeclarations :: !(Map (Text, Name) (FilePath, Loc)) + , oiNodes :: !(Map (Text, Name) (FilePath, Loc)) + } + deriving stock (Eq, Show) + +-- | Which member owns a shared declaration, e.g. @declarationOwner index "id" "ProjectId"@. +declarationOwner :: OwnershipIndex -> Text -> Name -> Maybe (FilePath, Loc) +declarationOwner index namespace name = Map.lookup (namespace, name) (oiDeclarations index) + +-- | Which member owns a node, e.g. @nodeOwner index "aggregate" "Project"@. +nodeOwner :: OwnershipIndex -> Text -> Name -> Maybe (FilePath, Loc) +nodeOwner index kind name = Map.lookup (kind, name) (oiNodes index) + +-- | One member of a composed workspace. +data WorkspaceMember = WorkspaceMember + { wmPath :: !FilePath + -- ^ Normalized, manifest-relative. + , wmSpec :: !Spec + -- ^ Exactly as parsed: line numbers are the member's own. + , wmLineBase :: !Int + -- ^ Added to this member's lines to place them in the merged spec. + , wmLineCount :: !Int + -- ^ Source lines in the member file. + } + deriving stock (Eq, Show) + +{- | A whole service, composed from its members and ready to be checked, +scaffolded, or diffed as one contract. + +'wsMergedSpec' is the load-bearing field: it is a single 'Spec' holding every +member's declarations and nodes in canonical member order, with line numbers +relocated into disjoint ranges. Because it is an ordinary 'Spec', the existing +whole-spec validation, type-graph resolution, coverage, and binding analysis +run over it unchanged — cross-file references resolve by name exactly as if the +members had been one file, with no risk of a node-specific rule diverging +between the single-file and workspace paths. +-} +data WorkspaceSpec = WorkspaceSpec + { wsService :: !Text + -- ^ The stable workspace identity (the manifest's @service@ name). + , wsManifestPath :: !FilePath + , wsContext :: !Name + -- ^ The members' unanimous @context@. + , wsModuleRoot :: !(Maybe Text) + , wsLayout :: !(Maybe Placement) + , wsMembers :: ![WorkspaceMember] + -- ^ Canonical order. + , wsMergedSpec :: !Spec + , wsLineMap :: !LineMap + , wsOwnership :: !OwnershipIndex + } + deriving stock (Eq, Show) + +{- | Resolve a merged-spec line to @(member path, that member's own line)@. +'Nothing' means the line belongs to no member — render it against the manifest. +-} +resolveWorkspaceLine :: WorkspaceSpec -> Int -> Maybe (FilePath, Int) +resolveWorkspaceLine workspace n + | n <= 0 = Nothing + | otherwise = + listToMaybe + [ (path, n - low) + | (low, high, path) <- lmRanges (wsLineMap workspace) + , n > low + , n <= high + ] + +{- | A single @.keiro@ file as a one-member workspace. The identity is the +file's base name, the merged spec is the spec itself, and the line map is the +identity, so @checkWorkspace (oneMemberWorkspace fp spec)@ yields exactly +@validateSpec spec@ attributed to @fp@. Downstream plans use this as the +uniform input type for single-file inputs. +-} +oneMemberWorkspace :: FilePath -> Spec -> WorkspaceSpec +oneMemberWorkspace path spec = + WorkspaceSpec + { wsService = T.pack (takeBaseName path) + , wsManifestPath = path + , wsContext = specContext spec + , wsModuleRoot = specModuleRoot spec + , wsLayout = specLayout spec + , wsMembers = + [ WorkspaceMember + { wmPath = relative + , wmSpec = spec + , wmLineBase = 0 + , wmLineCount = maximum (0 : collectLocs spec) + } + ] + , wsMergedSpec = spec + , wsLineMap = LineMap [(0, maxBound, relative)] + , wsOwnership = ownershipOf [(relative, spec)] + } + where + relative = takeFileName path + +{- | Validate a composed workspace. This runs the /existing/ whole-spec +validator over the merged spec once and maps each diagnostic's line back +through the line map, so the workspace and single-file paths can never diverge +on what counts as valid. +-} +checkWorkspace :: WorkspaceSpec -> [WorkspaceDiagnostic] +checkWorkspace workspace = + [ WorkspaceDiagnostic + { wdLocations = pure (locationFor (line diagnostic)) + , wdSeverity = severity diagnostic + , wdCode = code diagnostic + , wdMessage = message diagnostic + } + | diagnostic <- validateSpec (wsMergedSpec workspace) + ] + where + locationFor n = case resolveWorkspaceLine workspace n of + Just (path, original) -> WorkspaceLocation (WorkspaceMemberFile path) original "" + -- A line owned by no member (the placeholder location 'Loc 0') is the + -- workspace's own; point at the manifest rather than invent a member. + Nothing -> WorkspaceLocation WorkspaceManifestFile (max 1 n) "" + +-------------------------------------------------------------------------------- +-- Composition +-------------------------------------------------------------------------------- + +{- | Compose parsed members into one service graph, or refuse with every +relevant file and line cited. + +The third argument supplies one entry per manifest member as +@(normalized manifest-relative path, source text, parsed spec)@. The source +text is needed for two things the AST cannot provide: counting lines for the +line map, and locating the @context@\/@module@\/@layout@ clause lines that +'Keiro.Dsl.Grammar.Spec' does not record, so a refusal can point at the clause +an author actually wrote. The scan is used for diagnostics only, never for +semantics. + +Composition proceeds in a fixed order, and every stage's refusals are collected +before any is reported — a workspace with two problems reports both. The stages +are: the members' @context@ must be unanimous; the manifest is the +@module@\/@layout@ authority and members must be absent-or-exactly-equal; every +shared declaration has exactly one owning member (identical duplicates are +refused, they never silently merge); every node identity has exactly one owning +member; and no two members may claim generated module paths that collide under +case folding. +-} +composeWorkspace :: + FilePath -> + WorkspaceManifest -> + [(FilePath, Text, Spec)] -> + Either (NonEmpty WorkspaceDiagnostic) WorkspaceSpec +composeWorkspace manifestPath manifest supplied + | (d : ds) <- unsupplied = Left (d :| ds) + | (d : ds) <- refusals = Left (d :| ds) + | otherwise = Right composed + where + ordered = + [ (ref, lookup (wmrPath ref) [(path, (text, spec)) | (path, text, spec) <- supplied]) + | ref <- NE.toList (wmfMembers manifest) + ] + unsupplied = + [ WorkspaceDiagnostic + { wdLocations = pure (manifestLocation (wmrLoc ref) "") + , wdSeverity = Error + , wdCode = WorkspaceMemberUnreadable + , wdMessage = "workspace member '" <> T.pack (wmrPath ref) <> "' was not supplied to the composer" + } + | (ref, Nothing) <- ordered + ] + entries = [(ref, text, spec) | (ref, Just (text, spec)) <- ordered] + + refusals = + contextRefusals + <> moduleRefusals + <> layoutRefusals + <> declarationRefusals + <> nodeRefusals + <> collisionRefusals + + -------------------------------------------------------------------------- + -- Effective context + -------------------------------------------------------------------------- + declaredContexts = nub [specContext spec | (_, _, spec) <- entries] + effectiveContext = case entries of + (_, _, spec) : _ -> specContext spec + [] -> "" + contextRefusals + | length declaredContexts <= 1 = [] + | otherwise = + [ WorkspaceDiagnostic + { wdLocations = + NE.fromList + [ memberLocation ref (clauseLine "context" text) ("member declares context '" <> specContext spec <> "'") + | (ref, text, spec) <- entries + ] + , wdSeverity = Error + , wdCode = WorkspaceContextMismatch + , wdMessage = + "workspace '" + <> wmfService manifest + <> "' members declare different contexts (" + <> T.intercalate ", " (sort declaredContexts) + <> "); every member of one workspace must declare the same context" + } + ] + + -------------------------------------------------------------------------- + -- Effective module root and layout + -------------------------------------------------------------------------- + (effectiveModuleRoot, moduleRefusals) = + resolveAuthority "module" id (wmfModuleRoot manifest) (wmfModuleRootLoc manifest) specModuleRoot + (effectiveLayout, layoutRefusals) = + resolveAuthority "layout" renderPlacement (wmfLayout manifest) (wmfLayoutLoc manifest) specLayout + + -- The absent-or-exactly-equal authority rule, shared by @module@ and + -- @layout@. When the manifest declares the clause it is the authority and + -- every member's clause must be absent or identical — never silently + -- overridden. When the manifest is silent, the members that declare the + -- clause must agree unanimously, and that value becomes effective. Both + -- halves exist so adoption needs no member edits: a fleet whose members + -- carry no clauses can put the authority wholly in the manifest, and a file + -- that already declares one can keep it when it becomes a member. + resolveAuthority :: + (Eq a) => + Text -> + (a -> Text) -> + Maybe a -> + Loc -> + (Spec -> Maybe a) -> + (Maybe a, [WorkspaceDiagnostic]) + resolveAuthority clauseKeyword renderValue manifestValue manifestLoc memberValue = + case manifestValue of + Just authority -> + ( Just authority + , [ WorkspaceDiagnostic + { wdLocations = + manifestLocation manifestLoc "" + :| [ memberLocation ref (clauseLine clauseKeyword text) ("member declares " <> clauseKeyword <> " " <> renderValue value) + | (ref, text, value) <- disagreeing + ] + , wdSeverity = Error + , wdCode = WorkspaceAuthorityConflict + , wdMessage = + "workspace manifest declares " + <> clauseKeyword + <> " " + <> renderValue authority + <> ", so every member's " + <> clauseKeyword + <> " clause must be absent or exactly equal" + } + | not (null disagreeing) + ] + ) + where + disagreeing = + [ (ref, text, value) + | (ref, text, spec) <- entries + , Just value <- [memberValue spec] + , value /= authority + ] + Nothing + | length (nub (map thd declared)) <= 1 -> (listToMaybe (map thd declared), []) + | otherwise -> + ( Nothing + , + [ WorkspaceDiagnostic + { wdLocations = + NE.fromList + [ memberLocation ref (clauseLine clauseKeyword text) ("member declares " <> clauseKeyword <> " " <> renderValue value) + | (ref, text, value) <- declared + ] + , wdSeverity = Error + , wdCode = WorkspaceAuthorityConflict + , wdMessage = + "the workspace manifest declares no " + <> clauseKeyword + <> " clause, so the members that declare one must agree; they do not" + } + ] + ) + where + declared = [(ref, text, value) | (ref, text, spec) <- entries, Just value <- [memberValue spec]] + where + thd (_, _, value) = value + + -------------------------------------------------------------------------- + -- Single-owner declarations and nodes + -------------------------------------------------------------------------- + declarationSites = + [ (name, (namespace, ref, loc)) + | (ref, _, spec) <- entries + , (namespace, name, loc) <- sharedDeclarations spec + ] + declarationRefusals = + [ WorkspaceDiagnostic + { wdLocations = + NE.fromList + [ memberLocation ref (Just (unLoc loc)) ("also declared here, as " <> namespace <> " '" <> name <> "'") + | (namespace, ref, loc) <- sites + ] + , wdSeverity = Error + , wdCode = WorkspaceDuplicateDeclaration + , wdMessage = + "duplicate declaration '" + <> name + <> "': a shared declaration has exactly one owning member (identical duplicates do not merge)" + } + | (name, sites) <- groupSites declarationSites + , length (nub [wmrPath ref | (_, ref, _) <- sites]) > 1 + ] + + nodeSites = + [ ((kind, name), (ref, loc)) + | (ref, _, spec) <- entries + , node <- specNodes spec + , let (kind, name, loc) = nodeIdentity node + ] + nodeRefusals = + [ WorkspaceDiagnostic + { wdLocations = + NE.fromList + [ memberLocation ref (Just (unLoc loc)) ("also defined here") + | (ref, loc) <- sites + ] + , wdSeverity = Error + , wdCode = WorkspaceDuplicateNodeName + , wdMessage = + "duplicate " + <> kind + <> " node name '" + <> name + <> "': a node has exactly one owning member" + } + | ((kind, name), sites) <- groupSites nodeSites + , length (nub [wmrPath ref | (ref, _) <- sites]) > 1 + ] + + -------------------------------------------------------------------------- + -- Merged spec and line map + -------------------------------------------------------------------------- + lineCounts = [max 1 (length (T.lines text)) | (_, text, _) <- entries] + lineBases = scanl (+) 0 lineCounts + members = + [ WorkspaceMember + { wmPath = wmrPath ref + , wmSpec = spec + , wmLineBase = base + , wmLineCount = memberLines + } + | ((ref, _, spec), base, memberLines) <- zip3 entries lineBases lineCounts + ] + relocatedSpecs = [relocateLocs (shiftBy (wmLineBase member)) (wmSpec member) | member <- members] + -- The placeholder location 'Loc 0' must stay 0: shifting it would land it + -- inside the previous member's range and mis-attribute the diagnostic. + shiftBy base n = if n <= 0 then n else n + base + lineMap = + LineMap + [ (wmLineBase member, wmLineBase member + wmLineCount member, wmPath member) + | member <- members + ] + mergedSpec = + Spec + { specContext = effectiveContext + , specModuleRoot = effectiveModuleRoot + , specLayout = effectiveLayout + , specIds = concatMap specIds relocatedSpecs + , specEnums = concatMap specEnums relocatedSpecs + , specRules = concatMap specRules relocatedSpecs + , specMapped = concatMap specMapped relocatedSpecs + , specNodes = concatMap specNodes relocatedSpecs + } + + -------------------------------------------------------------------------- + -- Cross-member generated-path collisions + -------------------------------------------------------------------------- + plannerContext = + Context + { contextName = effectiveContext + , moduleRoot = fromMaybe "" effectiveModuleRoot + , placement = fromMaybe GeneratedPrefix effectiveLayout + } + collisionRefusals + -- The effective context/module/layout are only meaningful once the + -- earlier stages agree; without them there is no honest planner input. + | not (null contextRefusals && null moduleRefusals && null layoutRefusals) = [] + -- Only ask the scaffold planner about a spec that already validates. + -- An invalid merged spec is 'checkWorkspace''s report to make, and the + -- planner is only designed to see specs that passed validation. + | any ((== Error) . severity) (validateSpec mergedSpec) = [] + | otherwise = case planScaffoldWithGoldens [] plannerContext mergedSpec of + Right _ -> [] + Left plannerRefusals -> concatMap crossMemberCollision plannerRefusals + crossMemberCollision (PathCollision path origins) = + [ WorkspaceDiagnostic + { wdLocations = + NE.fromList + [ WorkspaceLocation (WorkspaceMemberFile owner) original ("claimed here by " <> origin) + | (origin, owner, original) <- resolved + ] + , wdSeverity = Error + , wdCode = WorkspacePathCollision + , wdMessage = + "generated module path '" + <> T.pack path + <> "' is claimed by nodes in more than one member; on a case-insensitive filesystem these are one file" + } + | length (nub [owner | (_, owner, _) <- resolved]) > 1 + ] + where + resolved = + [ (origin, owner, original) + | origin <- origins + , Just mergedLine <- [originLine origin] + , Just (owner, original) <- [lookupLine mergedLine] + ] + crossMemberCollision _ = [] + lookupLine n = + listToMaybe + [ (path, n - low) + | (low, high, path) <- lmRanges lineMap + , n > low + , n <= high + ] + + -------------------------------------------------------------------------- + -- Result + -------------------------------------------------------------------------- + composed = + WorkspaceSpec + { wsService = wmfService manifest + , wsManifestPath = manifestPath + , wsContext = effectiveContext + , wsModuleRoot = effectiveModuleRoot + , wsLayout = effectiveLayout + , wsMembers = members + , wsMergedSpec = mergedSpec + , wsLineMap = lineMap + , wsOwnership = ownershipOf [(wmPath member, wmSpec member) | member <- members] + } + + manifestLocation loc role = WorkspaceLocation WorkspaceManifestFile (max 1 (unLoc loc)) role + memberLocation ref found role = + WorkspaceLocation (WorkspaceMemberFile (wmrPath ref)) (fromMaybe 1 found) role + +-- | Group @(key, site)@ pairs by key, preserving first-appearance order. +groupSites :: (Ord k) => [(k, v)] -> [(k, [v])] +groupSites pairs = + [ (key, reverse sites) + | key <- nub (map fst pairs) + , Just sites <- [Map.lookup key grouped] + ] + where + grouped = Map.fromListWith (<>) [(key, [value]) | (key, value) <- pairs] + +-- | The four shared-declaration namespaces of one spec, with names and lines. +sharedDeclarations :: Spec -> [(Text, Name, Loc)] +sharedDeclarations spec = + [("id", idName d, idLoc d) | d <- specIds spec] + <> [("enum", enumName d, enumLoc d) | d <- specEnums spec] + <> [("rule", ruleName d, ruleLoc d) | d <- specRules spec] + <> [("mapped", mappedDeclName d, mappedDeclLoc d) | d <- specMapped spec] + +mappedDeclName :: MappedDecl -> Name +mappedDeclName MappedStructural{msName = name} = name +mappedDeclName MappedOpaque{moName = name} = name + +mappedDeclLoc :: MappedDecl -> Loc +mappedDeclLoc MappedStructural{msLoc = loc} = loc +mappedDeclLoc MappedOpaque{moLoc = loc} = loc + +-- | Build the ownership index from members carrying their original locations. +ownershipOf :: [(FilePath, Spec)] -> OwnershipIndex +ownershipOf members = + OwnershipIndex + { oiDeclarations = + Map.fromList + [ ((namespace, name), (path, loc)) + | (path, spec) <- members + , (namespace, name, loc) <- sharedDeclarations spec + ] + , oiNodes = + Map.fromList + [ ((kind, name), (path, loc)) + | (path, spec) <- members + , node <- specNodes spec + , let (kind, name, loc) = nodeIdentity node + ] + } + +{- | The line of the first non-comment source line whose first word is the +given clause keyword. Used only to point a refusal at the @context@, +@module@, or @layout@ clause an author wrote, because 'Spec' records no +location for them. +-} +clauseLine :: Text -> Text -> Maybe Int +clauseLine clauseKeyword source = + listToMaybe + [ index + | (index, raw) <- zip [1 ..] (T.lines source) + , (leading : _) <- [T.words (T.takeWhile (/= '#') raw)] + , leading == clauseKeyword + ] + +{- | The merged-spec line embedded in a scaffold module's origin string, which +"Keiro.Dsl.Scaffold" formats as @\ \ (line N)@. Context-level +modules carry no line and yield 'Nothing', which is correct: they belong to the +workspace, not to any one member, so they can never be a cross-member +collision. +-} +originLine :: Text -> Maybe Int +originLine origin = do + withoutClose <- T.stripSuffix ")" origin + let (before, after) = T.breakOnEnd " (line " withoutClose + if T.null before then Nothing else readMaybe (T.unpack after) + +-------------------------------------------------------------------------------- +-- Loading +-------------------------------------------------------------------------------- + +{- | How the loader obtains file contents. 'csRead' receives a path relative to +the workspace root (the manifest's own directory); 'Left' is a human-readable +read-failure reason. + +This seam exists so the same loader can read from the working tree now and +from @git show \:\@ blobs later, when whole-workspace @diff@ must +resolve a workspace as it existed at an older revision without re-implementing +composition. +-} +newtype ContentSource = ContentSource + { csRead :: FilePath -> IO (Either Text Text) + } + +-- | Read files from a directory on disk. +fileContentSource :: FilePath -> ContentSource +fileContentSource root = + ContentSource + { csRead = \relative -> do + let full = if root == "." then relative else root relative + exists <- doesFileExist full + if not exists + then pure (Left ("no such file: " <> T.pack full)) + else do + attempt <- Exception.try (TIO.readFile full) + pure $ case attempt of + Left readError -> Left (T.pack (show (readError :: Exception.IOException))) + Right contents -> Right contents + } + +{- | Read a manifest and all its members through a content source, then compose +them into one service graph. + +Member read and parse failures are collected, not fail-fast: a workspace with +two unreadable members reports both, which matters when a whole service is +being adopted at once. +-} +loadWorkspace :: ContentSource -> FilePath -> IO (Either WorkspaceFailure WorkspaceSpec) +loadWorkspace source manifestPath = do + manifestRead <- csRead source (takeFileName manifestPath) + case manifestRead of + Left reason -> pure (Left (WorkspaceManifestUnreadable reason)) + Right manifestText -> case parseWorkspaceManifest manifestPath manifestText of + Left err -> pure (Left (WorkspaceManifestUnparseable err)) + Right manifest -> do + results <- traverse readMember (NE.toList (wmfMembers manifest)) + case [diagnostic | Left diagnostic <- results] of + (d : ds) -> pure (Left (WorkspaceRefused (d :| ds))) + [] -> + pure + ( first + WorkspaceRefused + (composeWorkspace manifestPath manifest [entry | Right entry <- results]) + ) + where + readMember ref = do + result <- csRead source (wmrPath ref) + pure $ case result of + Left reason -> Left (memberFailure ref WorkspaceMemberUnreadable ("workspace member '" <> T.pack (wmrPath ref) <> "' could not be read: " <> reason)) + Right text -> case parseSpec (workspaceDisplayPath manifestPath (WorkspaceMemberFile (wmrPath ref))) text of + Left err -> + Left + ( memberFailure + ref + WorkspaceMemberParseFailed + ("workspace member '" <> T.pack (wmrPath ref) <> "' failed to parse:\n" <> err) + ) + Right spec -> Right (wmrPath ref, text, spec) + memberFailure ref failureCode note = + WorkspaceDiagnostic + { wdLocations = pure (WorkspaceLocation WorkspaceManifestFile (max 1 (unLoc (wmrLoc ref))) "") + , wdSeverity = Error + , wdCode = failureCode + , wdMessage = note + } + +-------------------------------------------------------------------------------- +-- 'HasLocs' coverage of the AST +-- +-- One line per type in "Keiro.Dsl.Grammar". A new AST type fails to compile +-- here until it is added, which is what makes 'relocateLocs' provably total. +-------------------------------------------------------------------------------- + +instance HasLocs AdvanceNode +instance HasLocs Aggregate +instance HasLocs Atom +instance HasLocs BackoffSpec +instance HasLocs BindRow +instance HasLocs CmpOp +instance HasLocs Command +instance HasLocs Consistency +instance HasLocs ContractEvent +instance HasLocs ContractField +instance HasLocs ContractNode +instance HasLocs ContractType +instance HasLocs CorrelateDecl +instance HasLocs DecodeSpec +instance HasLocs DerivStrategy +instance HasLocs Derivation +instance HasLocs DeriveSpec +instance HasLocs Disp +instance HasLocs DispAction +instance HasLocs DispatchDisposition +instance HasLocs DispatchNode +instance HasLocs Disposition +instance HasLocs DispositionRow +instance HasLocs EmitMapRow +instance HasLocs EmitNode +instance HasLocs EnumDecl +instance HasLocs EnvelopeBinding +instance HasLocs EnvelopeLayer +instance HasLocs Event +instance HasLocs EventBody +instance HasLocs Expr +instance HasLocs Field +instance HasLocs FieldBinding +instance HasLocs FireAtExpr +instance HasLocs FireDisposition +instance HasLocs FireNode +instance HasLocs FireOutcome +instance HasLocs HandleNode +instance HasLocs HaskellSource +instance HasLocs Hole +instance HasLocs IdDecl +instance HasLocs IdExpr +instance HasLocs IdStrategy +instance HasLocs InboxAction +instance HasLocs InkPersist +instance HasLocs InputDecl +instance HasLocs IntakeNode +instance HasLocs MappedDecl +instance HasLocs MappedShape +instance HasLocs Mapping +instance HasLocs Node +instance HasLocs OnMissing +instance HasLocs OperationNode +instance HasLocs OperationShape +instance HasLocs PgmqDispatchNode +instance HasLocs Placement +instance HasLocs PolicyChoice +instance HasLocs Presence +instance HasLocs ProcessNode +instance HasLocs ProjectionSpec +instance HasLocs PublisherNode +instance HasLocs ReadModelNode +instance HasLocs RegDecl +instance HasLocs RegInitial +instance HasLocs ResolveDecl +instance HasLocs ResolveSource +instance HasLocs RmColumn +instance HasLocs RmFeed +instance HasLocs RmScope +instance HasLocs RouterDispatchNode +instance HasLocs RouterNode +instance HasLocs RuleDecl +instance HasLocs SagaRef +instance HasLocs SnapPolicy +instance HasLocs SnapshotSpec +instance HasLocs Spec +instance HasLocs StateDecl +instance HasLocs TimerNode +instance HasLocs Transition +instance HasLocs TransitionMode +instance HasLocs TypeExpr +instance HasLocs UnionEncoding +instance HasLocs UnknownFields +instance HasLocs WfBodyItem +instance HasLocs WireArm +instance HasLocs WireEnum +instance HasLocs WireField +instance HasLocs WireSource +instance HasLocs WireSpec +instance HasLocs WorkflowNode +instance HasLocs WorkqueueNode +instance HasLocs WqDispRow +instance HasLocs WqField +instance HasLocs WqGroupKey +instance HasLocs WqOrdering +instance HasLocs WqProvision diff --git a/src/Keiro/Dsl/WorkspaceAdoption.hs b/src/Keiro/Dsl/WorkspaceAdoption.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/WorkspaceAdoption.hs @@ -0,0 +1,268 @@ +{- | Adopting pre-workspace scaffold output into workspace history. + +The first whole-workspace scaffold into an output directory that already holds +per-context scaffold output has to answer one question honestly: /which of these +files are mine?/ Guessing in either direction is harmful. Claiming everything +would take ownership of hand-written code and then overwrite it on the next run. +Claiming nothing would report the entire existing tree as unrelated and leave a +human to reconcile it by hand. + +So adoption claims only what is __attributable__: + + * @record@ evidence — the file is listed in a legacy per-context scaffold + record for this workspace's effective context, and the workspace still + produces it. + + * @banner@ evidence — the file sits at a path this workspace produces as + Generated and carries the @-- \@generated@ banner, but no surviving record + lists it. This is the orphan case IR-2 describes: two same-context specs + scaffolded into one directory, the second overwriting the first's record, so + the first spec's files lost their only attribution. + +Everything else is reported and left alone. Hole paths are never claimed — the +create-once rule keeps governing them. Files the plan never mentions are listed +as unclaimed. Files the legacy record lists that this workspace no longer +produces are listed as likely stale, and are deliberately __not__ merged into +the workspace record: the record states what this workspace produces and +adopted, not what an abandoned scaffold once produced. + +Nothing is deleted and nothing is renamed. The legacy record gains exactly one +appended @superseded-by:@ line, which its own v1 parser ignores, so an older +keiro-dsl binary keeps reading it unchanged. +-} +module Keiro.Dsl.WorkspaceAdoption ( + ClaimEvidence (..), + ClaimedFile (..), + MigrationReport (..), + adoptionReport, + adoptedRows, + renderMigrationReport, + markLegacyRecordSuperseded, + outputTreeFiles, +) where + +import Data.List (sort) +import Data.Maybe (isNothing) +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.Scaffold (ModuleKind (..), ScaffoldModule (..)) +import Keiro.Dsl.ScaffoldRecord (ScaffoldRecord (..), parseRecord, recordFileName) +import Keiro.Dsl.ScaffoldRun (StaleModule (..)) +import Keiro.Dsl.WorkspaceRecord (AdoptedRow (..), supersededByLine, workspaceMigrationReportFileName) +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) +import System.FilePath (()) + +-- | Why a file could be claimed. See the module header. +data ClaimEvidence = ClaimedFromRecord | ClaimedFromBanner + deriving stock (Eq, Show) + +data ClaimedFile = ClaimedFile + { cfPath :: !FilePath + , cfEvidence :: !ClaimEvidence + , cfSource :: !(Maybe Text) + -- ^ The legacy record's file name, for @record@ evidence. + , cfSpec :: !(Maybe Text) + -- ^ The legacy record's @spec:@ field, for @record@ evidence. + } + deriving stock (Eq, Show) + +{- | What one adopting run found. Printed in the scaffold output and persisted +beside the generated tree as the durable review artifact. +-} +data MigrationReport = MigrationReport + { mrService :: !Text + , mrLegacyRecord :: !(Maybe (FilePath, Text)) + -- ^ The legacy record consulted, as @(file name, its @spec:@ field)@. + , mrClaimed :: ![ClaimedFile] + , mrLikelyStale :: ![StaleModule] + , mrUnclaimed :: ![FilePath] + } + deriving stock (Eq, Show) + +{- | Compute the adoption report for an output directory, or 'Nothing' when +there is nothing to adopt or report (the ordinary case: a fresh directory, or +one this workspace already owns). + +Only the workspace's __own effective context__ is consulted. A record for a +different context belongs to a different service and is never read, reported, +or marked. +-} +adoptionReport :: FilePath -> Text -> Text -> [ScaffoldModule] -> IO (Maybe MigrationReport) +adoptionReport out context service modules = do + legacy <- readLegacyRecord (out legacyName) + present <- Set.fromList <$> outputTreeFiles out + let plannedGenerated = [modulePath m | m <- modules, kind m == Generated] + plannedAll = Set.fromList (map modulePath modules) + onDisk path = path `Set.member` present + + recordedFiles = maybe [] recFiles legacy + recordSpec = fmap recSpecPath legacy + + claimedFromRecord = + [ ClaimedFile + { cfPath = path + , cfEvidence = ClaimedFromRecord + , cfSource = Just (T.pack legacyName) + , cfSpec = recordSpec + } + | (Generated, path) <- recordedFiles + , path `Set.member` plannedAll + , onDisk path + ] + recordClaimedPaths = Set.fromList (map cfPath claimedFromRecord) + + -- A banner claim reads the file, so it is filtered before the read. + bannerCandidates <- + traverse + (\path -> (,) path <$> hasGeneratedBanner (out path)) + [ path + | path <- plannedGenerated + , onDisk path + , path `Set.notMember` recordClaimedPaths + ] + let claimedFromBanner = + [ ClaimedFile{cfPath = path, cfEvidence = ClaimedFromBanner, cfSource = Nothing, cfSpec = Nothing} + | (path, True) <- bannerCandidates + ] + claimed = claimedFromRecord <> claimedFromBanner + + likelyStale = + [ StaleModule fileKind path + | (fileKind, path) <- recordedFiles + , path `Set.notMember` plannedAll + , onDisk path + ] + staleOrGenerated = + Set.fromList (map stalePath likelyStale) <> Set.fromList plannedGenerated + + -- Everything left on disk that this run neither produces nor + -- attributes. Planned Generated paths are excluded because this run + -- writes them; saying they were "left untouched" would be false. + unclaimed = sort [path | path <- Set.toList present, path `Set.notMember` staleOrGenerated] + + report = + MigrationReport + { mrService = service + , mrLegacyRecord = (,) legacyName <$> recordSpec + , mrClaimed = claimed + , mrLikelyStale = likelyStale + , mrUnclaimed = unclaimed + } + pure $ + if null claimed && null likelyStale && null unclaimed && isNothing legacy + then Nothing + else Just report + where + legacyName = recordFileName context + +-- | The record rows an adopting run adds to the new workspace record. +adoptedRows :: MigrationReport -> [AdoptedRow] +adoptedRows report = + [ AdoptedRow + { adPath = cfPath claimed + , adEvidence = case cfEvidence claimed of + ClaimedFromRecord -> "record" + ClaimedFromBanner -> "banner" + , adSource = cfSource claimed + , adSpec = cfSpec claimed + } + | claimed <- mrClaimed report + ] + +{- | Append the supersession marker to a legacy record, once. Appending is +idempotent by inspection: a record that already carries the line is left exactly +as it is, so a re-run after an interrupted adoption cannot accumulate markers. +-} +markLegacyRecordSuperseded :: FilePath -> Text -> Text -> IO () +markLegacyRecordSuperseded out context service = do + let path = out recordFileName context + exists <- doesFileExist path + if not exists + then pure () + else do + contents <- TIO.readFile path + let marker = supersededByLine service + if marker `elem` T.lines contents + then pure () + else TIO.writeFile path (ensureNewline contents <> marker <> "\n") + where + ensureNewline contents + | T.null contents || T.isSuffixOf "\n" contents = contents + | otherwise = contents <> "\n" + +-- | Every @.hs@ file under a directory, as sorted paths relative to it. +outputTreeFiles :: FilePath -> IO [FilePath] +outputTreeFiles root = do + exists <- doesDirectoryExist root + if not exists then pure [] else sort <$> walk "" + where + walk relative = do + entries <- listDirectory (root relative) + fmap concat . traverse (visit relative) $ sort entries + visit relative entry = do + let child = if null relative then entry else relative entry + isDirectory <- doesDirectoryExist (root child) + if isDirectory + then walk child + else pure [child | ".hs" `T.isSuffixOf` T.pack child] + +readLegacyRecord :: FilePath -> IO (Maybe ScaffoldRecord) +readLegacyRecord path = do + exists <- doesFileExist path + if exists then parseRecord <$> TIO.readFile path else pure Nothing + +hasGeneratedBanner :: FilePath -> IO Bool +hasGeneratedBanner path = do + contents <- TIO.readFile path + pure (any (T.isPrefixOf "-- @generated") (T.lines contents)) + +{- | Render the report a human reviews. It is printed in the scaffold output and +written to @keiro-dsl-migration-report.workspace.\.txt@. +-} +renderMigrationReport :: MigrationReport -> [Text] +renderMigrationReport report = + [ "migration: adopting pre-workspace scaffold output into workspace " <> mrService report + ] + <> legacySection + <> claimedSection + <> staleSection + <> unclaimedSection + <> [ "note: keiro-dsl never deletes files. The legacy record was marked superseded, not removed." + , "note: the full report is kept at " <> T.pack (workspaceMigrationReportFileName (mrService report)) + ] + where + legacySection = case mrLegacyRecord report of + Nothing -> [" legacy record: (none for this context)"] + Just (name, specPath) -> [" legacy record: " <> T.pack name <> " (spec " <> specPath <> ")"] + claimedSection = case mrClaimed report of + [] -> [" claimed: nothing was attributable to this workspace"] + claimed -> + [" claimed " <> tshow (length claimed) <> " file(s) into workspace history:"] + <> [ " " <> evidenceTag (cfEvidence entry) <> " " <> T.pack (cfPath entry) + | entry <- claimed + ] + evidenceTag ClaimedFromRecord = "record" + evidenceTag ClaimedFromBanner = "banner" + staleSection = case mrLikelyStale report of + [] -> [] + stale -> + [ " likely stale: " + <> tshow (length stale) + <> " file(s) the legacy scaffold recorded that this workspace does not produce:" + ] + <> map staleLine stale + staleLine stale = case staleKind stale of + Generated -> " generated " <> T.pack (stalePath stale) <> " (safe to delete; still on disk)" + HoleStub -> " hole " <> T.pack (stalePath stale) <> " (hand-owned — review before deleting)" + unclaimedSection = case mrUnclaimed report of + [] -> [] + unclaimed -> + [ " unclaimed: " + <> tshow (length unclaimed) + <> " file(s) this workspace does not own; left untouched:" + ] + <> [" " <> T.pack path | path <- unclaimed] + tshow :: (Show a) => a -> Text + tshow = T.pack . show diff --git a/src/Keiro/Dsl/WorkspaceDiff.hs b/src/Keiro/Dsl/WorkspaceDiff.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/WorkspaceDiff.hs @@ -0,0 +1,163 @@ +{- | Whole-service evolution findings enriched with workspace source ownership. + +The ordinary differ remains the single authority for compatibility. This module +runs it over the two composed 'WorkspaceSpec' graphs and adds only source +citations. Consequently, file layout can never manufacture, suppress, or demote +a wire finding. +-} +module Keiro.Dsl.WorkspaceDiff ( + OwnedSite (..), + WorkspaceChange (..), + WorkspaceMeta (..), + WorkspaceDiffReport, + workspaceDiffReport, + diffWorkspaces, + renderWorkspaceFinding, +) where + +import Control.Applicative ((<|>)) +import Data.Char (isSpace) +import Data.List (find) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Keiro.Dsl.Diff (Change (..), ChangeKind (..), advisoryAt, consumerBuildContext, diffSpecs) +import Keiro.Dsl.DiffReport (OwnedSite (..), WorkspaceChange (..), WorkspaceDiffReport, WorkspaceMeta (..), renderFinding, workspaceDiffReport) +import Keiro.Dsl.Grammar (Loc (..), Name, Placement (..)) +import Keiro.Dsl.Validate (DiagnosticCode (..)) +import Keiro.Dsl.Workspace (OwnershipIndex (..), WorkspaceSpec (..)) + +-- | Diff two composed service graphs and cite every participant we can resolve. +diffWorkspaces :: WorkspaceSpec -> WorkspaceSpec -> [WorkspaceChange] +diffWorkspaces old new = + map annotate (diffSpecs (wsMergedSpec old) (wsMergedSpec new)) + <> ownershipMoveChanges old new + <> authorityChanges old new + where + annotate change = + WorkspaceChange + { wcChange = change + , wcDeclarationSite = + ownedSiteForName new (declarationName kind) + <|> ownedSiteForName old (declarationName kind) + , wcUseSites = + [ (path, ownedSiteForName new (pathRoot path) <|> ownedSiteForName old (pathRoot path)) + | path <- ckPaths kind + ] + } + where + kind = changeKind change + +-- | Preserve the existing headline/vector bytes and append indented citations. +renderWorkspaceFinding :: WorkspaceChange -> Text +renderWorkspaceFinding workspaceChange = + T.intercalate "\n" (renderFinding (wcChange workspaceChange) : declarationLine <> useLines) + where + declarationLine = case wcDeclarationSite workspaceChange of + Nothing -> [] + Just site -> [" declared: " <> renderOwnedSite site] + useLines = + [ " use-site: " <> path <> " (" <> renderOwnedSite site <> ")" + | (path, Just site) <- wcUseSites workspaceChange + ] + +renderOwnedSite :: OwnedSite -> Text +renderOwnedSite site = T.pack (osFile site) <> ":" <> T.pack (show (osLine site)) + +ownedSiteForName :: WorkspaceSpec -> Name -> Maybe OwnedSite +ownedSiteForName workspace name = do + (_, (file, Loc line)) <- find ((== name) . snd . fst) entries + pure (OwnedSite file line) + where + ownership = wsOwnership workspace + entries = Map.toAscList (oiDeclarations ownership) <> Map.toAscList (oiNodes ownership) + +declarationName :: ChangeKind -> Name +declarationName kind + | "mapped-" `T.isPrefixOf` ckFacet kind + , Just mapped <- mappedNameFromSubject (ckSubject kind) = + mapped + | otherwise = ckNode kind + +mappedNameFromSubject :: Text -> Maybe Name +mappedNameFromSubject subject = + case T.breakOn " : " subject of + (_, rest) + | not (T.null rest) + , let name = T.takeWhile (not . isSpace) (T.drop 3 rest) + , not (T.null name) -> + Just name + _ -> Nothing + +pathRoot :: Text -> Name +pathRoot = T.takeWhile (\c -> c /= '.' && not (isSpace c)) + +changeKind :: Change -> ChangeKind +changeKind (Additive kind) = kind +changeKind (Advisory kind) = kind +changeKind (Breaking kind) = kind + +ownershipMoveChanges :: WorkspaceSpec -> WorkspaceSpec -> [WorkspaceChange] +ownershipMoveChanges old new = + [ WorkspaceChange + { wcChange = + advisoryAt + (consumerBuildContext name []) + name + "ownership" + name + OwnershipMoved + ( "declaration moved " + <> T.pack oldFile + <> " -> " + <> T.pack newFile + <> "; source ownership changed while wire evolution remains independently classified" + ) + , wcDeclarationSite = Just (OwnedSite newFile (unLoc newLoc)) + , wcUseSites = [] + } + | (key@(_, name), (oldFile, _)) <- Map.toAscList (ownershipEntries (wsOwnership old)) + , Just (newFile, newLoc) <- [Map.lookup key (ownershipEntries (wsOwnership new))] + , oldFile /= newFile + ] + +ownershipEntries :: OwnershipIndex -> Map.Map (Text, Name) (FilePath, Loc) +ownershipEntries ownership = oiDeclarations ownership <> oiNodes ownership + +authorityChanges :: WorkspaceSpec -> WorkspaceSpec -> [WorkspaceChange] +authorityChanges old new = + concat + [ changed "service-identity" (wsService old) (wsService new) serviceDetail + , changed "context" (wsContext old) (wsContext new) contextDetail + , changed "module-root" (renderModuleRoot (wsModuleRoot old)) (renderModuleRoot (wsModuleRoot new)) moduleDetail + , changed "layout" (renderLayout (wsLayout old)) (renderLayout (wsLayout new)) layoutDetail + ] + where + changed field before after detail + | before == after = [] + | otherwise = + [ WorkspaceChange + { wcChange = + advisoryAt + (consumerBuildContext (wsService new) []) + (wsService new) + "workspace-authority" + field + WorkspaceAuthorityChanged + (field <> " changed '" <> before <> "' -> '" <> after <> "'; " <> detail) + , wcDeclarationSite = Nothing + , wcUseSites = [] + } + ] + serviceDetail = "scaffold and compatibility history are re-keyed; follow the workspace adoption path" + contextDetail = "generated module namespaces change, and read-model registry/subscription identities may emit separate DerivedIdentityChanged findings" + moduleDetail = "generated module paths change without changing persisted wire identity" + layoutDetail = "generated module placement changes without changing persisted wire identity" + +renderModuleRoot :: Maybe Text -> Text +renderModuleRoot = maybe "(default)" id + +renderLayout :: Maybe Placement -> Text +renderLayout Nothing = "(default)" +renderLayout (Just GeneratedPrefix) = "prefixed" +renderLayout (Just CollocatedLeaf) = "collocated" diff --git a/src/Keiro/Dsl/WorkspaceRecord.hs b/src/Keiro/Dsl/WorkspaceRecord.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/WorkspaceRecord.hs @@ -0,0 +1,281 @@ +{- | Versioned persistence for one successful __whole-workspace__ scaffold run. + +A workspace record answers three questions a context-keyed +"Keiro.Dsl.ScaffoldRecord" cannot: which service produced this output tree, +which member files it was composed from, and __which member produced each +emitted module__. The last one is what makes moving an aggregate from one member +file to another an ownership move rather than a stale/new pair. + +__Coexistence.__ Workspace history is keyed by the service name in a distinct +file-name slot, @keiro-dsl-scaffold-record.workspace.\.txt@, and never +by context. A context name is lexed as letters, digits, @_@ and @-@ and can +never contain a dot, so this slot provably cannot collide with a legacy +context-keyed name even when a service is named after its context. Legacy +records and a workspace record may therefore share one output directory: the +workspace path never writes a context-keyed name, and an older keiro-dsl binary +is structurally incapable of parsing — and therefore of clobbering — workspace +history. The one exception is the explicit adoption step, which /appends/ a +@superseded-by:@ line to a legacy record; the v1 parser ignores unknown lines, +so old binaries still read it. + +The format is line-oriented like the v1 record, with a distinct header so no +reader can confuse the schemas: + +@ +keiro-dsl workspace scaffold record v1 +service: demo-project +manifest: service.keiro-workspace +context: demo-project +module-root: Demo.Modules.Project +layout: collocated +member domain/project.keiro +module {"kind":"generated","path":"Demo/Project/Generated/StructuralProjections.hs"} +module {"kind":"generated","path":"Demo/Project/Project/Generated/Domain.hs","owner":"domain/project.keiro"} +mapping {…} +binding {…} +adopted {"path":"…","evidence":"record","source":"keiro-dsl-scaffold-record.demo-project.txt"} +@ + +@module@ rows are canonical single-line JSON, following the precedent set for +@mapping@ rows. An /absent/ @owner@ means the module is context-level: emitted +once for the whole merged graph (the structural projection facade, the +replay-audit assembly, or a binding skeleton shared by declarations from several +members). Unknown row kinds and unknown JSON keys are ignored so a later tool +version can extend the schema; paths that are absolute or contain @..@ are +rejected rather than joined to an output root. +-} +module Keiro.Dsl.WorkspaceRecord ( + WorkspaceRecord (..), + WorkspaceModuleRow (..), + AdoptedRow (..), + renderWorkspaceRecord, + parseWorkspaceRecord, + workspaceRecordFileName, + workspaceManifestFileName, + workspaceMigrationReportFileName, + supersededByLine, +) where + +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=)) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy qualified as BL +import Data.List (nub) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as Text +import Keiro.Dsl.ExplainBindings (BindingHole (..)) +import Keiro.Dsl.MappedConsumer (MappingIdentity (..)) +import Keiro.Dsl.Scaffold (ModuleKind (..)) +import System.FilePath (isAbsolute, splitDirectories) + +{- | One emitted module: what kind it is, where it landed relative to the output +directory, and which member file produced it ('Nothing' for context-level +modules emitted once from the merged graph). +-} +data WorkspaceModuleRow = WorkspaceModuleRow + { wrmKind :: !ModuleKind + , wrmPath :: !FilePath + , wrmOwner :: !(Maybe FilePath) + } + deriving stock (Eq, Show) + +instance ToJSON WorkspaceModuleRow where + toJSON row = + object $ + [ "kind" .= (case wrmKind row of Generated -> "generated" :: Text; HoleStub -> "hole") + , "path" .= T.pack (wrmPath row) + ] + <> ["owner" .= T.pack owner | Just owner <- [wrmOwner row]] + +instance FromJSON WorkspaceModuleRow where + parseJSON = withObject "WorkspaceModuleRow" $ \fields -> do + kindLabel <- fields .: "kind" + moduleKind <- case (kindLabel :: Text) of + "generated" -> pure Generated + "hole" -> pure HoleStub + other -> fail ("unknown module kind: " <> T.unpack other) + path <- fields .: "path" + owner <- fields .:? "owner" + pure + WorkspaceModuleRow + { wrmKind = moduleKind + , wrmPath = T.unpack (path :: Text) + , wrmOwner = T.unpack <$> (owner :: Maybe Text) + } + +{- | One file imported into workspace history from pre-workspace scaffold +output. @adEvidence@ is @record@ when a legacy per-context scaffold record +listed the file, or @banner@ when the file sits at a planned Generated path and +carries the @-- \@generated@ banner but no surviving record lists it (the orphan +case created when one legacy record overwrote another). +-} +data AdoptedRow = AdoptedRow + { adPath :: !FilePath + , adEvidence :: !Text + , adSource :: !(Maybe Text) + -- ^ The legacy record's file name, when the evidence is @record@. + , adSpec :: !(Maybe Text) + -- ^ The legacy record's @spec:@ field, when available. + } + deriving stock (Eq, Show) + +instance ToJSON AdoptedRow where + toJSON row = + object $ + ["path" .= T.pack (adPath row), "evidence" .= adEvidence row] + <> ["source" .= source | Just source <- [adSource row]] + <> ["spec" .= specPath | Just specPath <- [adSpec row]] + +instance FromJSON AdoptedRow where + parseJSON = withObject "AdoptedRow" $ \fields -> do + path <- fields .: "path" + evidence <- fields .: "evidence" + source <- fields .:? "source" + specPath <- fields .:? "spec" + pure + AdoptedRow + { adPath = T.unpack (path :: Text) + , adEvidence = evidence + , adSource = source + , adSpec = specPath + } + +-- | Everything one successful whole-workspace scaffold produced. +data WorkspaceRecord = WorkspaceRecord + { wrService :: !Text + -- ^ The manifest's @service@ name: the workspace's durable identity. + , wrManifest :: !Text + {- ^ The manifest's __file name__, not a path. Members are relative to its + directory, so the directory is wherever the manifest currently sits; + recording only the name keeps the record independent of the invoking + working directory, which is what makes byte-identical output provable. + -} + , wrContext :: !Text + , wrModuleRoot :: !Text + , wrLayout :: !Text + , wrMembers :: ![FilePath] + -- ^ Canonically ordered manifest-relative member paths. + , wrModules :: ![WorkspaceModuleRow] + , wrMappings :: ![MappingIdentity] + , wrBindingObligations :: ![BindingHole] + , wrAdopted :: ![AdoptedRow] + } + deriving stock (Eq, Show) + +workspaceRecordHeader :: Text +workspaceRecordHeader = "keiro-dsl workspace scaffold record v1" + +renderWorkspaceRecord :: WorkspaceRecord -> Text +renderWorkspaceRecord record = + T.unlines $ + [ workspaceRecordHeader + , "service: " <> wrService record + , "manifest: " <> wrManifest record + , "context: " <> wrContext record + , "module-root: " <> rootLabel + , "layout: " <> wrLayout record + ] + <> ["member " <> T.pack path | path <- wrMembers record] + <> ["module " <> encodeRow row | row <- wrModules record] + <> ["mapping " <> encodeRow mapping | mapping <- wrMappings record] + <> ["binding " <> encodeRow obligation | obligation <- wrBindingObligations record] + <> ["adopted " <> encodeRow adopted | adopted <- wrAdopted record] + where + rootLabel = if T.null (wrModuleRoot record) then "(none)" else wrModuleRoot record + +encodeRow :: (ToJSON a) => a -> Text +encodeRow = Text.decodeUtf8 . BL.toStrict . Aeson.encode + +{- | Parse a workspace record. The header and the five @key: value@ fields must +each appear exactly once; unknown lines are ignored for forward compatibility; +unsafe paths are rejected rather than joined to an output root. +-} +parseWorkspaceRecord :: Text -> Maybe WorkspaceRecord +parseWorkspaceRecord contents = case T.lines contents of + header : rows + | header == workspaceRecordHeader -> do + service <- exactlyOne "service: " rows + manifest <- exactlyOne "manifest: " rows + context <- exactlyOne "context: " rows + rootLabel <- exactlyOne "module-root: " rows + layout <- exactlyOne "layout: " rows + members <- traverse safePath [path | row <- rows, Just path <- [T.stripPrefix "member " row]] + modules <- traverse (decodeRow "module ") (rowsWith "module " rows) + checkedModules <- traverse checkedModule modules + mappings <- traverse (decodeRow "mapping ") (rowsWith "mapping " rows) + obligations <- traverse (decodeRow "binding ") (rowsWith "binding " rows) + adopted <- traverse (decodeRow "adopted ") (rowsWith "adopted " rows) + checkedAdopted <- traverse checkedAdoption adopted + if hasDuplicates members + || hasDuplicates (map wrmPath checkedModules) + || hasDuplicates (map mappingSpecName mappings) + || hasDuplicates (map bindingKey obligations) + then Nothing + else + pure + WorkspaceRecord + { wrService = service + , wrManifest = manifest + , wrContext = context + , wrModuleRoot = if rootLabel == "(none)" then "" else rootLabel + , wrLayout = layout + , wrMembers = members + , wrModules = checkedModules + , wrMappings = mappings + , wrBindingObligations = obligations + , wrAdopted = checkedAdopted + } + _ -> Nothing + where + exactlyOne prefix rows = case [value | row <- rows, Just value <- [T.stripPrefix prefix row]] of + [value] -> Just value + _ -> Nothing + rowsWith prefix rows = [row | row <- rows, prefix `T.isPrefixOf` row] + decodeRow prefix row = do + payload <- T.stripPrefix prefix row + Aeson.decodeStrict' (Text.encodeUtf8 payload) + checkedModule row = do + path <- safePath (T.pack (wrmPath row)) + owner <- traverse (safePath . T.pack) (wrmOwner row) + pure row{wrmPath = path, wrmOwner = owner} + checkedAdoption row = do + path <- safePath (T.pack (adPath row)) + pure row{adPath = path} + safePath raw = + let path = T.unpack raw + in if null path || isAbsolute path || ".." `elem` splitDirectories path + then Nothing + else Just path + hasDuplicates :: (Eq a) => [a] -> Bool + hasDuplicates values = length values /= length (nub values) + bindingKey hole = + ( holeMappedName hole + , holeModule hole + , holeSymbol hole + , holeKind hole + , holePath hole + ) + +{- | @keiro-dsl-scaffold-record.workspace.\.txt@ — the workspace +history file. See the module header for why the @workspace.@ slot cannot +collide with a context-keyed name. +-} +workspaceRecordFileName :: Text -> FilePath +workspaceRecordFileName service = "keiro-dsl-scaffold-record.workspace." <> T.unpack service <> ".txt" + +-- | @keiro-dsl-manifest.workspace.\.txt@ — the Cabal build manifest. +workspaceManifestFileName :: Text -> FilePath +workspaceManifestFileName service = "keiro-dsl-manifest.workspace." <> T.unpack service <> ".txt" + +{- | @keiro-dsl-migration-report.workspace.\.txt@ — the durable review +artifact written once, on the run that adopts pre-workspace scaffold output. +-} +workspaceMigrationReportFileName :: Text -> FilePath +workspaceMigrationReportFileName service = "keiro-dsl-migration-report.workspace." <> T.unpack service <> ".txt" + +{- | The single line adoption appends to a superseded legacy record. The v1 +parser ignores unknown lines, so the legacy record keeps parsing for old +binaries and stays readable for humans; nothing is renamed or deleted. +-} +supersededByLine :: Text -> Text +supersededByLine service = "superseded-by: " <> T.pack (workspaceRecordFileName service) diff --git a/src/Keiro/Dsl/WorkspaceScaffold.hs b/src/Keiro/Dsl/WorkspaceScaffold.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Dsl/WorkspaceScaffold.hs @@ -0,0 +1,611 @@ +{- | Whole-__workspace__ scaffolding: one invocation plans and emits the +complete generated module set for every member of a service workspace. + +The module exists separately from "Keiro.Dsl.ScaffoldRun" for a structural +reason, not a stylistic one: "Keiro.Dsl.Workspace" already imports +'Keiro.Dsl.ScaffoldRun' (its cross-member collision check asks the planner), so +workspace-aware scaffolding cannot live there without a module cycle. Everything +it needs from the single-spec pipeline is imported, never re-implemented — the +refusal gates, the stale comparison, the constraint plan, the drift computation +— so a workspace and a single spec can never disagree about what is legal. + +Two properties are true __by construction__ rather than by test: + + * Emission runs once over the workspace's /merged/ 'Spec' + ('Keiro.Dsl.Workspace.wsMergedSpec'), so the context-level artifacts — the + structural projection facade and the replay-audit assembly — are emitted + exactly once from the complete graph. Concatenating per-member scaffolds + would emit them N times from N partial graphs, which is the defect this + module fixes. + + * A one-member workspace produces exactly the single-file module set, in the + same order, with identical bytes and identical metadata, because it calls + the same emitters with the same inputs. + +History is workspace-keyed ("Keiro.Dsl.WorkspaceRecord"). Each module remembers +which member produced it, so moving an aggregate between member files is an +/ownership move/ rather than a stale-plus-new pair. + +Atomicity here means what it means for a single spec: every refusal is computed +before the first output byte changes. There are no staged temp-file writes. +-} +module Keiro.Dsl.WorkspaceScaffold ( + -- * Planning + ModuleProvenance (..), + WorkspacePlan (..), + planWorkspaceScaffold, + planWorkspaceScaffoldWithGoldens, + provenanceOwner, + + -- * Golden payload roots + goldenRootDivergence, + + -- * Execution + OwnershipMove (..), + WorkspaceScaffoldReport (..), + executeWorkspaceScaffold, + renderWorkspaceScaffoldReport, +) where + +import Data.List (nub, sortOn) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Keiro.Dsl.ExplainBindings (BindingHole (..), bindingHoles) +import Keiro.Dsl.Goldens (GoldenPayload) +import Keiro.Dsl.Grammar +import Keiro.Dsl.Harness (harnessForWithGoldens, harnessProcess, harnessReadModel, harnessRouter, harnessWorkflow) +import Keiro.Dsl.Manifest (moduleNameOf, renderManifest) +import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), consumerPlan) +import Keiro.Dsl.Scaffold +import Keiro.Dsl.ScaffoldRun ( + MappingDrift (..), + Refusal (..), + StaleModule (..), + WriteDisposition (..), + constraintPlan, + mappingDrift, + missingGeneratedBanners, + newBindingObligations, + obligationKindLabel, + pureRefusals, + renderMappingIdentity, + staleAgainst, + ) +import Keiro.Dsl.Validate (nodeIdentity) +import Keiro.Dsl.Workspace (WorkspaceMember (..), WorkspaceSpec (..), declarationOwner, nodeOwner) +import Keiro.Dsl.WorkspaceAdoption (MigrationReport (..), adoptedRows, adoptionReport, markLegacyRecordSuperseded, renderMigrationReport) +import Keiro.Dsl.WorkspaceRecord +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.FilePath (takeDirectory, takeFileName, ()) + +-------------------------------------------------------------------------------- +-- Planning +-------------------------------------------------------------------------------- + +{- | Which member file produced an emitted module. 'ContextLevel' means the +module belongs to the whole service rather than to any one member: the +structural projection facade, the replay-audit assembly, and any binding +skeleton shared by declarations owned by different members. +-} +data ModuleProvenance + = ContextLevel + | MemberOwned !FilePath + deriving stock (Eq, Ord, Show) + +-- | The owning member path, or 'Nothing' for a context-level module. +provenanceOwner :: ModuleProvenance -> Maybe FilePath +provenanceOwner ContextLevel = Nothing +provenanceOwner (MemberOwned path) = Just path + +{- | The complete, refusal-free write set for one whole-workspace scaffold, with +each module's producing member attached. +-} +data WorkspacePlan = WorkspacePlan + { wpWorkspace :: !WorkspaceSpec + , wpContext :: !Context + , wpGoldenRoot :: !FilePath + {- ^ 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. + -} + , wpModules :: ![(ScaffoldModule, ModuleProvenance)] + } + deriving stock (Eq, Show) + +-- | 'planWorkspaceScaffoldWithGoldens' with no golden payload fixtures. +planWorkspaceScaffold :: FilePath -> Context -> WorkspaceSpec -> Either [Refusal] WorkspacePlan +planWorkspaceScaffold = planWorkspaceScaffoldWithGoldens [] + +{- | Plan the whole workspace: build the merged module set once, attribute each +module to its owning member, then run every pure refusal gate over the complete +set. A refusal carries no write set, so it cannot be executed by accident. + +Because the gates see the whole workspace, a case-folded module-path collision +between two members is caught here, with both member files named in the +collision's origins. +-} +planWorkspaceScaffoldWithGoldens :: + [GoldenPayload] -> + FilePath -> + Context -> + WorkspaceSpec -> + Either [Refusal] WorkspacePlan +planWorkspaceScaffoldWithGoldens goldens goldenRoot ctx workspace = + case pureRefusals ctx merged (map fst tagged) of + [] -> + Right + WorkspacePlan + { wpWorkspace = workspace + , wpContext = ctx + , wpGoldenRoot = goldenRoot + , wpModules = tagged + } + refusals -> Left refusals + where + merged = wsMergedSpec workspace + tagged = workspaceModules goldens ctx workspace + +{- | The tagged module set, in exactly the order +'Keiro.Dsl.ScaffoldRun.scaffoldModulesWithGoldens' produces for the merged spec. + +Attribution is structural, never a re-parse of the human-readable @origin@ +string: structural modules carry the mapped declarations they were emitted for +('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 = + [attributed (declarationProvenance names) m | (m, names) <- scaffoldStructuralOwners ctx merged] + <> [attributed ContextLevel m | m <- scaffoldReplayAudit ctx merged] + <> concat + [ map (attributed (nodeProvenance node)) (emittersFor node) + | node <- specNodes merged + ] + where + merged = wsMergedSpec workspace + ownership = wsOwnership workspace + + emittersFor node = case node of + NAggregate aggregate -> scaffoldAggregate ctx merged aggregate <> harnessForWithGoldens goldens ctx merged aggregate + NProcess process -> scaffoldProcess ctx process <> harnessProcess ctx process + NRouter router -> scaffoldRouter ctx router <> harnessRouter ctx router + NContract contract -> scaffoldContract ctx contract + NIntake intake -> scaffoldIntake ctx intake + NPublisher publisher -> scaffoldPublisher ctx publisher + NWorkqueue workqueue -> scaffoldWorkqueue ctx workqueue + NReadModel readModel -> scaffoldReadModel ctx readModel <> harnessReadModel ctx readModel + NWorkflow workflow -> harnessWorkflow ctx workflow + NEmit _ -> [] + NPgmqDispatch _ -> [] + NOperation _ -> [] + + nodeProvenance node = + let (kind', name, _) = nodeIdentity node + in maybe ContextLevel (MemberOwned . fst) (nodeOwner ownership kind' name) + + -- A structural module belongs to a member only when every declaration it + -- was emitted for has the same owner. A binding skeleton shared by + -- declarations from two members belongs to neither: attributing it to one + -- would make the other member's obligations look like they moved whenever + -- the map iteration order changed. + declarationProvenance names = case nub owners of + [owner] | length owners == length names -> MemberOwned owner + _ -> ContextLevel + where + owners = [owner | name <- names, Just (owner, _) <- [declarationOwner ownership "mapped" name]] + + -- Name the producing member in refusal messages, so a cross-member path + -- collision says which files claimed the path. `origin` is metadata read + -- only by refusal rendering: it never reaches the module text, the record, + -- or the build manifest. A single-member workspace adds no prefix, which is + -- what keeps it identical to the single-file path down to this field. + attributed provenance m = (annotate provenance m, provenance) + annotate (MemberOwned path) m + | length (wsMembers workspace) > 1 = m{origin = T.pack path <> ": " <> origin m} + annotate _ m = m + +-------------------------------------------------------------------------------- +-- Golden payload roots +-------------------------------------------------------------------------------- + +{- | Refuse when a member has golden payload fixtures beside it that the +workspace's single golden root does not have. + +Golden fixtures are keyed @\\/\\/\.v\.json@ — +by aggregate, and an aggregate has exactly one owner across a workspace — so one +root per workspace cannot collide, while a per-member root would make a +fixture's location depend on which file currently owns the aggregate and break +the rule that an ownership move is not a content change. + +Without this check the failure would be silent: a member-adjacent fixture the +workspace root lacks is simply not found, the harness embeds a synthesized weak +stand-in instead of the file-owned payload, and generated bytes change with no +diagnostic at all. +-} +goldenRootDivergence :: FilePath -> WorkspaceSpec -> IO [Refusal] +goldenRootDivergence workspaceRoot workspace = do + stranded <- concat <$> traverse strandedFor (wsMembers workspace) + pure [GoldenRootDivergence workspaceRoot stranded | not (null stranded)] + where + manifestDir = takeDirectory (wsManifestPath workspace) + strandedFor member = concat <$> traverse (check member) (upcastFixtures (wmSpec member)) + check member relative = do + let memberRoot = manifestDir takeDirectory (wmPath member) "golden-payloads" + besideMember <- firstExisting memberRoot relative + case besideMember of + Nothing -> pure [] + Just found -> do + atRoot <- firstExisting workspaceRoot relative + pure (case atRoot of Nothing -> [found]; Just _ -> []) + -- Mirror the two shapes `loadGoldenPayloads` accepts: a root holding + -- context directories, or a root that already is the context directory. + firstExisting root relative = firstJustM [root relative, root dropContext relative] + dropContext relative = case break (== '/') relative of + (_, '/' : rest) -> rest + _ -> relative + firstJustM [] = pure Nothing + firstJustM (path : rest) = do + exists <- doesFileExist path + if exists then pure (Just path) else firstJustM rest + +{- | The @\\/\\/\.v\.json@ fixture paths a +spec's declared upcasters would load, in spec order. +-} +upcastFixtures :: Spec -> [FilePath] +upcastFixtures spec = + [ T.unpack (specContext spec) T.unpack (aggName aggregate) fixtureName event sourceVersion + | NAggregate aggregate <- specNodes spec + , event <- aggEvents aggregate + , Just (sourceVersion, _) <- [evUpcastFrom event] + ] + where + fixtureName event sourceVersion = T.unpack (evName event) <> ".v" <> show sourceVersion <> ".json" + +-------------------------------------------------------------------------------- +-- Execution +-------------------------------------------------------------------------------- + +{- | A module the workspace still produces, but from a different member file +than last time. 'Nothing' on either side means context-level. + +An ownership move is deliberately __not__ a stale entry and __not__ a new file: +the path is still produced, so nothing is orphaned. Reporting it separately is +what stops "I moved this aggregate to another file" from looking like "another +spec's leftovers". Whole-workspace diffing must classify it identically. +-} +data OwnershipMove = OwnershipMove + { omPath :: !FilePath + , omPrevious :: !(Maybe FilePath) + , omCurrent :: !(Maybe FilePath) + } + deriving stock (Eq, Show) + +-- | What one successful whole-workspace scaffold did. +data WorkspaceScaffoldReport = WorkspaceScaffoldReport + { wsrManifestPath :: !FilePath + , wsrOutDir :: !FilePath + , wsrService :: !Text + , wsrContext :: !Context + , wsrMembers :: ![FilePath] + , wsrDispositions :: ![(ScaffoldModule, ModuleProvenance, WriteDisposition)] + , wsrBuildManifestPath :: !FilePath + , wsrRecordPath :: !FilePath + , wsrPreviousManifest :: !(Maybe Text) + {- ^ The manifest file name the previous workspace record was written from, + when it differs from this run's. + -} + , wsrStale :: ![StaleModule] + , wsrOwnershipMoves :: ![OwnershipMove] + , wsrConsumerPlan :: !ConsumerPlan + , wsrConstraintPlan :: ![Text] + , wsrMappingDrift :: ![MappingDrift] + , wsrNewHoles :: ![BindingHole] + , wsrMigration :: !(Maybe MigrationReport) + -- ^ Present only on the run that adopted pre-workspace scaffold output. + } + deriving stock (Eq, Show) + +{- | Execute a planned whole-workspace scaffold. + +The shape mirrors 'Keiro.Dsl.ScaffoldRun.executeScaffold' step for step, with +three differences that matter: + + * Both preflights — stranded golden fixtures and Generated paths lacking the + @-- \@generated@ banner — are evaluated over the __complete__ workspace set + before the output directory is created or any file is touched. A bannerless + file under any member's subtree therefore refuses the whole run, and a + refused run leaves the tree, the record, and the build manifest untouched. + + * History is read from and written to the workspace-keyed record, so stale + detection compares whole workspaces. A module produced by a sibling member + is in the current set and can no longer be a false positive — the defect + that made two same-context specs report each other's files as stale. + + * A Generated module whose bytes already match is reported 'Unchanged' and + not rewritten, which is what makes idempotence observable rather than + merely claimed. +-} +executeWorkspaceScaffold :: FilePath -> Bool -> WorkspacePlan -> IO (Either [Refusal] WorkspaceScaffoldReport) +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 + refusals@(_ : _) -> pure (Left refusals) + [] -> do + previous <- readWorkspaceRecord recordPath + stale <- staleAgainst out (map modulePath modules) (previousFiles previous) + -- Adoption is a one-shot, guarded by the absence of workspace + -- history: once this workspace owns the directory there is nothing + -- left to import, and the migration report stays as written. + migration <- case previous of + Just _ -> pure Nothing + Nothing -> adoptionReport out (wsContext workspace) service modules + let currentPlan = consumerPlan merged + drift = maybe [] (mappingDrift (consumerMappings currentPlan) . wrMappings) previous + currentObligations = either (const []) id (bindingHoles merged) + newHoles = maybe [] (newBindingObligations currentObligations . wrBindingObligations) previous + createDirectoryIfMissing True out + dispositions <- traverse (writeWorkspaceModule out) (wpModules plan) + TIO.writeFile buildManifestPath (renderManifest (T.pack manifestName) modules merged) + -- Adoption provenance is durable history, not a one-run note: a + -- later run that adopts nothing carries the previous rows forward, + -- or the record would silently forget where its files came from. + let adopted = case migration of + Just report -> adoptedRows report + Nothing -> maybe [] wrAdopted previous + TIO.writeFile recordPath (renderWorkspaceRecord (currentWorkspaceRecord plan adopted)) + case migration of + Nothing -> pure () + Just report -> do + TIO.writeFile + (out workspaceMigrationReportFileName service) + (T.unlines (renderMigrationReport report)) + markLegacyRecordSuperseded out (wsContext workspace) service + pure $ + Right + WorkspaceScaffoldReport + { wsrManifestPath = wsManifestPath workspace + , wsrOutDir = out + , wsrService = wsService workspace + , wsrContext = wpContext plan + , wsrMembers = map wmPath (wsMembers workspace) + , wsrDispositions = dispositions + , wsrBuildManifestPath = buildManifestPath + , wsrRecordPath = recordPath + , wsrPreviousManifest = do + record <- previous + if wrManifest record == T.pack manifestName then Nothing else Just (wrManifest record) + , wsrStale = stale + , wsrOwnershipMoves = ownershipMoves previous (wpModules plan) + , wsrConsumerPlan = currentPlan + , wsrConstraintPlan = constraintPlan merged currentPlan + , wsrMappingDrift = drift + , wsrNewHoles = newHoles + , wsrMigration = migration + } + where + workspace = wpWorkspace plan + merged = wsMergedSpec workspace + modules = map fst (wpModules plan) + service = wsService workspace + manifestName = takeFileName (wsManifestPath workspace) + recordPath = out workspaceRecordFileName service + buildManifestPath = out workspaceManifestFileName service + previousFiles previous = [(wrmKind row, wrmPath row) | row <- maybe [] wrModules previous] + +readWorkspaceRecord :: FilePath -> IO (Maybe WorkspaceRecord) +readWorkspaceRecord path = do + exists <- doesFileExist path + if exists then parseWorkspaceRecord <$> TIO.readFile path else pure Nothing + +{- | The record this run writes: the plan's modules with their owners, the +canonical member list, the merged graph's mappings and obligations, and any +files adopted from pre-workspace scaffold output. +-} +currentWorkspaceRecord :: WorkspacePlan -> [AdoptedRow] -> WorkspaceRecord +currentWorkspaceRecord plan adopted = + WorkspaceRecord + { wrService = wsService workspace + , wrManifest = T.pack (takeFileName (wsManifestPath workspace)) + , wrContext = wsContext workspace + , wrModuleRoot = moduleRoot ctx + , wrLayout = layoutLabel ctx + , wrMembers = map wmPath (wsMembers workspace) + , wrModules = + [ WorkspaceModuleRow + { wrmKind = kind m + , wrmPath = modulePath m + , wrmOwner = provenanceOwner provenance + } + | (m, provenance) <- wpModules plan + ] + , wrMappings = consumerMappings (consumerPlan merged) + , wrBindingObligations = either (const []) id (bindingHoles merged) + , wrAdopted = adopted + } + where + workspace = wpWorkspace plan + merged = wsMergedSpec workspace + ctx = wpContext plan + +layoutLabel :: Context -> Text +layoutLabel ctx = case placement ctx of GeneratedPrefix -> "prefixed"; CollocatedLeaf -> "collocated" + +{- | Paths this run still produces whose owning member changed. Computed against +the previous record before stale detection, and never overlapping it: a moved +module's path is still in the current plan, so it was never a removal. +-} +ownershipMoves :: Maybe WorkspaceRecord -> [(ScaffoldModule, ModuleProvenance)] -> [OwnershipMove] +ownershipMoves previous current = + [ OwnershipMove + { omPath = modulePath m + , omPrevious = wrmOwner row + , omCurrent = provenanceOwner provenance + } + | (m, provenance) <- current + , Just row <- [Map.lookup (modulePath m) previousByPath] + , wrmOwner row /= provenanceOwner provenance + ] + where + previousByPath = Map.fromList [(wrmPath row, row) | row <- maybe [] wrModules previous] + +{- | Write one module. Generated modules whose bytes already match are left +alone and reported 'Unchanged'; hole modules keep the create-once rule. The +single-spec 'Keiro.Dsl.ScaffoldRun.executeScaffold' is untouched, so its report +bytes are unaffected. +-} +writeWorkspaceModule :: + FilePath -> + (ScaffoldModule, ModuleProvenance) -> + IO (ScaffoldModule, ModuleProvenance, WriteDisposition) +writeWorkspaceModule out (m, provenance) = do + let path = out modulePath m + exists <- doesFileExist path + case kind m of + HoleStub + | exists -> pure (m, provenance, Skipped) + | otherwise -> write path Created + Generated + | exists -> do + existing <- TIO.readFile path + if existing == moduleText m + then pure (m, provenance, Unchanged) + else write path Overwritten + | otherwise -> write path Overwritten + where + write path disposition = do + createDirectoryIfMissing True (takeDirectory path) + TIO.writeFile path (moduleText m) + pure (m, provenance, disposition) + +{- | The report a successful whole-workspace scaffold prints, following the +single-spec report's shape so the two stay readable side by side: the header +names the service instead of a spec, each module line carries its owning member, +and the stale section keeps the exact "keiro-dsl never deletes files." sentence. +-} +renderWorkspaceScaffoldReport :: WorkspaceScaffoldReport -> [Text] +renderWorkspaceScaffoldReport report = + [ "workspace: " + <> wsrService report + <> " (" + <> T.pack (wsrManifestPath report) + <> ") -> " + <> T.pack (wsrOutDir report) + <> " (module-root=" + <> rootLabel + <> ", layout=" + <> layoutLabel ctx + <> ")" + , "members: " <> T.intercalate ", " (map T.pack (wsrMembers report)) + ] + <> map moduleLine dispositions + <> [ "firewall: OK (" <> tshow generatedCount <> " generated modules scanned, 0 forbidden operators)" + , harnessLine + , dependencyLine + , "manifest: " <> T.pack (wsrBuildManifestPath report) + , "record: " <> T.pack (wsrRecordPath report) + ] + <> previousManifestNote + <> migrationSection + <> constraintSection + <> newHolesSection + <> mappingDriftSection + <> ownershipSection + <> staleSection + where + ctx = wsrContext report + dispositions = wsrDispositions report + rootLabel = if T.null (moduleRoot ctx) then "(none)" else moduleRoot ctx + names = [moduleNameOf (modulePath m) | (m, _, _) <- dispositions] + nameWidth = maximum (1 : map T.length names) + moduleLine (m, provenance, disposition) = + " " + <> kindTag (kind m) + <> " " + <> pad (moduleNameOf (modulePath m)) + <> " " + <> dispositionTag disposition + <> " " + <> ownerTag provenance + kindTag Generated = "generated" + kindTag HoleStub = "hole " + dispositionTag Overwritten = "(overwritten)" + dispositionTag Created = "(created)" + dispositionTag Skipped = "(skipped: already present)" + dispositionTag Unchanged = "(unchanged)" + ownerTag ContextLevel = "(context-level)" + ownerTag (MemberOwned path) = T.pack path + pad name = name <> T.replicate (nameWidth - T.length name) " " + generatedCount = length [() | (m, _, _) <- dispositions, kind m == Generated] + harnesses = + sortOn + id + [ moduleNameOf (modulePath m) + | (m, _, _) <- dispositions + , any (`T.isSuffixOf` moduleNameOf (modulePath m)) [".Harness", ".ProcessHarness", ".WorkflowFacts"] + ] + harnessLine = case harnesses of + [] -> "harness: (none emitted)" + _ -> "harness: run `cabal test ` over " <> T.unwords harnesses + dependencyLine = + "dependency plan: consumer packages " + <> renderBracketed (consumerPackages (wsrConsumerPlan report)) + <> ", consumer modules " + <> renderBracketed (consumerModules (wsrConsumerPlan report)) + previousManifestNote = case wsrPreviousManifest report of + Just previous -> ["note: the previous workspace record was written from manifest " <> previous] + Nothing -> [] + migrationSection = maybe [] renderMigrationReport (wsrMigration report) + constraintSection = case wsrConstraintPlan report of + [] -> [] + constraints -> "constraint plan:" : map (" " <>) constraints + newHolesSection = case wsrNewHoles report of + [] -> [] + obligations -> + ["newly required holes since last scaffold: " <> tshow (length obligations)] + <> concatMap obligationLines obligations + obligationLines hole = + [ " " <> holeModule hole + , " " <> holeSignature hole <> " (" <> obligationKindLabel (holeKind hole) <> ")" + ] + mappingDriftSection = case wsrMappingDrift report of + [] -> [] + drifts -> + ["mapping drift: " <> tshow (length drifts) <> " declaration(s) changed since the previous scaffold:"] + <> concatMap driftLines drifts + driftLines drift = + [ " " <> driftSpecName drift + , " previous: " <> maybe "(absent)" renderMappingIdentity (driftPrevious drift) + , " current: " <> maybe "(absent)" renderMappingIdentity (driftCurrent drift) + ] + ownershipSection = case wsrOwnershipMoves report of + [] -> [] + moves -> + ["ownership moves: " <> tshow (length moves) <> " module(s) changed owning member (content unaffected):"] + <> [ " " <> T.pack (omPath move) <> " " <> ownerName (omPrevious move) <> " -> " <> ownerName (omCurrent move) + | move <- moves + ] + ownerName = maybe "(context-level)" T.pack + staleSection = case wsrStale report of + [] -> [] + stale -> + [ "stale: " + <> tshow (length stale) + <> " file(s) from a previous scaffold of workspace " + <> wsrService report + <> " are no longer produced by this workspace:" + ] + <> map staleLine stale + <> ["note: keiro-dsl never deletes files."] + staleLine stale = case staleKind stale of + Generated -> " generated " <> T.pack (stalePath stale) <> " (safe to delete; still on disk)" + HoleStub -> " hole " <> T.pack (stalePath stale) <> " (hand-owned — review before deleting)" + +renderBracketed :: [Text] -> Text +renderBracketed values = "[" <> T.intercalate ", " values <> "]" + +tshow :: (Show a) => a -> Text +tshow = T.pack . show diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -12,2817 +12,4189 @@ import Data.Aeson qualified as Aeson import Data.Aeson.KeyMap qualified as KeyMap import Data.Either (isLeft, isRight) -import Data.List (partition, sort) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Map.Strict qualified as Map -import Data.Set qualified as Set -import Data.Text qualified as T -import Data.Text.IO qualified as TIO -import Keiro.Codec (Codec (..), EventType (..), decodeRaw) -import Keiro.Dsl.CodecCompare -import Keiro.Dsl.Coverage qualified as Coverage -import Keiro.Dsl.Diff (Change (..), ChangeKind (..), CompatibilitySurface (..), CompatibilityVector (..), FamilyDiff (..), Label (..), NodeFamily, RolloutConstraint (..), SurfaceVerdict (..), defaultGate, deriveLabel, diffSpecs, familyRegistry, gateWith, gatedBreaking, isAdvisory, isBreaking, verdictFor) -import Keiro.Dsl.DiffReport (diffReport, parseSurfaceName, remediationFor, renderExplainBlock, renderFinding) -import Keiro.Dsl.ExplainBindings (BindingHole (..), BindingObligation (..), BindingObligationKind (..), bindingObligations, renderBindingObligations) -import Keiro.Dsl.FoldFingerprint (aggregateFoldFingerprint, aggregateFoldSurface) -import Keiro.Dsl.Goldens (GoldenEvidence (..), GoldenPayload (..), emitGoldenPayloads, goldenRelativePath, goldensForDiff) -import Keiro.Dsl.Grammar -import Keiro.Dsl.Harness (harnessFor, harnessForWithGoldens, harnessReadModel, harnessRouter, harnessWorkflow) -import Keiro.Dsl.Manifest (manifestDependencies, moduleNameOf, renderManifest) -import Keiro.Dsl.MappedConsumer (ConsumerPlan (..)) -import Keiro.Dsl.Parser (parseSpec) -import Keiro.Dsl.PrettyPrint (renderSpec, renderTransition) -import Keiro.Dsl.ReadModelShape (canonicalShape, deriveShapeHash, registryNameFor, subscriptionNameFor) -import Keiro.Dsl.ReplayImpact (AggregateImpact (..), ReplayImpact (..)) -import Keiro.Dsl.ReplayImpact qualified as ReplayImpact -import Keiro.Dsl.Scaffold (Context (..), ModuleKind (..), ScaffoldModule (..), codecComparisonBanner, codecComparisonModule, defaultContext, firewallBreaches, genPrefixFor, holePrefixFor, scaffoldAggregate, scaffoldIntake, scaffoldProcess, scaffoldPublisher, scaffoldReadModel, scaffoldRefusals, scaffoldReplayAudit, scaffoldRouter, scaffoldWorkqueue, windowSeconds) -import Keiro.Dsl.ScaffoldRecord (ScaffoldRecord (..), parseRecord, recordFileName) -import Keiro.Dsl.ScaffoldRun (MappingDrift (..), Refusal (..), ScaffoldReport (..), StaleModule (..), WriteDisposition (..), executeScaffold, planScaffold, renderRefusals, renderScaffoldReport, scaffoldModules) -import Keiro.Dsl.Skeleton (skeletonFor, skeletonKinds) -import Keiro.Dsl.TypeGraph -import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), Severity (..), derivedQueueTrio, validateSpec) -import System.Directory (createDirectory, createDirectoryIfMissing, doesFileExist, getTemporaryDirectory, removeFile, removePathForcibly) -import System.Environment (lookupEnv) -import System.Exit (ExitCode (..)) -import System.FilePath (takeDirectory, ()) -import System.IO (hClose, openTempFile) -import System.Process (readProcessWithExitCode) -import Test.Hspec hiding (Spec) -import Test.QuickCheck - -main :: IO () -main = hspec $ do - describe "historical codec comparison" $ do - it "treats object-key order as RFC 8785 parity" $ do - let historical = object ["z" .= (1 :: Int), "a" .= (2 :: Int)] - generated = object ["a" .= (2 :: Int), "z" .= (1 :: Int)] - classifyObservation (EncodeObservation "ordered-object" historical generated) - `shouldBe` Right JsonParity - it "classifies an omitted key versus explicit null as version work at that pointer" $ do - let historical = object [] - generated = object ["description" .= Aeson.Null] - classifyObservation (EncodeObservation "absent-description" historical generated) - `shouldBe` Right (RequiresVersionWork (EncodedValueDifference (JsonPointer "/description") historical generated)) - it "classifies generated rejection of a historical value as version work" $ - classifyObservation - ( DecodeObservation - "legacy.json" - (object ["tag" .= ("legacy" :: T.Text)]) - (DecodedShape (object ["tag" .= ("legacy" :: T.Text)])) - (DecodeFailed "unknown tag") - ) - `shouldBe` Right (RequiresVersionWork (GeneratedDecodeRejected "unknown tag")) - it "treats historical-codec rejection as invalid input rather than parity" $ - classifyObservation - ( DecodeObservation - "corrupt.json" - Aeson.Null - (DecodeFailed "not historical data") - (DecodeFailed "not generated data") - ) - `shouldBe` Left (HistoricalCodecRejected "corrupt.json" "not historical data") - it "reports uncovered union arms separately by corpus origin" $ do - let canonical = DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical") - local = DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local_file") - report = compareReport comparisonProvenance [] [] [canonical, local] [ObservedBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local_file")] - crCoverageGaps report - `shouldBe` [CoverageGap HistoricalGolden (JsonPointer "/location") (UnionArm "canonical")] - reportSucceeded report `shouldBe` False - it "derives optional, null, and union-arm observations from a generated branch schema" $ do - let schema = - BranchRecord - [ BranchField "description" True (BranchOptional BranchScalar) - , BranchField "location" False (BranchUnion "tag" "contents" [BranchArm "local" (Just BranchScalar), BranchArm "canonical" Nothing]) - ] - historical = object ["location" .= object ["tag" .= ("canonical" :: T.Text)]] - observedBranchesFor HistoricalGolden schema historical - `shouldBe` [ ObservedBranch HistoricalGolden (JsonPointer "/description") OptionalMissing - , ObservedBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical") - ] - let declared = declaredBranchesFor HistoricalGolden schema - forM_ - [ DeclaredBranch HistoricalGolden (JsonPointer "/description") OptionalMissing - , DeclaredBranch HistoricalGolden (JsonPointer "/description") OptionalPresent - , DeclaredBranch HistoricalGolden (JsonPointer "/description") ExplicitNull - , DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local") - , DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical") - ] - (\branch -> declared `shouldContain` [branch]) - it "round-trips the stable machine report" $ do - let observation = EncodeObservation "parity" (object ["a" .= (1 :: Int)]) (object ["a" .= (1 :: Int)]) - report = compareReport comparisonProvenance [] [observation] [] [] - Aeson.eitherDecode (Aeson.encode report) `shouldBe` Right report - it "atomically writes and replaces the machine report" $ - withTempDirectory "keiro-dsl-codec-compare" $ \out -> do - let path = out "report.json" - firstReport = compareReport comparisonProvenance [] [] [] [] - secondReport = compareReport comparisonProvenance [HistoricalGoldenUnreadable "bad.json" "bad JSON"] [] [] [] - writeCompareReportAtomic path firstReport `shouldReturn` Right () - Aeson.eitherDecodeFileStrict path `shouldReturn` Right firstReport - writeCompareReportAtomic path secondReport `shouldReturn` Right () - Aeson.eitherDecodeFileStrict path `shouldReturn` Right secondReport - - describe "historical codec comparison scaffold" $ do - it "emits an opt-in non-production runner without entering the ordinary module registry" $ do - spec <- specOf "test/fixtures/structural-conformance.keiro" - let ctx = defaultContext (specContext spec) - planned = codecComparisonModule ctx spec "ArtifactInfo" - ordinary = scaffoldModules ctx spec - case planned of - Left err -> expectationFailure (T.unpack err) - Right comparisonModule -> do - modulePath comparisonModule - `shouldBe` "Generated/StructuralConformance/Structural/CodecCompare/ArtifactInfo.hs" - moduleText comparisonModule `shouldSatisfy` T.isInfixOf codecComparisonBanner - moduleText comparisonModule `shouldSatisfy` T.isInfixOf "Generated.StructuralConformance.ArtifactCatalog.Codec qualified as GeneratedCodec" - moduleText comparisonModule `shouldSatisfy` T.isInfixOf "branchSchema = BranchRecord" - map modulePath ordinary `shouldNotContain` [modulePath comparisonModule] - it "refuses opaque selections rather than upgrading their claim" $ do - spec <- specOf "test/fixtures/structural-conformance.keiro" - codecComparisonModule (defaultContext (specContext spec)) spec "VendorGeometry" - `shouldSatisfy` either (T.isInfixOf "is opaque") (const False) - - describe "structural/opaque coverage reporting" $ do - it "reports mapped private-event roots and consumer-json register boundaries without a percentage" $ do - spec <- specOf "test/fixtures/structural-conformance.keiro" - report <- shouldResolveCoverage "structural-conformance.keiro" spec - Coverage.privateEventPayloads (Coverage.coverageSummary report) - `shouldBe` Coverage.CoverageCounts 2 1 1 0 - Coverage.snapshotRegisters (Coverage.coverageSummary report) - `shouldBe` Coverage.CoverageCounts 2 1 1 0 - map Coverage.opaqueMappedType (Coverage.coverageOpaqueBoundaries report) - `shouldBe` ["VendorGeometry"] - map Coverage.snapshotEncoding (Coverage.coverageSnapshotBoundaries report) - `shouldBe` ["consumer-json-cache", "consumer-json-cache"] - map Coverage.snapshotInvalidation (Coverage.coverageSnapshotBoundaries report) - `shouldBe` ["tracked-by-mapped-wire-fingerprint", "tracked-by-mapped-wire-fingerprint"] - map Coverage.findingCode (Coverage.coverageFindings report) - `shouldBe` [CoverageOpaqueSurface] - map Coverage.findingSeverity (Coverage.coverageFindings report) - `shouldBe` [Warning] - case Aeson.toJSON report of - Aeson.Object values -> - forM_ ["spec", "roots", "opaqueBoundaries", "snapshotBoundaries", "unsupportedSurfaces"] $ - \key -> KeyMap.member key values `shouldBe` True - value -> expectationFailure ("coverage report was not an object: " <> show value) - it "reports explicit Json leaves by their complete persisted path" $ do - spec <- withMetadataJson <$> specOf "test/fixtures/structural-conformance.keiro" - report <- shouldResolveCoverage "structural-conformance-json.keiro" spec - Coverage.jsonBoundaries (Coverage.privateEventPayloads (Coverage.coverageSummary report)) - `shouldBe` 1 - map Coverage.jsonPath (Coverage.coverageJsonBoundaries report) - `shouldBe` ["ArtifactCatalog event ArtifactRecorded .artifact : ArtifactInfo .metadata : ArtifactMetadata .note"] - it "keeps a zero-opaque spec advisory-free and makes rejection explicitly opt-in" $ do - original <- specOf "test/fixtures/structural-conformance.keiro" - clear <- shouldResolveCoverage "structural-only.keiro" (withoutVendorGeometry original) - Coverage.opaqueRoots (Coverage.privateEventPayloads (Coverage.coverageSummary clear)) `shouldBe` 0 - Coverage.coverageOpaqueBoundaries clear `shouldBe` [] - Coverage.coverageFindings clear `shouldBe` [] - opaque <- shouldResolveCoverage "structural-conformance.keiro" original - Coverage.coverageSucceeded opaque `shouldBe` True - let gated = Coverage.failOnOpaque opaque - Coverage.coverageSucceeded gated `shouldBe` False - map Coverage.findingCode (Coverage.coverageFindings gated) - `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueGateExceeded] - map Coverage.findingSeverity (Coverage.coverageFindings gated) - `shouldBe` [Warning, Error] - it "diffs named opaque boundaries and fails only an explicitly gated increase" $ do - newSpec <- specOf "test/fixtures/structural-conformance.keiro" - report <- case Coverage.coverageDiffReport "structural-conformance.keiro" "HEAD" (withoutVendorGeometry newSpec) newSpec of - Left err -> expectationFailure (show err) >> fail "unreachable" - Right value -> pure value - fmap Coverage.opaqueBoundaryDelta (Coverage.coverageDelta report) `shouldBe` Just 1 - fmap (map Coverage.opaqueMappedType . Coverage.addedOpaqueBoundaries) (Coverage.coverageDelta report) - `shouldBe` Just ["VendorGeometry"] - map Coverage.findingCode (Coverage.coverageFindings report) - `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueBoundaryAdded] - Coverage.coverageSucceeded report `shouldBe` True - let gated = Coverage.failOnOpaqueIncrease report - Coverage.coverageSucceeded gated `shouldBe` False - map Coverage.findingCode (Coverage.coverageFindings gated) - `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueBoundaryAdded, CoverageOpaqueGateExceeded] - it "appends the six stable coverage and comparison registry codes" $ - map - show - [ CoverageOpaqueSurface - , CoverageOpaqueBoundaryAdded - , CoverageOpaqueGateExceeded - , CodecCompareDifference - , CodecCompareCoverageGap - , CodecCompareInvalidInput - ] - `shouldBe` [ "CoverageOpaqueSurface" - , "CoverageOpaqueBoundaryAdded" - , "CoverageOpaqueGateExceeded" - , "CodecCompareDifference" - , "CodecCompareCoverageGap" - , "CodecCompareInvalidInput" - ] - - describe "parse . pretty round-trip" $ - do - it "re-parses any generated spec to an equal AST (modulo source locations)" $ - checkCoverage $ - forAll genSpec $ \s -> - let families = map nodeTag (specNodes s) - roundTrip = parseSpec "" (renderSpec s) === Right s - in cover 5 (not (null (specMapped s))) "mapped" $ - foldr (\family -> cover 1 (family `elem` families) family) roundTrip allNodeTags - it "round-trips an aggregate with no states" $ - parseSpec "" (renderSpec emptyStatesSpec) `shouldBe` Right emptyStatesSpec - it "separates transition emit clauses from following nodes" $ do - spec <- parseInlineSpec "" crossFamilyBoundarySpec - case specNodes spec of - [NAggregate first, NEmit _, NAggregate second, NPgmqDispatch _] -> do - concatMap tEmits (aggTransitions first) `shouldBe` ["Changed"] - aggStates second `shouldBe` [] - nodes -> expectationFailure ("unexpected node sequence: " <> show (map nodeTag nodes)) - - describe "mapped types (EP-149)" $ do - it "round-trips the canonical structural and opaque consumer fixture" $ do - source <- TIO.readFile "test/fixtures/consumer-types.keiro" - spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source - parseSpec "" (renderSpec spec) `shouldBe` Right spec - length (specMapped spec) `shouldBe` 4 - it "preserves every missing-value policy, nested type expression, and unit union arm" $ do - source <- TIO.readFile "test/fixtures/consumer-types.keiro" - spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source - let fields = [field | MappedStructural{msShape = ShapeRecord _ _ recordFields} <- specMapped spec, field <- recordFields] - arms = [arm | MappedStructural{msShape = ShapeUnion _ unionArms} <- specMapped spec, arm <- unionArms] - [value | field <- fields, Just value <- [wfOnMissing field]] - `shouldBe` [OmCtor "Guide", OmNull, OmInt 0, OmBool False, OmEmptyList, OmEmptyMap] - [wfType field | field <- fields, wfHaskell field == "labels"] - `shouldBe` [TList (TOptional TText)] - [waCtor arm | arm <- arms, waPayload arm == Nothing] - `shouldBe` ["Unknown"] - it "rejects every mapped validation fixture with its stable diagnostic code" $ do - let cases = - [ ("mapped-unresolved.keiro", MappedUnresolvedName) - , ("mapped-ambiguous.keiro", MappedAmbiguousName) - , ("mapped-dup-fieldname.keiro", MappedDuplicateFieldName) - , ("mapped-dup-wirekey.keiro", MappedDuplicateWireKey) - , ("mapped-dup-armname.keiro", MappedDuplicateArmName) - , ("mapped-dup-tag.keiro", MappedDuplicateWireTag) - , ("mapped-recursive.keiro", MappedRecursiveType) - , ("mapped-recursive-mutual.keiro", MappedRecursiveType) - , ("mapped-bad-encoding.keiro", MappedUnsupportedEncoding) - , ("mapped-union-key-collision.keiro", MappedUnsupportedEncoding) - , ("mapped-optional-json.keiro", MappedNonInjectiveNullability) - , ("mapped-optional-optional.keiro", MappedNonInjectiveNullability) - , ("mapped-optional-opaque.keiro", MappedNonInjectiveNullability) - , ("mapped-missing-binding.keiro", MappedMissingIngredient) - , ("mapped-missing-binding-version.keiro", MappedMissingIngredient) - , ("mapped-missing-canonical.keiro", MappedMissingIngredient) - , ("mapped-missing-fixture.keiro", MappedMissingIngredient) - , ("mapped-missing-initial.keiro", MappedMissingInitialValue) - , ("mapped-bad-haskell-name.keiro", MappedInvalidHaskellName) - , ("mapped-empty-identity.keiro", MappedInvalidIdentity) - , ("mapped-import-conflict.keiro", MappedImportConflict) - , ("mapped-illtyped-default.keiro", MappedDefaultIllTyped) - , ("mapped-guard.keiro", MappedGuardUnsupported) - , ("mapped-guard-natural.keiro", MappedGuardUnsupported) - ] - forM_ cases $ \(fixture, expected) -> - errorCodesOf ("test/fixtures/" <> fixture) `shouldReturn` [expected] - it "keeps Time in Keiki's curated guard set while rejecting Natural" $ - errorCodesOf "test/fixtures/mapped-guard-time.keiro" `shouldReturn` [] - it "rejects required defaults, missing optional policies, Int overflow, and negative Natural defaults" $ do - let invalidFields = - [ WireField "requiredDefault" "requiredDefault" TText PRequired (Just (OmText "x")) noLoc - , WireField "missingPolicy" "missingPolicy" TText POptional Nothing noLoc - , WireField "overflow" "overflow" TInt POptional (Just (OmInt (toInteger (maxBound :: Int) + 1))) noLoc - , WireField "negativeNatural" "negativeNatural" TNatural POptional (Just (OmInt (-1))) noLoc - ] - declaration = completeStructural "Defaults" (ShapeRecord "Defaults" RejectUnknown invalidFields) - errorCodes (mappedSpec [declaration]) - `shouldBe` [MappedDefaultIllTyped, MappedMissingIngredient, MappedDefaultIllTyped, MappedDefaultIllTyped] - - describe "mapped type graph (EP-149)" $ do - it "resolves checked declarations, transitive reachability, and every aggregate root path" $ do - source <- TIO.readFile "test/fixtures/consumer-types.keiro" - spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source - graph <- shouldResolveTypeGraph spec - Map.size (tgDeclarations graph) `shouldBe` 4 - Map.lookup (MappedKey "ArtifactInfo") (tgReachability graph) - `shouldBe` Just (Set.fromList [MappedKey "ArtifactKind", MappedKey "ArtifactLocation"]) - map renderUsePath (usePaths graph "ArtifactLocation") - `shouldBe` [ "Catalog command ObserveArtifact .artifact : ArtifactInfo .location : ArtifactLocation" - , "Catalog event ArtifactObserved .artifact : ArtifactInfo .location : ArtifactLocation" - , "Catalog register currentArtifact : ArtifactInfo .location : ArtifactLocation" - ] - it "resolves every builtin through the complete expression algebra" $ do - source <- TIO.readFile "test/fixtures/consumer-types.keiro" - spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source - graph <- shouldResolveTypeGraph spec - case Map.lookup (MappedKey "ArtifactInfo") (tgDeclarations graph) of - Just (ResolvedStructural _ (RRecord _ _ fields)) -> - Set.fromList (concatMap (foldTypeExpr expressionTags . rwfType) fields) - `shouldBe` Set.fromList ["text", "int", "bool", "natural", "time", "json", "optional", "list", "map", "ref:ArtifactKind", "ref:ArtifactLocation"] - declaration -> expectationFailure ("unexpected ArtifactInfo declaration: " <> show declaration) - it "rejects direct, mutual, wrapped, and union-arm recursion" $ do - let direct = mappedSpec [completeStructural "A" (recordShape [TRef "A"])] - mutual = mappedSpec [completeStructural "A" (recordShape [TRef "B"]), completeStructural "B" (recordShape [TRef "A"])] - wrapped = mappedSpec [completeStructural "A" (recordShape [TList (TOptional (TRef "A"))])] - throughArm = mappedSpec [completeStructural "A" (ShapeUnion (TaggedObject "tag" "contents" RejectUnknown) [WireArm "Again" "again" (Just (TRef "A")) noLoc])] - map (hasTypeGraphError isRecursive . resolveTypeGraph) [direct, mutual, wrapped, throughArm] - `shouldBe` replicate 4 True - it "keeps existing ids and enums outside the mapped-reference namespace" $ do - let spec = - (mappedSpec [completeStructural "A" (recordShape [TRef "ExistingId"])]) - { specIds = [IdDecl "ExistingId" "id" noLoc] - } - resolveTypeGraph spec `shouldSatisfy` hasTypeGraphError isUnresolved - it "fingerprints wire identity while ignoring Haskell selector names" $ do - source <- TIO.readFile "test/fixtures/consumer-types.keiro" - base <- parseInlineSpec "test/fixtures/consumer-types.keiro" source - baseGraph <- shouldResolveTypeGraph base - haskellRenameGraph <- shouldResolveTypeGraph (mapArtifactField (\field -> field{wfHaskell = "renamedKey"}) base) - wireRenameGraph <- shouldResolveTypeGraph (mapArtifactField (\field -> field{wfKey = "renamed_key"}) base) - wireFingerprint haskellRenameGraph "ArtifactInfo" `shouldBe` wireFingerprint baseGraph "ArtifactInfo" - wireFingerprint wireRenameGraph "ArtifactInfo" `shouldNotBe` wireFingerprint baseGraph "ArtifactInfo" - - describe "string literal integrity" $ do - it "parses an escaped emit-map value as exactly one row" $ do - let src = - T.unlines - [ "context svc" - , "" - , "emit e {" - , " contract c" - , " topic events" - , " source \"svc\"" - , " key thingId" - , " map status {" - , " \"a\\\" => Wat \\\"b\" => ThingAccepted" - , " _ => skip" - , " }" - , " messageId derive hole" - , " idempotencyKey derive hole" - , "}" - ] - case parseSpec "" src of - Left err -> expectationFailure (T.unpack err) - Right spec -> case [row | NEmit e <- specNodes spec, row <- emMap e] of - [row] -> do - emrValue row `shouldBe` "a\" => Wat \"b" - emrEvent row `shouldBe` "ThingAccepted" - rows -> expectationFailure ("expected one emit-map row, got " <> show (length rows)) - it "rejects a raw newline inside a quoted string" $ do - let src = "context svc\n\ncontract c {\n schemaVersion 1\n discriminator kind\n topic events \"first\nsecond\"\n}\n" - parseSpec "" src `shouldSatisfy` leftContains "unescaped newline" - it "rejects an unknown escape sequence" $ do - let src = "context svc\n\ncontract c {\n schemaVersion 1\n discriminator kind\n topic events \"bad\\q\"\n}\n" - parseSpec "" src `shouldSatisfy` leftContains "unknown escape" - it "round-trips adversarial text through topics, emit maps, and quoted bindings" $ - property $ - forAll genAdversarialText $ \t -> - let spec = escapedSpec t - rendered = renderSpec spec - in counterexample (T.unpack rendered) (parseSpec "" rendered === Right spec) - - describe "partial status maps" $ do - it "suppresses totality only when the partial marker is present" $ do - partial <- parseInlineSpec "" (statusMapSpec " partial") - totalSpec <- parseInlineSpec "" (statusMapSpec "") - map code (validateSpec partial) `shouldNotContain` [StatusMapNotTotal] - map code (validateSpec totalSpec) `shouldContain` [StatusMapNotTotal] - parseSpec "" (renderSpec partial) `shouldBe` Right partial - - describe "positioned parser diagnostics" $ do - it "rejects a duplicate goto at the second clause" $ do - err <- parseErrorOf "" duplicateGotoSpec - err `shouldSatisfy` T.isInfixOf "duplicate goto" - err `shouldSatisfy` T.isInfixOf ":10:" - it "rejects duplicate wire and projection blocks at their second occurrences" $ do - wireErr <- parseErrorOf "" duplicateWireSpec - wireErr `shouldSatisfy` T.isInfixOf "duplicate wire block" - wireErr `shouldSatisfy` T.isInfixOf ":8:" - projectionErr <- parseErrorOf "" duplicateProjectionSpec - projectionErr `shouldSatisfy` T.isInfixOf "duplicate projection block" - projectionErr `shouldSatisfy` T.isInfixOf ":9:" - it "anchors a missing goto on the transition line" $ do - err <- parseErrorOf "" missingGotoSpec - err `shouldSatisfy` T.isInfixOf "missing a goto clause" - err `shouldSatisfy` T.isInfixOf ":8:" - it "stops before a misplaced dispatch-id and expects schedule at its start" $ do - let src = misplacedDispatchIdSpec - expectedPosition = - ":" - <> T.pack (show (lineNumberContaining "dispatch-id" src)) - <> ":5:" - err <- parseErrorOf "" src - err `shouldSatisfy` T.isInfixOf "schedule" - err `shouldSatisfy` T.isInfixOf expectedPosition - it "keeps a malformed register declaration's equals error" $ do - err <- parseErrorOf "" malformedRegisterSpec - err `shouldSatisfy` T.isInfixOf "expecting '='" - - describe "bounded decimal literals" $ do - forM_ decimalOverflowSpecs $ \(site, src) -> - it ("rejects overflow at " <> site) $ do - err <- parseErrorOf (" site <> ">") src - err `shouldSatisfy` T.isInfixOf ("decimal literal " <> decimalOverflow <> " is out of range") - it "accepts maxBound without changing its value" $ do - spec <- parseInlineSpec "" (wireDecimalSpec (T.pack (show (maxBound :: Int)))) - [wireSchemaVersion wire | NAggregate aggregate <- specNodes spec, Just wire <- [aggWire aggregate]] - `shouldBe` [maxBound] - - describe "identifier hygiene" $ do - it "reports constructor shape and Haskell keywords at their owning declarations" $ do - spec <- parseInlineSpec "" identifierHygieneSpec - [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic `elem` [IdentNotConstructorSafe, IdentHaskellKeyword]] - `shouldContain` [(IdentNotConstructorSafe, 3), (IdentHaskellKeyword, 7)] - it "rejects generated vertex constructors that collide with event constructors" $ do - spec <- parseInlineSpec "" vertexCollisionSpec - [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == VertexCtorCollision] - `shouldBe` [(VertexCtorCollision, 3)] - it "rejects underscore-leading names whose title-casing cannot make a module segment" $ do - spec <- parseInlineSpec "" underscoreNodeSpec - [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == IdentNotConstructorSafe] - `shouldBe` [(IdentNotConstructorSafe, 3)] - it "rejects non-ASCII identifier characters in the parser" $ - parseSpec "" unicodeIdentifierSpec `shouldSatisfy` leftContains "unexpected" - - describe "canonical reservation.keiro" $ - it "parses into the expected aggregate shape" $ do - input <- readTestText "test/fixtures/reservation.keiro" - case parseSpec "test/fixtures/reservation.keiro" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> do - specContext spec `shouldBe` "hospital-capacity" - length (specIds spec) `shouldBe` 3 - length (specEnums spec) `shouldBe` 3 - length (specRules spec) `shouldBe` 1 - case specNodes spec of - [NAggregate a] -> do - aggName a `shouldBe` "Reservation" - length (aggStates a) `shouldBe` 6 - length (aggCommands a) `shouldBe` 2 - length (aggEvents a) `shouldBe` 2 - length (aggTransitions a) `shouldBe` 2 - map stTerminal (aggStates a) `shouldBe` [False, False, False, True, True, True] - other -> expectationFailure ("expected one aggregate node, got " <> show (length other)) - - describe "validator" $ do - it "accepts the canonical reservation.keiro" $ do - codes <- errorCodesOf "test/fixtures/reservation.keiro" - codes `shouldBe` [] - it "rejects a missing status-map as StatusMapNotTotal" $ do - codes <- diagnosticCodesOf "test/fixtures/reservation-no-statusmap.keiro" - codes `shouldContain` [StatusMapNotTotal] - it "rejects an undeclared command as UndeclaredCommand" $ do - codes <- diagnosticCodesOf "test/fixtures/reservation-bad-command.keiro" - codes `shouldContain` [UndeclaredCommand] - it "rejects a wall-clock guard atom as ClockSampled" $ do - codes <- diagnosticCodesOf "test/fixtures/reservation-clock.keiro" - codes `shouldContain` [ClockSampled] - it "accepts a v2 event with a contiguous upcaster hole" $ do - codes <- errorCodesOf "test/fixtures/reservation-v2.keiro" - codes `shouldBe` [] - it "rejects a v2 event with no upcaster as EvtVersionMissingUpcaster" $ do - codes <- diagnosticCodesOf "test/fixtures/reservation-v2-noupcast.keiro" - codes `shouldContain` [EvtVersionMissingUpcaster] - it "accepts shared upcaster sources for different event kinds" $ do - codes <- errorCodesOf "test/fixtures/reservation-dup-upcast-source.keiro" - codes `shouldNotContain` [DuplicateUpcasterSource] - it "rejects a gap in the aggregate-global upcaster chain" $ do - codes <- errorCodesOf "test/fixtures/reservation-chain-gap.keiro" - codes `shouldContain` [UpcasterChainGap] - it "warns while a retiring event keeps its live emitting transition" $ do - diagnostics <- diagnosticsOf "test/fixtures/reservation-retiring.keiro" - [code d | d <- diagnostics, severity d == Error] `shouldBe` [] - [code d | d <- diagnostics, severity d == Warning] - `shouldContain` [EventRetirementInProgress] - it "rejects a retiring event after its live emitting transition disappears" $ do - source <- readTestText "test/fixtures/reservation-retiring.keiro" - spec <- parseInlineSpec "" (T.replace " ; emit TransferReservationConfirmed" "" source) - [code d | d <- validateSpec spec, severity d == Error] - `shouldContain` [EventRetirementInProgress] - it "warns when a deprecated event has no replay-only emitting transition" $ do - diagnostics <- diagnosticsOf "test/fixtures/reservation-deprecated.keiro" - [code d | d <- diagnostics, severity d == Error] `shouldBe` [] - [code d | d <- diagnostics, severity d == Warning] - `shouldContain` [DeprecatedEventReplayHazard] - it "recognises deprecated plus replay-only as the replay-safe cutover" $ do - diagnostics <- diagnosticsOf "test/fixtures/reservation-deprecated-replay-only.keiro" - [code d | d <- diagnostics, severity d == Error] `shouldBe` [] - [code d | d <- diagnostics, severity d == Warning] - `shouldContain` [EventRetirementInProgress] - [code d | d <- diagnostics] `shouldNotContain` [DeprecatedEventReplayHazard] - it "requires exact, unique status-map event keys" $ do - dangling <- errorCodesOf "test/fixtures/statusmap-dangling.keiro" - mapM_ (\expected -> dangling `shouldContain` [expected]) [StatusMapDanglingKey, StatusMapNotTotal] - duplicate <- errorCodesOf "test/fixtures/statusmap-dup-key.keiro" - duplicate `shouldContain` [StatusMapDuplicateKey] - it "rejects duplicate spec and aggregate names" $ do - codes <- errorCodesOf "test/fixtures/duplicate-names.keiro" - mapM_ - (\expected -> codes `shouldContain` [expected]) - [ DuplicateNodeName - , DuplicateEnumCtor - , DuplicateEnumWire - , DuplicateIdPrefix - , DuplicateCommandName - , DuplicateEventName - ] - it "rejects aggregate-local references that do not resolve" $ do - codes <- errorCodesOf "test/fixtures/aggregate-bad-refs.keiro" - codes `shouldContain` [RegisterInitialOutOfScope, UndeclaredCommand, WriteTargetNotRegister] - it "anchors UnreachableState on the state row" $ do - let src = - T.unlines - [ "context repro" - , "" - , "aggregate Thing" - , " regs" - , " states" - , " Initial" - , " Unreachable" - ] - case parseSpec "" src of - Left err -> expectationFailure (T.unpack err) - Right spec -> - [line d | d <- validateSpec spec, code d == UnreachableState] - `shouldBe` [7] - it "accepts a replay-only twin with a live sibling (plan 143)" $ do - codes <- errorCodesOf "test/fixtures/reservation-guard-tightened-twin.keiro" - codes `shouldBe` [] - it "rejects a replay-only transition that emits nothing" $ do - case parseSpec "" (replayOnlySpecWith [" write reservationState := Held", " goto Held"]) of - Left err -> expectationFailure (T.unpack err) - Right spec -> - [code d | d <- validateSpec spec, severity d == Error] - `shouldContain` [ReplayOnlyEmitsNothing] - it "warns when a replay-only transition has no live sibling" $ do - case parseSpec "" (replayOnlySpecWith [" emit TransferReservationCreated", " goto Held"]) of - Left err -> expectationFailure (T.unpack err) - Right spec -> do - [code d | d <- validateSpec spec, severity d == Warning] - `shouldContain` [ReplayOnlyCommandStillLive] - [code d | d <- validateSpec spec, severity d == Error] - `shouldNotContain` [ReplayOnlyCommandStillLive] - - describe "complementExpr (plan 143)" $ do - it "applies De Morgan over and/or and flips comparison operators" $ do - let a = EAtom (AName "a") - b = EAtom (AName "b") - complementExpr (EAnd a b) - `shouldBe` EOr (ECmp OpEq a (EAtom (ABool False))) (ECmp OpEq b (EAtom (ABool False))) - complementExpr (ECmp OpLt a b) `shouldBe` ECmp OpGe a b - complementExpr (ECmp OpEq a b) `shouldBe` ECmp OpNeq a b - complementExpr (ECmp OpLe a b) `shouldBe` ECmp OpGt a b - complementExpr (ECmp OpGt a b) `shouldBe` ECmp OpLe a b - complementExpr (ECmp OpGe a b) `shouldBe` ECmp OpLt a b - complementExpr (ECmp OpNeq a b) `shouldBe` ECmp OpEq a b - it "flips boolean literals and grounds bare names as == false" $ do - complementExpr (EAtom (ABool True)) `shouldBe` EAtom (ABool False) - complementExpr (EAtom (AName "open")) - `shouldBe` ECmp OpEq (EAtom (AName "open")) (EAtom (ABool False)) - it "stays inside the grammar: the complement of any guard re-parses" $ - property $ - forAll genExpr $ \e -> - let twin = - replayOnlySpecWith - [ " guard " <> renderExprText (complementExpr e) - , " emit TransferReservationCreated" - , " goto Held" - ] - in case parseSpec "" twin of - Left err -> counterexample (T.unpack err) False - Right spec -> - [tGuard t | NAggregate a <- specNodes spec, t <- aggTransitions a] - === [Just (complementExpr e)] - - describe "evolution parsing" $ do - it "parses event version and upcaster from reservation-v2.keiro" $ do - input <- readTestText "test/fixtures/reservation-v2.keiro" - case parseSpec "test/fixtures/reservation-v2.keiro" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> case [e | NAggregate a <- specNodes spec, e <- aggEvents a, evName e == "TransferReservationCreated"] of - (e : _) -> do - evVersion e `shouldBe` 2 - evUpcastFrom e `shouldBe` Just (1, Hole) - [] -> expectationFailure "TransferReservationCreated not found" - it "round-trips the retiring marker" $ do - spec <- specOf "test/fixtures/reservation-retiring.keiro" - parseSpec "" (renderSpec spec) `shouldBe` Right spec - [evRetiring event | NAggregate aggregate <- specNodes spec, event <- aggEvents aggregate, evName event == "TransferReservationConfirmed"] - `shouldBe` [True] - it "rejects an event marked both retiring and deprecated" $ do - source <- readTestText "test/fixtures/reservation-retiring.keiro" - let conflicting = T.replace "retiring event TransferReservationConfirmed" "retiring deprecated event TransferReservationConfirmed" source - parseSpec "" conflicting `shouldSatisfy` isLeft - - describe "aggregate snapshots (EP-109)" $ do - it "parses, validates, and round-trips a snapshot policy with codec fixture" $ do - spec <- specOf "test/fixtures/reservation-snapshot.keiro" - errorCodesOf "test/fixtures/reservation-snapshot.keiro" `shouldReturn` [] - parseSpec "" (renderSpec spec) `shouldBe` Right spec - case [aggregate | NAggregate aggregate <- specNodes spec] of - [aggregate] -> aggSnapshot aggregate `shouldBe` Just (SnapshotSpec (SnapEvery 100) 1 "7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc" noLoc) - aggregates -> expectationFailure ("expected one snapshot aggregate, got " <> show (length aggregates)) - it "rejects disabled intervals and invalid codec fixtures" $ do - source <- readTestText "test/fixtures/reservation-snapshot.keiro" - interval <- parseInlineSpec "" (T.replace "snapshot every 100" "snapshot every 0" source) - map code (validateSpec interval) `shouldContain` [SnapshotIntervalInvalid] - version <- parseInlineSpec "" (T.replace "state-codec version=1" "state-codec version=0" source) - map code (validateSpec version) `shouldContain` [SnapshotCodecFixtureInvalid] - emptyHash <- parseInlineSpec "" (T.replace "shape-hash=\"7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc\"" "shape-hash=\"\"" source) - map code (validateSpec emptyHash) `shouldContain` [SnapshotCodecFixtureInvalid] - it "conditionally lowers JSON instances and the live defaultStateCodec" $ do - snapshot <- specOf "test/fixtures/reservation-snapshot.keiro" - ordinary <- specOf "test/fixtures/reservation.keiro" - case ([aggregate | NAggregate aggregate <- specNodes snapshot], [aggregate | NAggregate aggregate <- specNodes ordinary]) of - ([snapshotAggregate], [ordinaryAggregate]) -> do - let snapshotModules = scaffoldAggregate (defaultContext (specContext snapshot)) snapshot snapshotAggregate - ordinaryModules = scaffoldAggregate (defaultContext (specContext ordinary)) ordinary ordinaryAggregate - snapshotDomain = generatedTextEndingIn "Domain.hs" snapshotModules - snapshotStream = generatedTextEndingIn "EventStream.hs" snapshotModules - ordinaryDomain = generatedTextEndingIn "Domain.hs" ordinaryModules - ordinaryStream = generatedTextEndingIn "EventStream.hs" ordinaryModules - snapshotDomain `shouldSatisfy` T.isInfixOf "deriving anyclass (ToJSON, FromJSON)" - snapshotStream `shouldSatisfy` T.isInfixOf "snapshotPolicy = Every 100" - snapshotStream `shouldSatisfy` T.isInfixOf "stateCodec = Just (withFoldFingerprint" - snapshotStream `shouldSatisfy` T.isInfixOf "Spec-visible fold changes invalidate old" - snapshotStream `shouldSatisfy` T.isInfixOf "module are invisible here" - snapshotStream `shouldSatisfy` T.isInfixOf "reservationSnapshotFixture = (1, \"7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc\")" - ordinaryDomain `shouldNotSatisfy` T.isInfixOf "DeriveAnyClass" - ordinaryStream `shouldSatisfy` T.isInfixOf "snapshotPolicy = Never" - ordinaryStream `shouldSatisfy` T.isInfixOf "stateCodec = Nothing" - ordinaryStream `shouldSatisfy` T.isInfixOf "reservationCategory = Stream.categoryUnsafe \"reservation\"" - firewallBreaches snapshotModules `shouldBe` [] - _ -> expectationFailure "expected one aggregate in each snapshot test spec" - - describe "aggregate fold fingerprints (plan 138)" $ do - it "is deterministic across repeated parses and formatting-only changes" $ do - source <- readTestText "test/fixtures/reservation.keiro" - first <- parseInlineSpec "" source - second <- parseInlineSpec "" ("\n\n" <> renderSpec first <> "\n") - aggregateFoldFingerprint first (onlyAggregate first) - `shouldBe` aggregateFoldFingerprint second (onlyAggregate second) - it "changes for transition writes, guards, and referenced rule bodies" $ do - base <- specOf "test/fixtures/reservation.keiro" - writeChanged <- specOf "test/fixtures/reservation-foldchange.keiro" - guardChanged <- specOf "test/fixtures/reservation-guard-tightened.keiro" - source <- readTestText "test/fixtures/reservation.keiro" - ruleChanged <- parseInlineSpec "" (T.replace "RedTag => true" "RedTag => false" source) - let baseFingerprint = aggregateFoldFingerprint base (onlyAggregate base) - aggregateFoldFingerprint writeChanged (onlyAggregate writeChanged) `shouldNotBe` baseFingerprint - aggregateFoldFingerprint guardChanged (onlyAggregate guardChanged) `shouldNotBe` baseFingerprint - aggregateFoldFingerprint ruleChanged (onlyAggregate ruleChanged) `shouldNotBe` baseFingerprint - it "ignores wire and projection changes" $ do - base <- specOf "test/fixtures/reservation.keiro" - wireChanged <- specOf "test/fixtures/reservation-wire.keiro" - source <- readTestText "test/fixtures/reservation.keiro" - projectionChanged <- parseInlineSpec "" (T.replace "projection transfer_decisions" "projection renamed_projection" source) - let surface = aggregateFoldSurface base (onlyAggregate base) - aggregateFoldSurface wireChanged (onlyAggregate wireChanged) `shouldBe` surface - aggregateFoldSurface projectionChanged (onlyAggregate projectionChanged) `shouldBe` surface - it "invalidates mapped-register snapshots when binding or wire identity changes" $ do - base <- specOf "test/fixtures/consumer-types.keiro" - bindingChanged <- specOf "test/fixtures/consumer-types-binding-change.keiro" - wireChanged <- specOf "test/fixtures/consumer-types-wirekey.keiro" - let baseFingerprint = aggregateFoldFingerprint base (onlyAggregate base) - aggregateFoldFingerprint bindingChanged (onlyAggregate bindingChanged) `shouldNotBe` baseFingerprint - aggregateFoldFingerprint wireChanged (onlyAggregate wireChanged) `shouldNotBe` baseFingerprint - - describe "process/timer (EP-3)" $ do - it "parses the hospital-surge process + nested timer" $ do - input <- readTestText "test/fixtures/hospital-surge.keiro" - case parseSpec "test/fixtures/hospital-surge.keiro" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> case [p | NProcess p <- specNodes spec] of - (p : _) -> do - procId p `shouldBe` "HospitalSurge" - procName p `shouldBe` "hospital-surge" - procRejected p `shouldBe` PolHalt - procPoison p `shouldBe` PolHalt - sagaCategory (procSaga p) `shouldBe` "hospitalSurge" - tmName (procTimer p) `shouldBe` "surgeFollowUp" - onReject (fireDisposition (tmFire (procTimer p))) `shouldBe` OFired - onAmbiguous (fireDisposition (tmFire (procTimer p))) `shouldBe` ORetry - tmMaxAttempts (procTimer p) `shouldBe` 5 - [] -> expectationFailure "no process node parsed" - it "round-trips the hospital-surge spec through parse . pretty" $ do - input <- readTestText "test/fixtures/hospital-surge.keiro" - case parseSpec "in" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "accepts the hospital-surge spec (no errors; benign-inversion warnings only)" $ do - codes <- errorCodesOf "test/fixtures/hospital-surge.keiro" - codes `shouldBe` [] - it "rejects illegal saga categories and no longer parses the raw stream-prefix clause" $ do - spec <- specOf "test/fixtures/hospital-surge.keiro" - mapM_ - (\categoryName -> processErrorCodes (\process -> process{procSaga = (procSaga process){sagaCategory = categoryName}}) spec `shouldContain` [SagaCategoryIllegal]) - ["", "$all", "hospital-surge", "hospital surge", "wf:surge"] - source <- readTestText "test/fixtures/hospital-surge.keiro" - parseSpec "" (T.replace "saga Surge category \"hospitalSurge\"" "saga Surge stream=\"hospital-surge-\" <> correlationId" source) - `shouldSatisfy` isLeft - it "rejects a wall-clock fireAt as ProcessFireAtNotInjected" $ do - codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro" - codes `shouldContain` [ProcessFireAtNotInjected] - it "reports one ProcessFireAtNotInjected for a wholly unknown fireAt field" $ do - codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro" - length (filter (== ProcessFireAtNotInjected) codes) `shouldBe` 1 - it "rejects a user-supplied dispatch id as ProcessDispatchIdSupplied" $ do - codes <- errorCodesOf "test/fixtures/hospital-surge-dispatchid.keiro" - codes `shouldContain` [ProcessDispatchIdSupplied] - it "rejects an unresolved saga reference as ProcessUnresolvedRef" $ do - codes <- errorCodesOf "test/fixtures/hospital-surge-badref.keiro" - codes `shouldContain` [ProcessUnresolvedRef] - it "rejects unresolved process commands, projections, schedules, and advance ids" $ do - codes <- errorCodesOf "test/fixtures/process-ghost-refs.keiro" - length (filter (== ProcessUnresolvedRef) codes) `shouldBe` 5 - codes `shouldContain` [ProcessDispatchIdSupplied] - - describe "router (EP-108)" $ do - it "parses the incident-paging router shape" $ do - input <- readTestText "test/fixtures/incident-paging/incident-paging.keiro" - case parseSpec "test/fixtures/incident-paging/incident-paging.keiro" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> case [router | NRouter router <- specNodes spec] of - [router] -> do - rtId router `shouldBe` "PagingRouter" - rtName router `shouldBe` "jitsurei-paging" - corrField (rtKey router) `shouldBe` "incidentId" - rvSource (rtResolve router) `shouldBe` ResolveReadModel "service_oncall" - rvRow (rtResolve router) `shouldBe` ["responderId"] - rdCommand (rtDispatch router) `shouldBe` "SendPage" - rtRejected router `shouldBe` PolDeadLetter - rtPoison router `shouldBe` PolHalt - routers -> expectationFailure ("expected one router, got " <> show (length routers)) - it "round-trips the incident-paging spec through parse . pretty" $ do - input <- readTestText "test/fixtures/incident-paging/incident-paging.keiro" - case parseSpec "in" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "accepts the incident-paging router with warnings only" $ do - codes <- errorCodesOf "test/fixtures/incident-paging/incident-paging.keiro" - codes `shouldBe` [] - diagnostics <- diagnosticCodesOf "test/fixtures/incident-paging/incident-paging.keiro" - diagnostics `shouldContain` [PolicyDeadLetterUnused, AmbiguousFollowsRejectedPolicy] - it "rejects unresolved targets, keys, commands, and binding scopes" $ do - spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" - routerErrorCodes (\router -> router{rtTarget = "Pge"}) spec `shouldContain` [RouterUnresolvedRef] - routerErrorCodes (\router -> router{rtKey = (rtKey router){corrField = "incidntId"}}) spec `shouldContain` [RouterKeyFieldUnknown] - routerErrorCodes (\router -> router{rtDispatch = (rtDispatch router){rdCommand = "SendPag"}}) spec `shouldContain` [RouterCommandUnknown] - routerErrorCodes - ( \router -> - let dispatch = rtDispatch router - in router{rtDispatch = dispatch{rdFields = [FieldBinding "responderId" (Just "resolved.responder")]}} - ) - spec - `shouldContain` [RouterBindingUnscoped] - it "rejects unresolved read models and contradictory rejection policies" $ do - spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" - let withoutReadModel = removeReadModel "service_oncall" spec - errorCodes withoutReadModel `shouldContain` [RouterUnresolvedRef] - routerErrorCodes - ( \router -> - let dispatch = rtDispatch router - disposition = rdDisposition dispatch - in router - { rtRejected = PolHalt - , rtDispatch = dispatch{rdDisposition = disposition{onFailed = DDeadLetter "page rejected"}} - } - ) - spec - `shouldContain` [PolicyContradiction] - it "rejects on-ambiguous Fired for process timers" $ do - spec <- specOf "test/fixtures/hospital-surge.keiro" - let changed = - spec - { specNodes = - [ case node of - NProcess process -> - let timer = procTimer process - fire = tmFire timer - disposition = fireDisposition fire - in NProcess process{procTimer = timer{tmFire = fire{fireDisposition = disposition{onAmbiguous = OFired}}}} - _ -> node - | node <- specNodes spec - ] - } - errorCodes changed `shouldContain` [AmbiguousMarkedBenign] - it "requires explicit policy and ambiguity clauses in the grammar" $ do - source <- readTestText "test/fixtures/hospital-surge.keiro" - parseSpec "" (T.replace " poison => halt\n" "" source) `shouldSatisfy` isLeft - parseSpec "" (T.replace " ; on-ambiguous Retry" "" source) `shouldSatisfy` isLeft - it "scaffolds firewall-clean router wiring, policies, and typed-hole guidance" $ do - spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" - case [router | NRouter router <- specNodes spec] of - [router] -> do - let ctx = defaultContext (specContext spec) - modules = scaffoldRouter ctx router - generated = [m | m <- modules, kind m == Generated] - holes = [m | m <- modules, kind m == HoleStub] - firewallBreaches generated `shouldBe` [] - case (generated, holes) of - ([generatedModule], [holeModule]) -> do - moduleText generatedModule `shouldSatisfy` T.isInfixOf "pagingRouterWorkerOptions" - moduleText generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedDeadLetter" - moduleText holeModule `shouldSatisfy` T.isInfixOf "UNION of resolved target identities" - moduleText holeModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate" - _ -> expectationFailure "expected one generated router module and one router hole module" - routers -> expectationFailure ("expected one router, got " <> show (length routers)) - it "requires a caller callback for non-halting poison policies" $ do - spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" - case [router | NRouter router <- specNodes spec] of - [router] -> do - let ctx = defaultContext (specContext spec) - generatedFor choice = [moduleText m | m <- scaffoldRouter ctx router{rtPoison = choice}, kind m == Generated] - mapM_ - ( \(choice, constructor) -> case generatedFor choice of - [generatedModule] -> do - generatedModule `shouldSatisfy` T.isInfixOf "(Envelope msg -> Eff es ()) -> WorkerOptions es msg" - generatedModule `shouldSatisfy` T.isInfixOf (constructor <> " poisonCallback") - _ -> expectationFailure "expected one generated router module" - ) - [(PolDeadLetter, "PoisonDeadLetter"), (PolSkip, "PoisonSkip")] - case [moduleText m | m <- scaffoldRouter ctx router{rtRejected = PolSkip}, kind m == Generated] of - [generatedModule] -> generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedSkip" - _ -> expectationFailure "expected one generated router module" - routers -> expectationFailure ("expected one router, got " <> show (length routers)) - it "emits router harness facts that pin policy and target-keyed identity" $ do - spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" - case [router | NRouter router <- specNodes spec] of - [router] -> case harnessRouter (defaultContext (specContext spec)) router of - [facts] -> do - moduleText facts `shouldSatisfy` T.isInfixOf "(\"rejectedPolicy\", \"deadLetter\")" - moduleText facts `shouldSatisfy` T.isInfixOf "targetStreamName, occurrence" - modules -> expectationFailure ("expected one router harness, got " <> show (length modules)) - routers -> expectationFailure ("expected one router, got " <> show (length routers)) - it "rejects invalid timer ceilings and target field bindings" $ do - codes <- errorCodesOf "test/fixtures/process-bad-timer.keiro" - mapM_ - (\expected -> codes `shouldContain` [expected]) - [ProcessTimerCeilingInvalid, ProcessFieldBindingUnresolved] - it "accepts resolved process projection references" $ do - codes <- errorCodesOf "test/fixtures/surge-service.keiro" - codes `shouldBe` [] - it "scaffolds the process: Generated wiring is firewall-clean + a HoleStub" $ do - mods <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" - let gens = [m | m <- mods, kind m == Generated] - holes = [m | m <- mods, kind m == HoleStub] - length holes `shouldBe` 1 - firewallBreaches gens `shouldBe` [] - case gens of - [generatedModule] -> do - -- the worker uses the spec's ceiling, never the dangerous default - moduleText generatedModule `shouldSatisfy` T.isInfixOf "max-attempts = 5" - moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeProcessWorkerOptions" - moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeCategory = Stream.categoryUnsafe \"hospitalSurge\"" - moduleText generatedModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate" - moduleText generatedModule `shouldSatisfy` T.isInfixOf "StreamName -> EventId -> CommandError -> Eff es Bool" - moduleText generatedModule `shouldSatisfy` T.isInfixOf "Left (CommandAmbiguous _)" - case holes of - [holeModule] -> moduleText holeModule `shouldSatisfy` T.isInfixOf "entityStream hospitalSurgeCategory" - _ -> expectationFailure "expected one process hole module" - _ -> expectationFailure "expected one generated process module" - it "process scaffold is deterministic" $ do - a <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" - b <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" - map moduleText a `shouldBe` map moduleText b - - describe "contract (EP-4)" $ do - it "parses the emergency contract (topics + events-on-topic + typed fields)" $ do - input <- readTestText "test/fixtures/contract.keiro" - case parseSpec "test/fixtures/contract.keiro" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> case [c | NContract c <- specNodes spec] of - (c : _) -> do - ctrName c `shouldBe` "emergency" - ctrDiscriminator c `shouldBe` "messageType" - map fst (ctrTopics c) `shouldBe` ["incidentEvents", "hospitalEvents"] - map ceName (ctrEvents c) `shouldBe` ["IncidentTransferNeedDeclared", "TransferReservationAccepted"] - [] -> expectationFailure "no contract node parsed" - it "round-trips the contract spec through parse . pretty" $ do - input <- readTestText "test/fixtures/contract.keiro" - case parseSpec "in" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "round-trips the intake (inbox) spec through parse . pretty" $ do - input <- readTestText "test/fixtures/intake.keiro" - case parseSpec "in" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "accepts the intake spec (complete disposition, no inversions)" $ do - codes <- errorCodesOf "test/fixtures/intake.keiro" - codes `shouldBe` [] - it "lowers explicit dedupe-only persistence and defaults omission to full-envelope" $ do - spec <- specOf "test/fixtures/intake.keiro" - ordinary <- specOf "test/fixtures/intake-decode.keiro" - case ([intake | NIntake intake <- specNodes spec], [intake | NIntake intake <- specNodes ordinary]) of - ([intake], [defaultIntake]) -> do - inkPersist intake `shouldBe` InkPersistDedupeOnly - inkPersist defaultIntake `shouldBe` InkPersistFull - renderSpec spec `shouldSatisfy` T.isInfixOf "persist = dedupe-only" - renderSpec ordinary `shouldNotSatisfy` T.isInfixOf "persist =" - let inbox = generatedTextEndingIn "Inbox.hs" (scaffoldIntake (defaultContext (specContext spec)) intake) - inbox `shouldSatisfy` T.isInfixOf "inboxPersistence = PersistDedupeOnly" - (intakes, defaultIntakes) -> - expectationFailure ("expected one intake in each fixture, got " <> show (length intakes, length defaultIntakes)) - it "rejects duplicate => retry (inversion 1)" $ do - codes <- errorCodesOf "test/fixtures/intake-dup-retry.keiro" - codes `shouldContain` [DispositionDuplicateRetry] - it "rejects previouslyFailed => retry (inversion 2)" $ do - codes <- errorCodesOf "test/fixtures/intake-pf-retry.keiro" - codes `shouldContain` [DispositionPreviouslyFailedRetry] - it "rejects an incomplete disposition table" $ do - codes <- errorCodesOf "test/fixtures/intake-incomplete.keiro" - codes `shouldContain` [DispositionIncomplete] - it "rejects a shadowing duplicate intake disposition row" $ do - codes <- errorCodesOf "test/fixtures/intake-dup-row.keiro" - codes `shouldContain` [DispositionDuplicateOutcome] - it "rejects intake events declared on another topic" $ do - codes <- errorCodesOf "test/fixtures/intake-topic-mismatch.keiro" - codes `shouldContain` [TopicAffinityMismatch] - it "round-trips the emit/publisher spec through parse . pretty" $ do - input <- readTestText "test/fixtures/emit.keiro" - case parseSpec "in" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "accepts the emit/publisher spec (skip present, coupling resolves)" $ do - codes <- errorCodesOf "test/fixtures/emit.keiro" - codes `shouldBe` [] - it "rejects a missing _ => skip catch-all as EmitSkipMissing" $ do - codes <- errorCodesOf "test/fixtures/emit-noskip.keiro" - codes `shouldContain` [EmitSkipMissing] - it "rejects mapping to an undeclared contract event as EmitUnresolvedContract" $ do - codes <- errorCodesOf "test/fixtures/emit-badevent.keiro" - codes `shouldContain` [EmitUnresolvedContract] - it "rejects emit events declared on another topic" $ do - codes <- errorCodesOf "test/fixtures/emit-topic-mismatch.keiro" - codes `shouldContain` [TopicAffinityMismatch] - - describe "pgmq workqueue/dispatch (EP-5)" $ do - it "round-trips the reservation-work spec through parse . pretty" $ do - input <- readTestText "test/fixtures/reservation-work.keiro" - case parseSpec "in" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "accepts the reservation-work spec (physical matches, no inversions)" $ do - codes <- errorCodesOf "test/fixtures/reservation-work.keiro" - codes `shouldBe` [] - it "rejects a divergent captured physical name as WqPhysicalDivergence" $ do - codes <- errorCodesOf "test/fixtures/reservation-work-divergent.keiro" - codes `shouldContain` [WqPhysicalDivergence] - it "rejects storeFailure => deadLetter as WqStoreFailureNotRetry" $ do - codes <- errorCodesOf "test/fixtures/reservation-work-sf-deadletter.keiro" - codes `shouldContain` [WqStoreFailureNotRetry] - it "rejects decodeFailure => retry as WqDecodeFailureNotDeadLetter" $ do - codes <- errorCodesOf "test/fixtures/reservation-work-df-retry.keiro" - codes `shouldContain` [WqDecodeFailureNotDeadLetter] - it "requires complete, unique workqueue disposition rows" $ do - incomplete <- errorCodesOf "test/fixtures/workqueue-incomplete.keiro" - incomplete `shouldContain` [WqDispositionIncomplete] - duplicateSpec <- specOf "test/fixtures/workqueue-dup-row.keiro" - let duplicateDiagnostics = [d | d <- validateSpec duplicateSpec, code d == DispositionDuplicateOutcome] - map line duplicateDiagnostics `shouldBe` [17] - it "checks the captured queueRef dlq and table fixtures" $ do - dlqCodes <- errorCodesOf "test/fixtures/workqueue-dlq-divergent.keiro" - dlqCodes `shouldContain` [WqDlqDivergence] - tableCodes <- errorCodesOf "test/fixtures/workqueue-table-divergent.keiro" - tableCodes `shouldContain` [WqTableDivergence] - it "matches queueRef for upper-case, punctuation, and hashed logical names" $ do - upper <- errorCodesOf "test/fixtures/workqueue-uppercase-logical.keiro" - upper `shouldBe` [] - hashed <- errorCodesOf "test/fixtures/workqueue-hashed-logical.keiro" - hashed `shouldBe` [] - derivedQueueTrio "hospital_capacity.reservation_work.per_hospital_fifo_lane_assignments" - `shouldBe` ( "hospital_capacity_reservat_757040df00976c33" - , "hospital_capacity_reservat_757040df00976c33_dlq" - , "pgmq.q_hospital_capacity_reservat_757040df00976c33" - ) - it "resolves dispatch dedup queues and payload wire fields" $ do - ghost <- errorCodesOf "test/fixtures/dispatch-dedup-ghost-queue.keiro" - ghost `shouldContain` [DispatchDedupQueueUnresolved] - field <- errorCodesOf "test/fixtures/dispatch-dedup-bad-field.keiro" - field `shouldContain` [DispatchDedupFieldUnresolved] - it "requires a resolvable group key exactly when ordering is FIFO" $ do - noKey <- errorCodesOf "test/fixtures/reservation-work-fifo-nokey.keiro" - noKey `shouldContain` [WqGroupKeyMissing] - unordered <- errorCodesOf "test/fixtures/reservation-work-key-unordered.keiro" - unordered `shouldContain` [WqGroupKeyWithoutFifo] - source <- readTestText "test/fixtures/reservation-work.keiro" - unresolved <- parseInlineSpec "" (T.replace "group key from reservationId" "group key from missingId" source) - map code (validateSpec unresolved) `shouldContain` [WqGroupKeyUnresolved] - it "warns on unlogged storage and rejects empty partition settings" $ do - warningCodes <- diagnosticCodesOf "test/fixtures/reservation-work-unlogged.keiro" - warningCodes `shouldContain` [WqUnloggedDurability] - partitionCodes <- errorCodesOf "test/fixtures/reservation-work-partitioned-empty.keiro" - partitionCodes `shouldContain` [WqPartitionSpecEmpty] - it "lowers ordering, provisioning, and raw group-key projection" $ do - spec <- specOf "test/fixtures/reservation-work.keiro" - case [workqueue | NWorkqueue workqueue <- specNodes spec] of - workqueue : _ -> do - let modules = scaffoldWorkqueue (defaultContext (specContext spec)) workqueue - queue = generatedTextEndingIn "Queue.hs" modules - policy = generatedTextEndingIn "QueuePolicy.hs" modules - queue `shouldSatisfy` T.isInfixOf "groupKeyFor payload = payload.reservationId" - policy `shouldSatisfy` T.isInfixOf "jobOrdering = FifoThroughput" - policy `shouldSatisfy` T.isInfixOf "withFifoIndexProvision (standardProvision)" - firewallBreaches modules `shouldBe` [] - [] -> expectationFailure "reservation-work fixture has no workqueue" - - describe "readmodel (EP-107)" $ do - it "parses and round-trips first-class read models" $ do - spec <- specOf "test/fixtures/readmodel.keiro" - case [readModel | NReadModel readModel <- specNodes spec] of - [subscriptionModel, inlineModel] -> do - rmName subscriptionModel `shouldBe` "transfer_decisions" - rmColumns subscriptionModel - `shouldBe` [ RmColumn "reservation_id" "text" True - , RmColumn "hospital_id" "text" True - , RmColumn "status" "text" True - , RmColumn "decided_at" "timestamptz" False - ] - rmScope subscriptionModel `shouldBe` Just (RmCategory "reservation") - rmFeed subscriptionModel `shouldBe` RmSubscription - rmSubscription subscriptionModel `shouldBe` Just "hospital-capacity-transfer-decisions-sub" - rmName inlineModel `shouldBe` "subscriptions" - rmScope inlineModel `shouldBe` Nothing - rmFeed inlineModel `shouldBe` RmInline - nodes -> expectationFailure ("expected two readmodel nodes, got " <> show (length nodes)) - parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "accepts an aggregate projection without a consistency clause" $ do - spec <- parseInlineSpec "" projectionWithoutConsistencySpec - case [projection | NAggregate aggregate <- specNodes spec, Just projection <- [aggProjection aggregate]] of - [projection] -> projConsistency projection `shouldBe` Nothing - projections -> expectationFailure ("expected one projection, got " <> show (length projections)) - it "pins the canonical UTF-8 shape digest and runtime identities" $ do - spec <- specOf "test/fixtures/readmodel.keiro" - case [readModel | NReadModel readModel <- specNodes spec] of - (subscriptionModel : inlineModel : _) -> do - canonicalShape subscriptionModel - `shouldBe` "transfer_decisions|reservation_id:text:req|hospital_id:text:req|status:text:req|decided_at:timestamptz:null" - deriveShapeHash subscriptionModel `shouldBe` "fnv1a:3717f6d9e3c44bd6" - deriveShapeHash inlineModel `shouldBe` "fnv1a:f54d9bb2f40a6738" - registryNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions" - subscriptionNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions-sub" - subscriptionNameFor "billing" inlineModel `shouldBe` "billing-subscriptions-sub" - nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes)) - it "accepts the positive readmodel fixture with all references resolved" $ do - spec <- specOf "test/fixtures/readmodel.keiro" - validateSpec spec `shouldBe` [] - it "rejects shape drift and unknown SQL column types" $ do - codes <- errorCodesOf "test/fixtures/readmodel-shape-drift.keiro" - codes `shouldContain` [RmShapeHashDrift, RmUnknownColumnType] - it "rejects Strong on inline and standalone projections" $ do - inlineCodes <- errorCodesOf "test/fixtures/readmodel-strong-inline.keiro" - inlineCodes `shouldContain` [RmStrongInlineOnly] - standalone <- specOf "test/fixtures/readmodel-strong-standalone.keiro" - let diagnostics = validateSpec standalone - map code diagnostics `shouldContain` [RmStrongInlineOnly, RmProjectionWithoutNode] - [severity diagnostic | diagnostic <- diagnostics, code diagnostic == RmProjectionWithoutNode] - `shouldBe` [Warning] - it "rejects scope without Strong and an unreferenced inline feed" $ do - scopeCodes <- errorCodesOf "test/fixtures/readmodel-scope-eventual.keiro" - scopeCodes `shouldContain` [RmScopeWithoutStrong] - inlineCodes <- errorCodesOf "test/fixtures/readmodel-inline-unreferenced.keiro" - inlineCodes `shouldContain` [RmInlineFeedUnreferenced] - it "rejects projection consistency conflicts" $ do - codes <- errorCodesOf "test/fixtures/readmodel-consistency-conflict.keiro" - codes `shouldContain` [RmConsistencyConflict] - it "resolves query read models and validates query consistency" $ do - codes <- errorCodesOf "test/fixtures/readmodel-query-unresolved.keiro" - codes `shouldContain` [QueryUnresolvedReadModel, QueryConsistencyInvalid] - it "resolves dispatch read models and declared dedup columns" $ do - codes <- errorCodesOf "test/fixtures/readmodel-dispatch-unresolved.keiro" - codes `shouldContain` [DispatchReadModelUnresolved, DispatchReadModelFieldUnknown] - it "scaffolds runtime records, rebuild helpers, async wiring, and typed holes" $ do - spec <- specOf "test/fixtures/readmodel.keiro" - let ctx = defaultContext (specContext spec) - readModels = [readModel | NReadModel readModel <- specNodes spec] - modules = concatMap (scaffoldReadModel ctx) readModels - transfer = generatedTextEndingIn "Transfer_decisions/ReadModel.hs" modules - inline = generatedTextEndingIn "Subscriptions/ReadModel.hs" modules - transferHoles = [moduleText m | m <- modules, "Transfer_decisions/ReadModelHoles.hs" `T.isSuffixOf` T.pack (modulePath m)] - length modules `shouldBe` 6 - length [m | m <- modules, kind m == Generated] `shouldBe` 4 - length [m | m <- modules, kind m == HoleStub] `shouldBe` 2 - firewallBreaches modules `shouldBe` [] - transfer `shouldSatisfy` T.isInfixOf "registerTransferDecisions" - transfer `shouldSatisfy` T.isInfixOf "Rebuild.startRebuild transferDecisionsReadModel [\"hospital-capacity-transfer-decisions-async\"]" - transfer `shouldSatisfy` T.isInfixOf "strongScope = CategoryHead \"reservation\"" - transfer `shouldSatisfy` T.isInfixOf "transferDecisionsAsyncProjection" - inline `shouldSatisfy` T.isInfixOf "Rebuild.startRebuild subscriptionsReadModel []" - inline `shouldNotSatisfy` T.isInfixOf "AsyncProjection" - transferHoles `shouldSatisfy` any (T.isInfixOf "RecordedEvent -> Tx.Transaction ()") - it "threads qualified table and column guidance into aggregate projection holes" $ do - spec <- specOf "test/fixtures/readmodel.keiro" - case [aggregate | NAggregate aggregate <- specNodes spec] of - [aggregate] -> do - let modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate - holes = [moduleText m | m <- modules, kind m == HoleStub] - projection = generatedTextEndingIn "Projection.hs" modules - holes `shouldSatisfy` any (T.isInfixOf "subscriptionsQualifiedTable") - holes `shouldSatisfy` any (T.isInfixOf "Table: \"billing\".\"subscriptions\"") - projection `shouldSatisfy` T.isInfixOf "ReadModelTable.subscriptionsQualifiedTable" - aggregates -> expectationFailure ("expected one aggregate, got " <> show (length aggregates)) - it "emits runtime-free derivation facts for each read model" $ do - spec <- specOf "test/fixtures/readmodel.keiro" - case [readModel | NReadModel readModel <- specNodes spec] of - (subscriptionModel : _) -> do - let modules = harnessReadModel (defaultContext (specContext spec)) subscriptionModel - harnessText = generatedTextEndingIn "ReadModelHarness.hs" modules - length modules `shouldBe` 1 - firewallBreaches modules `shouldBe` [] - harnessText `shouldSatisfy` T.isInfixOf "(\"shapeHash\", \"fnv1a:3717f6d9e3c44bd6\", \"fnv1a:3717f6d9e3c44bd6\")" - harnessText `shouldSatisfy` T.isInfixOf "(\"strongScope\", \"CategoryHead reservation\", \"CategoryHead reservation\")" - harnessText `shouldSatisfy` T.isInfixOf "runReadModelFacts" - nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes)) - - describe "workflow/operation (EP-6)" $ do - it "round-trips the workflow spec through parse . pretty" $ do - input <- readTestText "test/fixtures/workflow.keiro" - case parseSpec "in" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec - it "accepts the workflow spec (await<->signal matches, run resolves)" $ do - codes <- errorCodesOf "test/fixtures/workflow.keiro" - codes `shouldBe` [] - it "rejects a signal label with no matching await as AwaitSignalMismatch" $ do - codes <- errorCodesOf "test/fixtures/workflow-signal-mismatch.keiro" - codes `shouldContain` [AwaitSignalMismatch] - it "rejects duplicate workflow labels" $ do - codes <- errorCodesOf "test/fixtures/workflow-dup-label.keiro" - codes `shouldContain` [WorkflowDuplicateLabel] - it "rejects unresolved workflow id and sleep fields" $ do - codes <- errorCodesOf "test/fixtures/workflow-unresolved-fields.keiro" - codes `shouldContain` [WorkflowIdFieldUnresolved, WorkflowSleepDelayUnresolved] - it "validates rule domains, totality, case constructors, and bodies" $ do - unresolved <- errorCodesOf "test/fixtures/rule-bad-domain.keiro" - unresolved `shouldBe` [RuleDomainUnresolved] - codes <- errorCodesOf "test/fixtures/rule-not-total.keiro" - mapM_ - (\expected -> codes `shouldContain` [expected]) - [RuleNotTotal, RuleCaseUnknownCtor, ClockSampled, GuardAtomOutOfScope] - it "rejects unresolved command operation references" $ do - codes <- errorCodesOf "test/fixtures/operation-ghost-aggregate.keiro" - codes `shouldContain` [OperationUnresolvedRef] - it "rejects a signal value type that differs from its await" $ do - codes <- errorCodesOf "test/fixtures/operation-signal-value.keiro" - codes `shouldContain` [AwaitSignalValueMismatch] - it "round-trips guarded patches and terminal continueAsNew" $ do - input <- readTestText "test/fixtures/workflow-evolution.keiro" - case parseSpec "workflow-evolution" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> do - parseSpec "workflow-evolution" (renderSpec spec) `shouldBe` Right spec - errorCodes spec `shouldBe` [] - it "rejects duplicate patch ids anywhere in the workflow body" $ do - codes <- errorCodesOf "test/fixtures/workflow-patch-dup.keiro" - codes `shouldBe` [WorkflowPatchDuplicate] - it "rejects non-terminal and nested continueAsNew" $ do - codes <- errorCodesOf "test/fixtures/workflow-can-mid.keiro" - codes `shouldBe` [WorkflowContinueAsNewNotTerminal, WorkflowContinueAsNewNotTerminal] - it "rejects a colon in a patch id with a workflow diagnostic" $ do - codes <- errorCodesOf "test/fixtures/workflow-patch-colon.keiro" - codes `shouldBe` [WorkflowPatchIdInvalid] - it "lowers patch facts and live runtime declarations" $ do - spec <- specOf "test/fixtures/workflow-evolution.keiro" - case [workflow | NWorkflow workflow <- specNodes spec] of - [workflow] -> do - let modules = harnessWorkflow (defaultContext (specContext spec)) workflow - facts = generatedTextEndingIn "WorkflowFacts.hs" modules - runtime = generatedTextEndingIn "WorkflowRuntime.hs" modules - facts `shouldSatisfy` T.isInfixOf "patch:fraud-check-v2(step:fraud-check)" - facts `shouldSatisfy` T.isInfixOf "continueAsNew:RolloverSeed" - facts `shouldSatisfy` T.isInfixOf "(\"patches\", \"fraud-check-v2\")" - runtime `shouldSatisfy` T.isInfixOf "declaredPatches = Set.fromList [PatchId \"fraud-check-v2\"]" - runtime `shouldSatisfy` T.isInfixOf "opts{activePatches = declaredPatches}" - workflows -> expectationFailure ("expected one workflow, got " <> show (length workflows)) - - describe "replay impact" $ do - it "treats new events and transitions as replay-neutral" $ do - old <- specOf "test/fixtures/reservation.keiro" - let aggregate = onlyAggregate old - case (aggEvents aggregate, aggTransitions aggregate) of - (event : _, transition : _) -> do - let newEvent = - event - { evName = "ReservationReviewed" - , evLoc = noLoc - } - newTransition = - transition - { tEmits = ["ReservationReviewed"] - , tLoc = noLoc - } - new = - modifyAggregate - "Reservation" - ( \candidate -> - candidate - { aggEvents = aggEvents candidate <> [newEvent] - , aggTransitions = aggTransitions candidate <> [newTransition] - } - ) - old - ReplayImpact.replayImpact old new `shouldBe` ReplayNeutral - _ -> expectationFailure "reservation fixture must contain an event and transition" - - it "narrows a guard edit to that transition's event types" $ do - impact <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened.keiro" - impact - `shouldBe` ReplayAffected - ( Map.singleton - "Reservation" - AggregateImpact - { eventTypes = Set.singleton "TransferReservationCreated" - , includeSnapshotStreams = True - } - ) - - it "proves a syntactic guard loosening replay-neutral" $ do - old <- specOf "test/fixtures/reservation.keiro" - let loosened = - modifyAggregate - "Reservation" - ( \aggregate -> - aggregate - { aggTransitions = - [ transition{tGuard = Nothing} - | transition <- aggTransitions aggregate - ] - } - ) - old - ReplayImpact.replayImpact old loosened `shouldBe` ReplayNeutral - - it "marks every existing event when the aggregate wire convention changes" $ do - impact <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-wire.keiro" - case impact of - ReplayAffected aggregates -> - ReplayImpact.eventTypes <$> Map.lookup "Reservation" aggregates - `shouldBe` Just (Set.fromList ["TransferReservationCreated", "TransferReservationConfirmed"]) - ReplayNeutral -> expectationFailure "expected a wire-clause replay impact" - - it "includes snapshot streams when a write expression changes" $ do - impact <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-foldchange.keiro" - case impact of - ReplayAffected aggregates -> - includeSnapshotStreams <$> Map.lookup "Reservation" aggregates - `shouldBe` Just True - ReplayNeutral -> expectationFailure "expected a fold replay impact" - - it "detects codec evolution and ignores formatting-only rewrites" $ do - changed <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v2.keiro" - changed `shouldSatisfy` (/= ReplayNeutral) - old <- specOf "test/fixtures/reservation.keiro" - formatted <- parseInlineSpec "" (renderSpec old) - ReplayImpact.replayImpact old formatted `shouldBe` ReplayNeutral - - it "names mapped nested event and snapshot roots while ignoring Haskell-only changes" $ do - nested <- replayImpactFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-nested-propagation.keiro" - case nested of - ReplayAffected aggregates -> - Map.lookup "Catalog" aggregates - `shouldBe` Just AggregateImpact{eventTypes = Set.singleton "ArtifactObserved", includeSnapshotStreams = True} - ReplayNeutral -> expectationFailure "expected nested mapped wire change to affect replay" - sourceOnly <- replayImpactFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-haskell-rename.keiro" - sourceOnly `shouldBe` ReplayNeutral - - it "generates one context target for every aggregate, including the process saga" $ do - spec <- specOf "test/fixtures/surge-service.keiro" - case scaffoldReplayAudit (defaultContext (specContext spec)) spec of - [assembly] -> do - modulePath assembly `shouldBe` "Generated/SurgeDemo/ReplayAudit.hs" - moduleText assembly `shouldSatisfy` T.isInfixOf "Hospital.hospitalEventStream" - moduleText assembly `shouldSatisfy` T.isInfixOf "Surge.surgeEventStream" - T.count " AuditTarget" (moduleText assembly) `shouldBe` 2 - assemblies -> expectationFailure ("expected one replay-audit assembly, got " <> show (length assemblies)) - - describe "diff (evolution classification)" $ do - it "covers every node family exactly once and explains exclusions" $ do - sort (map fst familyRegistry) `shouldBe` ([minBound .. maxBound] :: [NodeFamily]) - [reason | (_, OutOfDiffScope reason) <- familyRegistry, T.null reason] `shouldBe` [] - it "derives every exercised headline from its vector under the default gate" $ do - changes <- - concat - <$> mapM - (uncurry diffFixtures) - [ ("test/fixtures/reservation.keiro", "test/fixtures/reservation-fieldadd.keiro") - , ("test/fixtures/reservation.keiro", "test/fixtures/reservation-v2.keiro") - , ("test/fixtures/reservation.keiro", "test/fixtures/reservation-enumadd.keiro") - , ("test/fixtures/contract.keiro", "test/fixtures/contract-fieldadd.keiro") - , ("test/fixtures/reservation-work.keiro", "test/fixtures/reservation-work-rename.keiro") - ] - forM_ changes $ \change -> - do - deriveLabel defaultGate (ckVector (kindOfChange change)) - `shouldBe` labelOfChange change - gatedBreaking defaultGate change `shouldBe` isBreaking change - it "never removes a breaking result when the gate grows" $ - property $ - forAll genCompatibilityVector $ \compatibility -> - forAll genSurfaceSet $ \gate -> - forAll genSurfaceSet $ \extra -> - deriveLabel gate compatibility - == LabelBreaking - ==> deriveLabel (gate <> extra) compatibility - == LabelBreaking - it "renders the consumer-neutral matrix with separate private, snapshot, and public surfaces" $ do - changes <- diffFixtures "test/fixtures/compatibility-vector-old.keiro" "test/fixtures/compatibility-vector-new.keiro" - golden <- readTestText "test/fixtures/compatibility-vector.diff.golden" - let rendered = T.intercalate "\n" (map renderFinding changes) - explained = T.intercalate "\n" (map renderExplainBlock changes) - reportJson = T.pack (show (Aeson.toJSON (diffReport defaultGate changes))) - T.stripEnd rendered `shouldBe` T.stripEnd golden - rendered `shouldSatisfy` T.isInfixOf "Reservation.event.TransferReservationCreated.patientAcuity" - rendered `shouldSatisfy` T.isInfixOf "old-binary-read-new-events=breaking" - rendered `shouldSatisfy` T.isInfixOf "snapshot-hydration=advisory" - rendered `shouldSatisfy` T.isInfixOf "public-consumer=breaking" - explained `shouldSatisfy` T.isInfixOf "invalidate and rebuild snapshots" - reportJson `shouldSatisfy` T.isInfixOf "keiro-dsl/diff-report/1" - reportJson `shouldSatisfy` T.isInfixOf "Reservation.event.TransferReservationCreated.patientAcuity" - let eventEnumFindings = - [ change - | change@(Advisory kind) <- changes - , ckCode kind == EnumCtorAdded - , verdictFor OldBinaryReadNewEvents (ckVector kind) == VBreaking - ] - eventEnumFindings `shouldSatisfy` all (not . gatedBreaking defaultGate) - eventEnumFindings `shouldSatisfy` all (gatedBreaking (gateWith [OldBinaryReadNewEvents])) - forM_ changes $ \change -> - remediationFor (ckContext (kindOfChange change)) (ckCode (kindOfChange change)) - `shouldSatisfy` (not . null) - it "rejects unknown --gate values with the valid surface list" $ do - parseSurfaceName "mystery-surface" - `shouldSatisfy` either (T.isInfixOf "old-binary-read-new-events" . T.pack) (const False) - it "covers the mapped evolution matrix with stable codes and non-empty remedies" $ do - let cases = - [ ("consumer-types-fieldadd-default.keiro", MappedFieldAddedWithDefault) - , ("consumer-types-fieldadd-nodefault.keiro", MappedFieldAddedNoDefault) - , ("consumer-types-fieldremove.keiro", MappedFieldRemoved) - , ("consumer-types-wirekey.keiro", MappedWireKeyChanged) - , ("consumer-types-haskell-rename.keiro", MappedHaskellSourceChanged) - , ("consumer-types-binding-change.keiro", MappedBindingChanged) - , ("consumer-types-fixtures-change.keiro", MappedFixturesChanged) - , ("consumer-types-initial-change.keiro", MappedInitialChanged) - , ("consumer-types-armadd.keiro", MappedArmAdded) - , ("consumer-types-tagchange.keiro", MappedArmTagChanged) - , ("consumer-types-enumadd.keiro", MappedEnumValueAdded) - , ("consumer-types-enumremove.keiro", MappedEnumValueRemoved) - , ("consumer-types-enumspelling.keiro", MappedEnumSpellingChanged) - , ("consumer-types-encoding.keiro", MappedUnionEncodingChanged) - , ("consumer-types-opaque-version.keiro", MappedOpaqueCodecChanged) - , ("consumer-types-mode-cross.keiro", MappedModeCrossed) - , ("consumer-types-nested-propagation.keiro", MappedArmTagChanged) - ] - forM_ cases $ \(fixture, expectedCode) -> do - changes <- diffFixtures "test/fixtures/consumer-types.keiro" ("test/fixtures/" <> fixture) - map (ckCode . kindOfChange) changes `shouldContain` [expectedCode] - forM_ changes $ \change -> - remediationFor (ckContext (kindOfChange change)) (ckCode (kindOfChange change)) - `shouldSatisfy` (not . null) - it "separates mapped event migration, snapshot invalidation, and directional rollout" $ do - breakingAdd <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-fieldadd-nodefault.keiro" - let noDefault = [change | change <- breakingAdd, ckCode (kindOfChange change) == MappedFieldAddedNoDefault] - [ckFacet kind | Breaking kind <- noDefault] `shouldContain` ["mapped-event"] - [ckFacet kind | Advisory kind <- noDefault] `shouldContain` ["mapped-register"] - defaulted <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-fieldadd-default.keiro" - [change | change <- defaulted, isBreaking change] `shouldBe` [] - let eventDefaults = [kind | Advisory kind <- defaulted, ckCode kind == MappedFieldAddedWithDefault, ckFacet kind == "mapped-event"] - eventDefaults `shouldSatisfy` any ((== VBreaking) . verdictFor OldBinaryReadNewEvents . ckVector) - armAdded <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-armadd.keiro" - [change | change <- armAdded, isBreaking change] `shouldBe` [] - [kind | Advisory kind <- armAdded, ckCode kind == MappedArmAdded, ckFacet kind == "mapped-event"] - `shouldSatisfy` any ((== VBreaking) . verdictFor OldBinaryReadNewEvents . ckVector) - it "propagates a nested mapped leaf to complete command, event, and register paths" $ do - changes <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-nested-propagation.keiro" - let subjects = - [ ckSubject kind - | change <- changes - , let kind = kindOfChange change - , ckCode kind == MappedArmTagChanged - ] - subjects - `shouldContain` [ "Catalog command ObserveArtifact .artifact : ArtifactInfo .location : ArtifactLocation .arm RepoPath[\"repository_path\"]" - , "Catalog event ArtifactObserved .artifact : ArtifactInfo .location : ArtifactLocation .arm RepoPath[\"repository_path\"]" - , "Catalog register currentArtifact : ArtifactInfo .location : ArtifactLocation .arm RepoPath[\"repository_path\"]" - ] - it "classifies every remaining mapped field and declaration evolution row" $ do - base <- specOf "test/fixtures/consumer-types.keiro" - let mutationCodes = - [ (mapArtifactNamedField "key" (\field -> field{wfType = TInt}) base, MappedFieldTypeChanged) - , (mapArtifactNamedField "key" (\field -> field{wfPresence = POptional, wfOnMissing = Just (OmText "")}) base, MappedPresenceChanged) - , (mapArtifactNamedField "key" (\field -> field{wfType = TOptional TText}) base, MappedNullabilityChanged) - , (mapArtifactNamedField "description" (\field -> field{wfOnMissing = Nothing}) base, MappedDefaultRemoved) - , (mapArtifactNamedField "count" (\field -> field{wfOnMissing = Just (OmInt 1)}) base, MappedDefaultChanged) - , (mapMappedStructural "ArtifactInfo" renameMappedRecordConstructor base, MappedRecordConstructorChanged) - , (mapMappedStructural "ArtifactInfo" changeMappedCanonical base, MappedCanonicalTypeChanged) - ] - forM_ mutationCodes $ \(candidate, expectedCode) -> - map (ckCode . kindOfChange) (diffSpecs base candidate) `shouldContain` [expectedCode] - let declarationA = completeStructural "A" (recordShape [TText]) - declarationB = completeStructural "B" (recordShape [TInt]) - onlyA = mappedSpec [declarationA] - withB = mappedSpec [declarationA, declarationB] - map (ckCode . kindOfChange) (diffSpecs onlyA withB) `shouldContain` [MappedDeclAdded] - map (ckCode . kindOfChange) (diffSpecs withB onlyA) `shouldContain` [MappedDeclRemoved] - diffSpecs base (mapArtifactNamedField "key" (\field -> field{wfHaskell = "renamedKey"}) base) - `shouldBe` [] - it "visits every mapped wire mutation and reports every complete root path" $ do - base <- specOf "test/fixtures/consumer-types.keiro" - let mutations = mappedWireMutations base - mutations `shouldSatisfy` (not . null) - visited <- fmap Set.unions . forM mutations $ \mutation -> do - let changes = - [ change - | change <- diffSpecs base (mmCandidate mutation) - , ckCode (kindOfChange change) == mmCode mutation - ] - actualSubjects = Set.fromList (map (ckSubject . kindOfChange) changes) - changes `shouldSatisfy` any (not . isAdditiveChange) - actualSubjects `shouldBe` mmExpectedSubjects mutation - pure actualSubjects - visited `shouldBe` Set.unions (map mmExpectedSubjects mutations) - it "reports the exact ingredient code when every required mapped fact is deleted" $ do - base <- specOf "test/fixtures/consumer-types.keiro" - forM_ (mappedIngredientMutations base) $ \(candidate, expectedCode) -> - errorCodes candidate `shouldContain` [expectedCode] - it "classifies a field added without a version bump as BREAKING" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldadd.keiro" - any isBreaking cs `shouldBe` True - [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldAddedWithoutBump] - it "classifies the same field wrapped as v2 + upcaster as ADDITIVE" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v2.keiro" - any isBreaking cs `shouldBe` False - [ck | Additive ck <- cs] `shouldSatisfy` any ((== "TransferReservationCreated") . ckSubject) - it "reports no breaking change when the spec is unchanged" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation.keiro" - any isBreaking cs `shouldBe` False - it "classifies a direct event field type change as EvtFieldTypeChanged" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldtype.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldTypeChanged] - it "resolves fields(Command) before comparing event field types" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-cmdfieldtype.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldTypeChanged] - it "uses EvtFieldRemovedSameVersion for an unchanged-version removal" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldremove.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldRemovedSameVersion] - it "uses EvtVersionDecreased for a version decrease" $ do - cs <- diffFixtures "test/fixtures/reservation-v2.keiro" "test/fixtures/reservation.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [EvtVersionDecreased] - it "rejects a v1 to v3 jump whose only upcaster starts at v2" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v3-dangling.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [EvtVersionMissingUpcaster] - it "classifies a vanished historical upcaster rung as UpcasterChainGap" $ do - cs <- diffFixtures "test/fixtures/reservation-v2.keiro" "test/fixtures/reservation-chain-gap.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [UpcasterChainGap] - it "classifies an enum constructor removal as EnumCtorRemoved" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumdrop.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [EnumCtorRemoved] - it "classifies an enum wire-spelling change as EnumWireSpellingChanged" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumwire.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [EnumWireSpellingChanged] - it "classifies an enum constructor addition per use site as advisory" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumadd.keiro" - any isBreaking cs `shouldBe` False - let enumFindings = [k | Advisory k <- cs, ckCode k == EnumCtorAdded] - [ckSubject k | k <- enumFindings] `shouldContain` ["BlackTag"] - [verdictFor SnapshotHydration (ckVector k) | k <- enumFindings] - `shouldContain` [VAdvisory] - it "classifies an effective wire convention change as WireSpecChanged" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-wire.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [WireSpecChanged] - it "advises when the aggregate fold surface changes" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-foldchange.keiro" - any isBreaking cs `shouldBe` False - [ckCode k | Advisory k <- cs] `shouldContain` [AggFoldSurfaceChanged] - it "advises on hazardous deprecation and reports un-deprecation" $ do - deprecated <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-deprecated.keiro" - any isBreaking deprecated `shouldBe` False - [ckCode k | Advisory k <- deprecated] `shouldContain` [DeprecatedEventReplayHazard] - restored <- diffFixtures "test/fixtures/reservation-deprecated.keiro" "test/fixtures/reservation.keiro" - any isAdvisory restored `shouldBe` True - [ckCode k | Advisory k <- restored] `shouldContain` [EventUndeprecated] - it "recognises replay-only deprecation as a replay-safe retirement cutover" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-deprecated-replay-only.keiro" - any isBreaking cs `shouldBe` False - [ckCode k | Advisory k <- cs] `shouldContain` [EventRetirementInProgress] - [ckCode k | Advisory k <- cs] `shouldNotContain` [DeprecatedEventReplayHazard] - it "advises when event retirement starts" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-retiring.keiro" - any isBreaking cs `shouldBe` False - [ckCode k | Advisory k <- cs] `shouldContain` [EventRetirementInProgress] - it "does not recommend decode-only deprecation for an event removal" $ do - old <- specOf "test/fixtures/reservation.keiro" - let new = - old - { specNodes = - [ case node of - NAggregate aggregate -> - NAggregate - aggregate - { aggEvents = - [ event - | event <- aggEvents aggregate - , evName event /= "TransferReservationConfirmed" - ] - } - _ -> node - | node <- specNodes old - ] - } - removals = [change | change@(Breaking kind) <- diffSpecs old new, ckCode kind == EvtRemovedNotDeprecated] - removals `shouldSatisfy` (not . null) - [ckDetail kind | Breaking kind <- removals] - `shouldSatisfy` all (not . T.isInfixOf "so old payloads still decode") - it "prints a paste-ready replay-only twin when a guard tightens (plan 143)" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened.keiro" - any isBreaking cs `shouldBe` False - let advisories = [k | Advisory k <- cs, ckCode k == AggGuardTightened] - map ckSubject advisories `shouldBe` ["Unrequested -- RequestTransferReservation"] - detail <- case advisories of - [k] -> pure (ckDetail k) - other -> expectationFailure ("expected one advisory, got " <> show other) >> pure "" - detail `shouldSatisfy` T.isInfixOf "replay-only Unrequested -- RequestTransferReservation" - -- The printed twin is paste-ready: appended to the new spec it - -- parses, validates without errors, and silences the advisory. - tightened <- readTestText "test/fixtures/reservation-guard-tightened.keiro" - let twinText = snd (T.breakOnEnd "\n\n" detail) - pasted = tightened <> "\n" <> twinText <> "\n" - case parseSpec "" pasted of - Left err -> expectationFailure (T.unpack err) - Right pastedSpec -> do - [code d | d <- validateSpec pastedSpec, severity d == Error] `shouldBe` [] - base <- specOf "test/fixtures/reservation.keiro" - [k | Advisory k <- diffSpecs base pastedSpec, ckCode k == AggGuardTightened] - `shouldBe` [] - it "omits the twin advisory when the twin is already present (plan 143)" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened-twin.keiro" - [k | Advisory k <- cs, ckCode k == AggGuardTightened] `shouldBe` [] - it "classifies a removed contract event as ContractEventRemoved" $ do - cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventdrop.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [ContractEventRemoved] - it "classifies contract field type changes and unversioned additions as ContractFieldChanged" $ do - changed <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldtype.keiro" - [ckCode k | Breaking k <- changed] `shouldContain` [ContractFieldChanged] - added <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldadd.keiro" - [ckCode k | Breaking k <- added] `shouldContain` [ContractFieldChanged] - it "reports a field addition with a contract version bump as an advisory" $ do - cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-bump-fieldadd.keiro" - any isBreaking cs `shouldBe` False - [ckCode k | Advisory k <- cs] `shouldContain` [ContractSchemaVersionBumped] - it "classifies a contract schema version decrease separately" $ do - cs <- diffFixtures "test/fixtures/contract-bump-fieldadd.keiro" "test/fixtures/contract.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [ContractSchemaVersionDecreased] - it "classifies contract topic and discriminator changes separately" $ do - topic <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-topic.keiro" - [ckCode k | Breaking k <- topic] `shouldContain` [ContractTopicChanged] - discriminator <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-discriminator.keiro" - [ckCode k | Breaking k <- discriminator] `shouldContain` [ContractDiscriminatorChanged] - it "classifies a new contract event as additive" $ do - cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventadd.keiro" - any isBreaking cs `shouldBe` False - [ckSubject k | Additive k <- cs] `shouldContain` ["IncidentTransferNeedCancelled"] - it "classifies workqueue wire names, types, and required additions as WqPayloadFieldChanged" $ do - wire <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-wirename.keiro" - [ckCode k | Breaking k <- wire] `shouldContain` [WqPayloadFieldChanged] - fieldTypeChange <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-fieldtype.keiro" - [ckCode k | Breaking k <- fieldTypeChange] `shouldContain` [WqPayloadFieldChanged] - required <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-reqfield.keiro" - [ckCode k | Breaking k <- required] `shouldContain` [WqPayloadFieldChanged] - it "classifies a new optional workqueue payload field as additive" $ do - cs <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-optfield.keiro" - any isBreaking cs `shouldBe` False - [ckSubject k | Additive k <- cs] `shouldContain` ["note"] - it "classifies workqueue ordering changes as breaking delivery-contract changes" $ do - cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-ordering-change.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [WqOrderingChanged] - [ckDetail k | Breaking k <- cs, ckCode k == WqOrderingChanged] - `shouldSatisfy` any (T.isInfixOf "delivery-order contract") - it "classifies workqueue provision changes as operational migrations" $ do - cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-provision-change.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [WqProvisionChanged] - [ckDetail k | Breaking k <- cs, ckCode k == WqProvisionChanged] - `shouldSatisfy` any (T.isInfixOf "migrate the existing queue operationally") - it "classifies workqueue group-key changes as breaking repartitioning" $ do - cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-group-key-change.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [WqGroupKeyChanged] - [ckDetail k | Breaking k <- cs, ckCode k == WqGroupKeyChanged] - `shouldSatisfy` any (T.isInfixOf "re-partitioned") - it "classifies a process input type change as ProcessInputChanged" $ do - cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-inputtype.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [ProcessInputChanged] - it "classifies workflow input and output changes as WorkflowShapeChanged" $ do - input <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-inputfield.keiro" - [ckCode k | Breaking k <- input] `shouldContain` [WorkflowShapeChanged] - output <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-output.keiro" - [ckCode k | Breaking k <- output] `shouldContain` [WorkflowShapeChanged] - it "classifies workflow relabeling and appends as WorkflowBodyChanged" $ do - relabeled <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-body.keiro" - [ckCode k | Breaking k <- relabeled] `shouldContain` [WorkflowBodyChanged] - appended <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-stepadd.keiro" - [ckCode k | Breaking k <- appended] `shouldContain` [WorkflowBodyChanged] - [ckDetail k | Breaking k <- appended, ckCode k == WorkflowBodyChanged] - `shouldSatisfy` any (T.isInfixOf "new patch guard") - it "classifies a body addition wholly guarded by a new patch as additive" $ do - cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-evolution-diff.keiro" - any isBreaking cs `shouldBe` False - [ckSubject k | Additive k <- cs, ckFacet k == "workflow-patch"] `shouldContain` ["fraud-check-v2"] - [ckSubject k | Additive k <- cs, ckFacet k == "workflow-continue-as-new"] `shouldContain` ["RolloverSeed"] - it "classifies removing an existing patch as breaking" $ do - cs <- diffFixtures "test/fixtures/workflow-evolution-diff.keiro" "test/fixtures/workflow-continue.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [WorkflowPatchRemoved] - [ckDetail k | Breaking k <- cs, ckCode k == WorkflowPatchRemoved] - `shouldSatisfy` any (T.isInfixOf "cannot prove") - it "classifies terminal continueAsNew append as additive and seed drift as breaking" $ do - appended <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-continue.keiro" - any isBreaking appended `shouldBe` False - [ckFacet k | Additive k <- appended] `shouldContain` ["workflow-continue-as-new"] - changed <- diffFixtures "test/fixtures/workflow-continue.keiro" "test/fixtures/workflow-continue-seed-v2.keiro" - [ckCode k | Breaking k <- changed] `shouldContain` [WorkflowContinueSeedChanged] - [ckDetail k | Breaking k <- changed, ckCode k == WorkflowContinueSeedChanged] - `shouldSatisfy` any (T.isInfixOf "restoreSeed") - it "classifies a workflow stable-name change as WorkflowStableNameChanged" $ do - cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-rename.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [WorkflowStableNameChanged] - it "classifies workflow id-derivation changes as DerivedIdentityChanged" $ do - cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-idfield.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [DerivedIdentityChanged] - it "classifies an id prefix change as IdPrefixChanged" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-idprefix.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [IdPrefixChanged] - it "classifies intake dedupe key and policy changes as DedupeIdentityChanged" $ do - policy <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-dedupepolicy.keiro" - [ckCode k | Breaking k <- policy] `shouldContain` [DedupeIdentityChanged] - key <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-dedupekey.keiro" - [ckCode k | Breaking k <- key] `shouldContain` [DedupeIdentityChanged] - it "reports intake decode-posture changes as warnings" $ do - cs <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-decode.keiro" - any isBreaking cs `shouldBe` False - [ckCode k | Advisory k <- cs] `shouldContain` [DecodePostureChanged] - [ckCode k | Advisory k <- cs] `shouldContain` [IntakePersistenceChanged] - it "classifies process and timer derivation changes as DerivedIdentityChanged" $ do - processName <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-procname.keiro" - [ckCode k | Breaking k <- processName] `shouldContain` [DerivedIdentityChanged] - timerId <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-timerid.keiro" - [ckCode k | Breaking k <- timerId] `shouldContain` [DerivedIdentityChanged] - base <- specOf "test/fixtures/hospital-surge.keiro" - let categoryChange = diffSpecs base (modifyProcess "HospitalSurge" (\process -> process{procSaga = (procSaga process){sagaCategory = "hospitalSurgeV2"}}) base) - [ckCode k | Breaking k <- categoryChange] `shouldContain` [DerivedIdentityChanged] - it "classifies router stable names, keys, and targets as identity-bearing" $ do - base <- specOf "test/fixtures/incident-paging/incident-paging.keiro" - let stableName = diffSpecs base (modifyRouter "PagingRouter" (\router -> router{rtName = "paging-v2"}) base) - keyDerivation = diffSpecs base (modifyRouter "PagingRouter" (\router -> router{rtKey = (rtKey router){corrVia = "otherIdText"}}) base) - target = diffSpecs base (modifyRouter "PagingRouter" (\router -> router{rtTarget = "OtherPage"}) base) - [ckCode k | Breaking k <- stableName] `shouldContain` [RouterStableNameChanged] - [ckCode k | Breaking k <- keyDerivation] `shouldContain` [DerivedIdentityChanged] - [ckCode k | Breaking k <- target] `shouldContain` [DerivedIdentityChanged] - it "advises on router dispatch-surface changes without making them breaking" $ do - cs <- diffFixtures "test/fixtures/incident-paging/incident-paging.keiro" "test/fixtures/incident-paging/incident-paging-dispatch.keiro" - any isBreaking cs `shouldBe` False - [ckCode k | Advisory k <- cs] `shouldBe` [RouterDecideSurfaceChanged] - it "advises on process dispatch-surface changes without making them breaking" $ do - cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-handle.keiro" - any isBreaking cs `shouldBe` False - [ckCode k | Advisory k <- cs] `shouldBe` [ProcessDecideSurfaceChanged] - it "advises on unversioned timer payload changes without making them breaking" $ do - cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-payload.keiro" - any isBreaking cs `shouldBe` False - [ckCode k | Advisory k <- cs] `shouldBe` [ProcessTimerPayloadChanged] - it "ignores formatting-only process and timer surface rewrites" $ do - original <- specOf "test/fixtures/hospital-surge.keiro" - formatted <- parseInlineSpec "" (renderSpec original) - diffSpecs original formatted `shouldBe` [] - it "reports a timer window change as a warning" $ do - cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-window.keiro" - any isBreaking cs `shouldBe` False - [ckCode k | Advisory k <- cs] `shouldContain` [TimerWindowChanged] - it "reports emit-map changes as warnings and derive changes as breaking" $ do - mapping <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-mapchange.keiro" - any isBreaking mapping `shouldBe` False - [ckCode k | Advisory k <- mapping] `shouldContain` [EmitMappingChanged] - derive <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-derive.keiro" - [ckCode k | Breaking k <- derive] `shouldContain` [DerivedIdentityChanged] - it "classifies publisher outbox identity and ordering independently" $ do - outbox <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-outboxfield.keiro" - [ckCode k | Breaking k <- outbox] `shouldContain` [DerivedIdentityChanged] - ordering <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-ordering.keiro" - any isBreaking ordering `shouldBe` False - [ckCode k | Advisory k <- ordering] `shouldContain` [PublisherPolicyChanged] - it "classifies workqueue names as QueueIdentityChanged" $ do - cs <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-rename.keiro" - [ckCode k | Breaking k <- cs] `shouldContain` [QueueIdentityChanged] - it "classifies pgmq dispatch dedupe and retargeting independently" $ do - dedupe <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-dedupkey.keiro" - [ckCode k | Breaking k <- dedupe] `shouldContain` [DedupeIdentityChanged] - retarget <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-retarget.keiro" - any isBreaking retarget `shouldBe` False - [ckCode k | Advisory k <- retarget] `shouldContain` [DispatchRetargeted] - it "reports aggregate projection changes as warnings" $ do - cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-projection.keiro" - any isBreaking cs `shouldBe` False - [ckCode k | Advisory k <- cs] `shouldContain` [ProjectionChanged] - it "classifies read-model version and unversioned shape changes" $ do - base <- specOf "test/fixtures/readmodel-runtime.keiro" - let versionTwo = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmVersion = 2}) base - changedShape = modifyReadModel "transfer_decisions" changeReadModelShape base - bumpedShape = modifyReadModel "transfer_decisions" (\readModel -> (changeReadModelShape readModel){rmVersion = 2}) base - decreased = diffSpecs versionTwo base - unversioned = diffSpecs base changedShape - bumped = diffSpecs base bumpedShape - [ckCode k | Breaking k <- decreased] `shouldContain` [ReadModelVersionDecreased] - [ckCode k | Breaking k <- unversioned] `shouldContain` [ReadModelShapeChangedWithoutBump] - any isBreaking bumped `shouldBe` False - [ckFacet k | Additive k <- bumped] `shouldContain` ["read-model-version"] - it "classifies read-model registry, table, subscription, and removal identities" $ do - base <- specOf "test/fixtures/readmodel-runtime.keiro" - let tableChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmTable = "transfer_decisions_v2"}) base - subscriptionChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmSubscription = Just "transfer-decisions-v2"}) base - renamed = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmName = "reservation_decisions"}) base - removed = removeReadModel "transfer_decisions" base - mapM_ - (\changes -> [ckCode k | Breaking k <- changes] `shouldContain` [DerivedIdentityChanged]) - [diffSpecs base tableChanged, diffSpecs base subscriptionChanged, diffSpecs base renamed, diffSpecs base removed] - it "classifies read-model feed flips and consistency/scope weakening as breaking" $ do - base <- specOf "test/fixtures/readmodel-runtime.keiro" - let feedChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmFeed = RmInline}) base - consistencyWeakened = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmConsistency = Eventual}) base - entireLog = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmScope = Just RmEntireLog}) base - [ckCode k | Breaking k <- diffSpecs base feedChanged] `shouldContain` [ReadModelFeedChanged] - [ckCode k | Breaking k <- diffSpecs base consistencyWeakened] `shouldContain` [ReadModelConsistencyWeakened] - [ckCode k | Breaking k <- diffSpecs entireLog base] `shouldContain` [ReadModelConsistencyWeakened] - it "classifies Eventual to Strong read-model consistency as additive" $ do - strong <- specOf "test/fixtures/readmodel-runtime.keiro" - let eventual = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmConsistency = Eventual}) strong - changes = diffSpecs eventual strong - any isBreaking changes `shouldBe` False - [ckFacet k | Additive k <- changes] `shouldContain` ["read-model-consistency"] - - describe "module placement (M1)" $ do - it "GeneratedPrefix is today's namespace (Generated.., holes at .)" $ do - let ctx = defaultContext "hospital-capacity" - genPrefixFor ctx "Reservation" `shouldBe` "Generated.HospitalCapacity.Reservation" - holePrefixFor ctx "Reservation" `shouldBe` "HospitalCapacity.Reservation" - it "module-root prefixes both layers" $ do - let ctx = (defaultContext "hospital-capacity"){moduleRoot = "Acme"} - genPrefixFor ctx "Reservation" `shouldBe` "Acme.Generated.HospitalCapacity.Reservation" - holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation" - it "CollocatedLeaf places the generated layer under the domain leaf" $ do - let ctx = (defaultContext "hospital-capacity"){moduleRoot = "Acme", placement = CollocatedLeaf} - genPrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation.Generated" - holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation" - it "parses and preserves the module/layout clauses through parse . pretty" $ do - let src = "context hospital-capacity\nmodule Acme.Services\nlayout collocated\n\naggregate Reservation\n regs\n states Open\n" - case parseSpec "" src of - Left err -> expectationFailure (T.unpack err) - Right spec -> do - specModuleRoot spec `shouldBe` Just "Acme.Services" - specLayout spec `shouldBe` Just CollocatedLeaf - parseSpec "" (renderSpec spec) `shouldBe` Right spec - it "a spec without the clauses leaves placement at the default" $ do - input <- readTestText "test/fixtures/reservation.keiro" - case parseSpec "test/fixtures/reservation.keiro" input of - Left err -> expectationFailure (T.unpack err) - Right spec -> do - specModuleRoot spec `shouldBe` Nothing - specLayout spec `shouldBe` Nothing - - describe "structural scaffold" $ do - it "emits one private shape module per structural declaration and one context facade" $ do - spec <- specOf "test/fixtures/consumer-types.keiro" - let modules = scaffoldModules (defaultContext (specContext spec)) spec - paths = map modulePath modules - paths - `shouldContain` [ "Generated/ConsumerDemo/Structural/Shape/ArtifactInfo.hs" - , "Generated/ConsumerDemo/Structural/Shape/ArtifactKind.hs" - , "Generated/ConsumerDemo/Structural/Shape/ArtifactLocation.hs" - , "Generated/ConsumerDemo/StructuralProjections.hs" - ] - paths `shouldNotContain` ["Generated/ConsumerDemo/Structural/Shape/VendorGeometry.hs"] - firewallBreaches modules `shouldBe` [] - it "emits one create-once binding skeleton per owning module and derives Generic for private shapes" $ do - spec <- specOf "test/fixtures/consumer-types.keiro" - let modules = scaffoldModules (defaultContext (specContext spec)) spec - skeletons = [moduleValue | moduleValue <- modules, kind moduleValue == HoleStub, modulePath moduleValue == "Example/Artifact/KeiroBindings.hs"] - shape = generatedTextEndingIn "Structural/Shape/ArtifactInfo.hs" modules - case skeletons of - [skeleton] -> do - moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactInfoBinding :: StructuralBinding" - moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactKindBinding :: StructuralBinding" - moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactLocationBinding :: StructuralBinding" - moduleText skeleton `shouldSatisfy` T.isInfixOf "HOLE: fill ArtifactInfo bindingToShape.key" - _ -> expectationFailure ("expected exactly one shared binding skeleton, got " <> show (map modulePath skeletons)) - shape `shouldSatisfy` T.isInfixOf "deriving stock (Eq, Generic, Show)" - shape `shouldSatisfy` T.isInfixOf "import GHC.Generics (Generic)" - it "never overwrites an existing binding skeleton" $ - withTempDirectory "keiro-dsl-binding-create-once" $ \out -> do - spec <- specOf "test/fixtures/consumer-types.keiro" - let ctx = defaultContext (specContext spec) - bindingPath = out "Example/Artifact/KeiroBindings.hs" - _ <- executePlannedScaffold out "consumer-types.keiro" ctx spec - TIO.writeFile bindingPath "hand-owned binding\n" - second <- executePlannedScaffold out "consumer-types.keiro" ctx spec - TIO.readFile bindingPath `shouldReturn` "hand-owned binding\n" - reportDispositions second - `shouldSatisfy` any (\(moduleValue, disposition) -> modulePath moduleValue == "Example/Artifact/KeiroBindings.hs" && disposition == Skipped) - it "fresh binding skeletons compile at the application boundary" $ - withTempDirectory "keiro-dsl-binding-compiles" $ \out -> do - spec <- specOf "test/fixtures/structural-conformance.keiro" - let ctx = defaultContext (specContext spec) - bindingSource = out "Conformance/Structural/Bindings.hs" - ghcOutput = out ".ghc" - _ <- executePlannedScaffold out "structural-conformance.keiro" ctx spec - createDirectoryIfMissing True ghcOutput - (exitCode, standardOutput, standardError) <- - readProcessWithExitCode - "cabal" - [ "exec" - , "--" - , "ghc" - , "-XGHC2024" - , "-XOverloadedStrings" - , "-fno-code" - , "-fforce-recomp" - , "-outputdir" - , ghcOutput - , "-i" <> out - , "-itest/conformance-structural" - , "-i../keiro-core/src" - , bindingSource - ] - "" - unless (exitCode == ExitSuccess) $ - expectationFailure (standardOutput <> standardError) - it "keeps consumer types in Domain while the generated Codec owns keys, tags, and defaults" $ do - spec <- specOf "test/fixtures/consumer-types.keiro" - let modules = scaffoldModules (defaultContext (specContext spec)) spec - domain = generatedTextEndingIn "Catalog/Domain.hs" modules - codec = generatedTextEndingIn "Catalog/Codec.hs" modules - domain `shouldSatisfy` T.isInfixOf "Example.Artifact.Domain.ArtifactInfo" - domain `shouldSatisfy` T.isInfixOf "Vendor.Geometry.Geometry" - domain `shouldSatisfy` T.isInfixOf "Example.Artifact.KeiroBindings.emptyArtifactInfo" - codec `shouldSatisfy` T.isInfixOf "\"location\" .= encodeArtifactLocationShape" - codec `shouldSatisfy` T.isInfixOf "\"local_file\"" - codec `shouldSatisfy` T.isInfixOf "Nothing -> pure Generated.ConsumerDemo.Structural.Shape.ArtifactKind.Guide" - codec `shouldSatisfy` T.isInfixOf "rejectUnknownFields \"ArtifactInfo\"" - codec `shouldSatisfy` T.isInfixOf "toJSON payload.geometry" - codec `shouldSatisfy` (not . T.isInfixOf "vendor.geometry.json") - it "generates shape-only nested types and schema-derived Keiki witnesses" $ do - spec <- specOf "test/fixtures/consumer-types.keiro" - let modules = scaffoldModules (defaultContext (specContext spec)) spec - shape = generatedTextEndingIn "Structural/Shape/ArtifactInfo.hs" modules - facade = generatedTextEndingIn "StructuralProjections.hs" modules - shape `shouldSatisfy` T.isInfixOf "data ArtifactInfoShape = ArtifactInfo" - shape `shouldSatisfy` T.isInfixOf "ArtifactKind.ArtifactKindShape" - shape `shouldSatisfy` (not . T.isInfixOf "KeiroBindings") - facade `shouldSatisfy` T.isInfixOf "type FieldName" - facade `shouldSatisfy` T.isInfixOf "= \"/key\"" - facade `shouldSatisfy` T.isInfixOf "fieldShapeId _ = \"example.artifact.ArtifactInfo.v1\"" - facade `shouldSatisfy` T.isInfixOf "bindingToShape Example.Artifact.KeiroBindings.artifactInfoBinding owner" - - describe "structural manifest" $ do - it "lists consumer packages and every domain, binding, fixture, and initial module" $ do - spec <- specOf "test/fixtures/consumer-types.keiro" - let modules = scaffoldModules (defaultContext (specContext spec)) spec - manifest = renderManifest "consumer-types.keiro" modules spec - mapM_ (\packageName -> manifestDependencies spec `shouldContain` [packageName]) ["artifact-domain", "vendor-geometry"] - manifest `shouldSatisfy` T.isInfixOf "consumer-packages:\n artifact-domain\n vendor-geometry" - mapM_ - (\moduleName -> manifest `shouldSatisfy` T.isInfixOf moduleName) - [ "Example.Artifact.Domain" - , "Example.Artifact.KeiroBindings" - , "Vendor.Geometry" - , "Vendor.Geometry.KeiroBindings" - ] - - describe "structural scaffold record" $ do - it "round-trips canonical mapping rows and reports binding drift on the next run" $ - withTempDirectory "keiro-dsl-mapping-record" $ \out -> do - spec <- specOf "test/fixtures/consumer-types.keiro" - let ctx = defaultContext (specContext spec) - first <- executePlannedScaffold out "consumer-types.keiro" ctx spec - length (consumerMappings (reportConsumerPlan first)) `shouldBe` 4 - recordText <- TIO.readFile (out recordFileName (specContext spec)) - let mappingRows = filter (T.isPrefixOf "mapping ") (T.lines recordText) - bindingRows = filter (T.isPrefixOf "binding ") (T.lines recordText) - length mappingRows `shouldBe` 4 - bindingRows `shouldSatisfy` (not . null) - fmap recMappings (parseRecord recordText) `shouldSatisfy` maybe False ((== 4) . length) - fmap recBindingObligations (parseRecord recordText) `shouldSatisfy` maybe False ((== length bindingRows) . length) - let bumped = spec{specMapped = map bumpArtifactBindingVersion (specMapped spec)} - second <- executePlannedScaffold out "consumer-types.keiro" ctx bumped - reportMappingDrift second - `shouldSatisfy` any (\drift -> driftSpecName drift == "ArtifactInfo" && driftPrevious drift /= driftCurrent drift) - renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "mapping drift:") - case mappingRows of - row : _ -> parseRecord (recordText <> row <> "\n") `shouldBe` Nothing - [] -> expectationFailure "expected mapping rows" - case bindingRows of - row : _ -> parseRecord (recordText <> row <> "\n") `shouldBe` Nothing - [] -> expectationFailure "expected binding rows" - it "reports exactly the newly added binding field without rewriting the shared skeleton" $ - withTempDirectory "keiro-dsl-binding-drift" $ \out -> do - spec <- specOf "test/fixtures/consumer-types.keiro" - let ctx = defaultContext (specContext spec) - _ <- executePlannedScaffold out "consumer-types.keiro" ctx spec - let extended = spec{specMapped = map addArtifactSummaryField (specMapped spec)} - second <- executePlannedScaffold out "consumer-types.keiro" ctx extended - reportNewHoles second - `shouldBe` [ BindingHole - { holeMappedName = "ArtifactInfo" - , holeModule = "Example.Artifact.KeiroBindings" - , holeSymbol = "artifactInfoBinding" - , holeKind = BindingValue - , holePath = Just "summary" - , holeSignature = "artifactInfoBinding.summary :: Text" - } - ] - renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "artifactInfoBinding.summary :: Text") - it "rejects malformed known mapping JSON while ignoring unrelated future rows" $ do - spec <- specOf "test/fixtures/consumer-types.keiro" - withTempDirectory "keiro-dsl-mapping-malformed" $ \out -> do - report <- executePlannedScaffold out "consumer-types.keiro" (defaultContext (specContext spec)) spec - recordText <- TIO.readFile (reportRecordPath report) - parseRecord (recordText <> "mapping {not-json}\n") `shouldBe` Nothing - parseRecord (recordText <> "future-row retained\n") `shouldBe` parseRecord recordText - - describe "structural import plan" $ do - it "reports the successful dependency plan in the scaffold report" $ - withTempDirectory "keiro-dsl-dependency-plan" $ \out -> do - spec <- specOf "test/fixtures/consumer-types.keiro" - report <- executePlannedScaffold out "consumer-types.keiro" (defaultContext (specContext spec)) spec - renderScaffoldReport report - `shouldSatisfy` any (T.isInfixOf "dependency plan: consumer packages [artifact-domain, vendor-geometry]") - it "refuses a binding module inside the generated namespace with the exact cycle" $ do - spec <- specOf "test/fixtures/consumer-types.keiro" - let cyclic = spec{specMapped = map moveArtifactBindingIntoGenerated (specMapped spec)} - case planScaffold (defaultContext (specContext cyclic)) cyclic of - Left refusals -> do - refusals `shouldSatisfy` any isImportCycle - renderRefusals refusals `shouldSatisfy` any (T.isInfixOf "Generated.ConsumerDemo.Bindings") - Right _ -> expectationFailure "expected an import-cycle refusal" - it "refuses missing mapped register initials but permits command/event-only use" $ do - missing <- specOf "test/fixtures/mapped-missing-initial.keiro" - planScaffold (defaultContext (specContext missing)) missing `shouldSatisfy` isLoweringRefusal - spec <- specOf "test/fixtures/consumer-types.keiro" - let commandOnly = removeMappedRegisterRequirements spec - planScaffold (defaultContext (specContext commandOnly)) commandOnly `shouldSatisfy` isRight - - describe "binding explanations" $ do - it "lists binding, fixture, and use-site-scoped initial obligations deterministically" $ do - spec <- specOf "test/fixtures/consumer-types.keiro" - obligations <- either (\errors -> expectationFailure (show errors) >> pure []) pure (bindingObligations spec) - length obligations `shouldBe` 7 - obligations - `shouldSatisfy` any - ( \obligation -> - obligationKind obligation == BindingValue - && obligationSymbol obligation == "artifactInfoBinding" - && obligationBindingVersion obligation == Just "1" - ) - obligations - `shouldSatisfy` any - ( \obligation -> - obligationKind obligation == InitialValue - && obligationSymbol obligation == "emptyArtifactInfo" - && any (T.isInfixOf "Catalog register currentArtifact") (obligationUseSites obligation) - ) - let rendered = renderBindingObligations (specContext spec) obligations - rendered `shouldSatisfy` T.isInfixOf "binding obligations for context consumer-demo" - rendered `shouldSatisfy` T.isInfixOf "artifactInfoBinding :: StructuralBinding Example.Artifact.Domain.ArtifactInfo ArtifactInfoShape" - rendered `shouldSatisfy` T.isInfixOf "provenance: binding-version \"1\"" - it "states explicitly when a spec has no structural obligations" $ do - spec <- specOf "test/fixtures/reservation.keiro" - obligations <- either (\errors -> expectationFailure (show errors) >> pure []) pure (bindingObligations spec) - renderBindingObligations (specContext spec) obligations - `shouldBe` "no binding obligations for context hospital-capacity" - - describe "exact generic structural bindings" $ do - forM_ - [ ("renamed-field", "selector mismatch") - , ("reordered-field", "selector mismatch") - , ("arity-mismatch", "no exact nominal correspondence") - , ("incompatible-type", "no exact nominal correspondence") - ] - $ \(fixture, diagnostic) -> - it ("rejects " <> fixture <> " and directs the author to the scaffolded module") $ - expectGenericCompileFailure fixture diagnostic - - describe "structural harness" $ do - it "emits every structural, wire-policy, projection, and replay assertion family" $ do - spec <- specOf "test/fixtures/consumer-types.keiro" - let aggregate = onlyAggregate spec - ctx = defaultContext (specContext spec) - harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx spec aggregate) - mapM_ - (\needle -> harness `shouldSatisfy` T.isInfixOf needle) - [ "binding domain round-trip: example.artifact.ArtifactInfo.v1/" - , "binding shape round-trip: example.artifact.ArtifactInfo.v1/" - , "mapped codec round-trip: ArtifactObserved/artifact/" - , "fixture coverage: example.artifact.ArtifactLocation.v1" - , "wire policy missing default: example.artifact.ArtifactInfo.v1/description" - , "wire policy explicit null: example.artifact.ArtifactInfo.v1/description" - , "wire policy unknown fields: example.artifact.ArtifactInfo.v1" - , "wire union arm: example.artifact.ArtifactLocation.v1/local_file" - , "canonical identity: example.artifact.ArtifactInfo.v1" - , "projection witness agreement: example.artifact.ArtifactInfo.v1/key" - , "forward/replay equality: ObserveArtifact from CatalogEmpty -- " - , "register currentArtifact" - ] - it "keeps opaque assertions at the declared codec boundary" $ do - spec <- specOf "test/fixtures/consumer-types.keiro" - let aggregate = onlyAggregate spec - ctx = defaultContext (specContext spec) - modules = scaffoldAggregate ctx spec aggregate <> harnessFor ctx spec aggregate - harness = generatedTextEndingIn "Harness.hs" modules - codec = generatedTextEndingIn "Codec.hs" modules - harness `shouldSatisfy` T.isInfixOf "opaque codec round-trip: vendor.geometry.json@3/" - harness `shouldNotSatisfy` T.isInfixOf "wire policy unknown fields: vendor.geometry.json" - harness `shouldNotSatisfy` T.isInfixOf "fixture coverage: vendor.geometry" - codec `shouldNotSatisfy` T.isInfixOf "encodeVendorGeometryShape" - - describe "manifest (M2)" $ do - it "lists exactly the modules the scaffolder produced" $ do - mods <- scaffoldFixture "test/fixtures/reservation.keiro" - spec <- specOf "test/fixtures/reservation.keiro" - let manifest = renderManifest "reservation.keiro" mods spec - expectedNames = sort (map (moduleNameOf . modulePath) mods) - -- every produced module name appears in the manifest… - mapM_ (\m -> (m `T.isInfixOf` manifest) `shouldBe` True) expectedNames - -- …and the module list is exactly the scaffolder's output set. - expectedNames - `shouldBe` sort - [ "Generated.HospitalCapacity.Reservation.Codec" - , "Generated.HospitalCapacity.Reservation.Domain" - , "Generated.HospitalCapacity.Reservation.EventStream" - , "Generated.HospitalCapacity.Reservation.Harness" - , "Generated.HospitalCapacity.Reservation.Projection" - , "HospitalCapacity.Reservation.Holes" - ] - it "derives the dependency set from the node kinds present (aggregate)" $ do - spec <- specOf "test/fixtures/reservation.keiro" - manifestDependencies spec `shouldBe` ["aeson", "base", "keiki", "keiro", "text"] - it "derives the process dependency set, including worker-policy runtime imports" $ do - spec <- specOf "test/fixtures/hospital-surge.keiro" - let dependencies = manifestDependencies spec - mapM_ (\dependency -> dependencies `shouldContain` [dependency]) ["time", "uuid", "shibuya-core", "keiki", "keiro"] - it "uses the registered shibuya-core package name for router scaffolds" $ do - spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" - let dependencies = manifestDependencies spec - mapM_ (\dependency -> dependencies `shouldContain` [dependency]) ["effectful-core", "keiro", "shibuya-core"] - dependencies `shouldNotContain` ["shibuya"] - - describe "new skeletons (M5)" $ do - it "every skeleton parses and validates with zero error diagnostics" $ - mapM_ assertSkeletonValid skeletonKinds - it "every skeleton passes the scaffold refusal gates" $ - mapM_ assertSkeletonScaffoldable skeletonKinds - it "fresh skeleton scaffolds match the committed compiling modules" $ - mapM_ (uncurry assertSkeletonMatchesCommitted) skeletonModuleRoots - it "rejects an unknown kind with a helpful message" $ - case skeletonFor "bogus" of - Left msg -> ("Valid kinds:" `T.isInfixOf` msg) `shouldBe` True - Right _ -> expectationFailure "expected an error for an unknown kind" - - describe "firewall self-check (M3)" $ do - it "flags a forbidden operator in a Generated module" $ do - let m = ScaffoldModule{modulePath = "Gen/Foo.hs", moduleText = "x = a ./= b", kind = Generated, origin = "test"} - firewallBreaches [m] `shouldBe` [("Gen/Foo.hs", "./=", 1)] - it "ignores forbidden operators in a HoleStub module (holes own them)" $ do - let m = ScaffoldModule{modulePath = "Foo/Holes.hs", moduleText = "x = lit 1 .== y", kind = HoleStub, origin = "test"} - firewallBreaches [m] `shouldBe` [] - it "matches `lit` as a word, not a substring of quality/split" $ do - let clean = ScaffoldModule{modulePath = "Gen/Q.hs", moduleText = "quality = split facility", kind = Generated, origin = "test"} - dirty = ScaffoldModule{modulePath = "Gen/L.hs", moduleText = "v = lit foo", kind = Generated, origin = "test"} - firewallBreaches [clean] `shouldBe` [] - firewallBreaches [dirty] `shouldBe` [("Gen/L.hs", "lit", 1)] - it "skips strings and comments and maximal-munches symbolic tokens" $ do - let clean = syntheticGenerated "Gen/Clean.hs" "wire = \"lit .== B.slot\"\n-- x =: y\nx = a .<= b" - dirty = syntheticGenerated "Gen/Dirty.hs" "x = a .< b\ny = c =: d" - firewallBreaches [clean] `shouldBe` [("Gen/Clean.hs", ".<=", 3)] - firewallBreaches [dirty] `shouldBe` [("Gen/Dirty.hs", ".<", 1), ("Gen/Dirty.hs", "=:", 2)] - it "guards keiki imports while allowing the generated Core allowlist" $ do - let forbidden = syntheticGenerated "Gen/Builder.hs" "import Keiki.Builder" - restricted = syntheticGenerated "Gen/CoreBad.hs" "import Keiki.Core (lit)" - allowed = syntheticGenerated "Gen/CoreGood.hs" "import Keiki.Core (RegFile (..), HsPred, step)" - firewallBreaches [forbidden] `shouldBe` [("Gen/Builder.hs", "import:Keiki.Builder", 1)] - firewallBreaches [restricted] `shouldBe` [("Gen/CoreBad.hs", "import:Keiki.Core", 1)] - firewallBreaches [allowed] `shouldBe` [] - it "finds no breach in real scaffolder output (aggregate + process fixtures)" $ do - aggMods <- scaffoldFixture "test/fixtures/reservation.keiro" - procMods <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" - firewallBreaches (aggMods <> procMods) `shouldBe` [] - - describe "scaffold gates" $ do - it "refuses duplicate and case-folded module paths with both origins" $ do - spec <- specOf "test/fixtures/reservation.keiro" - case [aggregate | NAggregate aggregate <- specNodes spec] of - aggregate : _ -> do - let duplicate = spec{specNodes = [NAggregate aggregate, NAggregate aggregate]} - caseVariant = spec{specNodes = [NAggregate aggregate, NAggregate aggregate{aggName = T.toUpper (aggName aggregate)}]} - planScaffold (defaultContext (specContext spec)) duplicate `shouldSatisfy` hasPathCollisionWithTwoOrigins - planScaffold (defaultContext (specContext spec)) caseVariant `shouldSatisfy` hasPathCollisionWithTwoOrigins - [] -> expectationFailure "reservation fixture has no aggregate" - it "refuses a bannerless Generated target without changing its bytes" $ - withTempDirectory "keiro-dsl-banner" $ \out -> do - spec <- specOf "test/fixtures/reservation.keiro" - let ctx = defaultContext (specContext spec) - case planScaffold ctx spec of - Left refusals -> expectationFailure ("unexpected planning refusal: " <> show refusals) - Right modules -> case [m | m <- modules, kind m == Generated] of - generated : _ -> do - let target = out modulePath generated - createDirectoryIfMissing True (takeDirectory target) - TIO.writeFile target "hand owned\n" - result <- executeScaffold out False "test/fixtures/reservation.keiro" ctx spec modules - result `shouldSatisfy` isMissingBannerRefusal - TIO.readFile target `shouldReturn` "hand owned\n" - forced <- executeScaffold out True "test/fixtures/reservation.keiro" ctx spec modules - forced `shouldSatisfy` isSuccessfulScaffold - TIO.readFile target `shouldReturn` moduleText generated - [] -> expectationFailure "reservation scaffold has no Generated module" - it "reports renamed-node modules as stale without deleting them" $ - withTempDirectory "keiro-dsl-stale-rename" $ \out -> do - spec <- parseInlineSpec "" loweringAggregateSpec - first <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext spec)) spec - let renamed = spec{specNodes = map renameCounter (specNodes spec)} - second <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext renamed)) renamed - let oldDomain = onlyPathEndingIn "Counter/Domain.hs" (map fst (reportDispositions first)) - oldHoles = onlyPathEndingIn "Counter/Holes.hs" (map fst (reportDispositions first)) - reportStale second `shouldSatisfy` \stale -> StaleModule Generated oldDomain `elem` stale && StaleModule HoleStub oldHoles `elem` stale - doesFileExist (out oldDomain) `shouldReturn` True - doesFileExist (out oldHoles) `shouldReturn` True - it "reports the entire old tree across a module-root flip" $ - withTempDirectory "keiro-dsl-stale-root" $ \out -> do - spec <- parseInlineSpec "" loweringAggregateSpec - let initialCtx = defaultContext (specContext spec) - rootedCtx = initialCtx{moduleRoot = "Acme"} - first <- executePlannedScaffold out "counter.keiro" initialCtx spec - second <- executePlannedScaffold out "moved-counter.keiro" rootedCtx spec - reportStale second - `shouldMatchList` [StaleModule (kind m) (modulePath m) | (m, _) <- reportDispositions first] - forM_ (reportStale second) $ \stale -> doesFileExist (out stalePath stale) `shouldReturn` True - renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "previous scaffold record used spec counter.keiro") - it "reports moved generated modules across a layout flip" $ - withTempDirectory "keiro-dsl-stale-layout" $ \out -> do - spec <- parseInlineSpec "" loweringAggregateSpec - let initialCtx = defaultContext (specContext spec) - collocatedCtx = initialCtx{placement = CollocatedLeaf} - first <- executePlannedScaffold out "counter.keiro" initialCtx spec - second <- executePlannedScaffold out "counter.keiro" collocatedCtx spec - let oldGenerated = [StaleModule Generated (modulePath m) | (m, _) <- reportDispositions first, kind m == Generated] - reportStale second `shouldSatisfy` all (`elem` oldGenerated) - length (reportStale second) `shouldBe` length oldGenerated - it "writes a parseable record and no stale section for a fresh output" $ - withTempDirectory "keiro-dsl-record" $ \out -> do - spec <- parseInlineSpec "" loweringAggregateSpec - let ctx = defaultContext (specContext spec) - report <- executePlannedScaffold out "counter.keiro" ctx spec - reportStale report `shouldBe` [] - renderScaffoldReport report `shouldSatisfy` all (not . T.isPrefixOf "stale:") - contents <- TIO.readFile (out recordFileName (specContext spec)) - parseRecord contents - `shouldBe` Just - ScaffoldRecord - { recSpecPath = "counter.keiro" - , recModuleRoot = "" - , recLayout = "prefixed" - , recFiles = [(kind m, modulePath m) | (m, _) <- reportDispositions report] - , recMappings = [] - , recBindingObligations = [] - } - parseRecord (T.replace "spec: " "future-field: retained\nspec: " contents) `shouldBe` parseRecord contents - parseRecord (T.replace "record v1" "record v2" contents) `shouldBe` Nothing - - describe "faithful scaffold lowering" $ do - it "escapes a trailing-backslash payload literal exactly once" $ do - spec <- specOf "test/fixtures/hospital-surge.keiro" - case [process | NProcess process <- specNodes spec] of - process : _ -> do - let timer = (procTimer process){tmPayload = [FieldBinding "kind" (Just "\"follow-up\\\"")]} - modules = scaffoldProcess (defaultContext (specContext spec)) process{procTimer = timer} - generatedTextEndingIn "Process.hs" modules - `shouldSatisfy` T.isInfixOf "\"kind\" .= (\"follow-up\\\\\" :: Value)" - [] -> expectationFailure "hospital-surge fixture has no process" - it "preserves quoted Text register initials and refuses unsafe register shapes" $ do - spec <- parseInlineSpec "" loweringAggregateSpec - let modules = scaffoldAggregate (defaultContext (specContext spec)) spec =<< [aggregate | NAggregate aggregate <- specNodes spec] - domain = generatedTextEndingIn "Domain.hs" modules - domain `shouldSatisfy` T.isInfixOf "RCons (Proxy @\"note\") \"hello world\"" - scaffoldRefusals spec `shouldBe` [] - bare <- parseInlineSpec "" (T.replace "\"hello world\"" "hello" loweringAggregateSpec) - scaffoldRefusals bare `shouldSatisfy` any (T.isInfixOf "RegTextInitialNotQuoted") - unsupported <- parseInlineSpec "" (T.replace "count:Int" "count:Time" loweringAggregateSpec) - scaffoldRefusals unsupported `shouldSatisfy` any (T.isInfixOf "FieldTypeUnrepresentable") - it "lowers seconds, minutes, hours, and both backoff constructors faithfully" $ do - windowSeconds "90s" `shouldBe` Right 90 - windowSeconds "5m" `shouldBe` Right 300 - windowSeconds "2h" `shouldBe` Right 7200 - emitSource <- readTestText "test/fixtures/emit.keiro" - let exponentialSource = T.replace "backoff constant 2s" "backoff exponential 2s max=60s multiplier=2.0" emitSource - exponential <- parseInlineSpec "" exponentialSource - case [publisher | NPublisher publisher <- specNodes exponential] of - publisher : _ -> do - let generated = generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext exponential)) publisher) - generated `shouldSatisfy` T.isInfixOf "ExponentialBackoff ExponentialBackoffOptions { initial = 2, maxDelay = 60, multiplier = 2.0 }" - parseSpec "" (renderSpec exponential) `shouldBe` Right exponential - [] -> expectationFailure "emit fixture has no publisher" - constant <- parseInlineSpec "" (T.replace "backoff constant 2s" "backoff constant 2m" emitSource) - case [publisher | NPublisher publisher <- specNodes constant] of - publisher : _ -> generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext constant)) publisher) `shouldSatisfy` T.isInfixOf "ConstantBackoff 120" - [] -> expectationFailure "emit fixture has no publisher" - it "refuses incomplete exponential backoff and rejects unknown window units" $ do - emitSource <- readTestText "test/fixtures/emit.keiro" - incomplete <- parseInlineSpec "" (T.replace "backoff constant 2s" "backoff exponential 2s" emitSource) - scaffoldRefusals incomplete `shouldSatisfy` any (T.isInfixOf "BackoffExponentialIncomplete") - parseSpec "" (T.replace "backoff constant 2s" "backoff constant 2x" emitSource) - `shouldSatisfy` leftContains "time unit: s, m, or h" - it "lowers workqueue retry windows in minutes to seconds" $ do - queueSource <- readTestText "test/fixtures/reservation-work.keiro" - queueSpec <- parseInlineSpec "" (T.replace "5s" "5m" queueSource) - case [workqueue | NWorkqueue workqueue <- specNodes queueSpec] of - workqueue : _ -> do - let policy = generatedTextEndingIn "QueuePolicy.hs" (scaffoldWorkqueue (defaultContext (specContext queueSpec)) workqueue) - policy `shouldSatisfy` T.isInfixOf "defaultRetryDelay = RetryDelay 300" - policy `shouldSatisfy` T.isInfixOf "Retry (RetryDelay 300)" - [] -> expectationFailure "queue fixture has no workqueue" - it "uses exact status-map keys and emits total Int harness samples" $ do - statusSpec <- parseInlineSpec "" exactStatusSpec - case [aggregate | NAggregate aggregate <- specNodes statusSpec] of - aggregate : _ -> do - let ctx = defaultContext (specContext statusSpec) - projection = generatedTextEndingIn "Projection.hs" (scaffoldAggregate ctx statusSpec aggregate) - harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx statusSpec aggregate) - projection `shouldSatisfy` T.isInfixOf "ReservationUnHeld {} -> Just \"available\"" - harness `shouldSatisfy` T.isInfixOf "CountBumpedData 0" - harness `shouldNotSatisfy` T.isInfixOf "sample: unsupported" - [] -> expectationFailure "exact-status spec has no aggregate" - - describe "scaffold" $ do - it "synthesizes the exact old wire shape and embeds it in the harness" $ do - oldSpec <- specOf "test/fixtures/reservation.keiro" - newSpec <- specOf "test/fixtures/reservation-v2.keiro" - case goldensForDiff oldSpec newSpec of - [golden] -> do - goldenRelativePath golden - `shouldBe` "hospital-capacity/Reservation/TransferReservationCreated.v1.json" - goldenJson golden - `shouldBe` "{\"commandId\":\"cmd_01hzy3v7q2e8kaw2m5x0d41n9c\",\"divertStatus\":\"open\",\"hospitalId\":\"hosp_01hzy3v7q2e8kaw2m5x0d41n9c\",\"kind\":\"TransferReservationCreated\",\"lifeCriticalOverride\":true,\"patientAcuity\":\"red\",\"reservationId\":\"rsv_01hzy3v7q2e8kaw2m5x0d41n9c\"}\n" - goldenEvidence golden `shouldBe` SynthesizedWeakStandIn - let aggregate = onlyAggregate newSpec - modules = - harnessForWithGoldens - [golden] - (defaultContext (specContext newSpec)) - newSpec - aggregate - harness = generatedTextEndingIn "Harness.hs" modules - harness `shouldSatisfy` T.isInfixOf "golden TransferReservationCreated.v1 decodes" - harness `shouldSatisfy` T.isInfixOf "\\\"reservationId\\\":\\\"rsv_" - harness `shouldSatisfy` (not . T.isInfixOf "current-shape stand-in") - goldens -> expectationFailure ("expected one synthesized golden, got " <> show goldens) - it "synthesizes complete nested mapped old shapes deterministically and never overwrites captured evidence" $ do - oldSpec <- specOf "test/fixtures/consumer-types.keiro" - newSpec <- specOf "test/fixtures/consumer-types-v2.keiro" - case goldensForDiff oldSpec newSpec of - [golden] -> do - goldenEvidence golden `shouldBe` SynthesizedWeakStandIn - goldenJson golden `shouldSatisfy` T.isInfixOf "\"artifact\":{" - goldenJson golden `shouldSatisfy` T.isInfixOf "\"location\":{\"contents\":\"sample\",\"tag\":\"local_file\"}" - goldenJson golden `shouldSatisfy` T.isInfixOf "\"labels\":[\"sample\"]" - goldenJson golden `shouldSatisfy` T.isInfixOf "\"revision\":1" - goldenJson golden `shouldSatisfy` T.isInfixOf "\"observedAt\":\"2026-01-01T00:00:00Z\"" - goldensForDiff oldSpec newSpec `shouldBe` [golden] - withTempDirectory "keiro-golden-preserve" $ \root -> do - let target = root goldenRelativePath golden - createDirectoryIfMissing True (takeDirectory target) - TIO.writeFile target "hand captured\n" - emitGoldenPayloads root oldSpec newSpec `shouldReturn` [] - TIO.readFile target `shouldReturn` "hand captured\n" - withTempDirectory "keiro-golden-write" $ \root -> do - let target = root goldenRelativePath golden - emitGoldenPayloads root oldSpec newSpec `shouldReturn` [target] - TIO.readFile target `shouldReturn` goldenJson golden - goldens -> expectationFailure ("expected one nested synthesized golden, got " <> show goldens) - it "dispatches shared-version upcasters by wire event type and passes foreign kinds through" $ do - source <- readTestText "test/fixtures/reservation-dup-upcast-source.keiro" - spec <- parseInlineSpec "" source - case [aggregate | NAggregate aggregate <- specNodes spec] of - [aggregate] -> do - let modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate - codec = generatedTextEndingIn "Codec.hs" modules - holes = case [moduleText m | m <- modules, "Holes.hs" `T.isSuffixOf` T.pack (modulePath m)] of - [text] -> text - _ -> "" - codec `shouldSatisfy` T.isInfixOf "upcasters = [(1, upcastRungV1)]" - codec `shouldSatisfy` T.isInfixOf "upcastRungV1 (EventType \"TransferReservationCreated\") value = upcastTransferReservationCreatedV1 value" - codec `shouldSatisfy` T.isInfixOf "upcastRungV1 (EventType \"TransferReservationConfirmed\") value = upcastTransferReservationConfirmedV1 value" - codec `shouldSatisfy` T.isInfixOf "upcastRungV1 _ value = Right value" - holes `shouldSatisfy` T.isInfixOf "receives ONLY TransferReservationCreated payloads" - _ -> expectationFailure "expected exactly one aggregate" - it "keeps foreign payloads byte-for-byte and invokes both same-rung event upcasters" $ do - let payloadA = object ["kind" .= ("AmountScaled" :: T.Text), "amount" .= (2 :: Int)] - payloadB = object ["kind" .= ("AmountRenamed" :: T.Text), "amount" .= (3 :: Int)] - foreignPayload = object ["kind" .= ("AmountObserved" :: T.Text), "amount" .= (7 :: Int)] - upcastA _ = Right (object ["kind" .= ("AmountScaled" :: T.Text), "amount" .= (200 :: Int)]) - upcastB _ = Right (object ["kind" .= ("AmountRenamed" :: T.Text), "amountInCents" .= (300 :: Int)]) - rung (EventType "AmountScaled") = upcastA - rung (EventType "AmountRenamed") = upcastB - rung _ = Right - codec = - Codec - { eventTypes = EventType "AmountScaled" :| [EventType "AmountRenamed", EventType "AmountObserved"] - , eventType = const (EventType "AmountObserved") - , schemaVersion = 2 - , encode = id - , decode = \_ -> Right - , upcasters = [(1, rung)] - } :: - Codec Value - decodeRaw codec (EventType "AmountObserved") 1 foreignPayload `shouldBe` Right foreignPayload - decodeRaw codec (EventType "AmountScaled") 1 payloadA - `shouldBe` Right (object ["kind" .= ("AmountScaled" :: T.Text), "amount" .= (200 :: Int)]) - decodeRaw codec (EventType "AmountRenamed") 1 payloadB - `shouldBe` Right (object ["kind" .= ("AmountRenamed" :: T.Text), "amountInCents" .= (300 :: Int)]) - it "never emits a keiki symbolic operator into a Generated module (firewall)" $ do - mods <- scaffoldFixture "test/fixtures/reservation.keiro" - firewallBreaches mods `shouldBe` [] - it "marks the Holes module HoleStub and the rest Generated" $ do - mods <- scaffoldFixture "test/fixtures/reservation.keiro" - let holes = [m | m <- mods, "Holes.hs" `T.isSuffixOf` T.pack (modulePath m)] - map kind holes `shouldBe` [HoleStub] - -- Domain, Codec, EventStream, Projection, Harness. - length [m | m <- mods, kind m == Generated] `shouldBe` 5 - it "is deterministic (re-scaffolding yields byte-identical text)" $ do - a <- scaffoldFixture "test/fixtures/reservation.keiro" - b <- scaffoldFixture "test/fixtures/reservation.keiro" - map moduleText a `shouldBe` map moduleText b - it "keeps retiring as validator-only metadata in generated modules" $ do - ordinary <- scaffoldFixture "test/fixtures/reservation.keiro" - retiring <- scaffoldFixture "test/fixtures/reservation-retiring.keiro" - map (\m -> (modulePath m, kind m, moduleText m)) retiring - `shouldBe` map (\m -> (modulePath m, kind m, moduleText m)) ordinary - it "matches the committed compiling Generated conformance modules (modulo whitespace)" $ do - mods <- scaffoldFixture "test/fixtures/reservation.keiro" - mapM_ assertMatchesCommitted [m | m <- mods, kind m == Generated] - it "matches every committed new-surface Generated module (modulo formatting)" $ do - spec <- specOf "test/fixtures/transfer-routing.keiro" - let modules = scaffoldModules (defaultContext (specContext spec)) spec - forM_ [m | m <- modules, kind m == Generated] $ \m -> do - committed <- readTestText ("test/conformance-newsurface/" <> modulePath m) - normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m) - it "scaffolds the register-free OrderStream smoke target without error" $ do - mods <- scaffoldFixture "test/fixtures/order.keiro" - -- 5 Generated (Domain/Codec/EventStream/Projection/Harness) + 1 Holes. - length mods `shouldBe` 6 - firewallBreaches mods `shouldBe` [] - let harness = generatedTextEndingIn "Harness.hs" mods - harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: PlaceOrder from OrderNotStarted -- \"" - harness `shouldSatisfy` T.isInfixOf "prefix <> \"final vertex\"" - harness `shouldNotSatisfy` T.isInfixOf "prefix <> \"register " - it "emits forward/replay checks with field-distinct Text samples" $ do - spec <- parseInlineSpec "" (T.replace "command Bump { count:Int }" "command Bump { count:Int noteText:Text echo:Text }" loweringAggregateSpec) - case [aggregate | NAggregate aggregate <- specNodes spec] of - aggregate : _ -> do - let ctx = defaultContext (specContext spec) - harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx spec aggregate) - harness `shouldSatisfy` T.isInfixOf "\"sample-noteText\" \"sample-echo\"" - harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: Bump from CounterPending -- \"" - harness `shouldSatisfy` T.isInfixOf "prefix <> \"register note\"" - [] -> expectationFailure "forward/replay sample spec has no aggregate" - it "emits the canonical reservation register checks" $ do - mods <- scaffoldFixture "test/fixtures/reservation.keiro" - let harness = generatedTextEndingIn "Harness.hs" mods - harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: RequestTransferReservation from ReservationUnrequested -- \"" - harness `shouldSatisfy` T.isInfixOf "prefix <> \"register reservationState\"" - it "lowers a replay-only transition to B.replayOnly in the holes skeleton (plan 143)" $ do - twinMods <- scaffoldFixture "test/fixtures/reservation-guard-tightened-twin.keiro" - let twinHoles = [moduleText m | m <- twinMods, kind m == HoleStub] - twinHoles `shouldSatisfy` any (T.isInfixOf "B.replayOnly") - let twinHarness = generatedTextEndingIn "Harness.hs" twinMods - T.count "forwardReplayRequestTransferReservation ::" twinHarness `shouldBe` 1 - plainMods <- scaffoldFixture "test/fixtures/reservation.keiro" - let plainHoles = [moduleText m | m <- plainMods, kind m == HoleStub] - plainHoles `shouldSatisfy` all (not . T.isInfixOf "B.replayOnly") - -comparisonProvenance :: CompareProvenance -comparisonProvenance = - CompareProvenance - { cpHistoricalCodecIdentity = "example.historical" - , cpHistoricalCodecVersion = "legacy-v1" - , cpCanonicalType = CanonicalTypeId "example.Artifact.v1" - , cpBindingSymbol = QualifiedValueName "Example.Bindings.artifactBinding" - , cpBindingVersion = BindingVersion "1" - , cpWireFingerprint = "deadbeef" - } - -syntheticGenerated :: FilePath -> T.Text -> ScaffoldModule -syntheticGenerated path contents = - ScaffoldModule{modulePath = path, moduleText = contents, kind = Generated, origin = "test"} - -generatedTextEndingIn :: T.Text -> [ScaffoldModule] -> T.Text -generatedTextEndingIn suffix modules = case [moduleText m | m <- modules, kind m == Generated, suffix `T.isSuffixOf` T.pack (modulePath m)] of - contents : _ -> contents - [] -> "" - -onlyAggregate :: Spec -> Aggregate -onlyAggregate spec = case [aggregate | NAggregate aggregate <- specNodes spec] of - [aggregate] -> aggregate - aggregates -> error ("expected one aggregate, got " <> show (length aggregates)) - -loweringAggregateSpec :: T.Text -loweringAggregateSpec = - T.unlines - [ "context samples" - , "" - , "aggregate Counter" - , " regs" - , " note Text = \"hello world\"" - , " count Int = 0" - , " state CounterVertex = Pending" - , " states Pending Done!" - , " command Bump { count:Int }" - , " event CountBumped { count:Int }" - , " Pending -- Bump --> emit CountBumped ; goto Done" - ] - -exactStatusSpec :: T.Text -exactStatusSpec = - T.unlines - [ "context samples" - , "" - , "aggregate Reservation" - , " regs" - , " state ReservationVertex = Open" - , " states Open Closed!" - , " command Bump { count:Int }" - , " event ReservationHeld { count:Int }" - , " event ReservationUnHeld { count:Int }" - , " event CountBumped { count:Int }" - , " Open -- Bump --> emit CountBumped ; goto Closed" - , " projection reservation_status consistency=Eventual key=count" - , " status-map { ReservationHeld=>held ReservationUnHeld=>available CountBumped=>bumped }" - ] - -hasPathCollisionWithTwoOrigins :: Either [Refusal] [ScaffoldModule] -> Bool -hasPathCollisionWithTwoOrigins = \case - Left refusals -> any hasTwo refusals - Right _ -> False - where - hasTwo (PathCollision _ origins) = length origins == 2 - hasTwo _ = False - -isMissingBannerRefusal :: Either [Refusal] a -> Bool -isMissingBannerRefusal = \case - Left [MissingGeneratedBanner paths] -> not (null paths) - _ -> False - -isSuccessfulScaffold :: Either [Refusal] a -> Bool -isSuccessfulScaffold = \case - Right _ -> True - Left _ -> False - -executePlannedScaffold :: FilePath -> FilePath -> Context -> Spec -> IO ScaffoldReport -executePlannedScaffold out specPath ctx spec = case planScaffold ctx spec of - Left refusals -> expectationFailure ("unexpected scaffold refusal: " <> show refusals) >> error "unreachable" - Right modules -> do - result <- executeScaffold out False specPath ctx spec modules - case result of - Left refusals -> expectationFailure ("unexpected execution refusal: " <> show refusals) >> error "unreachable" - Right report -> pure report - -renameCounter :: Node -> Node -renameCounter (NAggregate aggregate) = - NAggregate - aggregate - { aggName = "Widget" - , aggRegs = [reg{regType = if regType reg == "CounterVertex" then "WidgetVertex" else regType reg} | reg <- aggRegs aggregate] - } -renameCounter node = node - -onlyPathEndingIn :: FilePath -> [ScaffoldModule] -> FilePath -onlyPathEndingIn suffix modules = case [modulePath m | m <- modules, T.pack suffix `T.isSuffixOf` T.pack (modulePath m)] of - [path] -> path - paths -> error ("expected one path ending in " <> suffix <> ", got " <> show paths) - -withTempDirectory :: String -> (FilePath -> IO a) -> IO a -withTempDirectory template = bracket acquire removePathForcibly - where - acquire = do - base <- getTemporaryDirectory - (path, handle) <- openTempFile base template - hClose handle - removeFile path - createDirectory path - pure path - -{- | Parse a fixture and return the validator's diagnostic codes (failing the -test on a parse error). --} -diagnosticCodesOf :: FilePath -> IO [DiagnosticCode] -diagnosticCodesOf path = do - map code <$> diagnosticsOf path - --- | Parse a fixture and return all validator diagnostics. -diagnosticsOf :: FilePath -> IO [Diagnostic] -diagnosticsOf path = do - input <- readTestText path - case parseSpec path input of - Left err -> expectationFailure (T.unpack err) >> pure [] - Right spec -> pure (validateSpec spec) - -{- | Like 'diagnosticCodesOf' but only the Error-severity codes (warnings, e.g. -the benign-inversion notices, are excluded). --} -errorCodesOf :: FilePath -> IO [DiagnosticCode] -errorCodesOf path = do - diagnostics <- diagnosticsOf path - pure [code d | d <- diagnostics, severity d == Error] - -{- | Parse two fixtures and diff them (old, new). -| Plan 143: render an Expr in concrete guard syntax by printing a dummy -transition through the real pretty-printer and slicing its guard clause, -so the test exercises the exact printer the diff advisory uses. --} -renderExprText :: Expr -> T.Text -renderExprText e = - case [T.strip l | l <- T.lines rendered, "guard " `T.isPrefixOf` T.strip l] of - [guardLine] -> T.strip (T.drop (T.length "guard ") guardLine) - _ -> error ("renderExprText: unexpected printer output: " <> T.unpack rendered) - where - rendered = - renderTransition - Transition - { tSource = "S" - , tCommand = "C" - , tGuard = Just e - , tWrites = [] - , tEmits = [] - , tGoto = "S" - , tMode = TmLive - , tLoc = noLoc - } - -{- | Plan 143: a minimal spec whose only transition is replay-only, with the -supplied clause lines spliced into its body. --} -replayOnlySpecWith :: [T.Text] -> T.Text -replayOnlySpecWith clauseLines = - T.unlines $ - [ "context hospital-capacity" - , "" - , "id TransferReservationId prefix=rsv" - , "" - , "aggregate Reservation" - , " regs" - , " reservationId TransferReservationId = placeholder" - , " reservationState ReservationVertex = Unrequested" - , " states Unrequested Held" - , "" - , " command RequestTransferReservation { reservationId }" - , "" - , " event TransferReservationCreated = fields(RequestTransferReservation)" - , "" - , " replay-only Unrequested -- RequestTransferReservation -->" - ] - ++ clauseLines - -diffFixtures :: FilePath -> FilePath -> IO [Change] -diffFixtures oldP newP = do - old <- readTestText oldP - new <- readTestText newP - case (,) <$> parseSpec oldP old <*> parseSpec newP new of - Left err -> expectationFailure (T.unpack err) >> pure [] - Right (o, n) -> pure (diffSpecs o n) - -kindOfChange :: Change -> ChangeKind -kindOfChange (Additive kind) = kind -kindOfChange (Advisory kind) = kind -kindOfChange (Breaking kind) = kind - -labelOfChange :: Change -> Label -labelOfChange Additive{} = LabelAdditive -labelOfChange Advisory{} = LabelAdvisory -labelOfChange Breaking{} = LabelBreaking - -genSurfaceSet :: Gen (Set.Set CompatibilitySurface) -genSurfaceSet = Set.fromList <$> listOf (elements [minBound .. maxBound]) - -genCompatibilityVector :: Gen CompatibilityVector -genCompatibilityVector = - CompatibilityVector - <$> genVerdict - <*> genVerdict - <*> genVerdict - <*> genVerdict - <*> genVerdict - <*> genVerdict - <*> (Set.fromList <$> listOf (elements rolloutConstraints)) - where - genVerdict = elements [VCompatible, VAdvisory, VBreaking, VNotApplicable] - rolloutConstraints = - [ RolloutStopTheWorld - , RolloutWorkersFirst - , RolloutDrainRequired - , RolloutProducerLast - ] - -replayImpactFixtures :: FilePath -> FilePath -> IO ReplayImpact -replayImpactFixtures oldPath newPath = do - old <- specOf oldPath - new <- specOf newPath - pure (ReplayImpact.replayImpact old new) - -modifyAggregate :: Name -> (Aggregate -> Aggregate) -> Spec -> Spec -modifyAggregate target update spec = - spec - { specNodes = - [ case node of - NAggregate aggregate | aggName aggregate == target -> NAggregate (update aggregate) - _ -> node - | node <- specNodes spec - ] - } - -modifyReadModel :: Name -> (ReadModelNode -> ReadModelNode) -> Spec -> Spec -modifyReadModel target update spec = - spec - { specNodes = - [ case node of - NReadModel readModel | rmName readModel == target -> NReadModel (update readModel) - _ -> node - | node <- specNodes spec - ] - } - -removeReadModel :: Name -> Spec -> Spec -removeReadModel target spec = - spec{specNodes = [node | node <- specNodes spec, not (isTarget node)]} - where - isTarget (NReadModel readModel) = rmName readModel == target - isTarget _ = False - -modifyRouter :: Name -> (RouterNode -> RouterNode) -> Spec -> Spec -modifyRouter target update spec = - spec - { specNodes = - [ case node of - NRouter router | rtId router == target -> NRouter (update router) - _ -> node - | node <- specNodes spec - ] - } - -routerErrorCodes :: (RouterNode -> RouterNode) -> Spec -> [DiagnosticCode] -routerErrorCodes update = errorCodes . modifyRouter "PagingRouter" update - -modifyProcess :: Name -> (ProcessNode -> ProcessNode) -> Spec -> Spec -modifyProcess target update spec = - spec - { specNodes = - [ case node of - NProcess process | procId process == target -> NProcess (update process) - _ -> node - | node <- specNodes spec - ] - } - -processErrorCodes :: (ProcessNode -> ProcessNode) -> Spec -> [DiagnosticCode] -processErrorCodes update = errorCodes . modifyProcess "HospitalSurge" update - -errorCodes :: Spec -> [DiagnosticCode] -errorCodes spec = [code diagnostic | diagnostic <- validateSpec spec, severity diagnostic == Error] - -changeReadModelShape :: ReadModelNode -> ReadModelNode -changeReadModelShape readModel = - readModel - { rmColumns = rmColumns readModel <> [RmColumn "reviewed_by" "text" False] - , rmShape = "fnv1a:0000000000000000" - } - -{- | Assert a @new \@ skeleton parses and validates with zero -error-severity diagnostics. --} -assertSkeletonValid :: T.Text -> IO () -assertSkeletonValid kind = case skeletonFor kind of - Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err)) - Right src -> case parseSpec ("new:" <> T.unpack kind) src of - Left perr -> expectationFailure (T.unpack ("skeleton for " <> kind <> " failed to parse: " <> perr)) - Right spec -> - [code d | d <- validateSpec spec, severity d == Error] - `shouldBe` ([] :: [DiagnosticCode]) - -assertSkeletonScaffoldable :: T.Text -> IO () -assertSkeletonScaffoldable kind = case skeletonFor kind of - Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err)) - Right src -> case parseSpec ("new:" <> T.unpack kind) src of - Left perr -> expectationFailure (T.unpack perr) - Right spec -> planScaffold (defaultContext (specContext spec)) spec `shouldSatisfy` isSuccessfulScaffold - -skeletonModuleRoots :: [(T.Text, T.Text)] -skeletonModuleRoots = - [ ("aggregate", "SkelAggregate") - , ("process", "SkelProcess") - , ("router", "SkelRouter") - , ("contract", "SkelContract") - , ("intake", "SkelIntake") - , ("emit", "SkelEmit") - , ("workqueue", "SkelQueue") - , ("workflow", "SkelWorkflow") - ] - -assertSkeletonMatchesCommitted :: T.Text -> T.Text -> IO () -assertSkeletonMatchesCommitted kind root = case skeletonFor kind of - Left err -> expectationFailure (T.unpack err) - Right source -> case parseSpec ("new:" <> T.unpack kind) source of - Left err -> expectationFailure (T.unpack err) - Right spec -> do - let ctx = (defaultContext (specContext spec)){moduleRoot = root} - forM_ [m | m <- scaffoldModules ctx spec, kindOf m == Generated] $ \m -> do - committed <- readTestText ("test/conformance-skeletons/" <> modulePath m) - normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m) - where - kindOf = Keiro.Dsl.Scaffold.kind - -bumpArtifactBindingVersion :: MappedDecl -> MappedDecl -bumpArtifactBindingVersion declaration@MappedStructural{msName = "ArtifactInfo"} = - declaration{msBindingVersion = Just "2"} -bumpArtifactBindingVersion declaration = declaration - -addArtifactSummaryField :: MappedDecl -> MappedDecl -addArtifactSummaryField declaration@MappedStructural{msName = "ArtifactInfo", msShape = ShapeRecord constructor unknownFields fields} = - declaration - { msShape = - ShapeRecord - constructor - unknownFields - ( fields - <> [ WireField - { wfHaskell = "summary" - , wfKey = "summary" - , wfType = TText - , wfPresence = PRequired - , wfOnMissing = Nothing - , wfLoc = Loc 0 - } - ] - ) - } -addArtifactSummaryField declaration = declaration - -expectGenericCompileFailure :: FilePath -> String -> Expectation -expectGenericCompileFailure fixture expectedDiagnostic = do - let fixtureDir = "../keiro-core/test/compile-fail" fixture - fixtureSource = fixtureDir "Fixture.hs" - (exitCode, standardOutput, standardError) <- - readProcessWithExitCode - "cabal" - [ "exec" - , "--" - , "ghc" - , "-XGHC2024" - , "-fno-code" - , "-fforce-recomp" - , "-i../keiro-core/src" - , "-i" <> fixtureDir - , fixtureSource - ] - "" - exitCode `shouldSatisfy` (/= ExitSuccess) - let compilerOutput = standardOutput <> standardError - compilerOutput `shouldContain` expectedDiagnostic - compilerOutput `shouldContain` "Run keiro-dsl scaffold and fill the binding by hand at this error location in the scaffolded module." - compilerOutput `shouldContain` fixtureSource - -moveArtifactBindingIntoGenerated :: MappedDecl -> MappedDecl -moveArtifactBindingIntoGenerated declaration@MappedStructural{msName = "ArtifactInfo"} = - declaration{msBinding = Just "Generated.ConsumerDemo.Bindings.artifactInfoBinding"} -moveArtifactBindingIntoGenerated declaration = declaration - -removeMappedRegisterRequirements :: Spec -> Spec -removeMappedRegisterRequirements spec = - spec - { specMapped = map removeInitial (specMapped spec) - , specNodes = map removeRegisters (specNodes spec) - } - where - removeInitial declaration@MappedStructural{} = declaration{msInitial = Nothing} - removeInitial declaration@MappedOpaque{} = declaration{moInitial = Nothing} - removeRegisters (NAggregate aggregate) = - NAggregate - aggregate - { aggRegs = [] - , aggTransitions = [transition{tWrites = []} | transition <- aggTransitions aggregate] - } - removeRegisters node = node - -isImportCycle :: Refusal -> Bool -isImportCycle ImportCycle{} = True -isImportCycle _ = False - -isLoweringRefusal :: Either [Refusal] modules -> Bool -isLoweringRefusal (Left refusals) = any isLowering refusals - where - isLowering LoweringRefusal{} = True - isLowering _ = False -isLoweringRefusal (Right _) = False +import Data.Foldable (toList) +import Data.List (partition, sort, (\\)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Keiro.Codec (Codec (..), EventType (..), decodeRaw) +import Keiro.Dsl.CodecCompare +import Keiro.Dsl.Coverage qualified as Coverage +import Keiro.Dsl.Diff (Change (..), ChangeKind (..), CompatibilitySurface (..), CompatibilityVector (..), FamilyDiff (..), Label (..), NodeFamily, RolloutConstraint (..), SurfaceVerdict (..), defaultGate, deriveLabel, diffSpecs, familyRegistry, gateWith, gatedBreaking, isAdvisory, isBreaking, verdictFor) +import Keiro.Dsl.DiffReport (Remedy (..), diffReport, parseSurfaceName, remediationFor, renderExplainBlock, renderFinding) +import Keiro.Dsl.ExplainBindings (BindingHole (..), BindingObligation (..), BindingObligationKind (..), bindingHoles, bindingObligations, renderBindingObligations) +import Keiro.Dsl.FoldFingerprint (aggregateFoldFingerprint, aggregateFoldSurface) +import Keiro.Dsl.Goldens (GoldenEvidence (..), GoldenPayload (..), emitGoldenPayloads, goldenRelativePath, goldensForDiff) +import Keiro.Dsl.Grammar +import Keiro.Dsl.Harness (harnessFor, harnessForWithGoldens, harnessReadModel, harnessRouter, harnessWorkflow) +import Keiro.Dsl.Manifest (manifestDependencies, moduleNameOf, renderManifest) +import Keiro.Dsl.MappedConsumer (ConsumerPlan (..), consumerPlan) +import Keiro.Dsl.Parser (parseSpec) +import Keiro.Dsl.PrettyPrint (renderSpec, renderTransition) +import Keiro.Dsl.ReadModelShape (canonicalShape, deriveShapeHash, registryNameFor, subscriptionNameFor) +import Keiro.Dsl.ReplayImpact (AggregateImpact (..), ReplayImpact (..)) +import Keiro.Dsl.ReplayImpact qualified as ReplayImpact +import Keiro.Dsl.Scaffold (Context (..), ModuleKind (..), ScaffoldModule (..), codecComparisonBanner, codecComparisonModule, defaultContext, firewallBreaches, genPrefixFor, holePrefixFor, scaffoldAggregate, scaffoldIntake, scaffoldProcess, scaffoldPublisher, scaffoldReadModel, scaffoldRefusals, scaffoldReplayAudit, scaffoldRouter, scaffoldWorkqueue, windowSeconds) +import Keiro.Dsl.ScaffoldRecord (ScaffoldRecord (..), parseRecord, recordFileName) +import Keiro.Dsl.ScaffoldRun (MappingDrift (..), Refusal (..), ScaffoldReport (..), StaleModule (..), WriteDisposition (..), executeScaffold, planScaffold, renderRefusals, renderScaffoldReport, scaffoldModules) +import Keiro.Dsl.Skeleton (skeletonFor, skeletonKinds) +import Keiro.Dsl.TypeGraph +import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), Severity (..), derivedQueueTrio, renderDiagnostic, validateSpec) +import Keiro.Dsl.Workspace +import Keiro.Dsl.WorkspaceAdoption +import Keiro.Dsl.WorkspaceDiff +import Keiro.Dsl.WorkspaceRecord +import Keiro.Dsl.WorkspaceScaffold +import System.Directory (createDirectory, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getTemporaryDirectory, listDirectory, removeFile, removePathForcibly) +import System.Environment (lookupEnv) +import System.Exit (ExitCode (..)) +import System.FilePath (takeDirectory, ()) +import System.IO (hClose, openTempFile) +import System.Process (readProcessWithExitCode) +import Test.Hspec hiding (Spec) +import Test.QuickCheck + +main :: IO () +main = hspec $ do + describe "historical codec comparison" $ do + it "treats object-key order as RFC 8785 parity" $ do + let historical = object ["z" .= (1 :: Int), "a" .= (2 :: Int)] + generated = object ["a" .= (2 :: Int), "z" .= (1 :: Int)] + classifyObservation (EncodeObservation "ordered-object" historical generated) + `shouldBe` Right JsonParity + it "classifies an omitted key versus explicit null as version work at that pointer" $ do + let historical = object [] + generated = object ["description" .= Aeson.Null] + classifyObservation (EncodeObservation "absent-description" historical generated) + `shouldBe` Right (RequiresVersionWork (EncodedValueDifference (JsonPointer "/description") historical generated)) + it "classifies generated rejection of a historical value as version work" $ + classifyObservation + ( DecodeObservation + "legacy.json" + (object ["tag" .= ("legacy" :: T.Text)]) + (DecodedShape (object ["tag" .= ("legacy" :: T.Text)])) + (DecodeFailed "unknown tag") + ) + `shouldBe` Right (RequiresVersionWork (GeneratedDecodeRejected "unknown tag")) + it "treats historical-codec rejection as invalid input rather than parity" $ + classifyObservation + ( DecodeObservation + "corrupt.json" + Aeson.Null + (DecodeFailed "not historical data") + (DecodeFailed "not generated data") + ) + `shouldBe` Left (HistoricalCodecRejected "corrupt.json" "not historical data") + it "reports uncovered union arms separately by corpus origin" $ do + let canonical = DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical") + local = DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local_file") + report = compareReport comparisonProvenance [] [] [canonical, local] [ObservedBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local_file")] + crCoverageGaps report + `shouldBe` [CoverageGap HistoricalGolden (JsonPointer "/location") (UnionArm "canonical")] + reportSucceeded report `shouldBe` False + it "derives optional, null, and union-arm observations from a generated branch schema" $ do + let schema = + BranchRecord + [ BranchField "description" True (BranchOptional BranchScalar) + , BranchField "location" False (BranchUnion "tag" "contents" [BranchArm "local" (Just BranchScalar), BranchArm "canonical" Nothing]) + ] + historical = object ["location" .= object ["tag" .= ("canonical" :: T.Text)]] + observedBranchesFor HistoricalGolden schema historical + `shouldBe` [ ObservedBranch HistoricalGolden (JsonPointer "/description") OptionalMissing + , ObservedBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical") + ] + let declared = declaredBranchesFor HistoricalGolden schema + forM_ + [ DeclaredBranch HistoricalGolden (JsonPointer "/description") OptionalMissing + , DeclaredBranch HistoricalGolden (JsonPointer "/description") OptionalPresent + , DeclaredBranch HistoricalGolden (JsonPointer "/description") ExplicitNull + , DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "local") + , DeclaredBranch HistoricalGolden (JsonPointer "/location") (UnionArm "canonical") + ] + (\branch -> declared `shouldContain` [branch]) + it "round-trips the stable machine report" $ do + let observation = EncodeObservation "parity" (object ["a" .= (1 :: Int)]) (object ["a" .= (1 :: Int)]) + report = compareReport comparisonProvenance [] [observation] [] [] + Aeson.eitherDecode (Aeson.encode report) `shouldBe` Right report + it "atomically writes and replaces the machine report" $ + withTempDirectory "keiro-dsl-codec-compare" $ \out -> do + let path = out "report.json" + firstReport = compareReport comparisonProvenance [] [] [] [] + secondReport = compareReport comparisonProvenance [HistoricalGoldenUnreadable "bad.json" "bad JSON"] [] [] [] + writeCompareReportAtomic path firstReport `shouldReturn` Right () + Aeson.eitherDecodeFileStrict path `shouldReturn` Right firstReport + writeCompareReportAtomic path secondReport `shouldReturn` Right () + Aeson.eitherDecodeFileStrict path `shouldReturn` Right secondReport + + describe "historical codec comparison scaffold" $ do + it "emits an opt-in non-production runner without entering the ordinary module registry" $ do + spec <- specOf "test/fixtures/structural-conformance.keiro" + let ctx = defaultContext (specContext spec) + planned = codecComparisonModule ctx spec "ArtifactInfo" + ordinary = scaffoldModules ctx spec + case planned of + Left err -> expectationFailure (T.unpack err) + Right comparisonModule -> do + modulePath comparisonModule + `shouldBe` "Generated/StructuralConformance/Structural/CodecCompare/ArtifactInfo.hs" + moduleText comparisonModule `shouldSatisfy` T.isInfixOf codecComparisonBanner + moduleText comparisonModule `shouldSatisfy` T.isInfixOf "Generated.StructuralConformance.ArtifactCatalog.Codec qualified as GeneratedCodec" + moduleText comparisonModule `shouldSatisfy` T.isInfixOf "branchSchema = BranchRecord" + map modulePath ordinary `shouldNotContain` [modulePath comparisonModule] + it "refuses opaque selections rather than upgrading their claim" $ do + spec <- specOf "test/fixtures/structural-conformance.keiro" + codecComparisonModule (defaultContext (specContext spec)) spec "VendorGeometry" + `shouldSatisfy` either (T.isInfixOf "is opaque") (const False) + + describe "structural/opaque coverage reporting" $ do + it "reports mapped private-event roots and consumer-json register boundaries without a percentage" $ do + spec <- specOf "test/fixtures/structural-conformance.keiro" + report <- shouldResolveCoverage "structural-conformance.keiro" spec + Coverage.privateEventPayloads (Coverage.coverageSummary report) + `shouldBe` Coverage.CoverageCounts 2 1 1 0 + Coverage.snapshotRegisters (Coverage.coverageSummary report) + `shouldBe` Coverage.CoverageCounts 2 1 1 0 + map Coverage.opaqueMappedType (Coverage.coverageOpaqueBoundaries report) + `shouldBe` ["VendorGeometry"] + map Coverage.snapshotEncoding (Coverage.coverageSnapshotBoundaries report) + `shouldBe` ["consumer-json-cache", "consumer-json-cache"] + map Coverage.snapshotInvalidation (Coverage.coverageSnapshotBoundaries report) + `shouldBe` ["tracked-by-mapped-wire-fingerprint", "tracked-by-mapped-wire-fingerprint"] + map Coverage.findingCode (Coverage.coverageFindings report) + `shouldBe` [CoverageOpaqueSurface] + map Coverage.findingSeverity (Coverage.coverageFindings report) + `shouldBe` [Warning] + case Aeson.toJSON report of + Aeson.Object values -> + forM_ ["spec", "roots", "opaqueBoundaries", "snapshotBoundaries", "unsupportedSurfaces"] $ + \key -> KeyMap.member key values `shouldBe` True + value -> expectationFailure ("coverage report was not an object: " <> show value) + it "reports explicit Json leaves by their complete persisted path" $ do + spec <- withMetadataJson <$> specOf "test/fixtures/structural-conformance.keiro" + report <- shouldResolveCoverage "structural-conformance-json.keiro" spec + Coverage.jsonBoundaries (Coverage.privateEventPayloads (Coverage.coverageSummary report)) + `shouldBe` 1 + map Coverage.jsonPath (Coverage.coverageJsonBoundaries report) + `shouldBe` ["ArtifactCatalog event ArtifactRecorded .artifact : ArtifactInfo .metadata : ArtifactMetadata .note"] + it "keeps a zero-opaque spec advisory-free and makes rejection explicitly opt-in" $ do + original <- specOf "test/fixtures/structural-conformance.keiro" + clear <- shouldResolveCoverage "structural-only.keiro" (withoutVendorGeometry original) + Coverage.opaqueRoots (Coverage.privateEventPayloads (Coverage.coverageSummary clear)) `shouldBe` 0 + Coverage.coverageOpaqueBoundaries clear `shouldBe` [] + Coverage.coverageFindings clear `shouldBe` [] + opaque <- shouldResolveCoverage "structural-conformance.keiro" original + Coverage.coverageSucceeded opaque `shouldBe` True + let gated = Coverage.failOnOpaque opaque + Coverage.coverageSucceeded gated `shouldBe` False + map Coverage.findingCode (Coverage.coverageFindings gated) + `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueGateExceeded] + map Coverage.findingSeverity (Coverage.coverageFindings gated) + `shouldBe` [Warning, Error] + it "diffs named opaque boundaries and fails only an explicitly gated increase" $ do + newSpec <- specOf "test/fixtures/structural-conformance.keiro" + report <- case Coverage.coverageDiffReport "structural-conformance.keiro" "HEAD" (withoutVendorGeometry newSpec) newSpec of + Left err -> expectationFailure (show err) >> fail "unreachable" + Right value -> pure value + fmap Coverage.opaqueBoundaryDelta (Coverage.coverageDelta report) `shouldBe` Just 1 + fmap (map Coverage.opaqueMappedType . Coverage.addedOpaqueBoundaries) (Coverage.coverageDelta report) + `shouldBe` Just ["VendorGeometry"] + map Coverage.findingCode (Coverage.coverageFindings report) + `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueBoundaryAdded] + Coverage.coverageSucceeded report `shouldBe` True + let gated = Coverage.failOnOpaqueIncrease report + Coverage.coverageSucceeded gated `shouldBe` False + map Coverage.findingCode (Coverage.coverageFindings gated) + `shouldBe` [CoverageOpaqueSurface, CoverageOpaqueBoundaryAdded, CoverageOpaqueGateExceeded] + it "appends the six stable coverage and comparison registry codes" $ + map + show + [ CoverageOpaqueSurface + , CoverageOpaqueBoundaryAdded + , CoverageOpaqueGateExceeded + , CodecCompareDifference + , CodecCompareCoverageGap + , CodecCompareInvalidInput + ] + `shouldBe` [ "CoverageOpaqueSurface" + , "CoverageOpaqueBoundaryAdded" + , "CoverageOpaqueGateExceeded" + , "CodecCompareDifference" + , "CodecCompareCoverageGap" + , "CodecCompareInvalidInput" + ] + + describe "parse . pretty round-trip" $ + do + it "re-parses any generated spec to an equal AST (modulo source locations)" $ + checkCoverage $ + forAll genSpec $ \s -> + let families = map nodeTag (specNodes s) + roundTrip = parseSpec "" (renderSpec s) === Right s + in cover 5 (not (null (specMapped s))) "mapped" $ + foldr (\family -> cover 1 (family `elem` families) family) roundTrip allNodeTags + it "round-trips an aggregate with no states" $ + parseSpec "" (renderSpec emptyStatesSpec) `shouldBe` Right emptyStatesSpec + it "separates transition emit clauses from following nodes" $ do + spec <- parseInlineSpec "" crossFamilyBoundarySpec + case specNodes spec of + [NAggregate first, NEmit _, NAggregate second, NPgmqDispatch _] -> do + concatMap tEmits (aggTransitions first) `shouldBe` ["Changed"] + aggStates second `shouldBe` [] + nodes -> expectationFailure ("unexpected node sequence: " <> show (map nodeTag nodes)) + + describe "mapped types (EP-149)" $ do + it "round-trips the canonical structural and opaque consumer fixture" $ do + source <- TIO.readFile "test/fixtures/consumer-types.keiro" + spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source + parseSpec "" (renderSpec spec) `shouldBe` Right spec + length (specMapped spec) `shouldBe` 4 + it "preserves every missing-value policy, nested type expression, and unit union arm" $ do + source <- TIO.readFile "test/fixtures/consumer-types.keiro" + spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source + let fields = [field | MappedStructural{msShape = ShapeRecord _ _ recordFields} <- specMapped spec, field <- recordFields] + arms = [arm | MappedStructural{msShape = ShapeUnion _ unionArms} <- specMapped spec, arm <- unionArms] + [value | field <- fields, Just value <- [wfOnMissing field]] + `shouldBe` [OmCtor "Guide", OmNull, OmInt 0, OmBool False, OmEmptyList, OmEmptyMap] + [wfType field | field <- fields, wfHaskell field == "labels"] + `shouldBe` [TList (TOptional TText)] + [waCtor arm | arm <- arms, waPayload arm == Nothing] + `shouldBe` ["Unknown"] + it "rejects every mapped validation fixture with its stable diagnostic code" $ do + let cases = + [ ("mapped-unresolved.keiro", MappedUnresolvedName) + , ("mapped-ambiguous.keiro", MappedAmbiguousName) + , ("mapped-dup-fieldname.keiro", MappedDuplicateFieldName) + , ("mapped-dup-wirekey.keiro", MappedDuplicateWireKey) + , ("mapped-dup-armname.keiro", MappedDuplicateArmName) + , ("mapped-dup-tag.keiro", MappedDuplicateWireTag) + , ("mapped-recursive.keiro", MappedRecursiveType) + , ("mapped-recursive-mutual.keiro", MappedRecursiveType) + , ("mapped-bad-encoding.keiro", MappedUnsupportedEncoding) + , ("mapped-union-key-collision.keiro", MappedUnsupportedEncoding) + , ("mapped-optional-json.keiro", MappedNonInjectiveNullability) + , ("mapped-optional-optional.keiro", MappedNonInjectiveNullability) + , ("mapped-optional-opaque.keiro", MappedNonInjectiveNullability) + , ("mapped-missing-binding.keiro", MappedMissingIngredient) + , ("mapped-missing-binding-version.keiro", MappedMissingIngredient) + , ("mapped-missing-canonical.keiro", MappedMissingIngredient) + , ("mapped-missing-fixture.keiro", MappedMissingIngredient) + , ("mapped-missing-initial.keiro", MappedMissingInitialValue) + , ("mapped-bad-haskell-name.keiro", MappedInvalidHaskellName) + , ("mapped-empty-identity.keiro", MappedInvalidIdentity) + , ("mapped-import-conflict.keiro", MappedImportConflict) + , ("mapped-illtyped-default.keiro", MappedDefaultIllTyped) + , ("mapped-guard.keiro", MappedGuardUnsupported) + , ("mapped-guard-natural.keiro", MappedGuardUnsupported) + ] + forM_ cases $ \(fixture, expected) -> + errorCodesOf ("test/fixtures/" <> fixture) `shouldReturn` [expected] + it "keeps Time in Keiki's curated guard set while rejecting Natural" $ + errorCodesOf "test/fixtures/mapped-guard-time.keiro" `shouldReturn` [] + it "rejects required defaults, missing optional policies, Int overflow, and negative Natural defaults" $ do + let invalidFields = + [ WireField "requiredDefault" "requiredDefault" TText PRequired (Just (OmText "x")) noLoc + , WireField "missingPolicy" "missingPolicy" TText POptional Nothing noLoc + , WireField "overflow" "overflow" TInt POptional (Just (OmInt (toInteger (maxBound :: Int) + 1))) noLoc + , WireField "negativeNatural" "negativeNatural" TNatural POptional (Just (OmInt (-1))) noLoc + ] + declaration = completeStructural "Defaults" (ShapeRecord "Defaults" RejectUnknown invalidFields) + errorCodes (mappedSpec [declaration]) + `shouldBe` [MappedDefaultIllTyped, MappedMissingIngredient, MappedDefaultIllTyped, MappedDefaultIllTyped] + + describe "mapped type graph (EP-149)" $ do + it "resolves checked declarations, transitive reachability, and every aggregate root path" $ do + source <- TIO.readFile "test/fixtures/consumer-types.keiro" + spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source + graph <- shouldResolveTypeGraph spec + Map.size (tgDeclarations graph) `shouldBe` 4 + Map.lookup (MappedKey "ArtifactInfo") (tgReachability graph) + `shouldBe` Just (Set.fromList [MappedKey "ArtifactKind", MappedKey "ArtifactLocation"]) + map renderUsePath (usePaths graph "ArtifactLocation") + `shouldBe` [ "Catalog command ObserveArtifact .artifact : ArtifactInfo .location : ArtifactLocation" + , "Catalog event ArtifactObserved .artifact : ArtifactInfo .location : ArtifactLocation" + , "Catalog register currentArtifact : ArtifactInfo .location : ArtifactLocation" + ] + it "resolves every builtin through the complete expression algebra" $ do + source <- TIO.readFile "test/fixtures/consumer-types.keiro" + spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source + graph <- shouldResolveTypeGraph spec + case Map.lookup (MappedKey "ArtifactInfo") (tgDeclarations graph) of + Just (ResolvedStructural _ (RRecord _ _ fields)) -> + Set.fromList (concatMap (foldTypeExpr expressionTags . rwfType) fields) + `shouldBe` Set.fromList ["text", "int", "bool", "natural", "time", "json", "optional", "list", "map", "ref:ArtifactKind", "ref:ArtifactLocation"] + declaration -> expectationFailure ("unexpected ArtifactInfo declaration: " <> show declaration) + it "rejects direct, mutual, wrapped, and union-arm recursion" $ do + let direct = mappedSpec [completeStructural "A" (recordShape [TRef "A"])] + mutual = mappedSpec [completeStructural "A" (recordShape [TRef "B"]), completeStructural "B" (recordShape [TRef "A"])] + wrapped = mappedSpec [completeStructural "A" (recordShape [TList (TOptional (TRef "A"))])] + throughArm = mappedSpec [completeStructural "A" (ShapeUnion (TaggedObject "tag" "contents" RejectUnknown) [WireArm "Again" "again" (Just (TRef "A")) noLoc])] + map (hasTypeGraphError isRecursive . resolveTypeGraph) [direct, mutual, wrapped, throughArm] + `shouldBe` replicate 4 True + it "keeps existing ids and enums outside the mapped-reference namespace" $ do + let spec = + (mappedSpec [completeStructural "A" (recordShape [TRef "ExistingId"])]) + { specIds = [IdDecl "ExistingId" "id" noLoc] + } + resolveTypeGraph spec `shouldSatisfy` hasTypeGraphError isUnresolved + it "fingerprints wire identity while ignoring Haskell selector names" $ do + source <- TIO.readFile "test/fixtures/consumer-types.keiro" + base <- parseInlineSpec "test/fixtures/consumer-types.keiro" source + baseGraph <- shouldResolveTypeGraph base + haskellRenameGraph <- shouldResolveTypeGraph (mapArtifactField (\field -> field{wfHaskell = "renamedKey"}) base) + wireRenameGraph <- shouldResolveTypeGraph (mapArtifactField (\field -> field{wfKey = "renamed_key"}) base) + wireFingerprint haskellRenameGraph "ArtifactInfo" `shouldBe` wireFingerprint baseGraph "ArtifactInfo" + wireFingerprint wireRenameGraph "ArtifactInfo" `shouldNotBe` wireFingerprint baseGraph "ArtifactInfo" + + describe "string literal integrity" $ do + it "parses an escaped emit-map value as exactly one row" $ do + let src = + T.unlines + [ "context svc" + , "" + , "emit e {" + , " contract c" + , " topic events" + , " source \"svc\"" + , " key thingId" + , " map status {" + , " \"a\\\" => Wat \\\"b\" => ThingAccepted" + , " _ => skip" + , " }" + , " messageId derive hole" + , " idempotencyKey derive hole" + , "}" + ] + case parseSpec "" src of + Left err -> expectationFailure (T.unpack err) + Right spec -> case [row | NEmit e <- specNodes spec, row <- emMap e] of + [row] -> do + emrValue row `shouldBe` "a\" => Wat \"b" + emrEvent row `shouldBe` "ThingAccepted" + rows -> expectationFailure ("expected one emit-map row, got " <> show (length rows)) + it "rejects a raw newline inside a quoted string" $ do + let src = "context svc\n\ncontract c {\n schemaVersion 1\n discriminator kind\n topic events \"first\nsecond\"\n}\n" + parseSpec "" src `shouldSatisfy` leftContains "unescaped newline" + it "rejects an unknown escape sequence" $ do + let src = "context svc\n\ncontract c {\n schemaVersion 1\n discriminator kind\n topic events \"bad\\q\"\n}\n" + parseSpec "" src `shouldSatisfy` leftContains "unknown escape" + it "round-trips adversarial text through topics, emit maps, and quoted bindings" $ + property $ + forAll genAdversarialText $ \t -> + let spec = escapedSpec t + rendered = renderSpec spec + in counterexample (T.unpack rendered) (parseSpec "" rendered === Right spec) + + describe "partial status maps" $ do + it "suppresses totality only when the partial marker is present" $ do + partial <- parseInlineSpec "" (statusMapSpec " partial") + totalSpec <- parseInlineSpec "" (statusMapSpec "") + map code (validateSpec partial) `shouldNotContain` [StatusMapNotTotal] + map code (validateSpec totalSpec) `shouldContain` [StatusMapNotTotal] + parseSpec "" (renderSpec partial) `shouldBe` Right partial + + describe "positioned parser diagnostics" $ do + it "rejects a duplicate goto at the second clause" $ do + err <- parseErrorOf "" duplicateGotoSpec + err `shouldSatisfy` T.isInfixOf "duplicate goto" + err `shouldSatisfy` T.isInfixOf ":10:" + it "rejects duplicate wire and projection blocks at their second occurrences" $ do + wireErr <- parseErrorOf "" duplicateWireSpec + wireErr `shouldSatisfy` T.isInfixOf "duplicate wire block" + wireErr `shouldSatisfy` T.isInfixOf ":8:" + projectionErr <- parseErrorOf "" duplicateProjectionSpec + projectionErr `shouldSatisfy` T.isInfixOf "duplicate projection block" + projectionErr `shouldSatisfy` T.isInfixOf ":9:" + it "anchors a missing goto on the transition line" $ do + err <- parseErrorOf "" missingGotoSpec + err `shouldSatisfy` T.isInfixOf "missing a goto clause" + err `shouldSatisfy` T.isInfixOf ":8:" + it "stops before a misplaced dispatch-id and expects schedule at its start" $ do + let src = misplacedDispatchIdSpec + expectedPosition = + ":" + <> T.pack (show (lineNumberContaining "dispatch-id" src)) + <> ":5:" + err <- parseErrorOf "" src + err `shouldSatisfy` T.isInfixOf "schedule" + err `shouldSatisfy` T.isInfixOf expectedPosition + it "keeps a malformed register declaration's equals error" $ do + err <- parseErrorOf "" malformedRegisterSpec + err `shouldSatisfy` T.isInfixOf "expecting '='" + + describe "bounded decimal literals" $ do + forM_ decimalOverflowSpecs $ \(site, src) -> + it ("rejects overflow at " <> site) $ do + err <- parseErrorOf (" site <> ">") src + err `shouldSatisfy` T.isInfixOf ("decimal literal " <> decimalOverflow <> " is out of range") + it "accepts maxBound without changing its value" $ do + spec <- parseInlineSpec "" (wireDecimalSpec (T.pack (show (maxBound :: Int)))) + [wireSchemaVersion wire | NAggregate aggregate <- specNodes spec, Just wire <- [aggWire aggregate]] + `shouldBe` [maxBound] + + describe "identifier hygiene" $ do + it "reports constructor shape and Haskell keywords at their owning declarations" $ do + spec <- parseInlineSpec "" identifierHygieneSpec + [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic `elem` [IdentNotConstructorSafe, IdentHaskellKeyword]] + `shouldContain` [(IdentNotConstructorSafe, 3), (IdentHaskellKeyword, 7)] + it "rejects generated vertex constructors that collide with event constructors" $ do + spec <- parseInlineSpec "" vertexCollisionSpec + [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == VertexCtorCollision] + `shouldBe` [(VertexCtorCollision, 3)] + it "rejects underscore-leading names whose title-casing cannot make a module segment" $ do + spec <- parseInlineSpec "" underscoreNodeSpec + [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == IdentNotConstructorSafe] + `shouldBe` [(IdentNotConstructorSafe, 3)] + it "rejects non-ASCII identifier characters in the parser" $ + parseSpec "" unicodeIdentifierSpec `shouldSatisfy` leftContains "unexpected" + + describe "canonical reservation.keiro" $ + it "parses into the expected aggregate shape" $ do + input <- readTestText "test/fixtures/reservation.keiro" + case parseSpec "test/fixtures/reservation.keiro" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> do + specContext spec `shouldBe` "hospital-capacity" + length (specIds spec) `shouldBe` 3 + length (specEnums spec) `shouldBe` 3 + length (specRules spec) `shouldBe` 1 + case specNodes spec of + [NAggregate a] -> do + aggName a `shouldBe` "Reservation" + length (aggStates a) `shouldBe` 6 + length (aggCommands a) `shouldBe` 2 + length (aggEvents a) `shouldBe` 2 + length (aggTransitions a) `shouldBe` 2 + map stTerminal (aggStates a) `shouldBe` [False, False, False, True, True, True] + other -> expectationFailure ("expected one aggregate node, got " <> show (length other)) + + describe "validator" $ do + it "accepts the canonical reservation.keiro" $ do + codes <- errorCodesOf "test/fixtures/reservation.keiro" + codes `shouldBe` [] + it "rejects a missing status-map as StatusMapNotTotal" $ do + codes <- diagnosticCodesOf "test/fixtures/reservation-no-statusmap.keiro" + codes `shouldContain` [StatusMapNotTotal] + it "rejects an undeclared command as UndeclaredCommand" $ do + codes <- diagnosticCodesOf "test/fixtures/reservation-bad-command.keiro" + codes `shouldContain` [UndeclaredCommand] + it "rejects a wall-clock guard atom as ClockSampled" $ do + codes <- diagnosticCodesOf "test/fixtures/reservation-clock.keiro" + codes `shouldContain` [ClockSampled] + it "accepts a v2 event with a contiguous upcaster hole" $ do + codes <- errorCodesOf "test/fixtures/reservation-v2.keiro" + codes `shouldBe` [] + it "rejects a v2 event with no upcaster as EvtVersionMissingUpcaster" $ do + codes <- diagnosticCodesOf "test/fixtures/reservation-v2-noupcast.keiro" + codes `shouldContain` [EvtVersionMissingUpcaster] + it "accepts shared upcaster sources for different event kinds" $ do + codes <- errorCodesOf "test/fixtures/reservation-dup-upcast-source.keiro" + codes `shouldNotContain` [DuplicateUpcasterSource] + it "rejects a gap in the aggregate-global upcaster chain" $ do + codes <- errorCodesOf "test/fixtures/reservation-chain-gap.keiro" + codes `shouldContain` [UpcasterChainGap] + it "warns while a retiring event keeps its live emitting transition" $ do + diagnostics <- diagnosticsOf "test/fixtures/reservation-retiring.keiro" + [code d | d <- diagnostics, severity d == Error] `shouldBe` [] + [code d | d <- diagnostics, severity d == Warning] + `shouldContain` [EventRetirementInProgress] + it "rejects a retiring event after its live emitting transition disappears" $ do + source <- readTestText "test/fixtures/reservation-retiring.keiro" + spec <- parseInlineSpec "" (T.replace " ; emit TransferReservationConfirmed" "" source) + [code d | d <- validateSpec spec, severity d == Error] + `shouldContain` [EventRetirementInProgress] + it "warns when a deprecated event has no replay-only emitting transition" $ do + diagnostics <- diagnosticsOf "test/fixtures/reservation-deprecated.keiro" + [code d | d <- diagnostics, severity d == Error] `shouldBe` [] + [code d | d <- diagnostics, severity d == Warning] + `shouldContain` [DeprecatedEventReplayHazard] + it "recognises deprecated plus replay-only as the replay-safe cutover" $ do + diagnostics <- diagnosticsOf "test/fixtures/reservation-deprecated-replay-only.keiro" + [code d | d <- diagnostics, severity d == Error] `shouldBe` [] + [code d | d <- diagnostics, severity d == Warning] + `shouldContain` [EventRetirementInProgress] + [code d | d <- diagnostics] `shouldNotContain` [DeprecatedEventReplayHazard] + it "requires exact, unique status-map event keys" $ do + dangling <- errorCodesOf "test/fixtures/statusmap-dangling.keiro" + mapM_ (\expected -> dangling `shouldContain` [expected]) [StatusMapDanglingKey, StatusMapNotTotal] + duplicate <- errorCodesOf "test/fixtures/statusmap-dup-key.keiro" + duplicate `shouldContain` [StatusMapDuplicateKey] + it "rejects duplicate spec and aggregate names" $ do + codes <- errorCodesOf "test/fixtures/duplicate-names.keiro" + mapM_ + (\expected -> codes `shouldContain` [expected]) + [ DuplicateNodeName + , DuplicateEnumCtor + , DuplicateEnumWire + , DuplicateIdPrefix + , DuplicateCommandName + , DuplicateEventName + ] + it "rejects aggregate-local references that do not resolve" $ do + codes <- errorCodesOf "test/fixtures/aggregate-bad-refs.keiro" + codes `shouldContain` [RegisterInitialOutOfScope, UndeclaredCommand, WriteTargetNotRegister] + it "anchors UnreachableState on the state row" $ do + let src = + T.unlines + [ "context repro" + , "" + , "aggregate Thing" + , " regs" + , " states" + , " Initial" + , " Unreachable" + ] + case parseSpec "" src of + Left err -> expectationFailure (T.unpack err) + Right spec -> + [line d | d <- validateSpec spec, code d == UnreachableState] + `shouldBe` [7] + it "accepts a replay-only twin with a live sibling (plan 143)" $ do + codes <- errorCodesOf "test/fixtures/reservation-guard-tightened-twin.keiro" + codes `shouldBe` [] + it "rejects a replay-only transition that emits nothing" $ do + case parseSpec "" (replayOnlySpecWith [" write reservationState := Held", " goto Held"]) of + Left err -> expectationFailure (T.unpack err) + Right spec -> + [code d | d <- validateSpec spec, severity d == Error] + `shouldContain` [ReplayOnlyEmitsNothing] + it "warns when a replay-only transition has no live sibling" $ do + case parseSpec "" (replayOnlySpecWith [" emit TransferReservationCreated", " goto Held"]) of + Left err -> expectationFailure (T.unpack err) + Right spec -> do + [code d | d <- validateSpec spec, severity d == Warning] + `shouldContain` [ReplayOnlyCommandStillLive] + [code d | d <- validateSpec spec, severity d == Error] + `shouldNotContain` [ReplayOnlyCommandStillLive] + + describe "complementExpr (plan 143)" $ do + it "applies De Morgan over and/or and flips comparison operators" $ do + let a = EAtom (AName "a") + b = EAtom (AName "b") + complementExpr (EAnd a b) + `shouldBe` EOr (ECmp OpEq a (EAtom (ABool False))) (ECmp OpEq b (EAtom (ABool False))) + complementExpr (ECmp OpLt a b) `shouldBe` ECmp OpGe a b + complementExpr (ECmp OpEq a b) `shouldBe` ECmp OpNeq a b + complementExpr (ECmp OpLe a b) `shouldBe` ECmp OpGt a b + complementExpr (ECmp OpGt a b) `shouldBe` ECmp OpLe a b + complementExpr (ECmp OpGe a b) `shouldBe` ECmp OpLt a b + complementExpr (ECmp OpNeq a b) `shouldBe` ECmp OpEq a b + it "flips boolean literals and grounds bare names as == false" $ do + complementExpr (EAtom (ABool True)) `shouldBe` EAtom (ABool False) + complementExpr (EAtom (AName "open")) + `shouldBe` ECmp OpEq (EAtom (AName "open")) (EAtom (ABool False)) + it "stays inside the grammar: the complement of any guard re-parses" $ + property $ + forAll genExpr $ \e -> + let twin = + replayOnlySpecWith + [ " guard " <> renderExprText (complementExpr e) + , " emit TransferReservationCreated" + , " goto Held" + ] + in case parseSpec "" twin of + Left err -> counterexample (T.unpack err) False + Right spec -> + [tGuard t | NAggregate a <- specNodes spec, t <- aggTransitions a] + === [Just (complementExpr e)] + + describe "evolution parsing" $ do + it "parses event version and upcaster from reservation-v2.keiro" $ do + input <- readTestText "test/fixtures/reservation-v2.keiro" + case parseSpec "test/fixtures/reservation-v2.keiro" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> case [e | NAggregate a <- specNodes spec, e <- aggEvents a, evName e == "TransferReservationCreated"] of + (e : _) -> do + evVersion e `shouldBe` 2 + evUpcastFrom e `shouldBe` Just (1, Hole) + [] -> expectationFailure "TransferReservationCreated not found" + it "round-trips the retiring marker" $ do + spec <- specOf "test/fixtures/reservation-retiring.keiro" + parseSpec "" (renderSpec spec) `shouldBe` Right spec + [evRetiring event | NAggregate aggregate <- specNodes spec, event <- aggEvents aggregate, evName event == "TransferReservationConfirmed"] + `shouldBe` [True] + it "rejects an event marked both retiring and deprecated" $ do + source <- readTestText "test/fixtures/reservation-retiring.keiro" + let conflicting = T.replace "retiring event TransferReservationConfirmed" "retiring deprecated event TransferReservationConfirmed" source + parseSpec "" conflicting `shouldSatisfy` isLeft + + describe "aggregate snapshots (EP-109)" $ do + it "parses, validates, and round-trips a snapshot policy with codec fixture" $ do + spec <- specOf "test/fixtures/reservation-snapshot.keiro" + errorCodesOf "test/fixtures/reservation-snapshot.keiro" `shouldReturn` [] + parseSpec "" (renderSpec spec) `shouldBe` Right spec + case [aggregate | NAggregate aggregate <- specNodes spec] of + [aggregate] -> aggSnapshot aggregate `shouldBe` Just (SnapshotSpec (SnapEvery 100) 1 "7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc" noLoc) + aggregates -> expectationFailure ("expected one snapshot aggregate, got " <> show (length aggregates)) + it "rejects disabled intervals and invalid codec fixtures" $ do + source <- readTestText "test/fixtures/reservation-snapshot.keiro" + interval <- parseInlineSpec "" (T.replace "snapshot every 100" "snapshot every 0" source) + map code (validateSpec interval) `shouldContain` [SnapshotIntervalInvalid] + version <- parseInlineSpec "" (T.replace "state-codec version=1" "state-codec version=0" source) + map code (validateSpec version) `shouldContain` [SnapshotCodecFixtureInvalid] + emptyHash <- parseInlineSpec "" (T.replace "shape-hash=\"7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc\"" "shape-hash=\"\"" source) + map code (validateSpec emptyHash) `shouldContain` [SnapshotCodecFixtureInvalid] + it "conditionally lowers JSON instances and the live defaultStateCodec" $ do + snapshot <- specOf "test/fixtures/reservation-snapshot.keiro" + ordinary <- specOf "test/fixtures/reservation.keiro" + case ([aggregate | NAggregate aggregate <- specNodes snapshot], [aggregate | NAggregate aggregate <- specNodes ordinary]) of + ([snapshotAggregate], [ordinaryAggregate]) -> do + let snapshotModules = scaffoldAggregate (defaultContext (specContext snapshot)) snapshot snapshotAggregate + ordinaryModules = scaffoldAggregate (defaultContext (specContext ordinary)) ordinary ordinaryAggregate + snapshotDomain = generatedTextEndingIn "Domain.hs" snapshotModules + snapshotStream = generatedTextEndingIn "EventStream.hs" snapshotModules + ordinaryDomain = generatedTextEndingIn "Domain.hs" ordinaryModules + ordinaryStream = generatedTextEndingIn "EventStream.hs" ordinaryModules + snapshotDomain `shouldSatisfy` T.isInfixOf "deriving anyclass (ToJSON, FromJSON)" + snapshotStream `shouldSatisfy` T.isInfixOf "snapshotPolicy = Every 100" + snapshotStream `shouldSatisfy` T.isInfixOf "stateCodec = Just (withFoldFingerprint" + snapshotStream `shouldSatisfy` T.isInfixOf "Spec-visible fold changes invalidate old" + snapshotStream `shouldSatisfy` T.isInfixOf "module are invisible here" + snapshotStream `shouldSatisfy` T.isInfixOf "reservationSnapshotFixture = (1, \"7eb3a94f62f947231375d44083e2a1c8029d91ffe0329107d55092ed3430efcc\")" + ordinaryDomain `shouldNotSatisfy` T.isInfixOf "DeriveAnyClass" + ordinaryStream `shouldSatisfy` T.isInfixOf "snapshotPolicy = Never" + ordinaryStream `shouldSatisfy` T.isInfixOf "stateCodec = Nothing" + ordinaryStream `shouldSatisfy` T.isInfixOf "reservationCategory = Stream.categoryUnsafe \"reservation\"" + firewallBreaches snapshotModules `shouldBe` [] + _ -> expectationFailure "expected one aggregate in each snapshot test spec" + + describe "aggregate fold fingerprints (plan 138)" $ do + it "is deterministic across repeated parses and formatting-only changes" $ do + source <- readTestText "test/fixtures/reservation.keiro" + first <- parseInlineSpec "" source + second <- parseInlineSpec "" ("\n\n" <> renderSpec first <> "\n") + aggregateFoldFingerprint first (onlyAggregate first) + `shouldBe` aggregateFoldFingerprint second (onlyAggregate second) + it "changes for transition writes, guards, and referenced rule bodies" $ do + base <- specOf "test/fixtures/reservation.keiro" + writeChanged <- specOf "test/fixtures/reservation-foldchange.keiro" + guardChanged <- specOf "test/fixtures/reservation-guard-tightened.keiro" + source <- readTestText "test/fixtures/reservation.keiro" + ruleChanged <- parseInlineSpec "" (T.replace "RedTag => true" "RedTag => false" source) + let baseFingerprint = aggregateFoldFingerprint base (onlyAggregate base) + aggregateFoldFingerprint writeChanged (onlyAggregate writeChanged) `shouldNotBe` baseFingerprint + aggregateFoldFingerprint guardChanged (onlyAggregate guardChanged) `shouldNotBe` baseFingerprint + aggregateFoldFingerprint ruleChanged (onlyAggregate ruleChanged) `shouldNotBe` baseFingerprint + it "ignores wire and projection changes" $ do + base <- specOf "test/fixtures/reservation.keiro" + wireChanged <- specOf "test/fixtures/reservation-wire.keiro" + source <- readTestText "test/fixtures/reservation.keiro" + projectionChanged <- parseInlineSpec "" (T.replace "projection transfer_decisions" "projection renamed_projection" source) + let surface = aggregateFoldSurface base (onlyAggregate base) + aggregateFoldSurface wireChanged (onlyAggregate wireChanged) `shouldBe` surface + aggregateFoldSurface projectionChanged (onlyAggregate projectionChanged) `shouldBe` surface + it "invalidates mapped-register snapshots when binding or wire identity changes" $ do + base <- specOf "test/fixtures/consumer-types.keiro" + bindingChanged <- specOf "test/fixtures/consumer-types-binding-change.keiro" + wireChanged <- specOf "test/fixtures/consumer-types-wirekey.keiro" + let baseFingerprint = aggregateFoldFingerprint base (onlyAggregate base) + aggregateFoldFingerprint bindingChanged (onlyAggregate bindingChanged) `shouldNotBe` baseFingerprint + aggregateFoldFingerprint wireChanged (onlyAggregate wireChanged) `shouldNotBe` baseFingerprint + + describe "process/timer (EP-3)" $ do + it "parses the hospital-surge process + nested timer" $ do + input <- readTestText "test/fixtures/hospital-surge.keiro" + case parseSpec "test/fixtures/hospital-surge.keiro" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> case [p | NProcess p <- specNodes spec] of + (p : _) -> do + procId p `shouldBe` "HospitalSurge" + procName p `shouldBe` "hospital-surge" + procRejected p `shouldBe` PolHalt + procPoison p `shouldBe` PolHalt + sagaCategory (procSaga p) `shouldBe` "hospitalSurge" + tmName (procTimer p) `shouldBe` "surgeFollowUp" + onReject (fireDisposition (tmFire (procTimer p))) `shouldBe` OFired + onAmbiguous (fireDisposition (tmFire (procTimer p))) `shouldBe` ORetry + tmMaxAttempts (procTimer p) `shouldBe` 5 + [] -> expectationFailure "no process node parsed" + it "round-trips the hospital-surge spec through parse . pretty" $ do + input <- readTestText "test/fixtures/hospital-surge.keiro" + case parseSpec "in" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "accepts the hospital-surge spec (no errors; benign-inversion warnings only)" $ do + codes <- errorCodesOf "test/fixtures/hospital-surge.keiro" + codes `shouldBe` [] + it "rejects illegal saga categories and no longer parses the raw stream-prefix clause" $ do + spec <- specOf "test/fixtures/hospital-surge.keiro" + mapM_ + (\categoryName -> processErrorCodes (\process -> process{procSaga = (procSaga process){sagaCategory = categoryName}}) spec `shouldContain` [SagaCategoryIllegal]) + ["", "$all", "hospital-surge", "hospital surge", "wf:surge"] + source <- readTestText "test/fixtures/hospital-surge.keiro" + parseSpec "" (T.replace "saga Surge category \"hospitalSurge\"" "saga Surge stream=\"hospital-surge-\" <> correlationId" source) + `shouldSatisfy` isLeft + it "rejects a wall-clock fireAt as ProcessFireAtNotInjected" $ do + codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro" + codes `shouldContain` [ProcessFireAtNotInjected] + it "reports one ProcessFireAtNotInjected for a wholly unknown fireAt field" $ do + codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro" + length (filter (== ProcessFireAtNotInjected) codes) `shouldBe` 1 + it "rejects a user-supplied dispatch id as ProcessDispatchIdSupplied" $ do + codes <- errorCodesOf "test/fixtures/hospital-surge-dispatchid.keiro" + codes `shouldContain` [ProcessDispatchIdSupplied] + it "rejects an unresolved saga reference as ProcessUnresolvedRef" $ do + codes <- errorCodesOf "test/fixtures/hospital-surge-badref.keiro" + codes `shouldContain` [ProcessUnresolvedRef] + it "rejects unresolved process commands, projections, schedules, and advance ids" $ do + codes <- errorCodesOf "test/fixtures/process-ghost-refs.keiro" + length (filter (== ProcessUnresolvedRef) codes) `shouldBe` 5 + codes `shouldContain` [ProcessDispatchIdSupplied] + + describe "router (EP-108)" $ do + it "parses the incident-paging router shape" $ do + input <- readTestText "test/fixtures/incident-paging/incident-paging.keiro" + case parseSpec "test/fixtures/incident-paging/incident-paging.keiro" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> case [router | NRouter router <- specNodes spec] of + [router] -> do + rtId router `shouldBe` "PagingRouter" + rtName router `shouldBe` "jitsurei-paging" + corrField (rtKey router) `shouldBe` "incidentId" + rvSource (rtResolve router) `shouldBe` ResolveReadModel "service_oncall" + rvRow (rtResolve router) `shouldBe` ["responderId"] + rdCommand (rtDispatch router) `shouldBe` "SendPage" + rtRejected router `shouldBe` PolDeadLetter + rtPoison router `shouldBe` PolHalt + routers -> expectationFailure ("expected one router, got " <> show (length routers)) + it "round-trips the incident-paging spec through parse . pretty" $ do + input <- readTestText "test/fixtures/incident-paging/incident-paging.keiro" + case parseSpec "in" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "accepts the incident-paging router with warnings only" $ do + codes <- errorCodesOf "test/fixtures/incident-paging/incident-paging.keiro" + codes `shouldBe` [] + diagnostics <- diagnosticCodesOf "test/fixtures/incident-paging/incident-paging.keiro" + diagnostics `shouldContain` [PolicyDeadLetterUnused, AmbiguousFollowsRejectedPolicy] + it "rejects unresolved targets, keys, commands, and binding scopes" $ do + spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" + routerErrorCodes (\router -> router{rtTarget = "Pge"}) spec `shouldContain` [RouterUnresolvedRef] + routerErrorCodes (\router -> router{rtKey = (rtKey router){corrField = "incidntId"}}) spec `shouldContain` [RouterKeyFieldUnknown] + routerErrorCodes (\router -> router{rtDispatch = (rtDispatch router){rdCommand = "SendPag"}}) spec `shouldContain` [RouterCommandUnknown] + routerErrorCodes + ( \router -> + let dispatch = rtDispatch router + in router{rtDispatch = dispatch{rdFields = [FieldBinding "responderId" (Just "resolved.responder")]}} + ) + spec + `shouldContain` [RouterBindingUnscoped] + it "rejects unresolved read models and contradictory rejection policies" $ do + spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" + let withoutReadModel = removeReadModel "service_oncall" spec + errorCodes withoutReadModel `shouldContain` [RouterUnresolvedRef] + routerErrorCodes + ( \router -> + let dispatch = rtDispatch router + disposition = rdDisposition dispatch + in router + { rtRejected = PolHalt + , rtDispatch = dispatch{rdDisposition = disposition{onFailed = DDeadLetter "page rejected"}} + } + ) + spec + `shouldContain` [PolicyContradiction] + it "rejects on-ambiguous Fired for process timers" $ do + spec <- specOf "test/fixtures/hospital-surge.keiro" + let changed = + spec + { specNodes = + [ case node of + NProcess process -> + let timer = procTimer process + fire = tmFire timer + disposition = fireDisposition fire + in NProcess process{procTimer = timer{tmFire = fire{fireDisposition = disposition{onAmbiguous = OFired}}}} + _ -> node + | node <- specNodes spec + ] + } + errorCodes changed `shouldContain` [AmbiguousMarkedBenign] + it "requires explicit policy and ambiguity clauses in the grammar" $ do + source <- readTestText "test/fixtures/hospital-surge.keiro" + parseSpec "" (T.replace " poison => halt\n" "" source) `shouldSatisfy` isLeft + parseSpec "" (T.replace " ; on-ambiguous Retry" "" source) `shouldSatisfy` isLeft + it "scaffolds firewall-clean router wiring, policies, and typed-hole guidance" $ do + spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" + case [router | NRouter router <- specNodes spec] of + [router] -> do + let ctx = defaultContext (specContext spec) + modules = scaffoldRouter ctx router + generated = [m | m <- modules, kind m == Generated] + holes = [m | m <- modules, kind m == HoleStub] + firewallBreaches generated `shouldBe` [] + case (generated, holes) of + ([generatedModule], [holeModule]) -> do + moduleText generatedModule `shouldSatisfy` T.isInfixOf "pagingRouterWorkerOptions" + moduleText generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedDeadLetter" + moduleText holeModule `shouldSatisfy` T.isInfixOf "UNION of resolved target identities" + moduleText holeModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate" + _ -> expectationFailure "expected one generated router module and one router hole module" + routers -> expectationFailure ("expected one router, got " <> show (length routers)) + it "requires a caller callback for non-halting poison policies" $ do + spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" + case [router | NRouter router <- specNodes spec] of + [router] -> do + let ctx = defaultContext (specContext spec) + generatedFor choice = [moduleText m | m <- scaffoldRouter ctx router{rtPoison = choice}, kind m == Generated] + mapM_ + ( \(choice, constructor) -> case generatedFor choice of + [generatedModule] -> do + generatedModule `shouldSatisfy` T.isInfixOf "(Envelope msg -> Eff es ()) -> WorkerOptions es msg" + generatedModule `shouldSatisfy` T.isInfixOf (constructor <> " poisonCallback") + _ -> expectationFailure "expected one generated router module" + ) + [(PolDeadLetter, "PoisonDeadLetter"), (PolSkip, "PoisonSkip")] + case [moduleText m | m <- scaffoldRouter ctx router{rtRejected = PolSkip}, kind m == Generated] of + [generatedModule] -> generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedSkip" + _ -> expectationFailure "expected one generated router module" + routers -> expectationFailure ("expected one router, got " <> show (length routers)) + it "emits router harness facts that pin policy and target-keyed identity" $ do + spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" + case [router | NRouter router <- specNodes spec] of + [router] -> case harnessRouter (defaultContext (specContext spec)) router of + [facts] -> do + moduleText facts `shouldSatisfy` T.isInfixOf "(\"rejectedPolicy\", \"deadLetter\")" + moduleText facts `shouldSatisfy` T.isInfixOf "targetStreamName, occurrence" + modules -> expectationFailure ("expected one router harness, got " <> show (length modules)) + routers -> expectationFailure ("expected one router, got " <> show (length routers)) + it "rejects invalid timer ceilings and target field bindings" $ do + codes <- errorCodesOf "test/fixtures/process-bad-timer.keiro" + mapM_ + (\expected -> codes `shouldContain` [expected]) + [ProcessTimerCeilingInvalid, ProcessFieldBindingUnresolved] + it "accepts resolved process projection references" $ do + codes <- errorCodesOf "test/fixtures/surge-service.keiro" + codes `shouldBe` [] + it "scaffolds the process: Generated wiring is firewall-clean + a HoleStub" $ do + mods <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" + let gens = [m | m <- mods, kind m == Generated] + holes = [m | m <- mods, kind m == HoleStub] + length holes `shouldBe` 1 + firewallBreaches gens `shouldBe` [] + case gens of + [generatedModule] -> do + -- the worker uses the spec's ceiling, never the dangerous default + moduleText generatedModule `shouldSatisfy` T.isInfixOf "max-attempts = 5" + moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeProcessWorkerOptions" + moduleText generatedModule `shouldSatisfy` T.isInfixOf "hospitalSurgeCategory = Stream.categoryUnsafe \"hospitalSurge\"" + moduleText generatedModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate" + moduleText generatedModule `shouldSatisfy` T.isInfixOf "StreamName -> EventId -> CommandError -> Eff es Bool" + moduleText generatedModule `shouldSatisfy` T.isInfixOf "Left (CommandAmbiguous _)" + case holes of + [holeModule] -> moduleText holeModule `shouldSatisfy` T.isInfixOf "entityStream hospitalSurgeCategory" + _ -> expectationFailure "expected one process hole module" + _ -> expectationFailure "expected one generated process module" + it "process scaffold is deterministic" $ do + a <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" + b <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" + map moduleText a `shouldBe` map moduleText b + + describe "contract (EP-4)" $ do + it "parses the emergency contract (topics + events-on-topic + typed fields)" $ do + input <- readTestText "test/fixtures/contract.keiro" + case parseSpec "test/fixtures/contract.keiro" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> case [c | NContract c <- specNodes spec] of + (c : _) -> do + ctrName c `shouldBe` "emergency" + ctrDiscriminator c `shouldBe` "messageType" + map fst (ctrTopics c) `shouldBe` ["incidentEvents", "hospitalEvents"] + map ceName (ctrEvents c) `shouldBe` ["IncidentTransferNeedDeclared", "TransferReservationAccepted"] + [] -> expectationFailure "no contract node parsed" + it "round-trips the contract spec through parse . pretty" $ do + input <- readTestText "test/fixtures/contract.keiro" + case parseSpec "in" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "round-trips the intake (inbox) spec through parse . pretty" $ do + input <- readTestText "test/fixtures/intake.keiro" + case parseSpec "in" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "accepts the intake spec (complete disposition, no inversions)" $ do + codes <- errorCodesOf "test/fixtures/intake.keiro" + codes `shouldBe` [] + it "lowers explicit dedupe-only persistence and defaults omission to full-envelope" $ do + spec <- specOf "test/fixtures/intake.keiro" + ordinary <- specOf "test/fixtures/intake-decode.keiro" + case ([intake | NIntake intake <- specNodes spec], [intake | NIntake intake <- specNodes ordinary]) of + ([intake], [defaultIntake]) -> do + inkPersist intake `shouldBe` InkPersistDedupeOnly + inkPersist defaultIntake `shouldBe` InkPersistFull + renderSpec spec `shouldSatisfy` T.isInfixOf "persist = dedupe-only" + renderSpec ordinary `shouldNotSatisfy` T.isInfixOf "persist =" + let inbox = generatedTextEndingIn "Inbox.hs" (scaffoldIntake (defaultContext (specContext spec)) intake) + inbox `shouldSatisfy` T.isInfixOf "inboxPersistence = PersistDedupeOnly" + (intakes, defaultIntakes) -> + expectationFailure ("expected one intake in each fixture, got " <> show (length intakes, length defaultIntakes)) + it "rejects duplicate => retry (inversion 1)" $ do + codes <- errorCodesOf "test/fixtures/intake-dup-retry.keiro" + codes `shouldContain` [DispositionDuplicateRetry] + it "rejects previouslyFailed => retry (inversion 2)" $ do + codes <- errorCodesOf "test/fixtures/intake-pf-retry.keiro" + codes `shouldContain` [DispositionPreviouslyFailedRetry] + it "rejects an incomplete disposition table" $ do + codes <- errorCodesOf "test/fixtures/intake-incomplete.keiro" + codes `shouldContain` [DispositionIncomplete] + it "rejects a shadowing duplicate intake disposition row" $ do + codes <- errorCodesOf "test/fixtures/intake-dup-row.keiro" + codes `shouldContain` [DispositionDuplicateOutcome] + it "rejects intake events declared on another topic" $ do + codes <- errorCodesOf "test/fixtures/intake-topic-mismatch.keiro" + codes `shouldContain` [TopicAffinityMismatch] + it "round-trips the emit/publisher spec through parse . pretty" $ do + input <- readTestText "test/fixtures/emit.keiro" + case parseSpec "in" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "accepts the emit/publisher spec (skip present, coupling resolves)" $ do + codes <- errorCodesOf "test/fixtures/emit.keiro" + codes `shouldBe` [] + it "rejects a missing _ => skip catch-all as EmitSkipMissing" $ do + codes <- errorCodesOf "test/fixtures/emit-noskip.keiro" + codes `shouldContain` [EmitSkipMissing] + it "rejects mapping to an undeclared contract event as EmitUnresolvedContract" $ do + codes <- errorCodesOf "test/fixtures/emit-badevent.keiro" + codes `shouldContain` [EmitUnresolvedContract] + it "rejects emit events declared on another topic" $ do + codes <- errorCodesOf "test/fixtures/emit-topic-mismatch.keiro" + codes `shouldContain` [TopicAffinityMismatch] + + describe "pgmq workqueue/dispatch (EP-5)" $ do + it "round-trips the reservation-work spec through parse . pretty" $ do + input <- readTestText "test/fixtures/reservation-work.keiro" + case parseSpec "in" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "accepts the reservation-work spec (physical matches, no inversions)" $ do + codes <- errorCodesOf "test/fixtures/reservation-work.keiro" + codes `shouldBe` [] + it "rejects a divergent captured physical name as WqPhysicalDivergence" $ do + codes <- errorCodesOf "test/fixtures/reservation-work-divergent.keiro" + codes `shouldContain` [WqPhysicalDivergence] + it "rejects storeFailure => deadLetter as WqStoreFailureNotRetry" $ do + codes <- errorCodesOf "test/fixtures/reservation-work-sf-deadletter.keiro" + codes `shouldContain` [WqStoreFailureNotRetry] + it "rejects decodeFailure => retry as WqDecodeFailureNotDeadLetter" $ do + codes <- errorCodesOf "test/fixtures/reservation-work-df-retry.keiro" + codes `shouldContain` [WqDecodeFailureNotDeadLetter] + it "requires complete, unique workqueue disposition rows" $ do + incomplete <- errorCodesOf "test/fixtures/workqueue-incomplete.keiro" + incomplete `shouldContain` [WqDispositionIncomplete] + duplicateSpec <- specOf "test/fixtures/workqueue-dup-row.keiro" + let duplicateDiagnostics = [d | d <- validateSpec duplicateSpec, code d == DispositionDuplicateOutcome] + map line duplicateDiagnostics `shouldBe` [17] + it "checks the captured queueRef dlq and table fixtures" $ do + dlqCodes <- errorCodesOf "test/fixtures/workqueue-dlq-divergent.keiro" + dlqCodes `shouldContain` [WqDlqDivergence] + tableCodes <- errorCodesOf "test/fixtures/workqueue-table-divergent.keiro" + tableCodes `shouldContain` [WqTableDivergence] + it "matches queueRef for upper-case, punctuation, and hashed logical names" $ do + upper <- errorCodesOf "test/fixtures/workqueue-uppercase-logical.keiro" + upper `shouldBe` [] + hashed <- errorCodesOf "test/fixtures/workqueue-hashed-logical.keiro" + hashed `shouldBe` [] + derivedQueueTrio "hospital_capacity.reservation_work.per_hospital_fifo_lane_assignments" + `shouldBe` ( "hospital_capacity_reservat_757040df00976c33" + , "hospital_capacity_reservat_757040df00976c33_dlq" + , "pgmq.q_hospital_capacity_reservat_757040df00976c33" + ) + it "resolves dispatch dedup queues and payload wire fields" $ do + ghost <- errorCodesOf "test/fixtures/dispatch-dedup-ghost-queue.keiro" + ghost `shouldContain` [DispatchDedupQueueUnresolved] + field <- errorCodesOf "test/fixtures/dispatch-dedup-bad-field.keiro" + field `shouldContain` [DispatchDedupFieldUnresolved] + it "requires a resolvable group key exactly when ordering is FIFO" $ do + noKey <- errorCodesOf "test/fixtures/reservation-work-fifo-nokey.keiro" + noKey `shouldContain` [WqGroupKeyMissing] + unordered <- errorCodesOf "test/fixtures/reservation-work-key-unordered.keiro" + unordered `shouldContain` [WqGroupKeyWithoutFifo] + source <- readTestText "test/fixtures/reservation-work.keiro" + unresolved <- parseInlineSpec "" (T.replace "group key from reservationId" "group key from missingId" source) + map code (validateSpec unresolved) `shouldContain` [WqGroupKeyUnresolved] + it "warns on unlogged storage and rejects empty partition settings" $ do + warningCodes <- diagnosticCodesOf "test/fixtures/reservation-work-unlogged.keiro" + warningCodes `shouldContain` [WqUnloggedDurability] + partitionCodes <- errorCodesOf "test/fixtures/reservation-work-partitioned-empty.keiro" + partitionCodes `shouldContain` [WqPartitionSpecEmpty] + it "lowers ordering, provisioning, and raw group-key projection" $ do + spec <- specOf "test/fixtures/reservation-work.keiro" + case [workqueue | NWorkqueue workqueue <- specNodes spec] of + workqueue : _ -> do + let modules = scaffoldWorkqueue (defaultContext (specContext spec)) workqueue + queue = generatedTextEndingIn "Queue.hs" modules + policy = generatedTextEndingIn "QueuePolicy.hs" modules + queue `shouldSatisfy` T.isInfixOf "groupKeyFor payload = payload.reservationId" + policy `shouldSatisfy` T.isInfixOf "jobOrdering = FifoThroughput" + policy `shouldSatisfy` T.isInfixOf "withFifoIndexProvision (standardProvision)" + firewallBreaches modules `shouldBe` [] + [] -> expectationFailure "reservation-work fixture has no workqueue" + + describe "readmodel (EP-107)" $ do + it "parses and round-trips first-class read models" $ do + spec <- specOf "test/fixtures/readmodel.keiro" + case [readModel | NReadModel readModel <- specNodes spec] of + [subscriptionModel, inlineModel] -> do + rmName subscriptionModel `shouldBe` "transfer_decisions" + rmColumns subscriptionModel + `shouldBe` [ RmColumn "reservation_id" "text" True + , RmColumn "hospital_id" "text" True + , RmColumn "status" "text" True + , RmColumn "decided_at" "timestamptz" False + ] + rmScope subscriptionModel `shouldBe` Just (RmCategory "reservation") + rmFeed subscriptionModel `shouldBe` RmSubscription + rmSubscription subscriptionModel `shouldBe` Just "hospital-capacity-transfer-decisions-sub" + rmName inlineModel `shouldBe` "subscriptions" + rmScope inlineModel `shouldBe` Nothing + rmFeed inlineModel `shouldBe` RmInline + nodes -> expectationFailure ("expected two readmodel nodes, got " <> show (length nodes)) + parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "accepts an aggregate projection without a consistency clause" $ do + spec <- parseInlineSpec "" projectionWithoutConsistencySpec + case [projection | NAggregate aggregate <- specNodes spec, Just projection <- [aggProjection aggregate]] of + [projection] -> projConsistency projection `shouldBe` Nothing + projections -> expectationFailure ("expected one projection, got " <> show (length projections)) + it "pins the canonical UTF-8 shape digest and runtime identities" $ do + spec <- specOf "test/fixtures/readmodel.keiro" + case [readModel | NReadModel readModel <- specNodes spec] of + (subscriptionModel : inlineModel : _) -> do + canonicalShape subscriptionModel + `shouldBe` "transfer_decisions|reservation_id:text:req|hospital_id:text:req|status:text:req|decided_at:timestamptz:null" + deriveShapeHash subscriptionModel `shouldBe` "fnv1a:3717f6d9e3c44bd6" + deriveShapeHash inlineModel `shouldBe` "fnv1a:f54d9bb2f40a6738" + registryNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions" + subscriptionNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions-sub" + subscriptionNameFor "billing" inlineModel `shouldBe` "billing-subscriptions-sub" + nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes)) + it "accepts the positive readmodel fixture with all references resolved" $ do + spec <- specOf "test/fixtures/readmodel.keiro" + validateSpec spec `shouldBe` [] + it "rejects shape drift and unknown SQL column types" $ do + codes <- errorCodesOf "test/fixtures/readmodel-shape-drift.keiro" + codes `shouldContain` [RmShapeHashDrift, RmUnknownColumnType] + it "rejects Strong on inline and standalone projections" $ do + inlineCodes <- errorCodesOf "test/fixtures/readmodel-strong-inline.keiro" + inlineCodes `shouldContain` [RmStrongInlineOnly] + standalone <- specOf "test/fixtures/readmodel-strong-standalone.keiro" + let diagnostics = validateSpec standalone + map code diagnostics `shouldContain` [RmStrongInlineOnly, RmProjectionWithoutNode] + [severity diagnostic | diagnostic <- diagnostics, code diagnostic == RmProjectionWithoutNode] + `shouldBe` [Warning] + it "rejects scope without Strong and an unreferenced inline feed" $ do + scopeCodes <- errorCodesOf "test/fixtures/readmodel-scope-eventual.keiro" + scopeCodes `shouldContain` [RmScopeWithoutStrong] + inlineCodes <- errorCodesOf "test/fixtures/readmodel-inline-unreferenced.keiro" + inlineCodes `shouldContain` [RmInlineFeedUnreferenced] + it "rejects projection consistency conflicts" $ do + codes <- errorCodesOf "test/fixtures/readmodel-consistency-conflict.keiro" + codes `shouldContain` [RmConsistencyConflict] + it "resolves query read models and validates query consistency" $ do + codes <- errorCodesOf "test/fixtures/readmodel-query-unresolved.keiro" + codes `shouldContain` [QueryUnresolvedReadModel, QueryConsistencyInvalid] + it "resolves dispatch read models and declared dedup columns" $ do + codes <- errorCodesOf "test/fixtures/readmodel-dispatch-unresolved.keiro" + codes `shouldContain` [DispatchReadModelUnresolved, DispatchReadModelFieldUnknown] + it "scaffolds runtime records, rebuild helpers, async wiring, and typed holes" $ do + spec <- specOf "test/fixtures/readmodel.keiro" + let ctx = defaultContext (specContext spec) + readModels = [readModel | NReadModel readModel <- specNodes spec] + modules = concatMap (scaffoldReadModel ctx) readModels + transfer = generatedTextEndingIn "Transfer_decisions/ReadModel.hs" modules + inline = generatedTextEndingIn "Subscriptions/ReadModel.hs" modules + transferHoles = [moduleText m | m <- modules, "Transfer_decisions/ReadModelHoles.hs" `T.isSuffixOf` T.pack (modulePath m)] + length modules `shouldBe` 6 + length [m | m <- modules, kind m == Generated] `shouldBe` 4 + length [m | m <- modules, kind m == HoleStub] `shouldBe` 2 + firewallBreaches modules `shouldBe` [] + transfer `shouldSatisfy` T.isInfixOf "registerTransferDecisions" + transfer `shouldSatisfy` T.isInfixOf "Rebuild.startRebuild transferDecisionsReadModel [\"hospital-capacity-transfer-decisions-async\"]" + transfer `shouldSatisfy` T.isInfixOf "strongScope = CategoryHead \"reservation\"" + transfer `shouldSatisfy` T.isInfixOf "transferDecisionsAsyncProjection" + inline `shouldSatisfy` T.isInfixOf "Rebuild.startRebuild subscriptionsReadModel []" + inline `shouldNotSatisfy` T.isInfixOf "AsyncProjection" + transferHoles `shouldSatisfy` any (T.isInfixOf "RecordedEvent -> Tx.Transaction ()") + it "threads qualified table and column guidance into aggregate projection holes" $ do + spec <- specOf "test/fixtures/readmodel.keiro" + case [aggregate | NAggregate aggregate <- specNodes spec] of + [aggregate] -> do + let modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate + holes = [moduleText m | m <- modules, kind m == HoleStub] + projection = generatedTextEndingIn "Projection.hs" modules + holes `shouldSatisfy` any (T.isInfixOf "subscriptionsQualifiedTable") + holes `shouldSatisfy` any (T.isInfixOf "Table: \"billing\".\"subscriptions\"") + projection `shouldSatisfy` T.isInfixOf "ReadModelTable.subscriptionsQualifiedTable" + aggregates -> expectationFailure ("expected one aggregate, got " <> show (length aggregates)) + it "emits runtime-free derivation facts for each read model" $ do + spec <- specOf "test/fixtures/readmodel.keiro" + case [readModel | NReadModel readModel <- specNodes spec] of + (subscriptionModel : _) -> do + let modules = harnessReadModel (defaultContext (specContext spec)) subscriptionModel + harnessText = generatedTextEndingIn "ReadModelHarness.hs" modules + length modules `shouldBe` 1 + firewallBreaches modules `shouldBe` [] + harnessText `shouldSatisfy` T.isInfixOf "(\"shapeHash\", \"fnv1a:3717f6d9e3c44bd6\", \"fnv1a:3717f6d9e3c44bd6\")" + harnessText `shouldSatisfy` T.isInfixOf "(\"strongScope\", \"CategoryHead reservation\", \"CategoryHead reservation\")" + harnessText `shouldSatisfy` T.isInfixOf "runReadModelFacts" + nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes)) + + describe "workflow/operation (EP-6)" $ do + it "round-trips the workflow spec through parse . pretty" $ do + input <- readTestText "test/fixtures/workflow.keiro" + case parseSpec "in" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> parseSpec "in" (renderSpec spec) `shouldBe` Right spec + it "accepts the workflow spec (await<->signal matches, run resolves)" $ do + codes <- errorCodesOf "test/fixtures/workflow.keiro" + codes `shouldBe` [] + it "rejects a signal label with no matching await as AwaitSignalMismatch" $ do + codes <- errorCodesOf "test/fixtures/workflow-signal-mismatch.keiro" + codes `shouldContain` [AwaitSignalMismatch] + it "rejects duplicate workflow labels" $ do + codes <- errorCodesOf "test/fixtures/workflow-dup-label.keiro" + codes `shouldContain` [WorkflowDuplicateLabel] + it "rejects unresolved workflow id and sleep fields" $ do + codes <- errorCodesOf "test/fixtures/workflow-unresolved-fields.keiro" + codes `shouldContain` [WorkflowIdFieldUnresolved, WorkflowSleepDelayUnresolved] + it "validates rule domains, totality, case constructors, and bodies" $ do + unresolved <- errorCodesOf "test/fixtures/rule-bad-domain.keiro" + unresolved `shouldBe` [RuleDomainUnresolved] + codes <- errorCodesOf "test/fixtures/rule-not-total.keiro" + mapM_ + (\expected -> codes `shouldContain` [expected]) + [RuleNotTotal, RuleCaseUnknownCtor, ClockSampled, GuardAtomOutOfScope] + it "rejects unresolved command operation references" $ do + codes <- errorCodesOf "test/fixtures/operation-ghost-aggregate.keiro" + codes `shouldContain` [OperationUnresolvedRef] + it "rejects a signal value type that differs from its await" $ do + codes <- errorCodesOf "test/fixtures/operation-signal-value.keiro" + codes `shouldContain` [AwaitSignalValueMismatch] + it "round-trips guarded patches and terminal continueAsNew" $ do + input <- readTestText "test/fixtures/workflow-evolution.keiro" + case parseSpec "workflow-evolution" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> do + parseSpec "workflow-evolution" (renderSpec spec) `shouldBe` Right spec + errorCodes spec `shouldBe` [] + it "rejects duplicate patch ids anywhere in the workflow body" $ do + codes <- errorCodesOf "test/fixtures/workflow-patch-dup.keiro" + codes `shouldBe` [WorkflowPatchDuplicate] + it "rejects non-terminal and nested continueAsNew" $ do + codes <- errorCodesOf "test/fixtures/workflow-can-mid.keiro" + codes `shouldBe` [WorkflowContinueAsNewNotTerminal, WorkflowContinueAsNewNotTerminal] + it "rejects a colon in a patch id with a workflow diagnostic" $ do + codes <- errorCodesOf "test/fixtures/workflow-patch-colon.keiro" + codes `shouldBe` [WorkflowPatchIdInvalid] + it "lowers patch facts and live runtime declarations" $ do + spec <- specOf "test/fixtures/workflow-evolution.keiro" + case [workflow | NWorkflow workflow <- specNodes spec] of + [workflow] -> do + let modules = harnessWorkflow (defaultContext (specContext spec)) workflow + facts = generatedTextEndingIn "WorkflowFacts.hs" modules + runtime = generatedTextEndingIn "WorkflowRuntime.hs" modules + facts `shouldSatisfy` T.isInfixOf "patch:fraud-check-v2(step:fraud-check)" + facts `shouldSatisfy` T.isInfixOf "continueAsNew:RolloverSeed" + facts `shouldSatisfy` T.isInfixOf "(\"patches\", \"fraud-check-v2\")" + runtime `shouldSatisfy` T.isInfixOf "declaredPatches = Set.fromList [PatchId \"fraud-check-v2\"]" + runtime `shouldSatisfy` T.isInfixOf "opts{activePatches = declaredPatches}" + workflows -> expectationFailure ("expected one workflow, got " <> show (length workflows)) + + describe "replay impact" $ do + it "treats new events and transitions as replay-neutral" $ do + old <- specOf "test/fixtures/reservation.keiro" + let aggregate = onlyAggregate old + case (aggEvents aggregate, aggTransitions aggregate) of + (event : _, transition : _) -> do + let newEvent = + event + { evName = "ReservationReviewed" + , evLoc = noLoc + } + newTransition = + transition + { tEmits = ["ReservationReviewed"] + , tLoc = noLoc + } + new = + modifyAggregate + "Reservation" + ( \candidate -> + candidate + { aggEvents = aggEvents candidate <> [newEvent] + , aggTransitions = aggTransitions candidate <> [newTransition] + } + ) + old + ReplayImpact.replayImpact old new `shouldBe` ReplayNeutral + _ -> expectationFailure "reservation fixture must contain an event and transition" + + it "narrows a guard edit to that transition's event types" $ do + impact <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened.keiro" + impact + `shouldBe` ReplayAffected + ( Map.singleton + "Reservation" + AggregateImpact + { eventTypes = Set.singleton "TransferReservationCreated" + , includeSnapshotStreams = True + } + ) + + it "proves a syntactic guard loosening replay-neutral" $ do + old <- specOf "test/fixtures/reservation.keiro" + let loosened = + modifyAggregate + "Reservation" + ( \aggregate -> + aggregate + { aggTransitions = + [ transition{tGuard = Nothing} + | transition <- aggTransitions aggregate + ] + } + ) + old + ReplayImpact.replayImpact old loosened `shouldBe` ReplayNeutral + + it "marks every existing event when the aggregate wire convention changes" $ do + impact <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-wire.keiro" + case impact of + ReplayAffected aggregates -> + ReplayImpact.eventTypes <$> Map.lookup "Reservation" aggregates + `shouldBe` Just (Set.fromList ["TransferReservationCreated", "TransferReservationConfirmed"]) + ReplayNeutral -> expectationFailure "expected a wire-clause replay impact" + + it "includes snapshot streams when a write expression changes" $ do + impact <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-foldchange.keiro" + case impact of + ReplayAffected aggregates -> + includeSnapshotStreams <$> Map.lookup "Reservation" aggregates + `shouldBe` Just True + ReplayNeutral -> expectationFailure "expected a fold replay impact" + + it "detects codec evolution and ignores formatting-only rewrites" $ do + changed <- replayImpactFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v2.keiro" + changed `shouldSatisfy` (/= ReplayNeutral) + old <- specOf "test/fixtures/reservation.keiro" + formatted <- parseInlineSpec "" (renderSpec old) + ReplayImpact.replayImpact old formatted `shouldBe` ReplayNeutral + + it "names mapped nested event and snapshot roots while ignoring Haskell-only changes" $ do + nested <- replayImpactFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-nested-propagation.keiro" + case nested of + ReplayAffected aggregates -> + Map.lookup "Catalog" aggregates + `shouldBe` Just AggregateImpact{eventTypes = Set.singleton "ArtifactObserved", includeSnapshotStreams = True} + ReplayNeutral -> expectationFailure "expected nested mapped wire change to affect replay" + sourceOnly <- replayImpactFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-haskell-rename.keiro" + sourceOnly `shouldBe` ReplayNeutral + + it "generates one context target for every aggregate, including the process saga" $ do + spec <- specOf "test/fixtures/surge-service.keiro" + case scaffoldReplayAudit (defaultContext (specContext spec)) spec of + [assembly] -> do + modulePath assembly `shouldBe` "Generated/SurgeDemo/ReplayAudit.hs" + moduleText assembly `shouldSatisfy` T.isInfixOf "Hospital.hospitalEventStream" + moduleText assembly `shouldSatisfy` T.isInfixOf "Surge.surgeEventStream" + T.count " AuditTarget" (moduleText assembly) `shouldBe` 2 + assemblies -> expectationFailure ("expected one replay-audit assembly, got " <> show (length assemblies)) + + describe "diff (evolution classification)" $ do + it "covers every node family exactly once and explains exclusions" $ do + sort (map fst familyRegistry) `shouldBe` ([minBound .. maxBound] :: [NodeFamily]) + [reason | (_, OutOfDiffScope reason) <- familyRegistry, T.null reason] `shouldBe` [] + it "derives every exercised headline from its vector under the default gate" $ do + changes <- + concat + <$> mapM + (uncurry diffFixtures) + [ ("test/fixtures/reservation.keiro", "test/fixtures/reservation-fieldadd.keiro") + , ("test/fixtures/reservation.keiro", "test/fixtures/reservation-v2.keiro") + , ("test/fixtures/reservation.keiro", "test/fixtures/reservation-enumadd.keiro") + , ("test/fixtures/contract.keiro", "test/fixtures/contract-fieldadd.keiro") + , ("test/fixtures/reservation-work.keiro", "test/fixtures/reservation-work-rename.keiro") + ] + forM_ changes $ \change -> + do + deriveLabel defaultGate (ckVector (kindOfChange change)) + `shouldBe` labelOfChange change + gatedBreaking defaultGate change `shouldBe` isBreaking change + it "never removes a breaking result when the gate grows" $ + property $ + forAll genCompatibilityVector $ \compatibility -> + forAll genSurfaceSet $ \gate -> + forAll genSurfaceSet $ \extra -> + deriveLabel gate compatibility + == LabelBreaking + ==> deriveLabel (gate <> extra) compatibility + == LabelBreaking + it "renders the consumer-neutral matrix with separate private, snapshot, and public surfaces" $ do + changes <- diffFixtures "test/fixtures/compatibility-vector-old.keiro" "test/fixtures/compatibility-vector-new.keiro" + golden <- readTestText "test/fixtures/compatibility-vector.diff.golden" + let rendered = T.intercalate "\n" (map renderFinding changes) + explained = T.intercalate "\n" (map renderExplainBlock changes) + reportJson = T.pack (show (Aeson.toJSON (diffReport defaultGate changes))) + T.stripEnd rendered `shouldBe` T.stripEnd golden + rendered `shouldSatisfy` T.isInfixOf "Reservation.event.TransferReservationCreated.patientAcuity" + rendered `shouldSatisfy` T.isInfixOf "old-binary-read-new-events=breaking" + rendered `shouldSatisfy` T.isInfixOf "snapshot-hydration=advisory" + rendered `shouldSatisfy` T.isInfixOf "public-consumer=breaking" + explained `shouldSatisfy` T.isInfixOf "invalidate and rebuild snapshots" + reportJson `shouldSatisfy` T.isInfixOf "keiro-dsl/diff-report/1" + reportJson `shouldSatisfy` T.isInfixOf "Reservation.event.TransferReservationCreated.patientAcuity" + let eventEnumFindings = + [ change + | change@(Advisory kind) <- changes + , ckCode kind == EnumCtorAdded + , verdictFor OldBinaryReadNewEvents (ckVector kind) == VBreaking + ] + eventEnumFindings `shouldSatisfy` all (not . gatedBreaking defaultGate) + eventEnumFindings `shouldSatisfy` all (gatedBreaking (gateWith [OldBinaryReadNewEvents])) + forM_ changes $ \change -> + remediationFor (ckContext (kindOfChange change)) (ckCode (kindOfChange change)) + `shouldSatisfy` (not . null) + it "rejects unknown --gate values with the valid surface list" $ do + parseSurfaceName "mystery-surface" + `shouldSatisfy` either (T.isInfixOf "old-binary-read-new-events" . T.pack) (const False) + it "covers the mapped evolution matrix with stable codes and non-empty remedies" $ do + let cases = + [ ("consumer-types-fieldadd-default.keiro", MappedFieldAddedWithDefault) + , ("consumer-types-fieldadd-nodefault.keiro", MappedFieldAddedNoDefault) + , ("consumer-types-fieldremove.keiro", MappedFieldRemoved) + , ("consumer-types-wirekey.keiro", MappedWireKeyChanged) + , ("consumer-types-haskell-rename.keiro", MappedHaskellSourceChanged) + , ("consumer-types-binding-change.keiro", MappedBindingChanged) + , ("consumer-types-fixtures-change.keiro", MappedFixturesChanged) + , ("consumer-types-initial-change.keiro", MappedInitialChanged) + , ("consumer-types-armadd.keiro", MappedArmAdded) + , ("consumer-types-tagchange.keiro", MappedArmTagChanged) + , ("consumer-types-enumadd.keiro", MappedEnumValueAdded) + , ("consumer-types-enumremove.keiro", MappedEnumValueRemoved) + , ("consumer-types-enumspelling.keiro", MappedEnumSpellingChanged) + , ("consumer-types-encoding.keiro", MappedUnionEncodingChanged) + , ("consumer-types-opaque-version.keiro", MappedOpaqueCodecChanged) + , ("consumer-types-mode-cross.keiro", MappedModeCrossed) + , ("consumer-types-nested-propagation.keiro", MappedArmTagChanged) + ] + forM_ cases $ \(fixture, expectedCode) -> do + changes <- diffFixtures "test/fixtures/consumer-types.keiro" ("test/fixtures/" <> fixture) + map (ckCode . kindOfChange) changes `shouldContain` [expectedCode] + forM_ changes $ \change -> + remediationFor (ckContext (kindOfChange change)) (ckCode (kindOfChange change)) + `shouldSatisfy` (not . null) + it "separates mapped event migration, snapshot invalidation, and directional rollout" $ do + breakingAdd <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-fieldadd-nodefault.keiro" + let noDefault = [change | change <- breakingAdd, ckCode (kindOfChange change) == MappedFieldAddedNoDefault] + [ckFacet kind | Breaking kind <- noDefault] `shouldContain` ["mapped-event"] + [ckFacet kind | Advisory kind <- noDefault] `shouldContain` ["mapped-register"] + defaulted <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-fieldadd-default.keiro" + [change | change <- defaulted, isBreaking change] `shouldBe` [] + let eventDefaults = [kind | Advisory kind <- defaulted, ckCode kind == MappedFieldAddedWithDefault, ckFacet kind == "mapped-event"] + eventDefaults `shouldSatisfy` any ((== VBreaking) . verdictFor OldBinaryReadNewEvents . ckVector) + armAdded <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-armadd.keiro" + [change | change <- armAdded, isBreaking change] `shouldBe` [] + [kind | Advisory kind <- armAdded, ckCode kind == MappedArmAdded, ckFacet kind == "mapped-event"] + `shouldSatisfy` any ((== VBreaking) . verdictFor OldBinaryReadNewEvents . ckVector) + it "propagates a nested mapped leaf to complete command, event, and register paths" $ do + changes <- diffFixtures "test/fixtures/consumer-types.keiro" "test/fixtures/consumer-types-nested-propagation.keiro" + let subjects = + [ ckSubject kind + | change <- changes + , let kind = kindOfChange change + , ckCode kind == MappedArmTagChanged + ] + subjects + `shouldContain` [ "Catalog command ObserveArtifact .artifact : ArtifactInfo .location : ArtifactLocation .arm RepoPath[\"repository_path\"]" + , "Catalog event ArtifactObserved .artifact : ArtifactInfo .location : ArtifactLocation .arm RepoPath[\"repository_path\"]" + , "Catalog register currentArtifact : ArtifactInfo .location : ArtifactLocation .arm RepoPath[\"repository_path\"]" + ] + it "classifies every remaining mapped field and declaration evolution row" $ do + base <- specOf "test/fixtures/consumer-types.keiro" + let mutationCodes = + [ (mapArtifactNamedField "key" (\field -> field{wfType = TInt}) base, MappedFieldTypeChanged) + , (mapArtifactNamedField "key" (\field -> field{wfPresence = POptional, wfOnMissing = Just (OmText "")}) base, MappedPresenceChanged) + , (mapArtifactNamedField "key" (\field -> field{wfType = TOptional TText}) base, MappedNullabilityChanged) + , (mapArtifactNamedField "description" (\field -> field{wfOnMissing = Nothing}) base, MappedDefaultRemoved) + , (mapArtifactNamedField "count" (\field -> field{wfOnMissing = Just (OmInt 1)}) base, MappedDefaultChanged) + , (mapMappedStructural "ArtifactInfo" renameMappedRecordConstructor base, MappedRecordConstructorChanged) + , (mapMappedStructural "ArtifactInfo" changeMappedCanonical base, MappedCanonicalTypeChanged) + ] + forM_ mutationCodes $ \(candidate, expectedCode) -> + map (ckCode . kindOfChange) (diffSpecs base candidate) `shouldContain` [expectedCode] + let declarationA = completeStructural "A" (recordShape [TText]) + declarationB = completeStructural "B" (recordShape [TInt]) + onlyA = mappedSpec [declarationA] + withB = mappedSpec [declarationA, declarationB] + map (ckCode . kindOfChange) (diffSpecs onlyA withB) `shouldContain` [MappedDeclAdded] + map (ckCode . kindOfChange) (diffSpecs withB onlyA) `shouldContain` [MappedDeclRemoved] + diffSpecs base (mapArtifactNamedField "key" (\field -> field{wfHaskell = "renamedKey"}) base) + `shouldBe` [] + it "visits every mapped wire mutation and reports every complete root path" $ do + base <- specOf "test/fixtures/consumer-types.keiro" + let mutations = mappedWireMutations base + mutations `shouldSatisfy` (not . null) + visited <- fmap Set.unions . forM mutations $ \mutation -> do + let changes = + [ change + | change <- diffSpecs base (mmCandidate mutation) + , ckCode (kindOfChange change) == mmCode mutation + ] + actualSubjects = Set.fromList (map (ckSubject . kindOfChange) changes) + changes `shouldSatisfy` any (not . isAdditiveChange) + actualSubjects `shouldBe` mmExpectedSubjects mutation + pure actualSubjects + visited `shouldBe` Set.unions (map mmExpectedSubjects mutations) + it "reports the exact ingredient code when every required mapped fact is deleted" $ do + base <- specOf "test/fixtures/consumer-types.keiro" + forM_ (mappedIngredientMutations base) $ \(candidate, expectedCode) -> + errorCodes candidate `shouldContain` [expectedCode] + it "classifies a field added without a version bump as BREAKING" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldadd.keiro" + any isBreaking cs `shouldBe` True + [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldAddedWithoutBump] + it "classifies the same field wrapped as v2 + upcaster as ADDITIVE" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v2.keiro" + any isBreaking cs `shouldBe` False + [ck | Additive ck <- cs] `shouldSatisfy` any ((== "TransferReservationCreated") . ckSubject) + it "reports no breaking change when the spec is unchanged" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation.keiro" + any isBreaking cs `shouldBe` False + it "classifies a direct event field type change as EvtFieldTypeChanged" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldtype.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldTypeChanged] + it "resolves fields(Command) before comparing event field types" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-cmdfieldtype.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldTypeChanged] + it "uses EvtFieldRemovedSameVersion for an unchanged-version removal" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-fieldremove.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [EvtFieldRemovedSameVersion] + it "uses EvtVersionDecreased for a version decrease" $ do + cs <- diffFixtures "test/fixtures/reservation-v2.keiro" "test/fixtures/reservation.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [EvtVersionDecreased] + it "rejects a v1 to v3 jump whose only upcaster starts at v2" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-v3-dangling.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [EvtVersionMissingUpcaster] + it "classifies a vanished historical upcaster rung as UpcasterChainGap" $ do + cs <- diffFixtures "test/fixtures/reservation-v2.keiro" "test/fixtures/reservation-chain-gap.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [UpcasterChainGap] + it "classifies an enum constructor removal as EnumCtorRemoved" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumdrop.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [EnumCtorRemoved] + it "classifies an enum wire-spelling change as EnumWireSpellingChanged" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumwire.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [EnumWireSpellingChanged] + it "classifies an enum constructor addition per use site as advisory" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-enumadd.keiro" + any isBreaking cs `shouldBe` False + let enumFindings = [k | Advisory k <- cs, ckCode k == EnumCtorAdded] + [ckSubject k | k <- enumFindings] `shouldContain` ["BlackTag"] + [verdictFor SnapshotHydration (ckVector k) | k <- enumFindings] + `shouldContain` [VAdvisory] + it "classifies an effective wire convention change as WireSpecChanged" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-wire.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [WireSpecChanged] + it "advises when the aggregate fold surface changes" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-foldchange.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldContain` [AggFoldSurfaceChanged] + it "advises on hazardous deprecation and reports un-deprecation" $ do + deprecated <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-deprecated.keiro" + any isBreaking deprecated `shouldBe` False + [ckCode k | Advisory k <- deprecated] `shouldContain` [DeprecatedEventReplayHazard] + restored <- diffFixtures "test/fixtures/reservation-deprecated.keiro" "test/fixtures/reservation.keiro" + any isAdvisory restored `shouldBe` True + [ckCode k | Advisory k <- restored] `shouldContain` [EventUndeprecated] + it "recognises replay-only deprecation as a replay-safe retirement cutover" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-deprecated-replay-only.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldContain` [EventRetirementInProgress] + [ckCode k | Advisory k <- cs] `shouldNotContain` [DeprecatedEventReplayHazard] + it "advises when event retirement starts" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-retiring.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldContain` [EventRetirementInProgress] + it "does not recommend decode-only deprecation for an event removal" $ do + old <- specOf "test/fixtures/reservation.keiro" + let new = + old + { specNodes = + [ case node of + NAggregate aggregate -> + NAggregate + aggregate + { aggEvents = + [ event + | event <- aggEvents aggregate + , evName event /= "TransferReservationConfirmed" + ] + } + _ -> node + | node <- specNodes old + ] + } + removals = [change | change@(Breaking kind) <- diffSpecs old new, ckCode kind == EvtRemovedNotDeprecated] + removals `shouldSatisfy` (not . null) + [ckDetail kind | Breaking kind <- removals] + `shouldSatisfy` all (not . T.isInfixOf "so old payloads still decode") + it "prints a paste-ready replay-only twin when a guard tightens (plan 143)" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened.keiro" + any isBreaking cs `shouldBe` False + let advisories = [k | Advisory k <- cs, ckCode k == AggGuardTightened] + map ckSubject advisories `shouldBe` ["Unrequested -- RequestTransferReservation"] + detail <- case advisories of + [k] -> pure (ckDetail k) + other -> expectationFailure ("expected one advisory, got " <> show other) >> pure "" + detail `shouldSatisfy` T.isInfixOf "replay-only Unrequested -- RequestTransferReservation" + -- The printed twin is paste-ready: appended to the new spec it + -- parses, validates without errors, and silences the advisory. + tightened <- readTestText "test/fixtures/reservation-guard-tightened.keiro" + let twinText = snd (T.breakOnEnd "\n\n" detail) + pasted = tightened <> "\n" <> twinText <> "\n" + case parseSpec "" pasted of + Left err -> expectationFailure (T.unpack err) + Right pastedSpec -> do + [code d | d <- validateSpec pastedSpec, severity d == Error] `shouldBe` [] + base <- specOf "test/fixtures/reservation.keiro" + [k | Advisory k <- diffSpecs base pastedSpec, ckCode k == AggGuardTightened] + `shouldBe` [] + it "omits the twin advisory when the twin is already present (plan 143)" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened-twin.keiro" + [k | Advisory k <- cs, ckCode k == AggGuardTightened] `shouldBe` [] + it "classifies a removed contract event as ContractEventRemoved" $ do + cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventdrop.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [ContractEventRemoved] + it "classifies contract field type changes and unversioned additions as ContractFieldChanged" $ do + changed <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldtype.keiro" + [ckCode k | Breaking k <- changed] `shouldContain` [ContractFieldChanged] + added <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldadd.keiro" + [ckCode k | Breaking k <- added] `shouldContain` [ContractFieldChanged] + it "reports a field addition with a contract version bump as an advisory" $ do + cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-bump-fieldadd.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldContain` [ContractSchemaVersionBumped] + it "classifies a contract schema version decrease separately" $ do + cs <- diffFixtures "test/fixtures/contract-bump-fieldadd.keiro" "test/fixtures/contract.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [ContractSchemaVersionDecreased] + it "classifies contract topic and discriminator changes separately" $ do + topic <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-topic.keiro" + [ckCode k | Breaking k <- topic] `shouldContain` [ContractTopicChanged] + discriminator <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-discriminator.keiro" + [ckCode k | Breaking k <- discriminator] `shouldContain` [ContractDiscriminatorChanged] + it "classifies a new contract event as additive" $ do + cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventadd.keiro" + any isBreaking cs `shouldBe` False + [ckSubject k | Additive k <- cs] `shouldContain` ["IncidentTransferNeedCancelled"] + it "classifies workqueue wire names, types, and required additions as WqPayloadFieldChanged" $ do + wire <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-wirename.keiro" + [ckCode k | Breaking k <- wire] `shouldContain` [WqPayloadFieldChanged] + fieldTypeChange <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-fieldtype.keiro" + [ckCode k | Breaking k <- fieldTypeChange] `shouldContain` [WqPayloadFieldChanged] + required <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-reqfield.keiro" + [ckCode k | Breaking k <- required] `shouldContain` [WqPayloadFieldChanged] + it "classifies a new optional workqueue payload field as additive" $ do + cs <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-optfield.keiro" + any isBreaking cs `shouldBe` False + [ckSubject k | Additive k <- cs] `shouldContain` ["note"] + it "classifies workqueue ordering changes as breaking delivery-contract changes" $ do + cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-ordering-change.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [WqOrderingChanged] + [ckDetail k | Breaking k <- cs, ckCode k == WqOrderingChanged] + `shouldSatisfy` any (T.isInfixOf "delivery-order contract") + it "classifies workqueue provision changes as operational migrations" $ do + cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-provision-change.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [WqProvisionChanged] + [ckDetail k | Breaking k <- cs, ckCode k == WqProvisionChanged] + `shouldSatisfy` any (T.isInfixOf "migrate the existing queue operationally") + it "classifies workqueue group-key changes as breaking repartitioning" $ do + cs <- diffFixtures "test/fixtures/workqueue-policy-base.keiro" "test/fixtures/workqueue-group-key-change.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [WqGroupKeyChanged] + [ckDetail k | Breaking k <- cs, ckCode k == WqGroupKeyChanged] + `shouldSatisfy` any (T.isInfixOf "re-partitioned") + it "classifies a process input type change as ProcessInputChanged" $ do + cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-inputtype.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [ProcessInputChanged] + it "classifies workflow input and output changes as WorkflowShapeChanged" $ do + input <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-inputfield.keiro" + [ckCode k | Breaking k <- input] `shouldContain` [WorkflowShapeChanged] + output <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-output.keiro" + [ckCode k | Breaking k <- output] `shouldContain` [WorkflowShapeChanged] + it "classifies workflow relabeling and appends as WorkflowBodyChanged" $ do + relabeled <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-body.keiro" + [ckCode k | Breaking k <- relabeled] `shouldContain` [WorkflowBodyChanged] + appended <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-stepadd.keiro" + [ckCode k | Breaking k <- appended] `shouldContain` [WorkflowBodyChanged] + [ckDetail k | Breaking k <- appended, ckCode k == WorkflowBodyChanged] + `shouldSatisfy` any (T.isInfixOf "new patch guard") + it "classifies a body addition wholly guarded by a new patch as additive" $ do + cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-evolution-diff.keiro" + any isBreaking cs `shouldBe` False + [ckSubject k | Additive k <- cs, ckFacet k == "workflow-patch"] `shouldContain` ["fraud-check-v2"] + [ckSubject k | Additive k <- cs, ckFacet k == "workflow-continue-as-new"] `shouldContain` ["RolloverSeed"] + it "classifies removing an existing patch as breaking" $ do + cs <- diffFixtures "test/fixtures/workflow-evolution-diff.keiro" "test/fixtures/workflow-continue.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [WorkflowPatchRemoved] + [ckDetail k | Breaking k <- cs, ckCode k == WorkflowPatchRemoved] + `shouldSatisfy` any (T.isInfixOf "cannot prove") + it "classifies terminal continueAsNew append as additive and seed drift as breaking" $ do + appended <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-continue.keiro" + any isBreaking appended `shouldBe` False + [ckFacet k | Additive k <- appended] `shouldContain` ["workflow-continue-as-new"] + changed <- diffFixtures "test/fixtures/workflow-continue.keiro" "test/fixtures/workflow-continue-seed-v2.keiro" + [ckCode k | Breaking k <- changed] `shouldContain` [WorkflowContinueSeedChanged] + [ckDetail k | Breaking k <- changed, ckCode k == WorkflowContinueSeedChanged] + `shouldSatisfy` any (T.isInfixOf "restoreSeed") + it "classifies a workflow stable-name change as WorkflowStableNameChanged" $ do + cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-rename.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [WorkflowStableNameChanged] + it "classifies workflow id-derivation changes as DerivedIdentityChanged" $ do + cs <- diffFixtures "test/fixtures/workflow.keiro" "test/fixtures/workflow-idfield.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [DerivedIdentityChanged] + it "classifies an id prefix change as IdPrefixChanged" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-idprefix.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [IdPrefixChanged] + it "classifies intake dedupe key and policy changes as DedupeIdentityChanged" $ do + policy <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-dedupepolicy.keiro" + [ckCode k | Breaking k <- policy] `shouldContain` [DedupeIdentityChanged] + key <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-dedupekey.keiro" + [ckCode k | Breaking k <- key] `shouldContain` [DedupeIdentityChanged] + it "reports intake decode-posture changes as warnings" $ do + cs <- diffFixtures "test/fixtures/intake.keiro" "test/fixtures/intake-decode.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldContain` [DecodePostureChanged] + [ckCode k | Advisory k <- cs] `shouldContain` [IntakePersistenceChanged] + it "classifies process and timer derivation changes as DerivedIdentityChanged" $ do + processName <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-procname.keiro" + [ckCode k | Breaking k <- processName] `shouldContain` [DerivedIdentityChanged] + timerId <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-timerid.keiro" + [ckCode k | Breaking k <- timerId] `shouldContain` [DerivedIdentityChanged] + base <- specOf "test/fixtures/hospital-surge.keiro" + let categoryChange = diffSpecs base (modifyProcess "HospitalSurge" (\process -> process{procSaga = (procSaga process){sagaCategory = "hospitalSurgeV2"}}) base) + [ckCode k | Breaking k <- categoryChange] `shouldContain` [DerivedIdentityChanged] + it "classifies router stable names, keys, and targets as identity-bearing" $ do + base <- specOf "test/fixtures/incident-paging/incident-paging.keiro" + let stableName = diffSpecs base (modifyRouter "PagingRouter" (\router -> router{rtName = "paging-v2"}) base) + keyDerivation = diffSpecs base (modifyRouter "PagingRouter" (\router -> router{rtKey = (rtKey router){corrVia = "otherIdText"}}) base) + target = diffSpecs base (modifyRouter "PagingRouter" (\router -> router{rtTarget = "OtherPage"}) base) + [ckCode k | Breaking k <- stableName] `shouldContain` [RouterStableNameChanged] + [ckCode k | Breaking k <- keyDerivation] `shouldContain` [DerivedIdentityChanged] + [ckCode k | Breaking k <- target] `shouldContain` [DerivedIdentityChanged] + it "advises on router dispatch-surface changes without making them breaking" $ do + cs <- diffFixtures "test/fixtures/incident-paging/incident-paging.keiro" "test/fixtures/incident-paging/incident-paging-dispatch.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldBe` [RouterDecideSurfaceChanged] + it "advises on process dispatch-surface changes without making them breaking" $ do + cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-handle.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldBe` [ProcessDecideSurfaceChanged] + it "advises on unversioned timer payload changes without making them breaking" $ do + cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-payload.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldBe` [ProcessTimerPayloadChanged] + it "ignores formatting-only process and timer surface rewrites" $ do + original <- specOf "test/fixtures/hospital-surge.keiro" + formatted <- parseInlineSpec "" (renderSpec original) + diffSpecs original formatted `shouldBe` [] + it "reports a timer window change as a warning" $ do + cs <- diffFixtures "test/fixtures/hospital-surge.keiro" "test/fixtures/hospital-surge-window.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldContain` [TimerWindowChanged] + it "reports emit-map changes as warnings and derive changes as breaking" $ do + mapping <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-mapchange.keiro" + any isBreaking mapping `shouldBe` False + [ckCode k | Advisory k <- mapping] `shouldContain` [EmitMappingChanged] + derive <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-derive.keiro" + [ckCode k | Breaking k <- derive] `shouldContain` [DerivedIdentityChanged] + it "classifies publisher outbox identity and ordering independently" $ do + outbox <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-outboxfield.keiro" + [ckCode k | Breaking k <- outbox] `shouldContain` [DerivedIdentityChanged] + ordering <- diffFixtures "test/fixtures/emit.keiro" "test/fixtures/emit-ordering.keiro" + any isBreaking ordering `shouldBe` False + [ckCode k | Advisory k <- ordering] `shouldContain` [PublisherPolicyChanged] + it "classifies workqueue names as QueueIdentityChanged" $ do + cs <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-rename.keiro" + [ckCode k | Breaking k <- cs] `shouldContain` [QueueIdentityChanged] + it "classifies pgmq dispatch dedupe and retargeting independently" $ do + dedupe <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-dedupkey.keiro" + [ckCode k | Breaking k <- dedupe] `shouldContain` [DedupeIdentityChanged] + retarget <- diffFixtures "test/fixtures/reservation-work.keiro" "test/fixtures/reservation-work-retarget.keiro" + any isBreaking retarget `shouldBe` False + [ckCode k | Advisory k <- retarget] `shouldContain` [DispatchRetargeted] + it "reports aggregate projection changes as warnings" $ do + cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-projection.keiro" + any isBreaking cs `shouldBe` False + [ckCode k | Advisory k <- cs] `shouldContain` [ProjectionChanged] + it "classifies read-model version and unversioned shape changes" $ do + base <- specOf "test/fixtures/readmodel-runtime.keiro" + let versionTwo = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmVersion = 2}) base + changedShape = modifyReadModel "transfer_decisions" changeReadModelShape base + bumpedShape = modifyReadModel "transfer_decisions" (\readModel -> (changeReadModelShape readModel){rmVersion = 2}) base + decreased = diffSpecs versionTwo base + unversioned = diffSpecs base changedShape + bumped = diffSpecs base bumpedShape + [ckCode k | Breaking k <- decreased] `shouldContain` [ReadModelVersionDecreased] + [ckCode k | Breaking k <- unversioned] `shouldContain` [ReadModelShapeChangedWithoutBump] + any isBreaking bumped `shouldBe` False + [ckFacet k | Additive k <- bumped] `shouldContain` ["read-model-version"] + it "classifies read-model registry, table, subscription, and removal identities" $ do + base <- specOf "test/fixtures/readmodel-runtime.keiro" + let tableChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmTable = "transfer_decisions_v2"}) base + subscriptionChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmSubscription = Just "transfer-decisions-v2"}) base + renamed = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmName = "reservation_decisions"}) base + removed = removeReadModel "transfer_decisions" base + mapM_ + (\changes -> [ckCode k | Breaking k <- changes] `shouldContain` [DerivedIdentityChanged]) + [diffSpecs base tableChanged, diffSpecs base subscriptionChanged, diffSpecs base renamed, diffSpecs base removed] + it "classifies read-model feed flips and consistency/scope weakening as breaking" $ do + base <- specOf "test/fixtures/readmodel-runtime.keiro" + let feedChanged = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmFeed = RmInline}) base + consistencyWeakened = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmConsistency = Eventual}) base + entireLog = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmScope = Just RmEntireLog}) base + [ckCode k | Breaking k <- diffSpecs base feedChanged] `shouldContain` [ReadModelFeedChanged] + [ckCode k | Breaking k <- diffSpecs base consistencyWeakened] `shouldContain` [ReadModelConsistencyWeakened] + [ckCode k | Breaking k <- diffSpecs entireLog base] `shouldContain` [ReadModelConsistencyWeakened] + it "classifies Eventual to Strong read-model consistency as additive" $ do + strong <- specOf "test/fixtures/readmodel-runtime.keiro" + let eventual = modifyReadModel "transfer_decisions" (\readModel -> readModel{rmConsistency = Eventual}) strong + changes = diffSpecs eventual strong + any isBreaking changes `shouldBe` False + [ckFacet k | Additive k <- changes] `shouldContain` ["read-model-consistency"] + + describe "module placement (M1)" $ do + it "GeneratedPrefix is today's namespace (Generated.., holes at .)" $ do + let ctx = defaultContext "hospital-capacity" + genPrefixFor ctx "Reservation" `shouldBe` "Generated.HospitalCapacity.Reservation" + holePrefixFor ctx "Reservation" `shouldBe` "HospitalCapacity.Reservation" + it "module-root prefixes both layers" $ do + let ctx = (defaultContext "hospital-capacity"){moduleRoot = "Acme"} + genPrefixFor ctx "Reservation" `shouldBe` "Acme.Generated.HospitalCapacity.Reservation" + holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation" + it "CollocatedLeaf places the generated layer under the domain leaf" $ do + let ctx = (defaultContext "hospital-capacity"){moduleRoot = "Acme", placement = CollocatedLeaf} + genPrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation.Generated" + holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation" + it "parses and preserves the module/layout clauses through parse . pretty" $ do + let src = "context hospital-capacity\nmodule Acme.Services\nlayout collocated\n\naggregate Reservation\n regs\n states Open\n" + case parseSpec "" src of + Left err -> expectationFailure (T.unpack err) + Right spec -> do + specModuleRoot spec `shouldBe` Just "Acme.Services" + specLayout spec `shouldBe` Just CollocatedLeaf + parseSpec "" (renderSpec spec) `shouldBe` Right spec + it "a spec without the clauses leaves placement at the default" $ do + input <- readTestText "test/fixtures/reservation.keiro" + case parseSpec "test/fixtures/reservation.keiro" input of + Left err -> expectationFailure (T.unpack err) + Right spec -> do + specModuleRoot spec `shouldBe` Nothing + specLayout spec `shouldBe` Nothing + + describe "structural scaffold" $ do + it "emits one private shape module per structural declaration and one context facade" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let modules = scaffoldModules (defaultContext (specContext spec)) spec + paths = map modulePath modules + paths + `shouldContain` [ "Generated/ConsumerDemo/Structural/Shape/ArtifactInfo.hs" + , "Generated/ConsumerDemo/Structural/Shape/ArtifactKind.hs" + , "Generated/ConsumerDemo/Structural/Shape/ArtifactLocation.hs" + , "Generated/ConsumerDemo/StructuralProjections.hs" + ] + paths `shouldNotContain` ["Generated/ConsumerDemo/Structural/Shape/VendorGeometry.hs"] + firewallBreaches modules `shouldBe` [] + it "emits one create-once binding skeleton per owning module and derives Generic for private shapes" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let modules = scaffoldModules (defaultContext (specContext spec)) spec + skeletons = [moduleValue | moduleValue <- modules, kind moduleValue == HoleStub, modulePath moduleValue == "Example/Artifact/KeiroBindings.hs"] + shape = generatedTextEndingIn "Structural/Shape/ArtifactInfo.hs" modules + case skeletons of + [skeleton] -> do + moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactInfoBinding :: StructuralBinding" + moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactKindBinding :: StructuralBinding" + moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactLocationBinding :: StructuralBinding" + moduleText skeleton `shouldSatisfy` T.isInfixOf "HOLE: fill ArtifactInfo bindingToShape.key" + _ -> expectationFailure ("expected exactly one shared binding skeleton, got " <> show (map modulePath skeletons)) + shape `shouldSatisfy` T.isInfixOf "deriving stock (Eq, Generic, Show)" + shape `shouldSatisfy` T.isInfixOf "import GHC.Generics (Generic)" + it "never overwrites an existing binding skeleton" $ + withTempDirectory "keiro-dsl-binding-create-once" $ \out -> do + spec <- specOf "test/fixtures/consumer-types.keiro" + let ctx = defaultContext (specContext spec) + bindingPath = out "Example/Artifact/KeiroBindings.hs" + _ <- executePlannedScaffold out "consumer-types.keiro" ctx spec + TIO.writeFile bindingPath "hand-owned binding\n" + second <- executePlannedScaffold out "consumer-types.keiro" ctx spec + TIO.readFile bindingPath `shouldReturn` "hand-owned binding\n" + reportDispositions second + `shouldSatisfy` any (\(moduleValue, disposition) -> modulePath moduleValue == "Example/Artifact/KeiroBindings.hs" && disposition == Skipped) + it "fresh binding skeletons compile at the application boundary" $ + withTempDirectory "keiro-dsl-binding-compiles" $ \out -> do + spec <- specOf "test/fixtures/structural-conformance.keiro" + let ctx = defaultContext (specContext spec) + bindingSource = out "Conformance/Structural/Bindings.hs" + ghcOutput = out ".ghc" + _ <- executePlannedScaffold out "structural-conformance.keiro" ctx spec + createDirectoryIfMissing True ghcOutput + (exitCode, standardOutput, standardError) <- + readProcessWithExitCode + "cabal" + [ "exec" + , "--" + , "ghc" + , "-XGHC2024" + , "-XOverloadedStrings" + , "-fno-code" + , "-fforce-recomp" + , "-outputdir" + , ghcOutput + , "-i" <> out + , "-itest/conformance-structural" + , "-i../keiro-core/src" + , bindingSource + ] + "" + unless (exitCode == ExitSuccess) $ + expectationFailure (standardOutput <> standardError) + it "keeps consumer types in Domain while the generated Codec owns keys, tags, and defaults" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let modules = scaffoldModules (defaultContext (specContext spec)) spec + domain = generatedTextEndingIn "Catalog/Domain.hs" modules + codec = generatedTextEndingIn "Catalog/Codec.hs" modules + domain `shouldSatisfy` T.isInfixOf "Example.Artifact.Domain.ArtifactInfo" + domain `shouldSatisfy` T.isInfixOf "Vendor.Geometry.Geometry" + domain `shouldSatisfy` T.isInfixOf "Example.Artifact.KeiroBindings.emptyArtifactInfo" + codec `shouldSatisfy` T.isInfixOf "\"location\" .= encodeArtifactLocationShape" + codec `shouldSatisfy` T.isInfixOf "\"local_file\"" + codec `shouldSatisfy` T.isInfixOf "Nothing -> pure Generated.ConsumerDemo.Structural.Shape.ArtifactKind.Guide" + codec `shouldSatisfy` T.isInfixOf "rejectUnknownFields \"ArtifactInfo\"" + codec `shouldSatisfy` T.isInfixOf "toJSON payload.geometry" + codec `shouldSatisfy` (not . T.isInfixOf "vendor.geometry.json") + it "generates shape-only nested types and schema-derived Keiki witnesses" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let modules = scaffoldModules (defaultContext (specContext spec)) spec + shape = generatedTextEndingIn "Structural/Shape/ArtifactInfo.hs" modules + facade = generatedTextEndingIn "StructuralProjections.hs" modules + shape `shouldSatisfy` T.isInfixOf "data ArtifactInfoShape = ArtifactInfo" + shape `shouldSatisfy` T.isInfixOf "ArtifactKind.ArtifactKindShape" + shape `shouldSatisfy` (not . T.isInfixOf "KeiroBindings") + facade `shouldSatisfy` T.isInfixOf "type FieldName" + facade `shouldSatisfy` T.isInfixOf "= \"/key\"" + facade `shouldSatisfy` T.isInfixOf "fieldShapeId _ = \"example.artifact.ArtifactInfo.v1\"" + facade `shouldSatisfy` T.isInfixOf "bindingToShape Example.Artifact.KeiroBindings.artifactInfoBinding owner" + + describe "structural manifest" $ do + it "lists consumer packages and every domain, binding, fixture, and initial module" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let modules = scaffoldModules (defaultContext (specContext spec)) spec + manifest = renderManifest "consumer-types.keiro" modules spec + mapM_ (\packageName -> manifestDependencies spec `shouldContain` [packageName]) ["artifact-domain", "vendor-geometry"] + manifest `shouldSatisfy` T.isInfixOf "consumer-packages:\n artifact-domain\n vendor-geometry" + mapM_ + (\moduleName -> manifest `shouldSatisfy` T.isInfixOf moduleName) + [ "Example.Artifact.Domain" + , "Example.Artifact.KeiroBindings" + , "Vendor.Geometry" + , "Vendor.Geometry.KeiroBindings" + ] + + describe "structural scaffold record" $ do + it "round-trips canonical mapping rows and reports binding drift on the next run" $ + withTempDirectory "keiro-dsl-mapping-record" $ \out -> do + spec <- specOf "test/fixtures/consumer-types.keiro" + let ctx = defaultContext (specContext spec) + first <- executePlannedScaffold out "consumer-types.keiro" ctx spec + length (consumerMappings (reportConsumerPlan first)) `shouldBe` 4 + recordText <- TIO.readFile (out recordFileName (specContext spec)) + let mappingRows = filter (T.isPrefixOf "mapping ") (T.lines recordText) + bindingRows = filter (T.isPrefixOf "binding ") (T.lines recordText) + length mappingRows `shouldBe` 4 + bindingRows `shouldSatisfy` (not . null) + fmap recMappings (parseRecord recordText) `shouldSatisfy` maybe False ((== 4) . length) + fmap recBindingObligations (parseRecord recordText) `shouldSatisfy` maybe False ((== length bindingRows) . length) + let bumped = spec{specMapped = map bumpArtifactBindingVersion (specMapped spec)} + second <- executePlannedScaffold out "consumer-types.keiro" ctx bumped + reportMappingDrift second + `shouldSatisfy` any (\drift -> driftSpecName drift == "ArtifactInfo" && driftPrevious drift /= driftCurrent drift) + renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "mapping drift:") + case mappingRows of + row : _ -> parseRecord (recordText <> row <> "\n") `shouldBe` Nothing + [] -> expectationFailure "expected mapping rows" + case bindingRows of + row : _ -> parseRecord (recordText <> row <> "\n") `shouldBe` Nothing + [] -> expectationFailure "expected binding rows" + it "reports exactly the newly added binding field without rewriting the shared skeleton" $ + withTempDirectory "keiro-dsl-binding-drift" $ \out -> do + spec <- specOf "test/fixtures/consumer-types.keiro" + let ctx = defaultContext (specContext spec) + _ <- executePlannedScaffold out "consumer-types.keiro" ctx spec + let extended = spec{specMapped = map addArtifactSummaryField (specMapped spec)} + second <- executePlannedScaffold out "consumer-types.keiro" ctx extended + reportNewHoles second + `shouldBe` [ BindingHole + { holeMappedName = "ArtifactInfo" + , holeModule = "Example.Artifact.KeiroBindings" + , holeSymbol = "artifactInfoBinding" + , holeKind = BindingValue + , holePath = Just "summary" + , holeSignature = "artifactInfoBinding.summary :: Text" + } + ] + renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "artifactInfoBinding.summary :: Text") + it "rejects malformed known mapping JSON while ignoring unrelated future rows" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + withTempDirectory "keiro-dsl-mapping-malformed" $ \out -> do + report <- executePlannedScaffold out "consumer-types.keiro" (defaultContext (specContext spec)) spec + recordText <- TIO.readFile (reportRecordPath report) + parseRecord (recordText <> "mapping {not-json}\n") `shouldBe` Nothing + parseRecord (recordText <> "future-row retained\n") `shouldBe` parseRecord recordText + + describe "structural import plan" $ do + it "reports the successful dependency plan in the scaffold report" $ + withTempDirectory "keiro-dsl-dependency-plan" $ \out -> do + spec <- specOf "test/fixtures/consumer-types.keiro" + report <- executePlannedScaffold out "consumer-types.keiro" (defaultContext (specContext spec)) spec + renderScaffoldReport report + `shouldSatisfy` any (T.isInfixOf "dependency plan: consumer packages [artifact-domain, vendor-geometry]") + it "refuses a binding module inside the generated namespace with the exact cycle" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let cyclic = spec{specMapped = map moveArtifactBindingIntoGenerated (specMapped spec)} + case planScaffold (defaultContext (specContext cyclic)) cyclic of + Left refusals -> do + refusals `shouldSatisfy` any isImportCycle + renderRefusals refusals `shouldSatisfy` any (T.isInfixOf "Generated.ConsumerDemo.Bindings") + Right _ -> expectationFailure "expected an import-cycle refusal" + it "refuses missing mapped register initials but permits command/event-only use" $ do + missing <- specOf "test/fixtures/mapped-missing-initial.keiro" + planScaffold (defaultContext (specContext missing)) missing `shouldSatisfy` isLoweringRefusal + spec <- specOf "test/fixtures/consumer-types.keiro" + let commandOnly = removeMappedRegisterRequirements spec + planScaffold (defaultContext (specContext commandOnly)) commandOnly `shouldSatisfy` isRight + + describe "binding explanations" $ do + it "lists binding, fixture, and use-site-scoped initial obligations deterministically" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + obligations <- either (\errors -> expectationFailure (show errors) >> pure []) pure (bindingObligations spec) + length obligations `shouldBe` 7 + obligations + `shouldSatisfy` any + ( \obligation -> + obligationKind obligation == BindingValue + && obligationSymbol obligation == "artifactInfoBinding" + && obligationBindingVersion obligation == Just "1" + ) + obligations + `shouldSatisfy` any + ( \obligation -> + obligationKind obligation == InitialValue + && obligationSymbol obligation == "emptyArtifactInfo" + && any (T.isInfixOf "Catalog register currentArtifact") (obligationUseSites obligation) + ) + let rendered = renderBindingObligations (specContext spec) obligations + rendered `shouldSatisfy` T.isInfixOf "binding obligations for context consumer-demo" + rendered `shouldSatisfy` T.isInfixOf "artifactInfoBinding :: StructuralBinding Example.Artifact.Domain.ArtifactInfo ArtifactInfoShape" + rendered `shouldSatisfy` T.isInfixOf "provenance: binding-version \"1\"" + it "states explicitly when a spec has no structural obligations" $ do + spec <- specOf "test/fixtures/reservation.keiro" + obligations <- either (\errors -> expectationFailure (show errors) >> pure []) pure (bindingObligations spec) + renderBindingObligations (specContext spec) obligations + `shouldBe` "no binding obligations for context hospital-capacity" + + describe "exact generic structural bindings" $ do + forM_ + [ ("renamed-field", "selector mismatch") + , ("reordered-field", "selector mismatch") + , ("arity-mismatch", "no exact nominal correspondence") + , ("incompatible-type", "no exact nominal correspondence") + ] + $ \(fixture, diagnostic) -> + it ("rejects " <> fixture <> " and directs the author to the scaffolded module") $ + expectGenericCompileFailure fixture diagnostic + + describe "structural harness" $ do + it "emits every structural, wire-policy, projection, and replay assertion family" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let aggregate = onlyAggregate spec + ctx = defaultContext (specContext spec) + harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx spec aggregate) + mapM_ + (\needle -> harness `shouldSatisfy` T.isInfixOf needle) + [ "binding domain round-trip: example.artifact.ArtifactInfo.v1/" + , "binding shape round-trip: example.artifact.ArtifactInfo.v1/" + , "mapped codec round-trip: ArtifactObserved/artifact/" + , "fixture coverage: example.artifact.ArtifactLocation.v1" + , "wire policy missing default: example.artifact.ArtifactInfo.v1/description" + , "wire policy explicit null: example.artifact.ArtifactInfo.v1/description" + , "wire policy unknown fields: example.artifact.ArtifactInfo.v1" + , "wire union arm: example.artifact.ArtifactLocation.v1/local_file" + , "canonical identity: example.artifact.ArtifactInfo.v1" + , "projection witness agreement: example.artifact.ArtifactInfo.v1/key" + , "forward/replay equality: ObserveArtifact from CatalogEmpty -- " + , "register currentArtifact" + ] + it "keeps opaque assertions at the declared codec boundary" $ do + spec <- specOf "test/fixtures/consumer-types.keiro" + let aggregate = onlyAggregate spec + ctx = defaultContext (specContext spec) + modules = scaffoldAggregate ctx spec aggregate <> harnessFor ctx spec aggregate + harness = generatedTextEndingIn "Harness.hs" modules + codec = generatedTextEndingIn "Codec.hs" modules + harness `shouldSatisfy` T.isInfixOf "opaque codec round-trip: vendor.geometry.json@3/" + harness `shouldNotSatisfy` T.isInfixOf "wire policy unknown fields: vendor.geometry.json" + harness `shouldNotSatisfy` T.isInfixOf "fixture coverage: vendor.geometry" + codec `shouldNotSatisfy` T.isInfixOf "encodeVendorGeometryShape" + + describe "manifest (M2)" $ do + it "lists exactly the modules the scaffolder produced" $ do + mods <- scaffoldFixture "test/fixtures/reservation.keiro" + spec <- specOf "test/fixtures/reservation.keiro" + let manifest = renderManifest "reservation.keiro" mods spec + expectedNames = sort (map (moduleNameOf . modulePath) mods) + -- every produced module name appears in the manifest… + mapM_ (\m -> (m `T.isInfixOf` manifest) `shouldBe` True) expectedNames + -- …and the module list is exactly the scaffolder's output set. + expectedNames + `shouldBe` sort + [ "Generated.HospitalCapacity.Reservation.Codec" + , "Generated.HospitalCapacity.Reservation.Domain" + , "Generated.HospitalCapacity.Reservation.EventStream" + , "Generated.HospitalCapacity.Reservation.Harness" + , "Generated.HospitalCapacity.Reservation.Projection" + , "HospitalCapacity.Reservation.Holes" + ] + it "derives the dependency set from the node kinds present (aggregate)" $ do + spec <- specOf "test/fixtures/reservation.keiro" + manifestDependencies spec `shouldBe` ["aeson", "base", "keiki", "keiro", "text"] + it "derives the process dependency set, including worker-policy runtime imports" $ do + spec <- specOf "test/fixtures/hospital-surge.keiro" + let dependencies = manifestDependencies spec + mapM_ (\dependency -> dependencies `shouldContain` [dependency]) ["time", "uuid", "shibuya-core", "keiki", "keiro"] + it "uses the registered shibuya-core package name for router scaffolds" $ do + spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro" + let dependencies = manifestDependencies spec + mapM_ (\dependency -> dependencies `shouldContain` [dependency]) ["effectful-core", "keiro", "shibuya-core"] + dependencies `shouldNotContain` ["shibuya"] + + describe "new skeletons (M5)" $ do + it "every skeleton parses and validates with zero error diagnostics" $ + mapM_ assertSkeletonValid skeletonKinds + it "every skeleton passes the scaffold refusal gates" $ + mapM_ assertSkeletonScaffoldable skeletonKinds + it "fresh skeleton scaffolds match the committed compiling modules" $ + mapM_ (uncurry assertSkeletonMatchesCommitted) skeletonModuleRoots + it "rejects an unknown kind with a helpful message" $ + case skeletonFor "bogus" of + Left msg -> ("Valid kinds:" `T.isInfixOf` msg) `shouldBe` True + Right _ -> expectationFailure "expected an error for an unknown kind" + + describe "firewall self-check (M3)" $ do + it "flags a forbidden operator in a Generated module" $ do + let m = ScaffoldModule{modulePath = "Gen/Foo.hs", moduleText = "x = a ./= b", kind = Generated, origin = "test"} + firewallBreaches [m] `shouldBe` [("Gen/Foo.hs", "./=", 1)] + it "ignores forbidden operators in a HoleStub module (holes own them)" $ do + let m = ScaffoldModule{modulePath = "Foo/Holes.hs", moduleText = "x = lit 1 .== y", kind = HoleStub, origin = "test"} + firewallBreaches [m] `shouldBe` [] + it "matches `lit` as a word, not a substring of quality/split" $ do + let clean = ScaffoldModule{modulePath = "Gen/Q.hs", moduleText = "quality = split facility", kind = Generated, origin = "test"} + dirty = ScaffoldModule{modulePath = "Gen/L.hs", moduleText = "v = lit foo", kind = Generated, origin = "test"} + firewallBreaches [clean] `shouldBe` [] + firewallBreaches [dirty] `shouldBe` [("Gen/L.hs", "lit", 1)] + it "skips strings and comments and maximal-munches symbolic tokens" $ do + let clean = syntheticGenerated "Gen/Clean.hs" "wire = \"lit .== B.slot\"\n-- x =: y\nx = a .<= b" + dirty = syntheticGenerated "Gen/Dirty.hs" "x = a .< b\ny = c =: d" + firewallBreaches [clean] `shouldBe` [("Gen/Clean.hs", ".<=", 3)] + firewallBreaches [dirty] `shouldBe` [("Gen/Dirty.hs", ".<", 1), ("Gen/Dirty.hs", "=:", 2)] + it "guards keiki imports while allowing the generated Core allowlist" $ do + let forbidden = syntheticGenerated "Gen/Builder.hs" "import Keiki.Builder" + restricted = syntheticGenerated "Gen/CoreBad.hs" "import Keiki.Core (lit)" + allowed = syntheticGenerated "Gen/CoreGood.hs" "import Keiki.Core (RegFile (..), HsPred, step)" + firewallBreaches [forbidden] `shouldBe` [("Gen/Builder.hs", "import:Keiki.Builder", 1)] + firewallBreaches [restricted] `shouldBe` [("Gen/CoreBad.hs", "import:Keiki.Core", 1)] + firewallBreaches [allowed] `shouldBe` [] + it "finds no breach in real scaffolder output (aggregate + process fixtures)" $ do + aggMods <- scaffoldFixture "test/fixtures/reservation.keiro" + procMods <- scaffoldProcessFixture "test/fixtures/hospital-surge.keiro" + firewallBreaches (aggMods <> procMods) `shouldBe` [] + + describe "scaffold gates" $ do + it "refuses duplicate and case-folded module paths with both origins" $ do + spec <- specOf "test/fixtures/reservation.keiro" + case [aggregate | NAggregate aggregate <- specNodes spec] of + aggregate : _ -> do + let duplicate = spec{specNodes = [NAggregate aggregate, NAggregate aggregate]} + caseVariant = spec{specNodes = [NAggregate aggregate, NAggregate aggregate{aggName = T.toUpper (aggName aggregate)}]} + planScaffold (defaultContext (specContext spec)) duplicate `shouldSatisfy` hasPathCollisionWithTwoOrigins + planScaffold (defaultContext (specContext spec)) caseVariant `shouldSatisfy` hasPathCollisionWithTwoOrigins + [] -> expectationFailure "reservation fixture has no aggregate" + it "refuses a bannerless Generated target without changing its bytes" $ + withTempDirectory "keiro-dsl-banner" $ \out -> do + spec <- specOf "test/fixtures/reservation.keiro" + let ctx = defaultContext (specContext spec) + case planScaffold ctx spec of + Left refusals -> expectationFailure ("unexpected planning refusal: " <> show refusals) + Right modules -> case [m | m <- modules, kind m == Generated] of + generated : _ -> do + let target = out modulePath generated + createDirectoryIfMissing True (takeDirectory target) + TIO.writeFile target "hand owned\n" + result <- executeScaffold out False "test/fixtures/reservation.keiro" ctx spec modules + result `shouldSatisfy` isMissingBannerRefusal + TIO.readFile target `shouldReturn` "hand owned\n" + forced <- executeScaffold out True "test/fixtures/reservation.keiro" ctx spec modules + forced `shouldSatisfy` isSuccessfulScaffold + TIO.readFile target `shouldReturn` moduleText generated + [] -> expectationFailure "reservation scaffold has no Generated module" + it "reports renamed-node modules as stale without deleting them" $ + withTempDirectory "keiro-dsl-stale-rename" $ \out -> do + spec <- parseInlineSpec "" loweringAggregateSpec + first <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext spec)) spec + let renamed = spec{specNodes = map renameCounter (specNodes spec)} + second <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext renamed)) renamed + let oldDomain = onlyPathEndingIn "Counter/Domain.hs" (map fst (reportDispositions first)) + oldHoles = onlyPathEndingIn "Counter/Holes.hs" (map fst (reportDispositions first)) + reportStale second `shouldSatisfy` \stale -> StaleModule Generated oldDomain `elem` stale && StaleModule HoleStub oldHoles `elem` stale + doesFileExist (out oldDomain) `shouldReturn` True + doesFileExist (out oldHoles) `shouldReturn` True + it "reports the entire old tree across a module-root flip" $ + withTempDirectory "keiro-dsl-stale-root" $ \out -> do + spec <- parseInlineSpec "" loweringAggregateSpec + let initialCtx = defaultContext (specContext spec) + rootedCtx = initialCtx{moduleRoot = "Acme"} + first <- executePlannedScaffold out "counter.keiro" initialCtx spec + second <- executePlannedScaffold out "moved-counter.keiro" rootedCtx spec + reportStale second + `shouldMatchList` [StaleModule (kind m) (modulePath m) | (m, _) <- reportDispositions first] + forM_ (reportStale second) $ \stale -> doesFileExist (out stalePath stale) `shouldReturn` True + renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "previous scaffold record used spec counter.keiro") + it "reports moved generated modules across a layout flip" $ + withTempDirectory "keiro-dsl-stale-layout" $ \out -> do + spec <- parseInlineSpec "" loweringAggregateSpec + let initialCtx = defaultContext (specContext spec) + collocatedCtx = initialCtx{placement = CollocatedLeaf} + first <- executePlannedScaffold out "counter.keiro" initialCtx spec + second <- executePlannedScaffold out "counter.keiro" collocatedCtx spec + let oldGenerated = [StaleModule Generated (modulePath m) | (m, _) <- reportDispositions first, kind m == Generated] + reportStale second `shouldSatisfy` all (`elem` oldGenerated) + length (reportStale second) `shouldBe` length oldGenerated + it "writes a parseable record and no stale section for a fresh output" $ + withTempDirectory "keiro-dsl-record" $ \out -> do + spec <- parseInlineSpec "" loweringAggregateSpec + let ctx = defaultContext (specContext spec) + report <- executePlannedScaffold out "counter.keiro" ctx spec + reportStale report `shouldBe` [] + renderScaffoldReport report `shouldSatisfy` all (not . T.isPrefixOf "stale:") + contents <- TIO.readFile (out recordFileName (specContext spec)) + parseRecord contents + `shouldBe` Just + ScaffoldRecord + { recSpecPath = "counter.keiro" + , recModuleRoot = "" + , recLayout = "prefixed" + , recFiles = [(kind m, modulePath m) | (m, _) <- reportDispositions report] + , recMappings = [] + , recBindingObligations = [] + } + parseRecord (T.replace "spec: " "future-field: retained\nspec: " contents) `shouldBe` parseRecord contents + parseRecord (T.replace "record v1" "record v2" contents) `shouldBe` Nothing + + describe "faithful scaffold lowering" $ do + it "escapes a trailing-backslash payload literal exactly once" $ do + spec <- specOf "test/fixtures/hospital-surge.keiro" + case [process | NProcess process <- specNodes spec] of + process : _ -> do + let timer = (procTimer process){tmPayload = [FieldBinding "kind" (Just "\"follow-up\\\"")]} + modules = scaffoldProcess (defaultContext (specContext spec)) process{procTimer = timer} + generatedTextEndingIn "Process.hs" modules + `shouldSatisfy` T.isInfixOf "\"kind\" .= (\"follow-up\\\\\" :: Value)" + [] -> expectationFailure "hospital-surge fixture has no process" + it "preserves quoted Text register initials and refuses unsafe register shapes" $ do + spec <- parseInlineSpec "" loweringAggregateSpec + let modules = scaffoldAggregate (defaultContext (specContext spec)) spec =<< [aggregate | NAggregate aggregate <- specNodes spec] + domain = generatedTextEndingIn "Domain.hs" modules + domain `shouldSatisfy` T.isInfixOf "RCons (Proxy @\"note\") \"hello world\"" + scaffoldRefusals spec `shouldBe` [] + bare <- parseInlineSpec "" (T.replace "\"hello world\"" "hello" loweringAggregateSpec) + scaffoldRefusals bare `shouldSatisfy` any (T.isInfixOf "RegTextInitialNotQuoted") + unsupported <- parseInlineSpec "" (T.replace "count:Int" "count:Time" loweringAggregateSpec) + scaffoldRefusals unsupported `shouldSatisfy` any (T.isInfixOf "FieldTypeUnrepresentable") + it "lowers seconds, minutes, hours, and both backoff constructors faithfully" $ do + windowSeconds "90s" `shouldBe` Right 90 + windowSeconds "5m" `shouldBe` Right 300 + windowSeconds "2h" `shouldBe` Right 7200 + emitSource <- readTestText "test/fixtures/emit.keiro" + let exponentialSource = T.replace "backoff constant 2s" "backoff exponential 2s max=60s multiplier=2.0" emitSource + exponential <- parseInlineSpec "" exponentialSource + case [publisher | NPublisher publisher <- specNodes exponential] of + publisher : _ -> do + let generated = generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext exponential)) publisher) + generated `shouldSatisfy` T.isInfixOf "ExponentialBackoff ExponentialBackoffOptions { initial = 2, maxDelay = 60, multiplier = 2.0 }" + parseSpec "" (renderSpec exponential) `shouldBe` Right exponential + [] -> expectationFailure "emit fixture has no publisher" + constant <- parseInlineSpec "" (T.replace "backoff constant 2s" "backoff constant 2m" emitSource) + case [publisher | NPublisher publisher <- specNodes constant] of + publisher : _ -> generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext constant)) publisher) `shouldSatisfy` T.isInfixOf "ConstantBackoff 120" + [] -> expectationFailure "emit fixture has no publisher" + it "refuses incomplete exponential backoff and rejects unknown window units" $ do + emitSource <- readTestText "test/fixtures/emit.keiro" + incomplete <- parseInlineSpec "" (T.replace "backoff constant 2s" "backoff exponential 2s" emitSource) + scaffoldRefusals incomplete `shouldSatisfy` any (T.isInfixOf "BackoffExponentialIncomplete") + parseSpec "" (T.replace "backoff constant 2s" "backoff constant 2x" emitSource) + `shouldSatisfy` leftContains "time unit: s, m, or h" + it "lowers workqueue retry windows in minutes to seconds" $ do + queueSource <- readTestText "test/fixtures/reservation-work.keiro" + queueSpec <- parseInlineSpec "" (T.replace "5s" "5m" queueSource) + case [workqueue | NWorkqueue workqueue <- specNodes queueSpec] of + workqueue : _ -> do + let policy = generatedTextEndingIn "QueuePolicy.hs" (scaffoldWorkqueue (defaultContext (specContext queueSpec)) workqueue) + policy `shouldSatisfy` T.isInfixOf "defaultRetryDelay = RetryDelay 300" + policy `shouldSatisfy` T.isInfixOf "Retry (RetryDelay 300)" + [] -> expectationFailure "queue fixture has no workqueue" + it "uses exact status-map keys and emits total Int harness samples" $ do + statusSpec <- parseInlineSpec "" exactStatusSpec + case [aggregate | NAggregate aggregate <- specNodes statusSpec] of + aggregate : _ -> do + let ctx = defaultContext (specContext statusSpec) + projection = generatedTextEndingIn "Projection.hs" (scaffoldAggregate ctx statusSpec aggregate) + harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx statusSpec aggregate) + projection `shouldSatisfy` T.isInfixOf "ReservationUnHeld {} -> Just \"available\"" + harness `shouldSatisfy` T.isInfixOf "CountBumpedData 0" + harness `shouldNotSatisfy` T.isInfixOf "sample: unsupported" + [] -> expectationFailure "exact-status spec has no aggregate" + + describe "scaffold" $ do + it "synthesizes the exact old wire shape and embeds it in the harness" $ do + oldSpec <- specOf "test/fixtures/reservation.keiro" + newSpec <- specOf "test/fixtures/reservation-v2.keiro" + case goldensForDiff oldSpec newSpec of + [golden] -> do + goldenRelativePath golden + `shouldBe` "hospital-capacity/Reservation/TransferReservationCreated.v1.json" + goldenJson golden + `shouldBe` "{\"commandId\":\"cmd_01hzy3v7q2e8kaw2m5x0d41n9c\",\"divertStatus\":\"open\",\"hospitalId\":\"hosp_01hzy3v7q2e8kaw2m5x0d41n9c\",\"kind\":\"TransferReservationCreated\",\"lifeCriticalOverride\":true,\"patientAcuity\":\"red\",\"reservationId\":\"rsv_01hzy3v7q2e8kaw2m5x0d41n9c\"}\n" + goldenEvidence golden `shouldBe` SynthesizedWeakStandIn + let aggregate = onlyAggregate newSpec + modules = + harnessForWithGoldens + [golden] + (defaultContext (specContext newSpec)) + newSpec + aggregate + harness = generatedTextEndingIn "Harness.hs" modules + harness `shouldSatisfy` T.isInfixOf "golden TransferReservationCreated.v1 decodes" + harness `shouldSatisfy` T.isInfixOf "\\\"reservationId\\\":\\\"rsv_" + harness `shouldSatisfy` (not . T.isInfixOf "current-shape stand-in") + goldens -> expectationFailure ("expected one synthesized golden, got " <> show goldens) + it "synthesizes complete nested mapped old shapes deterministically and never overwrites captured evidence" $ do + oldSpec <- specOf "test/fixtures/consumer-types.keiro" + newSpec <- specOf "test/fixtures/consumer-types-v2.keiro" + case goldensForDiff oldSpec newSpec of + [golden] -> do + goldenEvidence golden `shouldBe` SynthesizedWeakStandIn + goldenJson golden `shouldSatisfy` T.isInfixOf "\"artifact\":{" + goldenJson golden `shouldSatisfy` T.isInfixOf "\"location\":{\"contents\":\"sample\",\"tag\":\"local_file\"}" + goldenJson golden `shouldSatisfy` T.isInfixOf "\"labels\":[\"sample\"]" + goldenJson golden `shouldSatisfy` T.isInfixOf "\"revision\":1" + goldenJson golden `shouldSatisfy` T.isInfixOf "\"observedAt\":\"2026-01-01T00:00:00Z\"" + goldensForDiff oldSpec newSpec `shouldBe` [golden] + withTempDirectory "keiro-golden-preserve" $ \root -> do + let target = root goldenRelativePath golden + createDirectoryIfMissing True (takeDirectory target) + TIO.writeFile target "hand captured\n" + emitGoldenPayloads root oldSpec newSpec `shouldReturn` [] + TIO.readFile target `shouldReturn` "hand captured\n" + withTempDirectory "keiro-golden-write" $ \root -> do + let target = root goldenRelativePath golden + emitGoldenPayloads root oldSpec newSpec `shouldReturn` [target] + TIO.readFile target `shouldReturn` goldenJson golden + goldens -> expectationFailure ("expected one nested synthesized golden, got " <> show goldens) + it "dispatches shared-version upcasters by wire event type and passes foreign kinds through" $ do + source <- readTestText "test/fixtures/reservation-dup-upcast-source.keiro" + spec <- parseInlineSpec "" source + case [aggregate | NAggregate aggregate <- specNodes spec] of + [aggregate] -> do + let modules = scaffoldAggregate (defaultContext (specContext spec)) spec aggregate + codec = generatedTextEndingIn "Codec.hs" modules + holes = case [moduleText m | m <- modules, "Holes.hs" `T.isSuffixOf` T.pack (modulePath m)] of + [text] -> text + _ -> "" + codec `shouldSatisfy` T.isInfixOf "upcasters = [(1, upcastRungV1)]" + codec `shouldSatisfy` T.isInfixOf "upcastRungV1 (EventType \"TransferReservationCreated\") value = upcastTransferReservationCreatedV1 value" + codec `shouldSatisfy` T.isInfixOf "upcastRungV1 (EventType \"TransferReservationConfirmed\") value = upcastTransferReservationConfirmedV1 value" + codec `shouldSatisfy` T.isInfixOf "upcastRungV1 _ value = Right value" + holes `shouldSatisfy` T.isInfixOf "receives ONLY TransferReservationCreated payloads" + _ -> expectationFailure "expected exactly one aggregate" + it "keeps foreign payloads byte-for-byte and invokes both same-rung event upcasters" $ do + let payloadA = object ["kind" .= ("AmountScaled" :: T.Text), "amount" .= (2 :: Int)] + payloadB = object ["kind" .= ("AmountRenamed" :: T.Text), "amount" .= (3 :: Int)] + foreignPayload = object ["kind" .= ("AmountObserved" :: T.Text), "amount" .= (7 :: Int)] + upcastA _ = Right (object ["kind" .= ("AmountScaled" :: T.Text), "amount" .= (200 :: Int)]) + upcastB _ = Right (object ["kind" .= ("AmountRenamed" :: T.Text), "amountInCents" .= (300 :: Int)]) + rung (EventType "AmountScaled") = upcastA + rung (EventType "AmountRenamed") = upcastB + rung _ = Right + codec = + Codec + { eventTypes = EventType "AmountScaled" :| [EventType "AmountRenamed", EventType "AmountObserved"] + , eventType = const (EventType "AmountObserved") + , schemaVersion = 2 + , encode = id + , decode = \_ -> Right + , upcasters = [(1, rung)] + } :: + Codec Value + decodeRaw codec (EventType "AmountObserved") 1 foreignPayload `shouldBe` Right foreignPayload + decodeRaw codec (EventType "AmountScaled") 1 payloadA + `shouldBe` Right (object ["kind" .= ("AmountScaled" :: T.Text), "amount" .= (200 :: Int)]) + decodeRaw codec (EventType "AmountRenamed") 1 payloadB + `shouldBe` Right (object ["kind" .= ("AmountRenamed" :: T.Text), "amountInCents" .= (300 :: Int)]) + it "never emits a keiki symbolic operator into a Generated module (firewall)" $ do + mods <- scaffoldFixture "test/fixtures/reservation.keiro" + firewallBreaches mods `shouldBe` [] + it "marks the Holes module HoleStub and the rest Generated" $ do + mods <- scaffoldFixture "test/fixtures/reservation.keiro" + let holes = [m | m <- mods, "Holes.hs" `T.isSuffixOf` T.pack (modulePath m)] + map kind holes `shouldBe` [HoleStub] + -- Domain, Codec, EventStream, Projection, Harness. + length [m | m <- mods, kind m == Generated] `shouldBe` 5 + it "is deterministic (re-scaffolding yields byte-identical text)" $ do + a <- scaffoldFixture "test/fixtures/reservation.keiro" + b <- scaffoldFixture "test/fixtures/reservation.keiro" + map moduleText a `shouldBe` map moduleText b + it "keeps retiring as validator-only metadata in generated modules" $ do + ordinary <- scaffoldFixture "test/fixtures/reservation.keiro" + retiring <- scaffoldFixture "test/fixtures/reservation-retiring.keiro" + map (\m -> (modulePath m, kind m, moduleText m)) retiring + `shouldBe` map (\m -> (modulePath m, kind m, moduleText m)) ordinary + it "matches the committed compiling Generated conformance modules (modulo whitespace)" $ do + mods <- scaffoldFixture "test/fixtures/reservation.keiro" + mapM_ assertMatchesCommitted [m | m <- mods, kind m == Generated] + it "matches every committed new-surface Generated module (modulo formatting)" $ do + spec <- specOf "test/fixtures/transfer-routing.keiro" + let modules = scaffoldModules (defaultContext (specContext spec)) spec + forM_ [m | m <- modules, kind m == Generated] $ \m -> do + committed <- readTestText ("test/conformance-newsurface/" <> modulePath m) + normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m) + it "scaffolds the register-free OrderStream smoke target without error" $ do + mods <- scaffoldFixture "test/fixtures/order.keiro" + -- 5 Generated (Domain/Codec/EventStream/Projection/Harness) + 1 Holes. + length mods `shouldBe` 6 + firewallBreaches mods `shouldBe` [] + let harness = generatedTextEndingIn "Harness.hs" mods + harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: PlaceOrder from OrderNotStarted -- \"" + harness `shouldSatisfy` T.isInfixOf "prefix <> \"final vertex\"" + harness `shouldNotSatisfy` T.isInfixOf "prefix <> \"register " + it "emits forward/replay checks with field-distinct Text samples" $ do + spec <- parseInlineSpec "" (T.replace "command Bump { count:Int }" "command Bump { count:Int noteText:Text echo:Text }" loweringAggregateSpec) + case [aggregate | NAggregate aggregate <- specNodes spec] of + aggregate : _ -> do + let ctx = defaultContext (specContext spec) + harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx spec aggregate) + harness `shouldSatisfy` T.isInfixOf "\"sample-noteText\" \"sample-echo\"" + harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: Bump from CounterPending -- \"" + harness `shouldSatisfy` T.isInfixOf "prefix <> \"register note\"" + [] -> expectationFailure "forward/replay sample spec has no aggregate" + it "emits the canonical reservation register checks" $ do + mods <- scaffoldFixture "test/fixtures/reservation.keiro" + let harness = generatedTextEndingIn "Harness.hs" mods + harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: RequestTransferReservation from ReservationUnrequested -- \"" + harness `shouldSatisfy` T.isInfixOf "prefix <> \"register reservationState\"" + it "lowers a replay-only transition to B.replayOnly in the holes skeleton (plan 143)" $ do + twinMods <- scaffoldFixture "test/fixtures/reservation-guard-tightened-twin.keiro" + let twinHoles = [moduleText m | m <- twinMods, kind m == HoleStub] + twinHoles `shouldSatisfy` any (T.isInfixOf "B.replayOnly") + let twinHarness = generatedTextEndingIn "Harness.hs" twinMods + T.count "forwardReplayRequestTransferReservation ::" twinHarness `shouldBe` 1 + plainMods <- scaffoldFixture "test/fixtures/reservation.keiro" + let plainHoles = [moduleText m | m <- plainMods, kind m == HoleStub] + plainHoles `shouldSatisfy` all (not . T.isInfixOf "B.replayOnly") + + describe "service workspace (EP-153)" $ do + describe "manifest grammar" $ do + it "round-trips the canonical fixture manifest byte-for-byte" $ do + source <- readTestText canonicalWorkspacePath + manifest <- shouldParseManifest canonicalWorkspacePath source + wmfService manifest `shouldBe` "demo-project" + wmfModuleRoot manifest `shouldBe` Just "Demo.Modules.Project" + wmfLayout manifest `shouldBe` Just CollocatedLeaf + map wmrPath (NE.toList (wmfMembers manifest)) + `shouldBe` [ "domain/project-artifact.keiro" + , "domain/project.keiro" + , "domain/shared.keiro" + ] + renderWorkspaceManifest manifest + `shouldBe` T.intercalate + "\n" + [ "service demo-project" + , "module Demo.Modules.Project" + , "layout collocated" + , "spec domain/project-artifact.keiro" + , "spec domain/project.keiro" + , "spec domain/shared.keiro" + ] + it "treats membership as a set: source order changes neither the AST nor the bytes" $ do + canonical <- readTestText canonicalWorkspacePath >>= shouldParseManifest canonicalWorkspacePath + reordered <- + shouldParseManifest "" $ + T.unlines + [ "service demo-project" + , "layout collocated" + , "spec domain/shared.keiro" + , "module Demo.Modules.Project" + , "spec domain/project.keiro" + , "spec ./domain/project-artifact.keiro" + ] + reordered `shouldBe` canonical + renderWorkspaceManifest reordered `shouldBe` renderWorkspaceManifest canonical + it "satisfies parse . render == id and render . parse . render == render" $ + property $ + forAll genWorkspaceManifest $ \manifest -> + let rendered = renderWorkspaceManifest manifest + in case parseWorkspaceManifest "" rendered of + Left err -> counterexample (T.unpack err) False + Right reparsed -> + counterexample (T.unpack rendered) $ + reparsed == manifest && renderWorkspaceManifest reparsed == rendered + it "recognizes a workspace manifest by extension, case-insensitively" $ do + map + isWorkspacePath + [ "service.keiro-workspace" + , "a/b/Service.KEIRO-Workspace" + , "service.keiro" + , ".keiro-workspace" + , "keiro-workspace" + ] + `shouldBe` [True, True, False, False, False] + describe "manifest refusals" $ do + let rejects label source expected = + it label $ case parseWorkspaceManifest "" source of + Right _ -> expectationFailure ("expected a refusal, got a manifest for:\n" <> T.unpack source) + Left err -> T.unpack err `shouldContain` expected + rejects + "an empty manifest" + "# only a comment\n" + "must begin with a 'service ' clause" + rejects + "a manifest with no service clause" + "spec domain/a.keiro\n" + "first clause of a workspace manifest must be 'service '" + rejects + "a manifest whose first clause is not service" + "module Demo\nservice demo\nspec domain/a.keiro\n" + "first clause of a workspace manifest must be 'service '" + rejects + "a duplicate service clause" + "service demo\nservice demo\nspec domain/a.keiro\n" + "duplicate 'service' clause" + rejects + "a duplicate module clause" + "service demo\nmodule Demo\nmodule Demo\nspec domain/a.keiro\n" + "duplicate 'module' clause" + rejects + "a duplicate layout clause" + "service demo\nlayout prefixed\nlayout prefixed\nspec domain/a.keiro\n" + "duplicate 'layout' clause" + rejects + "a manifest with no members" + "service demo\nmodule Demo\n" + "must list at least one 'spec .keiro' member" + rejects + "the same member listed twice" + "service demo\nspec domain/a.keiro\nspec ./domain/a.keiro\n" + "duplicate workspace member 'domain/a.keiro'" + rejects + "two members that differ only by case" + "service demo\nspec domain/a.keiro\nspec domain/A.keiro\n" + "differ only by case" + rejects + "an absolute member path" + "service demo\nspec /etc/a.keiro\n" + "must be relative, not absolute" + rejects + "a member path escaping the manifest directory" + "service demo\nspec ../escape.keiro\n" + "must not contain '..' segments" + rejects + "a member that is not a .keiro spec" + "service demo\nspec domain/a.txt\n" + "must name a .keiro spec" + rejects + "a manifest listing another manifest" + "service demo\nspec domain/other.keiro-workspace\n" + "must name a .keiro spec" + describe "line relocation" $ do + it "shifts every location the AST carries, and only the locations" $ do + spec <- specOf "test/fixtures/reservation.keiro" + let shifted = relocateLocs (+ 1000) spec + collectLocs spec `shouldSatisfy` (not . null) + collectLocs shifted `shouldBe` map (+ 1000) (collectLocs spec) + -- Loc's Eq deliberately ignores the line, so relocation cannot + -- change any equality-based behavior anywhere downstream. + shifted `shouldBe` spec + it "leaves the placeholder location alone so it never lands inside a member range" $ do + spec <- specOf "test/fixtures/reservation.keiro" + let blanked = relocateLocs (const 0) spec + reshifted = relocateLocs (\n -> if n <= 0 then n else n + 500) blanked + collectLocs reshifted `shouldBe` map (const 0) (collectLocs spec) + describe "composition" $ do + it "resolves cross-file ids, enums, mapped types, and read-model feeds" $ do + workspace <- shouldComposeWorkspace canonicalWorkspacePath + wsService workspace `shouldBe` "demo-project" + wsContext workspace `shouldBe` "demo-project" + wsModuleRoot workspace `shouldBe` Just "Demo.Modules.Project" + wsLayout workspace `shouldBe` Just CollocatedLeaf + map wmPath (wsMembers workspace) + `shouldBe` [ "domain/project-artifact.keiro" + , "domain/project.keiro" + , "domain/shared.keiro" + ] + -- Every member is individually incomplete; together they check. + checkWorkspace workspace `shouldBe` [] + it "records which member owns each shared declaration and node" $ do + workspace <- shouldComposeWorkspace canonicalWorkspacePath + let ownership = wsOwnership workspace + fmap fst (declarationOwner ownership "id" "ProjectId") + `shouldBe` Just "domain/shared.keiro" + fmap fst (declarationOwner ownership "enum" "ProjectPhase") + `shouldBe` Just "domain/shared.keiro" + fmap fst (declarationOwner ownership "rule" "phaseIsTerminal") + `shouldBe` Just "domain/shared.keiro" + fmap fst (declarationOwner ownership "mapped" "ProjectSummary") + `shouldBe` Just "domain/shared.keiro" + fmap fst (nodeOwner ownership "aggregate" "Project") + `shouldBe` Just "domain/project.keiro" + fmap fst (nodeOwner ownership "aggregate" "ProjectArtifact") + `shouldBe` Just "domain/project-artifact.keiro" + fmap fst (nodeOwner ownership "readmodel" "project_activity") + `shouldBe` Just "domain/project-artifact.keiro" + it "maps every merged line back to the member that wrote it" $ do + workspace <- shouldComposeWorkspace canonicalWorkspacePath + let bases = [(wmPath m, wmLineBase m, wmLineCount m) | m <- wsMembers workspace] + -- Ranges are disjoint and contiguous from zero. + map (\(_, base, _) -> base) bases `shouldBe` scanl (+) 0 (init [c | (_, _, c) <- bases]) + sequence_ + [ resolveWorkspaceLine workspace (base + offset) `shouldBe` Just (path, offset) + | (path, base, memberLines) <- bases + , offset <- [1, memberLines] + ] + resolveWorkspaceLine workspace 0 `shouldBe` Nothing + it "is insensitive to the order members are listed in" $ do + canonical <- shouldComposeWorkspace canonicalWorkspacePath + reordered <- shouldComposeWorkspace reorderedWorkspacePath + reordered{wsManifestPath = wsManifestPath canonical} `shouldBe` canonical + it "checks a single .keiro file as a one-member workspace, diagnostic for diagnostic" $ do + let fixtures = + [ "test/fixtures/reservation.keiro" + , "test/fixtures/consumer-types.keiro" + , "test/fixtures/aggregate-bad-refs.keiro" + , "test/fixtures/readmodel.keiro" + ] + forM_ fixtures $ \path -> do + spec <- specOf path + let workspace = oneMemberWorkspace path spec + viaWorkspace = map (renderWorkspaceDiagnostic path) (checkWorkspace workspace) + direct = map (renderDiagnostic path) (validateSpec spec) + viaWorkspace `shouldBe` direct + -- At least one of those fixtures must actually produce errors, + -- or the equivalence claim is vacuous. + badRefs <- specOf "test/fixtures/aggregate-bad-refs.keiro" + checkWorkspace (oneMemberWorkspace "test/fixtures/aggregate-bad-refs.keiro" badRefs) + `shouldSatisfy` any ((== Error) . wdSeverity) + describe "composition refusals" $ do + let refusesWith path expectedCode expectedFiles = do + diagnostics <- shouldRefuseWorkspace path + map wdCode (NE.toList diagnostics) `shouldContain` [expectedCode] + let cited = + [ wlFile location + | diagnostic <- NE.toList diagnostics + , wdCode diagnostic == expectedCode + , location <- NE.toList (wdLocations diagnostic) + ] + sort (nubOrd cited) `shouldBe` sort expectedFiles + it "refuses members that declare different contexts, citing every context clause" $ + refusesWith + "test/fixtures/workspace-context-mismatch/service.keiro-workspace" + WorkspaceContextMismatch + [WorkspaceMemberFile "domain/a.keiro", WorkspaceMemberFile "domain/b.keiro"] + it "refuses a member layout clause that contradicts the manifest authority" $ + refusesWith + "test/fixtures/workspace-authority-conflict/service.keiro-workspace" + WorkspaceAuthorityConflict + [WorkspaceManifestFile, WorkspaceMemberFile "domain/b.keiro"] + it "refuses a textually identical shared declaration owned by two members" $ + refusesWith + "test/fixtures/workspace-dup-decl/service.keiro-workspace" + WorkspaceDuplicateDeclaration + [WorkspaceMemberFile "domain/project.keiro", WorkspaceMemberFile "domain/shared.keiro"] + it "refuses one aggregate defined in two members" $ + refusesWith + "test/fixtures/workspace-dup-node/service.keiro-workspace" + WorkspaceDuplicateNodeName + [WorkspaceMemberFile "domain/a.keiro", WorkspaceMemberFile "domain/b.keiro"] + it "refuses generated paths that collide across members under case folding" $ + refusesWith + "test/fixtures/workspace-path-collision/service.keiro-workspace" + WorkspacePathCollision + [WorkspaceMemberFile "domain/a.keiro", WorkspaceMemberFile "domain/b.keiro"] + it "reports a listed member that is missing from disk" $ + refusesWith + "test/fixtures/workspace-missing-member/service.keiro-workspace" + WorkspaceMemberUnreadable + [WorkspaceManifestFile] + it "reports a member that does not parse" $ + refusesWith + "test/fixtures/workspace-member-parse-failed/service.keiro-workspace" + WorkspaceMemberParseFailed + [WorkspaceManifestFile] + it "surfaces a cross-file unresolved reference through the merged validator" $ do + workspace <- shouldComposeWorkspace "test/fixtures/workspace-unresolved/service.keiro-workspace" + let errors = [d | d <- checkWorkspace workspace, wdSeverity d == Error] + map wdCode errors `shouldContain` [GuardAtomOutOfScope] + [wlFile location | d <- errors, location <- NE.toList (wdLocations d)] + `shouldContain` [WorkspaceMemberFile "domain/project.keiro"] + describe "multi-file diagnostic rendering" $ do + it "puts the primary location in the established shape and every other file on a note line" $ do + diagnostics <- shouldRefuseWorkspace "test/fixtures/workspace-dup-decl/service.keiro-workspace" + let manifest = "keiro-dsl/test/fixtures/workspace-dup-decl/service.keiro-workspace" + map (renderWorkspaceDiagnostic manifest) (NE.toList diagnostics) + `shouldBe` [ T.intercalate + "\n" + [ "keiro-dsl/test/fixtures/workspace-dup-decl/domain/project.keiro:3: error[WorkspaceDuplicateDeclaration]: duplicate declaration 'ProjectId': a shared declaration has exactly one owning member (identical duplicates do not merge)" + , " keiro-dsl/test/fixtures/workspace-dup-decl/domain/shared.keiro:3: note: also declared here, as id 'ProjectId'" + ] + ] + describe "whole-service check through the CLI" $ do + it "prints OK and exits zero for the composed fixture workspace" $ do + (exitCode, out, err) <- runKeiroDsl ["check", canonicalWorkspacePath] + unless (exitCode == ExitSuccess) (expectationFailure (out <> err)) + lines out `shouldBe` ["OK"] + it "exits non-zero and names every involved file for a cross-file refusal" $ do + (exitCode, _, err) <- + runKeiroDsl ["check", "test/fixtures/workspace-dup-decl/service.keiro-workspace"] + exitCode `shouldBe` ExitFailure 1 + err `shouldContain` "error[WorkspaceDuplicateDeclaration]" + err `shouldContain` "workspace-dup-decl/domain/project.keiro:3" + err `shouldContain` "workspace-dup-decl/domain/shared.keiro:3" + it "attributes a merged-graph validation error to the member that wrote it" $ do + (exitCode, _, err) <- + runKeiroDsl ["check", "test/fixtures/workspace-unresolved/service.keiro-workspace"] + exitCode `shouldBe` ExitFailure 1 + err `shouldContain` "workspace-unresolved/domain/project.keiro:12: error[GuardAtomOutOfScope]" + it "produces byte-identical output for a manifest whose members are listed in reverse" $ do + (canonicalCode, canonicalOut, _) <- runKeiroDsl ["check", canonicalWorkspacePath, "--emit"] + (reorderedCode, reorderedOut, _) <- runKeiroDsl ["check", reorderedWorkspacePath, "--emit"] + canonicalCode `shouldBe` ExitSuccess + reorderedCode `shouldBe` ExitSuccess + reorderedOut `shouldBe` canonicalOut + (_, canonicalParse, _) <- runKeiroDsl ["parse", canonicalWorkspacePath] + (_, reorderedParse, _) <- runKeiroDsl ["parse", reorderedWorkspacePath] + reorderedParse `shouldBe` canonicalParse + it "keeps the single-file path working, byte for byte" $ do + (exitCode, out, err) <- runKeiroDsl ["check", "test/fixtures/reservation.keiro"] + unless (exitCode == ExitSuccess) (expectationFailure (out <> err)) + lines out `shouldBe` ["OK"] + it "explains bindings and reports coverage against the merged graph" $ do + (bindingsCode, bindingsOut, _) <- + runKeiroDsl ["check", canonicalWorkspacePath, "--explain-bindings"] + bindingsCode `shouldBe` ExitSuccess + bindingsOut `shouldContain` "binding obligations for context demo-project" + -- The obligation's use sites span both aggregate members, which + -- is only possible because the graph was resolved once, merged. + bindingsOut `shouldContain` "Project register summary : ProjectSummary" + bindingsOut `shouldContain` "ProjectArtifact command RecordArtifact .artifactSummary : ProjectSummary" + withTempDirectory "keiro-dsl-workspace-coverage" $ \out -> do + let reportPath = out "coverage.json" + (coverageCode, coverageOut, _) <- + runKeiroDsl ["check", canonicalWorkspacePath, "--coverage-report", reportPath] + coverageCode `shouldBe` ExitSuccess + coverageOut `shouldContain` "structural/opaque boundaries (reporting only)" + report <- Aeson.eitherDecodeFileStrict reportPath + case report of + Left err -> expectationFailure err + Right value -> coverageSpecPath value `shouldBe` Just (T.pack canonicalWorkspacePath) + + describe "workspace diff revision loading (EP-155 M1)" $ do + it "composes added, removed, and renamed members through an in-memory content source" $ do + project <- readTestText "test/fixtures/workspace/domain/project.keiro" + artifact <- readTestText "test/fixtures/workspace/domain/project-artifact.keiro" + shared <- readTestText "test/fixtures/workspace/domain/shared.keiro" + let extra = "context demo-project\n\nid ExtraId prefix=extra\n" + manifest members = + T.unlines + ( ["service demo-project", "module Demo.Modules.Project", "layout collocated"] + <> ["spec " <> T.pack member | member <- members] + ) + baseFiles = + Map.fromList + [ ("domain/project.keiro", project) + , ("domain/project-artifact.keiro", artifact) + , ("domain/shared.keiro", shared) + ] + loadFrom members files = + loadWorkspace + (memoryContentSource (Map.insert "service.keiro-workspace" (manifest members) files)) + "service.keiro-workspace" + baseMembers = ["domain/project.keiro", "domain/project-artifact.keiro", "domain/shared.keiro"] + expectLoaded result = case result of + Left failure -> expectationFailure (show failure) >> error "unreachable" + Right workspace -> pure workspace + + oldAdded <- loadFrom baseMembers baseFiles >>= expectLoaded + newAdded <- + loadFrom + (baseMembers <> ["domain/extra.keiro"]) + (Map.insert "domain/extra.keiro" extra baseFiles) + >>= expectLoaded + map changeCode (diffSpecs (wsMergedSpec oldAdded) (wsMergedSpec newAdded)) + `shouldContain` [DeclarationAdded] + + oldRemoved <- loadFrom baseMembers baseFiles >>= expectLoaded + newRemoved <- + loadFrom + ["domain/project.keiro", "domain/shared.keiro"] + (Map.delete "domain/project-artifact.keiro" baseFiles) + >>= expectLoaded + map changeCode (diffSpecs (wsMergedSpec oldRemoved) (wsMergedSpec newRemoved)) + `shouldContain` [EvtRemovedNotDeprecated] + + oldRenamed <- loadFrom baseMembers baseFiles >>= expectLoaded + let renamedMembers = ["domain/project-renamed.keiro", "domain/project-artifact.keiro", "domain/shared.keiro"] + renamedFiles = Map.insert "domain/project-renamed.keiro" project (Map.delete "domain/project.keiro" baseFiles) + newRenamed <- loadFrom renamedMembers renamedFiles >>= expectLoaded + diffSpecs (wsMergedSpec oldRenamed) (wsMergedSpec newRenamed) `shouldBe` [] + + describe "workspace diff ownership and unified reports (EP-155 M2)" $ do + it "classifies shared declarations at use sites across every member with owned citations" $ do + old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace" + new <- shouldComposeWorkspace "test/fixtures/workspace-diff-new/service.keiro-workspace" + let changes = diffWorkspaces old new + enumChanges = filter ((== EnumCtorAdded) . changeCode . wcChange) changes + mappedChanges = filter ((== MappedFieldTypeChanged) . changeCode . wcChange) changes + citedFiles workspaceChanges = + [ osFile site + | change <- workspaceChanges + , (_, Just site) <- wcUseSites change + ] + enumChanges `shouldSatisfy` (not . null) + mappedChanges `shouldSatisfy` (not . null) + let enumWireChanges = + [ change + | workspaceChange <- enumChanges + , let change = wcChange workspaceChange + , OldBinaryReadNewEvents `elem` breakingSurfaces change + ] + enumWireChanges `shouldSatisfy` (not . null) + enumWireChanges `shouldSatisfy` all (not . gatedBreaking defaultGate) + enumWireChanges `shouldSatisfy` all (gatedBreaking (gateWith [OldBinaryReadNewEvents])) + map (fmap osFile . wcDeclarationSite) (enumChanges <> mappedChanges) + `shouldSatisfy` all (== Just "domain/shared.keiro") + citedFiles enumChanges `shouldContain` ["domain/order.keiro", "domain/shipment.keiro"] + citedFiles mappedChanges `shouldContain` ["domain/order.keiro", "domain/shipment.keiro"] + let rendered = T.intercalate "\n" (map renderWorkspaceFinding (enumChanges <> mappedChanges)) + rendered `shouldSatisfy` T.isInfixOf " declared: domain/shared.keiro:3" + rendered `shouldSatisfy` T.isInfixOf " use-site: Order" + rendered `shouldSatisfy` T.isInfixOf "(domain/order.keiro:" + rendered `shouldSatisfy` T.isInfixOf "(domain/shipment.keiro:" + golden <- readTestText "test/fixtures/workspace-diff-new/workspace.diff.golden" + T.unlines (map renderWorkspaceFinding changes) `shouldBe` golden + + it "emits one additive version-1 report with workspace provenance" $ do + old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace" + new <- shouldComposeWorkspace "test/fixtures/workspace-diff-new/service.keiro-workspace" + let changes = diffWorkspaces old new + meta = + WorkspaceMeta + { wmIdentity = wsService new + , wmManifest = "service.keiro-workspace" + , wmSince = "HEAD" + , wmMembersOld = map wmPath (wsMembers old) + , wmMembersNew = map wmPath (wsMembers new) + , wmAdoptionBaseline = False + } + case Aeson.toJSON (workspaceDiffReport meta defaultGate changes) of + Aeson.Object report -> do + KeyMap.lookup "schema" report `shouldBe` Just (Aeson.String "keiro-dsl/diff-report/1") + case KeyMap.lookup "workspace" report of + Just (Aeson.Object workspace) -> do + KeyMap.lookup "identity" workspace `shouldBe` Just (Aeson.String "workspace-diff") + KeyMap.lookup "adoptionBaseline" workspace `shouldBe` Just (Aeson.Bool False) + other -> expectationFailure ("missing workspace report metadata: " <> show other) + case KeyMap.lookup "findings" report of + Just (Aeson.Array findings) -> do + findings `shouldSatisfy` (not . null) + let objects = [finding | Aeson.Object finding <- toList findings] + objects `shouldSatisfy` any (KeyMap.member "declaration") + objects `shouldSatisfy` any (KeyMap.member "useSites") + other -> expectationFailure ("missing workspace findings: " <> show other) + other -> expectationFailure ("workspace report was not an object: " <> show other) + + it "computes one replay-impact value over both aggregates" $ do + old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace" + new <- shouldComposeWorkspace "test/fixtures/workspace-diff-new/service.keiro-workspace" + case ReplayImpact.replayImpact (wsMergedSpec old) (wsMergedSpec new) of + ReplayAffected affected -> Map.keysSet affected `shouldBe` Set.fromList ["Order", "Shipment"] + ReplayNeutral -> expectationFailure "shared mapped evolution unexpectedly reported replay-neutral" + + describe "workspace ownership and authority changes (EP-155 M3)" $ do + it "reports an unchanged aggregate move once without wire evolution" $ do + old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace" + moved <- shouldComposeWorkspace "test/fixtures/workspace-diff-moved/service.keiro-workspace" + let changes = diffWorkspaces old moved + map (changeCode . wcChange) changes `shouldBe` [OwnershipMoved] + forM_ changes $ \workspaceMove -> do + let move = wcChange workspaceMove + move `shouldSatisfy` isAdvisory + move `shouldSatisfy` (not . gatedBreaking defaultGate) + move `shouldSatisfy` (not . gatedBreaking (gateWith [minBound .. maxBound])) + deriveLabel defaultGate (ckVector (workspaceChangeKind move)) `shouldBe` LabelAdvisory + remediationFor (ckContext (workspaceChangeKind move)) OwnershipMoved + `shouldBe` (RemedyRescaffoldWorkspace :| []) + renderWorkspaceFinding workspaceMove + `shouldSatisfy` T.isInfixOf "declaration moved domain/shipment.keiro -> domain/order.keiro" + + it "treats a member rename as the same owner-map change" $ do + old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace" + let ownership = wsOwnership old + renamed = + old + { wsOwnership = + ownership + { oiNodes = + Map.adjust + (\(_, loc) -> ("domain/shipping.keiro", loc)) + ("aggregate", "Shipment") + (oiNodes ownership) + } + } + moves = filter ((== OwnershipMoved) . changeCode . wcChange) (diffWorkspaces old renamed) + length moves `shouldBe` 1 + forM_ moves $ \move -> + renderWorkspaceFinding move `shouldSatisfy` T.isInfixOf "domain/shipment.keiro -> domain/shipping.keiro" + + it "reports ownership motion beside an independently classified wire edit" $ do + old <- shouldComposeWorkspace "test/fixtures/workspace-diff-old/service.keiro-workspace" + edited <- shouldComposeWorkspace "test/fixtures/workspace-diff-new/service.keiro-workspace" + let ownership = wsOwnership edited + movedAndEdited = + edited + { wsOwnership = + ownership + { oiNodes = + Map.adjust + (\(_, loc) -> ("domain/order.keiro", loc)) + ("aggregate", "Shipment") + (oiNodes ownership) + } + } + codes = map (changeCode . wcChange) (diffWorkspaces old movedAndEdited) + codes `shouldContain` [OwnershipMoved] + codes `shouldContain` [MappedFieldTypeChanged] + + it "reports context authority separately from derived read-model identity breaks" $ do + old <- shouldComposeWorkspace canonicalWorkspacePath + let newContext = "demo-project-renamed" + renamed = + old + { wsContext = newContext + , wsMergedSpec = (wsMergedSpec old){specContext = newContext} + } + changes = diffWorkspaces old renamed + codes = map (changeCode . wcChange) changes + codes `shouldContain` [WorkspaceAuthorityChanged] + codes `shouldContain` [DerivedIdentityChanged] + map wcChange changes `shouldSatisfy` any (gatedBreaking defaultGate) + + it "keeps service, module-root, and layout authority advisories non-blocking" $ do + old <- shouldComposeWorkspace canonicalWorkspacePath + let changed = + old + { wsService = "demo-project-renamed" + , wsModuleRoot = Just "Demo.Modules.Renamed" + , wsLayout = Just GeneratedPrefix + } + authority = filter ((== WorkspaceAuthorityChanged) . changeCode . wcChange) (diffWorkspaces old changed) + length authority `shouldBe` 3 + forM_ (map wcChange authority) $ \change -> do + deriveLabel defaultGate (ckVector (workspaceChangeKind change)) `shouldBe` LabelAdvisory + change `shouldSatisfy` (not . gatedBreaking (gateWith [minBound .. maxBound])) + remediationFor (ckContext (workspaceChangeKind change)) WorkspaceAuthorityChanged + `shouldBe` (RemedyRescaffoldWorkspace :| [RemedyRecompileConsumers]) + + describe "workspace scaffold (EP-154)" $ do + describe "workspace record" $ do + it "round-trips modules, owners, members, mappings, obligations, and adoptions" $ do + workspace <- shouldComposeWorkspace canonicalWorkspacePath + let record = sampleWorkspaceRecord workspace + rendered = renderWorkspaceRecord record + parseWorkspaceRecord rendered `shouldBe` Just record + -- The header pins the schema: a v1 context-keyed record and a + -- workspace record can never be read as each other. + T.lines rendered `shouldSatisfy` \case + header : _ -> header == "keiro-dsl workspace scaffold record v1" + [] -> False + parseRecord rendered `shouldBe` Nothing + parseWorkspaceRecord (T.replace "record v1" "record v2" rendered) `shouldBe` Nothing + it "ignores unknown rows and unknown JSON keys, and keeps context-level rows ownerless" $ do + workspace <- shouldComposeWorkspace canonicalWorkspacePath + let record = sampleWorkspaceRecord workspace + rendered = renderWorkspaceRecord record + parseWorkspaceRecord (T.replace "service: " "future-row: retained\nservice: " rendered) + `shouldBe` Just record + parseWorkspaceRecord (T.replace "\"kind\":\"generated\"" "\"kind\":\"generated\",\"future\":1" rendered) + `shouldBe` Just record + [row | row <- wrModules record, wrmOwner row == Nothing] + `shouldSatisfy` (not . null) + it "rejects unsafe module, owner, member, and adoption paths" $ do + workspace <- shouldComposeWorkspace canonicalWorkspacePath + let rendered = renderWorkspaceRecord (sampleWorkspaceRecord workspace) + corrupt from to = parseWorkspaceRecord (T.replace from to rendered) + corrupt "member domain/shared.keiro" "member /etc/passwd" `shouldBe` Nothing + corrupt "member domain/shared.keiro" "member ../escape.keiro" `shouldBe` Nothing + corrupt "\"owner\":\"domain/shared.keiro\"" "\"owner\":\"../shared.keiro\"" `shouldBe` Nothing + corrupt "\"path\":\"claimed/One.hs\"" "\"path\":\"/tmp/One.hs\"" `shouldBe` Nothing + it "keys history by service in a slot no context name can reach" $ do + -- A context name is lexed as letters/digits/_/- and can never + -- contain a dot, so the workspace slot cannot alias a legacy + -- record even when the service is named after its context. + workspaceRecordFileName "demo-project" + `shouldBe` "keiro-dsl-scaffold-record.workspace.demo-project.txt" + workspaceManifestFileName "demo-project" + `shouldBe` "keiro-dsl-manifest.workspace.demo-project.txt" + workspaceRecordFileName "demo-project" `shouldNotBe` recordFileName "demo-project" + map + (T.isInfixOf "." . T.pack) + [ workspaceRecordFileName "demo-project" + , recordFileName "demo-project" + ] + `shouldBe` [True, True] + supersededByLine "demo-project" + `shouldBe` "superseded-by: keiro-dsl-scaffold-record.workspace.demo-project.txt" + + describe "workspace plan" $ do + it "emits the context-level facade and replay-audit exactly once from the merged graph" $ do + plan <- shouldPlanWorkspace canonicalWorkspacePath + let modules = map fst (wpModules plan) + facades = [m | m <- modules, "StructuralProjections.hs" `isSuffixOfPath` m] + audits = [m | m <- modules, "ReplayAudit.hs" `isSuffixOfPath` m] + shapes = [m | m <- modules, "Structural/Shape/ProjectSummary.hs" `isSuffixOfPath` m] + length facades `shouldBe` 1 + length audits `shouldBe` 1 + length shapes `shouldBe` 1 + -- The audit assembles aggregates owned by two different member + -- files, which is only possible from one merged graph. + forM_ audits $ \audit -> do + moduleText audit `shouldSatisfy` T.isInfixOf "Project.projectEventStream" + moduleText audit `shouldSatisfy` T.isInfixOf "ProjectArtifact.projectArtifactEventStream" + it "attributes every module to its owning member and leaves shared ones context-level" $ do + plan <- shouldPlanWorkspace canonicalWorkspacePath + let memberPaths = map wmPath (wsMembers (wpWorkspace plan)) + ownerOf suffix = + case [provenance | (m, provenance) <- wpModules plan, suffix `isSuffixOfPath` m] of + [provenance] -> Just provenance + _ -> Nothing + ownerOf "StructuralProjections.hs" `shouldBe` Just ContextLevel + ownerOf "ReplayAudit.hs" `shouldBe` Just ContextLevel + ownerOf "Structural/Shape/ProjectSummary.hs" + `shouldBe` Just (MemberOwned "domain/shared.keiro") + ownerOf "Project/Generated/Domain.hs" + `shouldBe` Just (MemberOwned "domain/project.keiro") + ownerOf "ProjectArtifact/Generated/Domain.hs" + `shouldBe` Just (MemberOwned "domain/project-artifact.keiro") + ownerOf "Project_activity/Generated/ReadModel.hs" + `shouldBe` Just (MemberOwned "domain/project-artifact.keiro") + -- No module may claim an owner that is not a member of the + -- workspace: the record's owner column has to stay resolvable. + map (provenanceOwner . snd) (wpModules plan) + `shouldSatisfy` all (maybe True (`elem` memberPaths)) + it "plans a one-member workspace byte-identically to the single-file path" $ do + let fixtures = + [ "test/fixtures/reservation.keiro" + , "test/fixtures/consumer-types.keiro" + , "test/fixtures/readmodel.keiro" + , "test/fixtures/hospital-surge.keiro" + ] + -- Modules and refusals both: hospital-surge refuses on both + -- paths, which proves the gates agree as well as the emitters. + forM_ fixtures $ \path -> do + spec <- specOf path + let ctx = defaultContext (specContext spec) + workspace = oneMemberWorkspace path spec + fmap (map fst . wpModules) (planWorkspaceScaffold "goldens" ctx workspace) + `shouldBe` planScaffold ctx spec + -- The equality is not vacuous: at least one fixture plans, and + -- its per-node modules are attributed to the single member. + spec <- specOf "test/fixtures/reservation.keiro" + let workspace = oneMemberWorkspace "test/fixtures/reservation.keiro" spec + case planWorkspaceScaffold "goldens" (defaultContext (specContext spec)) workspace of + Left refusals -> expectationFailure ("reservation should plan: " <> show refusals) + Right plan -> do + wpModules plan `shouldSatisfy` (not . null) + map snd (wpModules plan) + `shouldSatisfy` all (`elem` [ContextLevel, MemberOwned "reservation.keiro"]) + map snd (wpModules plan) + `shouldSatisfy` elem (MemberOwned "reservation.keiro") + it "computes obligations from the complete merged graph, spanning members" $ do + workspace <- shouldComposeWorkspace canonicalWorkspacePath + case bindingObligations (wsMergedSpec workspace) of + Left graphErrors -> expectationFailure ("merged graph did not resolve: " <> show graphErrors) + Right obligations -> + case [o | o <- obligations, obligationMappedName o == "ProjectSummary", obligationKind o == BindingValue] of + [obligation] -> do + obligationUseSites obligation + `shouldSatisfy` any (T.isInfixOf "Project register summary") + obligationUseSites obligation + `shouldSatisfy` any (T.isInfixOf "ProjectArtifact command RecordArtifact") + found -> expectationFailure ("expected one ProjectSummary binding obligation, got " <> show (length found)) + it "refuses a case-folded path collision across members, naming both files" $ do + workspace <- shouldComposeWorkspace canonicalWorkspacePath + let collided = withCaseVariantAggregate workspace + case planWorkspaceScaffold "goldens" (workspaceContext collided) collided of + Right _ -> expectationFailure "expected a cross-member path collision refusal" + Left refusals -> do + let origins = concat [os | PathCollision _ os <- refusals] + origins `shouldSatisfy` any (T.isInfixOf "domain/project.keiro: ") + origins `shouldSatisfy` any (T.isInfixOf "domain/project-artifact.keiro: ") + it "refuses golden fixtures stranded beside a member instead of under the workspace root" $ + withTempDirectory "keiro-dsl-workspace-goldens" $ \root -> do + workspace <- writeGoldenWorkspace root + let workspaceGoldens = root "golden-payloads" + fixture = "hospital-capacity/Reservation/TransferReservationCreated.v1.json" + beside = root "domain/golden-payloads" fixture + goldenRootDivergence workspaceGoldens workspace `shouldReturn` [] + createDirectoryIfMissing True (takeDirectory beside) + TIO.writeFile beside "{}\n" + refusals <- goldenRootDivergence workspaceGoldens workspace + refusals `shouldBe` [GoldenRootDivergence workspaceGoldens [beside]] + renderRefusals refusals + `shouldSatisfy` any (T.isInfixOf "one golden root per workspace") + -- The same fixture under the workspace root is no divergence. + let atRoot = workspaceGoldens fixture + createDirectoryIfMissing True (takeDirectory atRoot) + TIO.writeFile atRoot "{}\n" + goldenRootDivergence workspaceGoldens workspace `shouldReturn` [] + + describe "workspace scaffold" $ do + it "writes workspace-keyed history and no context-keyed file at all" $ + withWorkspaceFixture "keiro-dsl-workspace-history" id $ \_ out workspace -> do + report <- executePlannedWorkspaceScaffold out workspace + wsrRecordPath report + `shouldBe` out "keiro-dsl-scaffold-record.workspace.demo-project.txt" + wsrBuildManifestPath report + `shouldBe` out "keiro-dsl-manifest.workspace.demo-project.txt" + doesFileExist (out recordFileName "demo-project") `shouldReturn` False + doesFileExist (out "keiro-dsl-manifest.demo-project.txt") `shouldReturn` False + contents <- TIO.readFile (wsrRecordPath report) + case parseWorkspaceRecord contents of + Nothing -> expectationFailure ("workspace record did not parse:\n" <> T.unpack contents) + Just record -> do + wrService record `shouldBe` "demo-project" + wrManifest record `shouldBe` "service.keiro-workspace" + wrMembers record + `shouldBe` [ "domain/project-artifact.keiro" + , "domain/project.keiro" + , "domain/shared.keiro" + ] + -- Context-level modules are ownerless; everything + -- else names the member that produced it. + [wrmPath row | row <- wrModules record, wrmOwner row == Nothing] + `shouldSatisfy` \ownerless -> + length ownerless == 2 + && any (T.isSuffixOf "StructuralProjections.hs" . T.pack) ownerless + && any (T.isSuffixOf "ReplayAudit.hs" . T.pack) ownerless + [ wrmOwner row + | row <- wrModules record + , "Project/Generated/Domain.hs" `T.isSuffixOf` T.pack (wrmPath row) + ] + `shouldBe` [Just "domain/project.keiro"] + it "is idempotent: an unchanged second run rewrites nothing and reports nothing" $ + withWorkspaceFixture "keiro-dsl-workspace-idempotent" id $ \_ out workspace -> do + first <- executePlannedWorkspaceScaffold out workspace + before <- treeSnapshot out + second <- executePlannedWorkspaceScaffold out workspace + after <- treeSnapshot out + after `shouldBe` before + map thd3 (wsrDispositions second) + `shouldSatisfy` all (`elem` [Unchanged, Skipped]) + wsrStale second `shouldBe` [] + wsrOwnershipMoves second `shouldBe` [] + wsrMappingDrift second `shouldBe` [] + wsrNewHoles second `shouldBe` [] + -- The first run had to write; the claim is not vacuous. + map thd3 (wsrDispositions first) `shouldSatisfy` any (== Overwritten) + renderWorkspaceScaffoldReport second + `shouldSatisfy` all (not . T.isPrefixOf "stale:") + it "produces byte-identical output for members listed in reverse order" $ + withWorkspaceFixture "keiro-dsl-workspace-order-a" id $ \_ outA workspaceA -> + withWorkspaceFixture "keiro-dsl-workspace-order-b" reverse $ \_ outB workspaceB -> do + _ <- executePlannedWorkspaceScaffold outA workspaceA + _ <- executePlannedWorkspaceScaffold outB workspaceB + treeB <- treeSnapshot outB + treeA <- treeSnapshot outA + treeB `shouldBe` treeA + map fst treeA `shouldSatisfy` elem "keiro-dsl-scaffold-record.workspace.demo-project.txt" + it "reports stale files only for the member that changed" $ + withWorkspaceFixture "keiro-dsl-workspace-stale" id $ \root out workspace -> do + first <- executePlannedWorkspaceScaffold out workspace + let siblingPaths = + [ modulePath m + | (m, provenance, _) <- wsrDispositions first + , provenance == MemberOwned "domain/project-artifact.keiro" + ] + siblingsBefore <- traverse (TIO.readFile . (out )) siblingPaths + renamed <- renameMemberAggregate root "domain/project.keiro" "Project" "Ledger" + second <- executePlannedWorkspaceScaffold out renamed + let stalePaths = map stalePath (wsrStale second) + stalePaths `shouldSatisfy` (not . null) + stalePaths `shouldSatisfy` all (T.isInfixOf "/Project/" . T.pack) + -- Nothing the sibling member owns is stale, and nothing it + -- owns changed on disk: no cross-member false positives. + stalePaths `shouldSatisfy` all (`notElem` siblingPaths) + siblingsAfter <- traverse (TIO.readFile . (out )) siblingPaths + siblingsAfter `shouldBe` siblingsBefore + forM_ stalePaths $ \path -> doesFileExist (out path) `shouldReturn` True + renderWorkspaceScaffoldReport second + `shouldSatisfy` any (T.isInfixOf "keiro-dsl never deletes files.") + it "reports an aggregate moved between members as an ownership move, not stale churn" $ + withWorkspaceFixture "keiro-dsl-workspace-move" id $ \root out workspace -> do + _ <- executePlannedWorkspaceScaffold out workspace + before <- treeSnapshot out + moved <- moveArtifactAggregate root + second <- executePlannedWorkspaceScaffold out moved + wsrStale second `shouldBe` [] + let moves = wsrOwnershipMoves second + moves `shouldSatisfy` (not . null) + moves + `shouldSatisfy` all + ( \move -> + omPrevious move == Just "domain/project-artifact.keiro" + && omCurrent move == Just "domain/project.keiro" + ) + map omPath moves + `shouldSatisfy` any (T.isInfixOf "ProjectArtifact" . T.pack) + -- An ownership move is not a content change: every module's + -- bytes, and the build manifest, are untouched. + map thd3 (wsrDispositions second) + `shouldSatisfy` all (`elem` [Unchanged, Skipped]) + after <- treeSnapshot out + map fst after `shouldBe` map fst before + [(path, text) | (path, text) <- after, not ("scaffold-record" `T.isInfixOf` T.pack path)] + `shouldBe` [(path, text) | (path, text) <- before, not ("scaffold-record" `T.isInfixOf` T.pack path)] + renderWorkspaceScaffoldReport second + `shouldSatisfy` any (T.isInfixOf "changed owning member") + it "leaves the tree, record, and manifest untouched when any member refuses" $ + withWorkspaceFixture "keiro-dsl-workspace-atomic" id $ \_ out workspace -> do + _ <- executePlannedWorkspaceScaffold out workspace + before <- treeSnapshot out + let broken = withCaseVariantAggregate workspace + case planWorkspaceScaffold "goldens" (workspaceContext broken) broken of + Right _ -> expectationFailure "expected the broken workspace to refuse" + Left refusals -> refusals `shouldSatisfy` any isPathCollision + treeSnapshot out `shouldReturn` before + -- A fresh output directory is never even created. + withTempDirectory "keiro-dsl-workspace-atomic-fresh" $ \fresh -> do + let target = fresh "out" + case planWorkspaceScaffold "goldens" (workspaceContext broken) broken of + Right _ -> expectationFailure "expected the broken workspace to refuse" + Left _ -> doesDirectoryExist target `shouldReturn` False + it "leaves prior workspace output byte-identical for parse, validation, and collision failures" $ + withWorkspaceFixture "keiro-dsl-workspace-atomic-cli" id $ \root out workspace -> do + _ <- executePlannedWorkspaceScaffold out workspace + before <- treeSnapshot out + let member = root "domain/project-artifact.keiro" + manifest = root "service.keiro-workspace" + original <- TIO.readFile member + let failures = + [ ("parse", "context demo-project\naggregate !!!\n") + , ("validation", T.replace "ProjectId" "MissingProjectId" original) + , ("collision", T.replace "aggregate ProjectArtifact" "aggregate PROJECT" original) + ] + forM_ failures $ \(failureKind, brokenSource) -> do + TIO.writeFile member brokenSource + (exitCode, stdoutText, stderrText) <- + runKeiroDsl ["scaffold", manifest, "--out", out] + unless (exitCode == ExitFailure 1) $ + expectationFailure + (failureKind <> " failure unexpectedly scaffolded:\n" <> stdoutText <> stderrText) + treeSnapshot out `shouldReturn` before + TIO.writeFile member original + it "refuses the whole workspace for one bannerless Generated target, changing nothing" $ + withWorkspaceFixture "keiro-dsl-workspace-banner" id $ \_ out workspace -> do + plan <- shouldPlanWorkspaceSpec workspace + let generated = [m | (m, _) <- wpModules plan, kind m == Generated] + case generated of + [] -> expectationFailure "workspace fixture has no Generated module" + target : _ -> do + let path = out modulePath target + createDirectoryIfMissing True (takeDirectory path) + TIO.writeFile path "hand owned\n" + before <- treeSnapshot out + refused <- executeWorkspaceScaffold out False plan + refused `shouldSatisfy` isMissingBannerRefusal + treeSnapshot out `shouldReturn` before + forced <- executeWorkspaceScaffold out True plan + forced `shouldSatisfy` isSuccessfulScaffold + TIO.readFile path `shouldReturn` moduleText target + it "scaffolds a whole workspace through the CLI" $ + withTempDirectory "keiro-dsl-workspace-cli" $ \out -> do + (exitCode, stdoutText, stderrText) <- + runKeiroDsl ["scaffold", canonicalWorkspacePath, "--out", out] + unless (exitCode == ExitSuccess) (expectationFailure (stdoutText <> stderrText)) + stderrText `shouldContain` "workspace: demo-project" + doesFileExist (out "keiro-dsl-scaffold-record.workspace.demo-project.txt") + `shouldReturn` True + tree <- treeSnapshot out + length [path | (path, _) <- tree, "StructuralProjections.hs" `T.isSuffixOf` T.pack path] + `shouldBe` 1 + length [path | (path, _) <- tree, "ReplayAudit.hs" `T.isSuffixOf` T.pack path] + `shouldBe` 1 + (secondCode, _, secondErr) <- + runKeiroDsl ["scaffold", canonicalWorkspacePath, "--out", out] + secondCode `shouldBe` ExitSuccess + secondErr `shouldSatisfy` (not . isInfixOfString "(overwritten)") + treeSnapshot out `shouldReturn` tree + + describe "workspace adoption" $ do + it "adopts an overwritten same-context record pair by record and by banner" $ + withInlineWorkspace "keiro-dsl-workspace-adopt" adoptionMembers $ \_ out workspace -> do + -- Reproduce today's defect first: two same-context specs + -- scaffolded independently into one directory, the second + -- replacing the first's record and calling its files stale. + specA <- parseInlineSpec "domain/a.keiro" adoptionMemberA + specB <- parseInlineSpec "domain/b.keiro" adoptionMemberB + let ctx = defaultContext "adoption-demo" + legacyA <- executePlannedScaffold out "domain/a.keiro" ctx specA + legacyB <- executePlannedScaffold out "domain/b.keiro" ctx specB + reportStale legacyB `shouldSatisfy` (not . null) + legacyBefore <- TIO.readFile (out recordFileName "adoption-demo") + + report <- executePlannedWorkspaceScaffold out workspace + wsrStale report `shouldBe` [] + case wsrMigration report of + Nothing -> expectationFailure "expected the first workspace run to adopt" + Just migration -> do + let generatedOf run = sort [modulePath m | (m, _) <- reportDispositions run, kind m == Generated] + claimedBy evidence = sort [cfPath entry | entry <- mrClaimed migration, cfEvidence entry == evidence] + -- The surviving record attributes B's files; A's + -- files survived only as banners, which is exactly + -- the orphan case the overwrite created. + claimedBy ClaimedFromRecord `shouldBe` generatedOf legacyB + claimedBy ClaimedFromBanner `shouldBe` sort (generatedOf legacyA \\ generatedOf legacyB) + claimedBy ClaimedFromBanner `shouldSatisfy` (not . null) + mrLikelyStale migration `shouldBe` [] + mrLegacyRecord migration + `shouldBe` Just (recordFileName "adoption-demo", "domain/b.keiro") + -- Provenance is persisted, not merely printed. + recorded <- parseWorkspaceRecord <$> TIO.readFile (wsrRecordPath report) + fmap (sort . map adPath . wrAdopted) recorded + `shouldBe` Just (sort (map cfPath (mrClaimed migration))) + fmap (sort . nubOrd . map adEvidence . wrAdopted) recorded + `shouldBe` Just ["banner", "record"] + persisted <- TIO.readFile (out "keiro-dsl-migration-report.workspace.adoption-demo.txt") + persisted `shouldBe` T.unlines (renderMigrationReport migration) + renderWorkspaceScaffoldReport report + `shouldSatisfy` any (T.isInfixOf "adopting pre-workspace scaffold output") + + -- The legacy record gained one line and nothing else: it + -- still parses to the same value for an old binary. + legacyAfter <- TIO.readFile (out recordFileName "adoption-demo") + T.lines legacyAfter `shouldSatisfy` elem (supersededByLine "adoption-demo") + parseRecord legacyAfter `shouldBe` parseRecord legacyBefore + T.lines legacyAfter + `shouldBe` T.lines legacyBefore <> [supersededByLine "adoption-demo"] + + -- Adoption is not a content change: the generated tree is + -- what a fresh workspace scaffold of the same members emits. + withInlineWorkspace "keiro-dsl-workspace-adopt-fresh" adoptionMembers $ \_ fresh freshWorkspace -> do + freshReport <- executePlannedWorkspaceScaffold fresh freshWorkspace + wsrMigration freshReport `shouldBe` Nothing + adoptedTree <- treeSnapshot out + freshTree <- treeSnapshot fresh + haskellOnly adoptedTree `shouldBe` haskellOnly freshTree + it "lists hand-written files as unclaimed and leaves their bytes alone" $ + withInlineWorkspace "keiro-dsl-workspace-unclaimed" adoptionMembers $ \_ out workspace -> do + plan <- shouldPlanWorkspaceSpec workspace + case [modulePath m | (m, _) <- wpModules plan, kind m == HoleStub] of + [] -> expectationFailure "adoption fixture emits no hole module" + holePath : _ -> do + writeFileWithParents (out holePath) "-- hand filled\n" + writeFileWithParents (out "Notes.hs") "module Notes where\n" + report <- executePlannedWorkspaceScaffold out workspace + case wsrMigration report of + Nothing -> expectationFailure "expected a report for a directory holding hand-written files" + Just migration -> do + mrLegacyRecord migration `shouldBe` Nothing + mrClaimed migration `shouldBe` [] + mrUnclaimed migration `shouldBe` sort [holePath, "Notes.hs"] + TIO.readFile (out holePath) `shouldReturn` "-- hand filled\n" + TIO.readFile (out "Notes.hs") `shouldReturn` "module Notes where\n" + it "never claims a bannerless file at a planned Generated path" $ + withInlineWorkspace "keiro-dsl-workspace-unattributable" adoptionMembers $ \_ out workspace -> do + plan <- shouldPlanWorkspaceSpec workspace + case [modulePath m | (m, _) <- wpModules plan, kind m == Generated] of + [] -> expectationFailure "adoption fixture emits no Generated module" + target : _ -> do + writeFileWithParents (out target) "hand owned\n" + refused <- executeWorkspaceScaffold out False plan + refused `shouldSatisfy` isMissingBannerRefusal + TIO.readFile (out target) `shouldReturn` "hand owned\n" + doesFileExist (out "keiro-dsl-migration-report.workspace.adoption-demo.txt") + `shouldReturn` False + it "adopts at most once, and the second run is an ordinary idempotent run" $ + withInlineWorkspace "keiro-dsl-workspace-adopt-once" adoptionMembers $ \_ out workspace -> do + specA <- parseInlineSpec "domain/a.keiro" adoptionMemberA + _ <- executePlannedScaffold out "domain/a.keiro" (defaultContext "adoption-demo") specA + first <- executePlannedWorkspaceScaffold out workspace + wsrMigration first `shouldSatisfy` \case Just _ -> True; Nothing -> False + before <- treeSnapshot out + reportBefore <- TIO.readFile (out "keiro-dsl-migration-report.workspace.adoption-demo.txt") + legacyBefore <- TIO.readFile (out recordFileName "adoption-demo") + + second <- executePlannedWorkspaceScaffold out workspace + wsrMigration second `shouldBe` Nothing + wsrStale second `shouldBe` [] + map thd3 (wsrDispositions second) `shouldSatisfy` all (`elem` [Unchanged, Skipped]) + treeSnapshot out `shouldReturn` before + TIO.readFile (out "keiro-dsl-migration-report.workspace.adoption-demo.txt") + `shouldReturn` reportBefore + legacyAfter <- TIO.readFile (out recordFileName "adoption-demo") + legacyAfter `shouldBe` legacyBefore + length (filter (== supersededByLine "adoption-demo") (T.lines legacyAfter)) + `shouldBe` 1 + +comparisonProvenance :: CompareProvenance +comparisonProvenance = + CompareProvenance + { cpHistoricalCodecIdentity = "example.historical" + , cpHistoricalCodecVersion = "legacy-v1" + , cpCanonicalType = CanonicalTypeId "example.Artifact.v1" + , cpBindingSymbol = QualifiedValueName "Example.Bindings.artifactBinding" + , cpBindingVersion = BindingVersion "1" + , cpWireFingerprint = "deadbeef" + } + +syntheticGenerated :: FilePath -> T.Text -> ScaffoldModule +syntheticGenerated path contents = + ScaffoldModule{modulePath = path, moduleText = contents, kind = Generated, origin = "test"} + +generatedTextEndingIn :: T.Text -> [ScaffoldModule] -> T.Text +generatedTextEndingIn suffix modules = case [moduleText m | m <- modules, kind m == Generated, suffix `T.isSuffixOf` T.pack (modulePath m)] of + contents : _ -> contents + [] -> "" + +onlyAggregate :: Spec -> Aggregate +onlyAggregate spec = case [aggregate | NAggregate aggregate <- specNodes spec] of + [aggregate] -> aggregate + aggregates -> error ("expected one aggregate, got " <> show (length aggregates)) + +loweringAggregateSpec :: T.Text +loweringAggregateSpec = + T.unlines + [ "context samples" + , "" + , "aggregate Counter" + , " regs" + , " note Text = \"hello world\"" + , " count Int = 0" + , " state CounterVertex = Pending" + , " states Pending Done!" + , " command Bump { count:Int }" + , " event CountBumped { count:Int }" + , " Pending -- Bump --> emit CountBumped ; goto Done" + ] + +exactStatusSpec :: T.Text +exactStatusSpec = + T.unlines + [ "context samples" + , "" + , "aggregate Reservation" + , " regs" + , " state ReservationVertex = Open" + , " states Open Closed!" + , " command Bump { count:Int }" + , " event ReservationHeld { count:Int }" + , " event ReservationUnHeld { count:Int }" + , " event CountBumped { count:Int }" + , " Open -- Bump --> emit CountBumped ; goto Closed" + , " projection reservation_status consistency=Eventual key=count" + , " status-map { ReservationHeld=>held ReservationUnHeld=>available CountBumped=>bumped }" + ] + +hasPathCollisionWithTwoOrigins :: Either [Refusal] [ScaffoldModule] -> Bool +hasPathCollisionWithTwoOrigins = \case + Left refusals -> any hasTwo refusals + Right _ -> False + where + hasTwo (PathCollision _ origins) = length origins == 2 + hasTwo _ = False + +isMissingBannerRefusal :: Either [Refusal] a -> Bool +isMissingBannerRefusal = \case + Left [MissingGeneratedBanner paths] -> not (null paths) + _ -> False + +isSuccessfulScaffold :: Either [Refusal] a -> Bool +isSuccessfulScaffold = \case + Right _ -> True + Left _ -> False + +executePlannedScaffold :: FilePath -> FilePath -> Context -> Spec -> IO ScaffoldReport +executePlannedScaffold out specPath ctx spec = case planScaffold ctx spec of + Left refusals -> expectationFailure ("unexpected scaffold refusal: " <> show refusals) >> error "unreachable" + Right modules -> do + result <- executeScaffold out False specPath ctx spec modules + case result of + Left refusals -> expectationFailure ("unexpected execution refusal: " <> show refusals) >> error "unreachable" + Right report -> pure report + +renameCounter :: Node -> Node +renameCounter (NAggregate aggregate) = + NAggregate + aggregate + { aggName = "Widget" + , aggRegs = [reg{regType = if regType reg == "CounterVertex" then "WidgetVertex" else regType reg} | reg <- aggRegs aggregate] + } +renameCounter node = node + +onlyPathEndingIn :: FilePath -> [ScaffoldModule] -> FilePath +onlyPathEndingIn suffix modules = case [modulePath m | m <- modules, T.pack suffix `T.isSuffixOf` T.pack (modulePath m)] of + [path] -> path + paths -> error ("expected one path ending in " <> suffix <> ", got " <> show paths) + +withTempDirectory :: String -> (FilePath -> IO a) -> IO a +withTempDirectory template = bracket acquire removePathForcibly + where + acquire = do + base <- getTemporaryDirectory + (path, handle) <- openTempFile base template + hClose handle + removeFile path + createDirectory path + pure path + +{- | Parse a fixture and return the validator's diagnostic codes (failing the +test on a parse error). +-} +diagnosticCodesOf :: FilePath -> IO [DiagnosticCode] +diagnosticCodesOf path = do + map code <$> diagnosticsOf path + +-- | Parse a fixture and return all validator diagnostics. +diagnosticsOf :: FilePath -> IO [Diagnostic] +diagnosticsOf path = do + input <- readTestText path + case parseSpec path input of + Left err -> expectationFailure (T.unpack err) >> pure [] + Right spec -> pure (validateSpec spec) + +{- | Like 'diagnosticCodesOf' but only the Error-severity codes (warnings, e.g. +the benign-inversion notices, are excluded). +-} +errorCodesOf :: FilePath -> IO [DiagnosticCode] +errorCodesOf path = do + diagnostics <- diagnosticsOf path + pure [code d | d <- diagnostics, severity d == Error] + +{- | Parse two fixtures and diff them (old, new). +| Plan 143: render an Expr in concrete guard syntax by printing a dummy +transition through the real pretty-printer and slicing its guard clause, +so the test exercises the exact printer the diff advisory uses. +-} +renderExprText :: Expr -> T.Text +renderExprText e = + case [T.strip l | l <- T.lines rendered, "guard " `T.isPrefixOf` T.strip l] of + [guardLine] -> T.strip (T.drop (T.length "guard ") guardLine) + _ -> error ("renderExprText: unexpected printer output: " <> T.unpack rendered) + where + rendered = + renderTransition + Transition + { tSource = "S" + , tCommand = "C" + , tGuard = Just e + , tWrites = [] + , tEmits = [] + , tGoto = "S" + , tMode = TmLive + , tLoc = noLoc + } + +{- | Plan 143: a minimal spec whose only transition is replay-only, with the +supplied clause lines spliced into its body. +-} +replayOnlySpecWith :: [T.Text] -> T.Text +replayOnlySpecWith clauseLines = + T.unlines $ + [ "context hospital-capacity" + , "" + , "id TransferReservationId prefix=rsv" + , "" + , "aggregate Reservation" + , " regs" + , " reservationId TransferReservationId = placeholder" + , " reservationState ReservationVertex = Unrequested" + , " states Unrequested Held" + , "" + , " command RequestTransferReservation { reservationId }" + , "" + , " event TransferReservationCreated = fields(RequestTransferReservation)" + , "" + , " replay-only Unrequested -- RequestTransferReservation -->" + ] + ++ clauseLines + +diffFixtures :: FilePath -> FilePath -> IO [Change] +diffFixtures oldP newP = do + old <- readTestText oldP + new <- readTestText newP + case (,) <$> parseSpec oldP old <*> parseSpec newP new of + Left err -> expectationFailure (T.unpack err) >> pure [] + Right (o, n) -> pure (diffSpecs o n) + +kindOfChange :: Change -> ChangeKind +kindOfChange (Additive kind) = kind +kindOfChange (Advisory kind) = kind +kindOfChange (Breaking kind) = kind + +labelOfChange :: Change -> Label +labelOfChange Additive{} = LabelAdditive +labelOfChange Advisory{} = LabelAdvisory +labelOfChange Breaking{} = LabelBreaking + +genSurfaceSet :: Gen (Set.Set CompatibilitySurface) +genSurfaceSet = Set.fromList <$> listOf (elements [minBound .. maxBound]) + +genCompatibilityVector :: Gen CompatibilityVector +genCompatibilityVector = + CompatibilityVector + <$> genVerdict + <*> genVerdict + <*> genVerdict + <*> genVerdict + <*> genVerdict + <*> genVerdict + <*> (Set.fromList <$> listOf (elements rolloutConstraints)) + where + genVerdict = elements [VCompatible, VAdvisory, VBreaking, VNotApplicable] + rolloutConstraints = + [ RolloutStopTheWorld + , RolloutWorkersFirst + , RolloutDrainRequired + , RolloutProducerLast + ] + +replayImpactFixtures :: FilePath -> FilePath -> IO ReplayImpact +replayImpactFixtures oldPath newPath = do + old <- specOf oldPath + new <- specOf newPath + pure (ReplayImpact.replayImpact old new) + +modifyAggregate :: Name -> (Aggregate -> Aggregate) -> Spec -> Spec +modifyAggregate target update spec = + spec + { specNodes = + [ case node of + NAggregate aggregate | aggName aggregate == target -> NAggregate (update aggregate) + _ -> node + | node <- specNodes spec + ] + } + +modifyReadModel :: Name -> (ReadModelNode -> ReadModelNode) -> Spec -> Spec +modifyReadModel target update spec = + spec + { specNodes = + [ case node of + NReadModel readModel | rmName readModel == target -> NReadModel (update readModel) + _ -> node + | node <- specNodes spec + ] + } + +removeReadModel :: Name -> Spec -> Spec +removeReadModel target spec = + spec{specNodes = [node | node <- specNodes spec, not (isTarget node)]} + where + isTarget (NReadModel readModel) = rmName readModel == target + isTarget _ = False + +modifyRouter :: Name -> (RouterNode -> RouterNode) -> Spec -> Spec +modifyRouter target update spec = + spec + { specNodes = + [ case node of + NRouter router | rtId router == target -> NRouter (update router) + _ -> node + | node <- specNodes spec + ] + } + +routerErrorCodes :: (RouterNode -> RouterNode) -> Spec -> [DiagnosticCode] +routerErrorCodes update = errorCodes . modifyRouter "PagingRouter" update + +modifyProcess :: Name -> (ProcessNode -> ProcessNode) -> Spec -> Spec +modifyProcess target update spec = + spec + { specNodes = + [ case node of + NProcess process | procId process == target -> NProcess (update process) + _ -> node + | node <- specNodes spec + ] + } + +processErrorCodes :: (ProcessNode -> ProcessNode) -> Spec -> [DiagnosticCode] +processErrorCodes update = errorCodes . modifyProcess "HospitalSurge" update + +errorCodes :: Spec -> [DiagnosticCode] +errorCodes spec = [code diagnostic | diagnostic <- validateSpec spec, severity diagnostic == Error] + +changeReadModelShape :: ReadModelNode -> ReadModelNode +changeReadModelShape readModel = + readModel + { rmColumns = rmColumns readModel <> [RmColumn "reviewed_by" "text" False] + , rmShape = "fnv1a:0000000000000000" + } + +{- | Assert a @new \@ skeleton parses and validates with zero +error-severity diagnostics. +-} +assertSkeletonValid :: T.Text -> IO () +assertSkeletonValid kind = case skeletonFor kind of + Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err)) + Right src -> case parseSpec ("new:" <> T.unpack kind) src of + Left perr -> expectationFailure (T.unpack ("skeleton for " <> kind <> " failed to parse: " <> perr)) + Right spec -> + [code d | d <- validateSpec spec, severity d == Error] + `shouldBe` ([] :: [DiagnosticCode]) + +assertSkeletonScaffoldable :: T.Text -> IO () +assertSkeletonScaffoldable kind = case skeletonFor kind of + Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err)) + Right src -> case parseSpec ("new:" <> T.unpack kind) src of + Left perr -> expectationFailure (T.unpack perr) + Right spec -> planScaffold (defaultContext (specContext spec)) spec `shouldSatisfy` isSuccessfulScaffold + +skeletonModuleRoots :: [(T.Text, T.Text)] +skeletonModuleRoots = + [ ("aggregate", "SkelAggregate") + , ("process", "SkelProcess") + , ("router", "SkelRouter") + , ("contract", "SkelContract") + , ("intake", "SkelIntake") + , ("emit", "SkelEmit") + , ("workqueue", "SkelQueue") + , ("workflow", "SkelWorkflow") + ] + +assertSkeletonMatchesCommitted :: T.Text -> T.Text -> IO () +assertSkeletonMatchesCommitted kind root = case skeletonFor kind of + Left err -> expectationFailure (T.unpack err) + Right source -> case parseSpec ("new:" <> T.unpack kind) source of + Left err -> expectationFailure (T.unpack err) + Right spec -> do + let ctx = (defaultContext (specContext spec)){moduleRoot = root} + forM_ [m | m <- scaffoldModules ctx spec, kindOf m == Generated] $ \m -> do + committed <- readTestText ("test/conformance-skeletons/" <> modulePath m) + normalizeGenerated committed `shouldBe` normalizeGenerated (moduleText m) + where + kindOf = Keiro.Dsl.Scaffold.kind + +bumpArtifactBindingVersion :: MappedDecl -> MappedDecl +bumpArtifactBindingVersion declaration@MappedStructural{msName = "ArtifactInfo"} = + declaration{msBindingVersion = Just "2"} +bumpArtifactBindingVersion declaration = declaration + +addArtifactSummaryField :: MappedDecl -> MappedDecl +addArtifactSummaryField declaration@MappedStructural{msName = "ArtifactInfo", msShape = ShapeRecord constructor unknownFields fields} = + declaration + { msShape = + ShapeRecord + constructor + unknownFields + ( fields + <> [ WireField + { wfHaskell = "summary" + , wfKey = "summary" + , wfType = TText + , wfPresence = PRequired + , wfOnMissing = Nothing + , wfLoc = Loc 0 + } + ] + ) + } +addArtifactSummaryField declaration = declaration + +expectGenericCompileFailure :: FilePath -> String -> Expectation +expectGenericCompileFailure fixture expectedDiagnostic = do + let fixtureDir = "../keiro-core/test/compile-fail" fixture + fixtureSource = fixtureDir "Fixture.hs" + (exitCode, standardOutput, standardError) <- + readProcessWithExitCode + "cabal" + [ "exec" + , "--" + , "ghc" + , "-XGHC2024" + , "-fno-code" + , "-fforce-recomp" + , "-i../keiro-core/src" + , "-i" <> fixtureDir + , fixtureSource + ] + "" + exitCode `shouldSatisfy` (/= ExitSuccess) + let compilerOutput = standardOutput <> standardError + compilerOutput `shouldContain` expectedDiagnostic + compilerOutput `shouldContain` "Run keiro-dsl scaffold and fill the binding by hand at this error location in the scaffolded module." + compilerOutput `shouldContain` fixtureSource + +moveArtifactBindingIntoGenerated :: MappedDecl -> MappedDecl +moveArtifactBindingIntoGenerated declaration@MappedStructural{msName = "ArtifactInfo"} = + declaration{msBinding = Just "Generated.ConsumerDemo.Bindings.artifactInfoBinding"} +moveArtifactBindingIntoGenerated declaration = declaration + +removeMappedRegisterRequirements :: Spec -> Spec +removeMappedRegisterRequirements spec = + spec + { specMapped = map removeInitial (specMapped spec) + , specNodes = map removeRegisters (specNodes spec) + } + where + removeInitial declaration@MappedStructural{} = declaration{msInitial = Nothing} + removeInitial declaration@MappedOpaque{} = declaration{moInitial = Nothing} + removeRegisters (NAggregate aggregate) = + NAggregate + aggregate + { aggRegs = [] + , aggTransitions = [transition{tWrites = []} | transition <- aggTransitions aggregate] + } + removeRegisters node = node + +isImportCycle :: Refusal -> Bool +isImportCycle ImportCycle{} = True +isImportCycle _ = False + +isLoweringRefusal :: Either [Refusal] modules -> Bool +isLoweringRefusal (Left refusals) = any isLowering refusals + where + isLowering LoweringRefusal{} = True + isLowering _ = False +isLoweringRefusal (Right _) = False + +-- | The canonical positive workspace fixture: three members under one context. +canonicalWorkspacePath :: FilePath +canonicalWorkspacePath = "test/fixtures/workspace/service.keiro-workspace" + +-- | Deterministic workspace source used to model git blobs without invoking git. +memoryContentSource :: Map.Map FilePath T.Text -> ContentSource +memoryContentSource files = + ContentSource + { csRead = \path -> + pure $ maybe (Left ("missing in-memory content: " <> T.pack path)) Right (Map.lookup path files) + } + +changeCode :: Change -> DiagnosticCode +changeCode (Additive kind) = ckCode kind +changeCode (Advisory kind) = ckCode kind +changeCode (Breaking kind) = ckCode kind + +breakingSurfaces :: Change -> [CompatibilitySurface] +breakingSurfaces change = + [ surface + | surface <- [minBound .. maxBound] + , verdictFor surface (ckVector kind) == VBreaking + ] + where + kind = case change of + Additive value -> value + Advisory value -> value + Breaking value -> value + +workspaceChangeKind :: Change -> ChangeKind +workspaceChangeKind (Additive kind) = kind +workspaceChangeKind (Advisory kind) = kind +workspaceChangeKind (Breaking kind) = kind + +-- | The same members as 'canonicalWorkspacePath', listed in reverse order. +reorderedWorkspacePath :: FilePath +reorderedWorkspacePath = "test/fixtures/workspace/service-reordered.keiro-workspace" + +{- | Load and compose a workspace fixture, failing the test on a refusal. The +fixture path is package-relative; the loader is rooted at the manifest's own +directory, exactly as the CLI roots it. +-} +shouldComposeWorkspace :: FilePath -> IO WorkspaceSpec +shouldComposeWorkspace path = do + resolved <- resolveTestPath path + loaded <- loadWorkspace (fileContentSource (takeDirectory resolved)) resolved + case loaded of + Left failure -> + expectationFailure (T.unpack (T.intercalate "\n" (renderWorkspaceFailure resolved failure))) + >> error "unreachable" + Right workspace -> pure workspace{wsManifestPath = path} + +{- | The 'Context' a workspace scaffolds under, with no CLI overrides: the +members' unanimous context name, the manifest's module-root and layout +authority, and the built-in defaults where the manifest is silent. +-} +workspaceContext :: WorkspaceSpec -> Context +workspaceContext workspace = + Context + { contextName = wsContext workspace + , moduleRoot = maybe "" id (wsModuleRoot workspace) + , placement = maybe GeneratedPrefix id (wsLayout workspace) + } + +-- | Compose and plan a workspace fixture, failing the test on any refusal. +shouldPlanWorkspace :: FilePath -> IO WorkspacePlan +shouldPlanWorkspace path = do + workspace <- shouldComposeWorkspace path + case planWorkspaceScaffold "goldens" (workspaceContext workspace) workspace of + Left refusals -> expectationFailure ("unexpected workspace plan refusal: " <> show refusals) >> error "unreachable" + Right plan -> pure plan + +-- | Does a scaffolded module's path end in this suffix? +isSuffixOfPath :: FilePath -> ScaffoldModule -> Bool +isSuffixOfPath suffix m = T.pack suffix `T.isSuffixOf` T.pack (modulePath m) + +{- | A workspace record built from real composed data plus two synthetic +adoption rows, so the round-trip test exercises every row kind including the +JSON encodings shared with the v1 record. +-} +sampleWorkspaceRecord :: WorkspaceSpec -> WorkspaceRecord +sampleWorkspaceRecord workspace = + WorkspaceRecord + { wrService = wsService workspace + , wrManifest = "service.keiro-workspace" + , wrContext = wsContext workspace + , wrModuleRoot = maybe "" id (wsModuleRoot workspace) + , wrLayout = "collocated" + , wrMembers = map wmPath (wsMembers workspace) + , wrModules = + [ WorkspaceModuleRow Generated "Demo/Generated/StructuralProjections.hs" Nothing + , WorkspaceModuleRow Generated "Demo/Project/Generated/Domain.hs" (Just "domain/project.keiro") + , WorkspaceModuleRow HoleStub "Demo/Project/Holes.hs" (Just "domain/shared.keiro") + ] + , wrMappings = consumerMappings (consumerPlan (wsMergedSpec workspace)) + , wrBindingObligations = either (const []) id (bindingHoles (wsMergedSpec workspace)) + , wrAdopted = + [ AdoptedRow "claimed/One.hs" "record" (Just "keiro-dsl-scaffold-record.demo-project.txt") (Just "project.keiro") + , AdoptedRow "claimed/Two.hs" "banner" Nothing Nothing + ] + } + +{- | The canonical workspace with a case-variant copy of one member's aggregate +grafted onto another member. Composition refuses this shape (EP-153 catches it +at the earliest boundary), so the planner's own cross-member collision gate can +only be exercised by constructing the graph directly — which is exactly what +this does, mirroring the single-file @caseVariant@ construction. +-} +withCaseVariantAggregate :: WorkspaceSpec -> WorkspaceSpec +withCaseVariantAggregate workspace = case [aggregate | NAggregate aggregate <- specNodes merged, aggName aggregate == "Project"] of + [] -> error "canonical workspace fixture has no Project aggregate" + aggregate : _ -> + let shouted = aggregate{aggName = T.toUpper (aggName aggregate)} + ownership = wsOwnership workspace + in workspace + { wsMergedSpec = merged{specNodes = specNodes merged <> [NAggregate shouted]} + , wsOwnership = + ownership + { oiNodes = + Map.insert + ("aggregate", aggName shouted) + ("domain/project-artifact.keiro", Loc 1) + (oiNodes ownership) + } + } + where + merged = wsMergedSpec workspace + +{- | Write a one-member workspace whose member declares an upcaster, so its +golden payload fixture has a canonical location. Returns the composed +workspace; the caller decides where the fixture lives. +-} +writeGoldenWorkspace :: FilePath -> IO WorkspaceSpec +writeGoldenWorkspace root = do + source <- readTestText "test/fixtures/reservation-v2.keiro" + createDirectoryIfMissing True (root "domain") + TIO.writeFile (root "domain/reservation.keiro") source + let manifestPath = root "service.keiro-workspace" + TIO.writeFile manifestPath "service gold-demo\nspec domain/reservation.keiro\n" + loaded <- loadWorkspace (fileContentSource root) manifestPath + case loaded of + Left failure -> + expectationFailure (T.unpack (T.intercalate "\n" (renderWorkspaceFailure manifestPath failure))) + >> error "unreachable" + Right workspace -> pure workspace + +{- | Materialize the canonical fixture workspace in a fresh temporary directory +and hand the callback its root, a sibling output directory, and the composed +workspace. Working on a copy is what lets a test edit a member and re-scaffold. + +The manifest's @spec@ lines are passed through the given function first, so a +caller can list the same members in a different order; the manifest __file +name__ stays the same, which is what makes two runs comparable byte for byte. +-} +withWorkspaceFixture :: + String -> + ([FilePath] -> [FilePath]) -> + (FilePath -> FilePath -> WorkspaceSpec -> IO a) -> + IO a +withWorkspaceFixture template orderMembers act = + withTempDirectory template $ \base -> do + let root = base "workspace" + out = base "out" + members = + [ "domain/project-artifact.keiro" + , "domain/project.keiro" + , "domain/shared.keiro" + ] + createDirectoryIfMissing True (root "domain") + forM_ members $ \relative -> do + source <- readTestText ("test/fixtures/workspace" relative) + TIO.writeFile (root relative) source + TIO.writeFile + (root "service.keiro-workspace") + ( T.unlines + ( ["service demo-project", "module Demo.Modules.Project", "layout collocated"] + <> ["spec " <> T.pack relative | relative <- orderMembers members] + ) + ) + workspace <- loadTempWorkspace root + act root out workspace + +{- | Materialize an inline workspace — a manifest plus literal member sources — +in a fresh temporary directory, and hand the callback its root, a sibling output +directory, and the composed workspace. +-} +withInlineWorkspace :: + String -> + (T.Text, [(FilePath, T.Text)]) -> + (FilePath -> FilePath -> WorkspaceSpec -> IO a) -> + IO a +withInlineWorkspace template (service, members) act = + withTempDirectory template $ \base -> do + let root = base "workspace" + out = base "out" + forM_ members $ \(relative, source) -> writeFileWithParents (root relative) source + TIO.writeFile + (root "service.keiro-workspace") + ( T.unlines + (("service " <> service) : ["spec " <> T.pack relative | (relative, _) <- members]) + ) + workspace <- loadTempWorkspace root + act root out workspace + +{- | Two independently valid members under one context. Each is a complete spec +that the pre-workspace single-file scaffolder accepts, which is what lets a test +reproduce the overwritten-record defect before adopting. +-} +adoptionMembers :: (T.Text, [(FilePath, T.Text)]) +adoptionMembers = ("adoption-demo", [("domain/a.keiro", adoptionMemberA), ("domain/b.keiro", adoptionMemberB)]) + +adoptionMemberA :: T.Text +adoptionMemberA = + T.unlines + [ "context adoption-demo" + , "" + , "aggregate Counter" + , " regs" + , " count Int = 0" + , " state CounterVertex = Pending" + , " states Pending Done!" + , " command Bump { count:Int }" + , " event CountBumped { count:Int }" + , " Pending -- Bump --> emit CountBumped ; goto Done" + ] + +adoptionMemberB :: T.Text +adoptionMemberB = + T.unlines + [ "context adoption-demo" + , "" + , "aggregate Widget" + , " regs" + , " size Int = 0" + , " state WidgetVertex = Draft" + , " states Draft Shipped!" + , " command Ship { size:Int }" + , " event WidgetShipped { size:Int }" + , " Draft -- Ship --> emit WidgetShipped ; goto Shipped" + ] + +writeFileWithParents :: FilePath -> T.Text -> IO () +writeFileWithParents path contents = do + createDirectoryIfMissing True (takeDirectory path) + TIO.writeFile path contents + +-- | Only the Haskell sources of a tree snapshot, dropping bookkeeping files. +haskellOnly :: [(FilePath, T.Text)] -> [(FilePath, T.Text)] +haskellOnly entries = [entry | entry@(path, _) <- entries, ".hs" `T.isSuffixOf` T.pack path] + +-- | Compose a workspace that a test just wrote to disk. +loadTempWorkspace :: FilePath -> IO WorkspaceSpec +loadTempWorkspace root = do + let manifestPath = root "service.keiro-workspace" + loaded <- loadWorkspace (fileContentSource root) manifestPath + case loaded of + Left failure -> + expectationFailure (T.unpack (T.intercalate "\n" (renderWorkspaceFailure manifestPath failure))) + >> error "unreachable" + Right workspace -> pure workspace + +-- | Plan an already-composed workspace, failing the test on a refusal. +shouldPlanWorkspaceSpec :: WorkspaceSpec -> IO WorkspacePlan +shouldPlanWorkspaceSpec workspace = + case planWorkspaceScaffold "goldens" (workspaceContext workspace) workspace of + Left refusals -> expectationFailure ("unexpected workspace plan refusal: " <> show refusals) >> error "unreachable" + Right plan -> pure plan + +-- | Plan then execute a whole-workspace scaffold, failing loudly on either. +executePlannedWorkspaceScaffold :: FilePath -> WorkspaceSpec -> IO WorkspaceScaffoldReport +executePlannedWorkspaceScaffold out workspace = do + plan <- shouldPlanWorkspaceSpec workspace + result <- executeWorkspaceScaffold out False plan + case result of + Left refusals -> expectationFailure ("unexpected workspace execution refusal: " <> show refusals) >> error "unreachable" + Right report -> pure report + +{- | Rename one member's aggregate in place and recompose. Only the +@aggregate \@ header is rewritten, so declarations that merely share the +prefix (@ProjectId@, @ProjectSummary@) are untouched. +-} +renameMemberAggregate :: FilePath -> FilePath -> T.Text -> T.Text -> IO WorkspaceSpec +renameMemberAggregate root member from to = do + source <- TIO.readFile (root member) + TIO.writeFile (root member) (T.replace ("aggregate " <> from <> "\n") ("aggregate " <> to <> "\n") source) + loadTempWorkspace root + +{- | Move the @ProjectArtifact@ aggregate from the artifact member into the +project member, and recompose. + +It is prepended, so the merged spec's node order — and therefore every emitted +byte, including the replay-audit assembly's aggregate list — is exactly what it +was. That isolates the change to ownership, which is the point of the test. +-} +moveArtifactAggregate :: FilePath -> IO WorkspaceSpec +moveArtifactAggregate root = do + artifact <- TIO.readFile (root "domain/project-artifact.keiro") + project <- TIO.readFile (root "domain/project.keiro") + case T.breakOn "aggregate ProjectArtifact" artifact of + (kept, moved) | not (T.null moved) -> do + TIO.writeFile (root "domain/project-artifact.keiro") kept + TIO.writeFile + (root "domain/project.keiro") + (T.replace "aggregate Project\n" (moved <> "\naggregate Project\n") project) + loadTempWorkspace root + _ -> expectationFailure "artifact member has no ProjectArtifact aggregate" >> error "unreachable" + +{- | Every regular file under a directory, as @(relative path, contents)@ sorted +by path — the comparison unit for "byte-identical output". +-} +treeSnapshot :: FilePath -> IO [(FilePath, T.Text)] +treeSnapshot root = do + exists <- doesDirectoryExist root + if not exists then pure [] else sort <$> walk "" + where + walk relative = do + entries <- listDirectory (root relative) + fmap concat . forM (sort entries) $ \entry -> do + let child = if null relative then entry else relative entry + isDirectory <- doesDirectoryExist (root child) + if isDirectory + then walk child + else do + contents <- TIO.readFile (root child) + pure [(child, contents)] + +thd3 :: (a, b, c) -> c +thd3 (_, _, value) = value + +isPathCollision :: Refusal -> Bool +isPathCollision PathCollision{} = True +isPathCollision _ = False + +isInfixOfString :: String -> String -> Bool +isInfixOfString needle haystack = T.isInfixOf (T.pack needle) (T.pack haystack) + +-- | Load a workspace fixture expecting a compose refusal, and return it. +shouldRefuseWorkspace :: FilePath -> IO (NonEmpty WorkspaceDiagnostic) +shouldRefuseWorkspace path = do + resolved <- resolveTestPath path + loaded <- loadWorkspace (fileContentSource (takeDirectory resolved)) resolved + case loaded of + Left (WorkspaceRefused diagnostics) -> pure diagnostics + Left other -> + expectationFailure + ("expected compose refusals, got:\n" <> T.unpack (T.intercalate "\n" (renderWorkspaceFailure resolved other))) + >> error "unreachable" + Right _ -> expectationFailure ("expected " <> path <> " to be refused") >> error "unreachable" + +{- | Invoke the built @keiro-dsl@ executable. Fixture paths are resolved first, +so the test works whether it runs from the package directory or the repository +root. +-} +runKeiroDsl :: [String] -> IO (ExitCode, String, String) +runKeiroDsl arguments = do + resolved <- traverse resolveArgument arguments + readProcessWithExitCode "cabal" (["run", "-v0", "keiro-dsl", "--"] <> resolved) "" + where + resolveArgument argument + | "test/fixtures/" `isPrefixOfString` argument = resolveTestPath argument + | otherwise = pure argument + isPrefixOfString prefix value = take (length prefix) value == prefix + +-- | The @spec@ field of a coverage report, i.e. what the report says it covers. +coverageSpecPath :: Value -> Maybe T.Text +coverageSpecPath value = case value of + Aeson.Object fields -> case KeyMap.lookup "spec" fields of + Just (Aeson.String path) -> Just path + _ -> Nothing + _ -> Nothing + +-- | Order-preserving deduplication for comparing cited file sets. +nubOrd :: (Eq a) => [a] -> [a] +nubOrd = go [] + where + go seen [] = reverse seen + go seen (x : xs) = if x `elem` seen then go seen xs else go (x : seen) xs + +-- | Parse a workspace manifest, failing the test on a refusal. +shouldParseManifest :: FilePath -> T.Text -> IO WorkspaceManifest +shouldParseManifest path source = case parseWorkspaceManifest path source of + Left err -> expectationFailure (T.unpack err) >> error "unreachable" + Right manifest -> pure manifest + +{- | Generate a canonical workspace manifest. Members are drawn from a pool of +paths that are distinct even under case folding and are held sorted, which is +the invariant every parsed manifest satisfies. +-} +genWorkspaceManifest :: Gen WorkspaceManifest +genWorkspaceManifest = do + service <- elements ["demo-project", "mori", "kotei", "a1", "svc-2"] + moduleRoot <- elements [Nothing, Just "Demo", Just "Demo.Modules.Project"] + layout <- elements [Nothing, Just GeneratedPrefix, Just CollocatedLeaf] + chosen <- + sublistOf + [ "a.keiro" + , "d-e_f.keiro" + , "domain/b.keiro" + , "domain/sub/c.keiro" + , "x1.keiro" + ] + `suchThat` (not . null) + pure + WorkspaceManifest + { wmfService = service + , wmfServiceLoc = Loc 1 + , wmfModuleRoot = moduleRoot + , wmfModuleRootLoc = Loc 2 + , wmfLayout = layout + , wmfLayoutLoc = Loc 3 + , wmfMembers = NE.fromList [WorkspaceMemberRef path (Loc 4) | path <- sort chosen] + } -- | Parse a fixture into a 'Spec', failing the test on a parse error. specOf :: FilePath -> IO Spec