keiro-dsl 0.4.0.1 → 0.5.0.0

raw patch · 14 files changed

+7462/−2847 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +115/−0
• app/Main.hs +304/−2
• keiro-dsl.cabal +6/−1
• src/Keiro/Dsl/Diff.hs +3/−0
• src/Keiro/Dsl/DiffReport.hs +101/−12
• src/Keiro/Dsl/Scaffold.hs +40/−10
• src/Keiro/Dsl/ScaffoldRun.hs +69/−11
• src/Keiro/Dsl/Validate.hs +18/−0
• src/Keiro/Dsl/Workspace.hs +1300/−0
• src/Keiro/Dsl/WorkspaceAdoption.hs +268/−0
• src/Keiro/Dsl/WorkspaceDiff.hs +163/−0
• src/Keiro/Dsl/WorkspaceRecord.hs +281/−0
• src/Keiro/Dsl/WorkspaceScaffold.hs +611/−0
• test/Main.hs +4183/−2811

@@ -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 <manifest>` 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+  `<file>:<line>: error[<Code>]: <message>` 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 <manifest>` 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 <manifest> --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.<service>`, 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.<service>.txt`. New+  `Keiro.Dsl.WorkspaceAdoption` module; recorded as ADR-15.++- **Whole-workspace diffing.** `keiro-dsl diff <manifest> --since <rev>`+  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

@@ -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

@@ -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

@@ -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

@@ -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 

@@ -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])         ] 

@@ -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 =

@@ -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.

@@ -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 \<rev\>@ 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 \<path\>@ 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 \<rev\>:\<repo-relative-path\>@: 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 <name>' clause"+        leading : _ -> case leading of+            ClService{} -> pure ()+            other -> failAt (clauseOffset other) "the first clause of a workspace manifest must be 'service <name>'"+    (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 <path>.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 @\<kind\> \<name\> (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 \<rev\>:\<path\>@ 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

@@ -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.\<service\>.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

@@ -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"

@@ -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.\<service\>.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.\<service\>.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.\<service\>.txt@ — the Cabal build manifest.+workspaceManifestFileName :: Text -> FilePath+workspaceManifestFileName service = "keiro-dsl-manifest.workspace." <> T.unpack service <> ".txt"++{- | @keiro-dsl-migration-report.workspace.\<service\>.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)

@@ -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 @\<context\>\/\<Aggregate\>\/\<Event\>.v\<N\>.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 @\<context\>\/\<Aggregate\>\/\<Event\>.v\<N\>.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 <your-component>` 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

@@ -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 "<gen>" (renderSpec s) === Right s-                         in cover 5 (not (null (specMapped s))) "mapped" $-                                foldr (\family -> cover 1 (family `elem` families) family) roundTrip allNodeTags-            it "round-trips an aggregate with no states" $-                parseSpec "<empty-states>" (renderSpec emptyStatesSpec) `shouldBe` Right emptyStatesSpec-            it "separates transition emit clauses from following nodes" $ do-                spec <- parseInlineSpec "<cross-family-boundaries>" crossFamilyBoundarySpec-                case specNodes spec of-                    [NAggregate first, NEmit _, NAggregate second, NPgmqDispatch _] -> do-                        concatMap tEmits (aggTransitions first) `shouldBe` ["Changed"]-                        aggStates second `shouldBe` []-                    nodes -> expectationFailure ("unexpected node sequence: " <> show (map nodeTag nodes))--    describe "mapped types (EP-149)" $ do-        it "round-trips the canonical structural and opaque consumer fixture" $ do-            source <- TIO.readFile "test/fixtures/consumer-types.keiro"-            spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source-            parseSpec "<consumer-types-round-trip>" (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 "<escaped-map>" src of-                Left err -> expectationFailure (T.unpack err)-                Right spec -> case [row | NEmit e <- specNodes spec, row <- emMap e] of-                    [row] -> do-                        emrValue row `shouldBe` "a\" => Wat \"b"-                        emrEvent row `shouldBe` "ThingAccepted"-                    rows -> expectationFailure ("expected one emit-map row, got " <> show (length rows))-        it "rejects a raw newline inside a quoted string" $ do-            let src = "context svc\n\ncontract c {\n  schemaVersion 1\n  discriminator kind\n  topic events \"first\nsecond\"\n}\n"-            parseSpec "<raw-newline>" src `shouldSatisfy` leftContains "unescaped newline"-        it "rejects an unknown escape sequence" $ do-            let src = "context svc\n\ncontract c {\n  schemaVersion 1\n  discriminator kind\n  topic events \"bad\\q\"\n}\n"-            parseSpec "<unknown-escape>" src `shouldSatisfy` leftContains "unknown escape"-        it "round-trips adversarial text through topics, emit maps, and quoted bindings" $-            property $-                forAll genAdversarialText $ \t ->-                    let spec = escapedSpec t-                        rendered = renderSpec spec-                     in counterexample (T.unpack rendered) (parseSpec "<escaped-round-trip>" rendered === Right spec)--    describe "partial status maps" $ do-        it "suppresses totality only when the partial marker is present" $ do-            partial <- parseInlineSpec "<partial-status-map>" (statusMapSpec " partial")-            totalSpec <- parseInlineSpec "<total-status-map>" (statusMapSpec "")-            map code (validateSpec partial) `shouldNotContain` [StatusMapNotTotal]-            map code (validateSpec totalSpec) `shouldContain` [StatusMapNotTotal]-            parseSpec "<partial-round-trip>" (renderSpec partial) `shouldBe` Right partial--    describe "positioned parser diagnostics" $ do-        it "rejects a duplicate goto at the second clause" $ do-            err <- parseErrorOf "<duplicate-goto>" duplicateGotoSpec-            err `shouldSatisfy` T.isInfixOf "duplicate goto"-            err `shouldSatisfy` T.isInfixOf "<duplicate-goto>:10:"-        it "rejects duplicate wire and projection blocks at their second occurrences" $ do-            wireErr <- parseErrorOf "<duplicate-wire>" duplicateWireSpec-            wireErr `shouldSatisfy` T.isInfixOf "duplicate wire block"-            wireErr `shouldSatisfy` T.isInfixOf "<duplicate-wire>:8:"-            projectionErr <- parseErrorOf "<duplicate-projection>" duplicateProjectionSpec-            projectionErr `shouldSatisfy` T.isInfixOf "duplicate projection block"-            projectionErr `shouldSatisfy` T.isInfixOf "<duplicate-projection>:9:"-        it "anchors a missing goto on the transition line" $ do-            err <- parseErrorOf "<missing-goto>" missingGotoSpec-            err `shouldSatisfy` T.isInfixOf "missing a goto clause"-            err `shouldSatisfy` T.isInfixOf "<missing-goto>:8:"-        it "stops before a misplaced dispatch-id and expects schedule at its start" $ do-            let src = misplacedDispatchIdSpec-                expectedPosition =-                    "<misplaced-dispatch-id>:"-                        <> T.pack (show (lineNumberContaining "dispatch-id" src))-                        <> ":5:"-            err <- parseErrorOf "<misplaced-dispatch-id>" src-            err `shouldSatisfy` T.isInfixOf "schedule"-            err `shouldSatisfy` T.isInfixOf expectedPosition-        it "keeps a malformed register declaration's equals error" $ do-            err <- parseErrorOf "<malformed-register>" malformedRegisterSpec-            err `shouldSatisfy` T.isInfixOf "expecting '='"--    describe "bounded decimal literals" $ do-        forM_ decimalOverflowSpecs $ \(site, src) ->-            it ("rejects overflow at " <> site) $ do-                err <- parseErrorOf ("<overflow-" <> site <> ">") src-                err `shouldSatisfy` T.isInfixOf ("decimal literal " <> decimalOverflow <> " is out of range")-        it "accepts maxBound without changing its value" $ do-            spec <- parseInlineSpec "<max-bound>" (wireDecimalSpec (T.pack (show (maxBound :: Int))))-            [wireSchemaVersion wire | NAggregate aggregate <- specNodes spec, Just wire <- [aggWire aggregate]]-                `shouldBe` [maxBound]--    describe "identifier hygiene" $ do-        it "reports constructor shape and Haskell keywords at their owning declarations" $ do-            spec <- parseInlineSpec "<identifier-hygiene>" 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 "<vertex-collision>" 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 "<underscore-node>" underscoreNodeSpec-            [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == IdentNotConstructorSafe]-                `shouldBe` [(IdentNotConstructorSafe, 3)]-        it "rejects non-ASCII identifier characters in the parser" $-            parseSpec "<unicode-identifier>" 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 "<retiring-without-emitter>" (T.replace " ; emit TransferReservationConfirmed" "" source)-            [code d | d <- validateSpec spec, severity d == Error]-                `shouldContain` [EventRetirementInProgress]-        it "warns when a deprecated event has no replay-only emitting transition" $ do-            diagnostics <- diagnosticsOf "test/fixtures/reservation-deprecated.keiro"-            [code d | d <- diagnostics, severity d == Error] `shouldBe` []-            [code d | d <- diagnostics, severity d == Warning]-                `shouldContain` [DeprecatedEventReplayHazard]-        it "recognises deprecated plus replay-only as the replay-safe cutover" $ do-            diagnostics <- diagnosticsOf "test/fixtures/reservation-deprecated-replay-only.keiro"-            [code d | d <- diagnostics, severity d == Error] `shouldBe` []-            [code d | d <- diagnostics, severity d == Warning]-                `shouldContain` [EventRetirementInProgress]-            [code d | d <- diagnostics] `shouldNotContain` [DeprecatedEventReplayHazard]-        it "requires exact, unique status-map event keys" $ do-            dangling <- errorCodesOf "test/fixtures/statusmap-dangling.keiro"-            mapM_ (\expected -> dangling `shouldContain` [expected]) [StatusMapDanglingKey, StatusMapNotTotal]-            duplicate <- errorCodesOf "test/fixtures/statusmap-dup-key.keiro"-            duplicate `shouldContain` [StatusMapDuplicateKey]-        it "rejects duplicate spec and aggregate names" $ do-            codes <- errorCodesOf "test/fixtures/duplicate-names.keiro"-            mapM_-                (\expected -> codes `shouldContain` [expected])-                [ DuplicateNodeName-                , DuplicateEnumCtor-                , DuplicateEnumWire-                , DuplicateIdPrefix-                , DuplicateCommandName-                , DuplicateEventName-                ]-        it "rejects aggregate-local references that do not resolve" $ do-            codes <- errorCodesOf "test/fixtures/aggregate-bad-refs.keiro"-            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 "<unreachable-row>" src of-                Left err -> expectationFailure (T.unpack err)-                Right spec ->-                    [line d | d <- validateSpec spec, code d == UnreachableState]-                        `shouldBe` [7]-        it "accepts a replay-only twin with a live sibling (plan 143)" $ do-            codes <- errorCodesOf "test/fixtures/reservation-guard-tightened-twin.keiro"-            codes `shouldBe` []-        it "rejects a replay-only transition that emits nothing" $ do-            case parseSpec "<replay-only-no-emit>" (replayOnlySpecWith ["    write reservationState := Held", "    goto  Held"]) of-                Left err -> expectationFailure (T.unpack err)-                Right spec ->-                    [code d | d <- validateSpec spec, severity d == Error]-                        `shouldContain` [ReplayOnlyEmitsNothing]-        it "warns when a replay-only transition has no live sibling" $ do-            case parseSpec "<replay-only-orphan>" (replayOnlySpecWith ["    emit  TransferReservationCreated", "    goto  Held"]) of-                Left err -> expectationFailure (T.unpack err)-                Right spec -> do-                    [code d | d <- validateSpec spec, severity d == Warning]-                        `shouldContain` [ReplayOnlyCommandStillLive]-                    [code d | d <- validateSpec spec, severity d == Error]-                        `shouldNotContain` [ReplayOnlyCommandStillLive]--    describe "complementExpr (plan 143)" $ do-        it "applies De Morgan over and/or and flips comparison operators" $ do-            let a = EAtom (AName "a")-                b = EAtom (AName "b")-            complementExpr (EAnd a b)-                `shouldBe` EOr (ECmp OpEq a (EAtom (ABool False))) (ECmp OpEq b (EAtom (ABool False)))-            complementExpr (ECmp OpLt a b) `shouldBe` ECmp OpGe a b-            complementExpr (ECmp OpEq a b) `shouldBe` ECmp OpNeq a b-            complementExpr (ECmp OpLe a b) `shouldBe` ECmp OpGt a b-            complementExpr (ECmp OpGt a b) `shouldBe` ECmp OpLe a b-            complementExpr (ECmp OpGe a b) `shouldBe` ECmp OpLt a b-            complementExpr (ECmp OpNeq a b) `shouldBe` ECmp OpEq a b-        it "flips boolean literals and grounds bare names as == false" $ do-            complementExpr (EAtom (ABool True)) `shouldBe` EAtom (ABool False)-            complementExpr (EAtom (AName "open"))-                `shouldBe` ECmp OpEq (EAtom (AName "open")) (EAtom (ABool False))-        it "stays inside the grammar: the complement of any guard re-parses" $-            property $-                forAll genExpr $ \e ->-                    let twin =-                            replayOnlySpecWith-                                [ "    guard " <> renderExprText (complementExpr e)-                                , "    emit  TransferReservationCreated"-                                , "    goto  Held"-                                ]-                     in case parseSpec "<complement>" twin of-                            Left err -> counterexample (T.unpack err) False-                            Right spec ->-                                [tGuard t | NAggregate a <- specNodes spec, t <- aggTransitions a]-                                    === [Just (complementExpr e)]--    describe "evolution parsing" $ do-        it "parses event version and upcaster from reservation-v2.keiro" $ do-            input <- readTestText "test/fixtures/reservation-v2.keiro"-            case parseSpec "test/fixtures/reservation-v2.keiro" input of-                Left err -> expectationFailure (T.unpack err)-                Right spec -> case [e | NAggregate a <- specNodes spec, e <- aggEvents a, evName e == "TransferReservationCreated"] of-                    (e : _) -> do-                        evVersion e `shouldBe` 2-                        evUpcastFrom e `shouldBe` Just (1, Hole)-                    [] -> expectationFailure "TransferReservationCreated not found"-        it "round-trips the retiring marker" $ do-            spec <- specOf "test/fixtures/reservation-retiring.keiro"-            parseSpec "<retiring-round-trip>" (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-retirement-markers>" conflicting `shouldSatisfy` isLeft--    describe "aggregate snapshots (EP-109)" $ do-        it "parses, validates, and round-trips a snapshot policy with codec fixture" $ do-            spec <- specOf "test/fixtures/reservation-snapshot.keiro"-            errorCodesOf "test/fixtures/reservation-snapshot.keiro" `shouldReturn` []-            parseSpec "<snapshot-round-trip>" (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 "<snapshot-zero>" (T.replace "snapshot every 100" "snapshot every 0" source)-            map code (validateSpec interval) `shouldContain` [SnapshotIntervalInvalid]-            version <- parseInlineSpec "<snapshot-version-zero>" (T.replace "state-codec version=1" "state-codec version=0" source)-            map code (validateSpec version) `shouldContain` [SnapshotCodecFixtureInvalid]-            emptyHash <- parseInlineSpec "<snapshot-empty-hash>" (T.replace "shape-hash=\"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 "<first>" source-            second <- parseInlineSpec "<second>" ("\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 "<rule-change>" (T.replace "RedTag => true" "RedTag => false" source)-            let baseFingerprint = aggregateFoldFingerprint base (onlyAggregate base)-            aggregateFoldFingerprint writeChanged (onlyAggregate writeChanged) `shouldNotBe` baseFingerprint-            aggregateFoldFingerprint guardChanged (onlyAggregate guardChanged) `shouldNotBe` baseFingerprint-            aggregateFoldFingerprint ruleChanged (onlyAggregate ruleChanged) `shouldNotBe` baseFingerprint-        it "ignores wire and projection changes" $ do-            base <- specOf "test/fixtures/reservation.keiro"-            wireChanged <- specOf "test/fixtures/reservation-wire.keiro"-            source <- readTestText "test/fixtures/reservation.keiro"-            projectionChanged <- parseInlineSpec "<projection-change>" (T.replace "projection transfer_decisions" "projection renamed_projection" source)-            let surface = aggregateFoldSurface base (onlyAggregate base)-            aggregateFoldSurface wireChanged (onlyAggregate wireChanged) `shouldBe` surface-            aggregateFoldSurface projectionChanged (onlyAggregate projectionChanged) `shouldBe` surface-        it "invalidates mapped-register snapshots when binding or wire identity changes" $ do-            base <- specOf "test/fixtures/consumer-types.keiro"-            bindingChanged <- specOf "test/fixtures/consumer-types-binding-change.keiro"-            wireChanged <- specOf "test/fixtures/consumer-types-wirekey.keiro"-            let baseFingerprint = aggregateFoldFingerprint base (onlyAggregate base)-            aggregateFoldFingerprint bindingChanged (onlyAggregate bindingChanged) `shouldNotBe` baseFingerprint-            aggregateFoldFingerprint wireChanged (onlyAggregate wireChanged) `shouldNotBe` baseFingerprint--    describe "process/timer (EP-3)" $ do-        it "parses the hospital-surge process + nested timer" $ do-            input <- readTestText "test/fixtures/hospital-surge.keiro"-            case parseSpec "test/fixtures/hospital-surge.keiro" input of-                Left err -> expectationFailure (T.unpack err)-                Right spec -> case [p | NProcess p <- specNodes spec] of-                    (p : _) -> do-                        procId p `shouldBe` "HospitalSurge"-                        procName p `shouldBe` "hospital-surge"-                        procRejected p `shouldBe` PolHalt-                        procPoison p `shouldBe` PolHalt-                        sagaCategory (procSaga p) `shouldBe` "hospitalSurge"-                        tmName (procTimer p) `shouldBe` "surgeFollowUp"-                        onReject (fireDisposition (tmFire (procTimer p))) `shouldBe` OFired-                        onAmbiguous (fireDisposition (tmFire (procTimer p))) `shouldBe` ORetry-                        tmMaxAttempts (procTimer p) `shouldBe` 5-                    [] -> expectationFailure "no process node parsed"-        it "round-trips the hospital-surge spec through parse . pretty" $ do-            input <- readTestText "test/fixtures/hospital-surge.keiro"-            case parseSpec "in" input of-                Left err -> expectationFailure (T.unpack err)-                Right spec -> 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 "<legacy-saga>" (T.replace "saga Surge category \"hospitalSurge\"" "saga Surge stream=\"hospital-surge-\" <> correlationId" source)-                `shouldSatisfy` isLeft-        it "rejects a wall-clock fireAt as ProcessFireAtNotInjected" $ do-            codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro"-            codes `shouldContain` [ProcessFireAtNotInjected]-        it "reports one ProcessFireAtNotInjected for a wholly unknown fireAt field" $ do-            codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro"-            length (filter (== ProcessFireAtNotInjected) codes) `shouldBe` 1-        it "rejects a user-supplied dispatch id as ProcessDispatchIdSupplied" $ do-            codes <- errorCodesOf "test/fixtures/hospital-surge-dispatchid.keiro"-            codes `shouldContain` [ProcessDispatchIdSupplied]-        it "rejects an unresolved saga reference as ProcessUnresolvedRef" $ do-            codes <- errorCodesOf "test/fixtures/hospital-surge-badref.keiro"-            codes `shouldContain` [ProcessUnresolvedRef]-        it "rejects unresolved process commands, projections, schedules, and advance ids" $ do-            codes <- errorCodesOf "test/fixtures/process-ghost-refs.keiro"-            length (filter (== ProcessUnresolvedRef) codes) `shouldBe` 5-            codes `shouldContain` [ProcessDispatchIdSupplied]--    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 "<missing-poison>" (T.replace "  poison => halt\n" "" source) `shouldSatisfy` isLeft-            parseSpec "<missing-ambiguous>" (T.replace " ; on-ambiguous Retry" "" source) `shouldSatisfy` isLeft-        it "scaffolds firewall-clean router wiring, policies, and typed-hole guidance" $ do-            spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"-            case [router | NRouter router <- specNodes spec] of-                [router] -> do-                    let ctx = defaultContext (specContext spec)-                        modules = scaffoldRouter ctx router-                        generated = [m | m <- modules, kind m == Generated]-                        holes = [m | m <- modules, kind m == HoleStub]-                    firewallBreaches generated `shouldBe` []-                    case (generated, holes) of-                        ([generatedModule], [holeModule]) -> do-                            moduleText generatedModule `shouldSatisfy` T.isInfixOf "pagingRouterWorkerOptions"-                            moduleText generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedDeadLetter"-                            moduleText holeModule `shouldSatisfy` T.isInfixOf "UNION of resolved target identities"-                            moduleText holeModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate"-                        _ -> expectationFailure "expected one generated router module and one router hole module"-                routers -> expectationFailure ("expected one router, got " <> show (length routers))-        it "requires a caller callback for non-halting poison policies" $ do-            spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"-            case [router | NRouter router <- specNodes spec] of-                [router] -> do-                    let ctx = defaultContext (specContext spec)-                        generatedFor choice = [moduleText m | m <- scaffoldRouter ctx router{rtPoison = choice}, kind m == Generated]-                    mapM_-                        ( \(choice, constructor) -> case generatedFor choice of-                            [generatedModule] -> do-                                generatedModule `shouldSatisfy` T.isInfixOf "(Envelope msg -> Eff es ()) -> WorkerOptions es msg"-                                generatedModule `shouldSatisfy` T.isInfixOf (constructor <> " poisonCallback")-                            _ -> expectationFailure "expected one generated router module"-                        )-                        [(PolDeadLetter, "PoisonDeadLetter"), (PolSkip, "PoisonSkip")]-                    case [moduleText m | m <- scaffoldRouter ctx router{rtRejected = PolSkip}, kind m == Generated] of-                        [generatedModule] -> generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedSkip"-                        _ -> expectationFailure "expected one generated router module"-                routers -> expectationFailure ("expected one router, got " <> show (length routers))-        it "emits router harness facts that pin policy and target-keyed identity" $ do-            spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"-            case [router | NRouter router <- specNodes spec] of-                [router] -> case harnessRouter (defaultContext (specContext spec)) router of-                    [facts] -> do-                        moduleText facts `shouldSatisfy` T.isInfixOf "(\"rejectedPolicy\", \"deadLetter\")"-                        moduleText facts `shouldSatisfy` T.isInfixOf "targetStreamName, occurrence"-                    modules -> expectationFailure ("expected one router harness, got " <> show (length modules))-                routers -> expectationFailure ("expected one router, got " <> show (length routers))-        it "rejects invalid timer ceilings and target field bindings" $ do-            codes <- errorCodesOf "test/fixtures/process-bad-timer.keiro"-            mapM_-                (\expected -> codes `shouldContain` [expected])-                [ProcessTimerCeilingInvalid, ProcessFieldBindingUnresolved]-        it "accepts resolved process projection references" $ do-            codes <- errorCodesOf "test/fixtures/surge-service.keiro"-            codes `shouldBe` []-        it "scaffolds the process: Generated wiring is firewall-clean + a HoleStub" $ do-            mods <- 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 "<unresolved-group-key>" (T.replace "group key from reservationId" "group key from missingId" source)-            map code (validateSpec unresolved) `shouldContain` [WqGroupKeyUnresolved]-        it "warns on unlogged storage and rejects empty partition settings" $ do-            warningCodes <- diagnosticCodesOf "test/fixtures/reservation-work-unlogged.keiro"-            warningCodes `shouldContain` [WqUnloggedDurability]-            partitionCodes <- errorCodesOf "test/fixtures/reservation-work-partitioned-empty.keiro"-            partitionCodes `shouldContain` [WqPartitionSpecEmpty]-        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 "<projection-without-consistency>" projectionWithoutConsistencySpec-            case [projection | NAggregate aggregate <- specNodes spec, Just projection <- [aggProjection aggregate]] of-                [projection] -> projConsistency projection `shouldBe` Nothing-                projections -> expectationFailure ("expected one projection, got " <> show (length projections))-        it "pins the canonical UTF-8 shape digest and runtime identities" $ do-            spec <- specOf "test/fixtures/readmodel.keiro"-            case [readModel | NReadModel readModel <- specNodes spec] of-                (subscriptionModel : inlineModel : _) -> do-                    canonicalShape subscriptionModel-                        `shouldBe` "transfer_decisions|reservation_id:text:req|hospital_id:text:req|status:text:req|decided_at:timestamptz:null"-                    deriveShapeHash subscriptionModel `shouldBe` "fnv1a:3717f6d9e3c44bd6"-                    deriveShapeHash inlineModel `shouldBe` "fnv1a:f54d9bb2f40a6738"-                    registryNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions"-                    subscriptionNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions-sub"-                    subscriptionNameFor "billing" inlineModel `shouldBe` "billing-subscriptions-sub"-                nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes))-        it "accepts the positive readmodel fixture with all references resolved" $ do-            spec <- specOf "test/fixtures/readmodel.keiro"-            validateSpec spec `shouldBe` []-        it "rejects shape drift and unknown SQL column types" $ do-            codes <- errorCodesOf "test/fixtures/readmodel-shape-drift.keiro"-            codes `shouldContain` [RmShapeHashDrift, RmUnknownColumnType]-        it "rejects Strong on inline and standalone projections" $ do-            inlineCodes <- errorCodesOf "test/fixtures/readmodel-strong-inline.keiro"-            inlineCodes `shouldContain` [RmStrongInlineOnly]-            standalone <- specOf "test/fixtures/readmodel-strong-standalone.keiro"-            let diagnostics = validateSpec standalone-            map code diagnostics `shouldContain` [RmStrongInlineOnly, RmProjectionWithoutNode]-            [severity diagnostic | diagnostic <- diagnostics, code diagnostic == RmProjectionWithoutNode]-                `shouldBe` [Warning]-        it "rejects scope without Strong and an unreferenced inline feed" $ do-            scopeCodes <- errorCodesOf "test/fixtures/readmodel-scope-eventual.keiro"-            scopeCodes `shouldContain` [RmScopeWithoutStrong]-            inlineCodes <- errorCodesOf "test/fixtures/readmodel-inline-unreferenced.keiro"-            inlineCodes `shouldContain` [RmInlineFeedUnreferenced]-        it "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 "<formatted>" (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-twin>" pasted of-                Left err -> expectationFailure (T.unpack err)-                Right pastedSpec -> do-                    [code d | d <- validateSpec pastedSpec, severity d == Error] `shouldBe` []-                    base <- specOf "test/fixtures/reservation.keiro"-                    [k | Advisory k <- diffSpecs base pastedSpec, ckCode k == AggGuardTightened]-                        `shouldBe` []-        it "omits the twin advisory when the twin is already present (plan 143)" $ do-            cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened-twin.keiro"-            [k | Advisory k <- cs, ckCode k == AggGuardTightened] `shouldBe` []-        it "classifies a removed contract event as ContractEventRemoved" $ do-            cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventdrop.keiro"-            [ckCode k | Breaking k <- cs] `shouldContain` [ContractEventRemoved]-        it "classifies contract field type changes and unversioned additions as ContractFieldChanged" $ do-            changed <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldtype.keiro"-            [ckCode k | Breaking k <- changed] `shouldContain` [ContractFieldChanged]-            added <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldadd.keiro"-            [ckCode k | Breaking k <- added] `shouldContain` [ContractFieldChanged]-        it "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 "<formatted-process>" (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.<Ctx>.<Node>, holes at <Ctx>.<Node>)" $ do-            let ctx = defaultContext "hospital-capacity"-            genPrefixFor ctx "Reservation" `shouldBe` "Generated.HospitalCapacity.Reservation"-            holePrefixFor ctx "Reservation" `shouldBe` "HospitalCapacity.Reservation"-        it "module-root prefixes both layers" $ do-            let ctx = (defaultContext "hospital-capacity"){moduleRoot = "Acme"}-            genPrefixFor ctx "Reservation" `shouldBe` "Acme.Generated.HospitalCapacity.Reservation"-            holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation"-        it "CollocatedLeaf places the generated layer under the domain leaf" $ do-            let ctx = (defaultContext "hospital-capacity"){moduleRoot = "Acme", placement = CollocatedLeaf}-            genPrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation.Generated"-            holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation"-        it "parses and preserves the module/layout clauses through parse . pretty" $ do-            let src = "context hospital-capacity\nmodule Acme.Services\nlayout collocated\n\naggregate Reservation\n  regs\n  states Open\n"-            case parseSpec "<m1>" src of-                Left err -> expectationFailure (T.unpack err)-                Right spec -> do-                    specModuleRoot spec `shouldBe` Just "Acme.Services"-                    specLayout spec `shouldBe` Just CollocatedLeaf-                    parseSpec "<m1>" (renderSpec spec) `shouldBe` Right spec-        it "a spec without the clauses leaves placement at the default" $ do-            input <- readTestText "test/fixtures/reservation.keiro"-            case parseSpec "test/fixtures/reservation.keiro" input of-                Left err -> expectationFailure (T.unpack err)-                Right spec -> do-                    specModuleRoot spec `shouldBe` Nothing-                    specLayout spec `shouldBe` Nothing--    describe "structural scaffold" $ do-        it "emits one private shape module per structural declaration and one context facade" $ do-            spec <- specOf "test/fixtures/consumer-types.keiro"-            let modules = scaffoldModules (defaultContext (specContext spec)) spec-                paths = map modulePath modules-            paths-                `shouldContain` [ "Generated/ConsumerDemo/Structural/Shape/ArtifactInfo.hs"-                                , "Generated/ConsumerDemo/Structural/Shape/ArtifactKind.hs"-                                , "Generated/ConsumerDemo/Structural/Shape/ArtifactLocation.hs"-                                , "Generated/ConsumerDemo/StructuralProjections.hs"-                                ]-            paths `shouldNotContain` ["Generated/ConsumerDemo/Structural/Shape/VendorGeometry.hs"]-            firewallBreaches modules `shouldBe` []-        it "emits one create-once binding skeleton per owning module and derives Generic for private shapes" $ do-            spec <- specOf "test/fixtures/consumer-types.keiro"-            let modules = scaffoldModules (defaultContext (specContext spec)) spec-                skeletons = [moduleValue | moduleValue <- modules, kind moduleValue == HoleStub, modulePath moduleValue == "Example/Artifact/KeiroBindings.hs"]-                shape = generatedTextEndingIn "Structural/Shape/ArtifactInfo.hs" modules-            case skeletons of-                [skeleton] -> do-                    moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactInfoBinding :: StructuralBinding"-                    moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactKindBinding :: StructuralBinding"-                    moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactLocationBinding :: StructuralBinding"-                    moduleText skeleton `shouldSatisfy` T.isInfixOf "HOLE: fill ArtifactInfo bindingToShape.key"-                _ -> expectationFailure ("expected exactly one shared binding skeleton, got " <> show (map modulePath skeletons))-            shape `shouldSatisfy` T.isInfixOf "deriving stock (Eq, Generic, Show)"-            shape `shouldSatisfy` T.isInfixOf "import GHC.Generics (Generic)"-        it "never overwrites an existing binding skeleton" $-            withTempDirectory "keiro-dsl-binding-create-once" $ \out -> do-                spec <- specOf "test/fixtures/consumer-types.keiro"-                let ctx = defaultContext (specContext spec)-                    bindingPath = out </> "Example/Artifact/KeiroBindings.hs"-                _ <- executePlannedScaffold out "consumer-types.keiro" ctx spec-                TIO.writeFile bindingPath "hand-owned binding\n"-                second <- executePlannedScaffold out "consumer-types.keiro" ctx spec-                TIO.readFile bindingPath `shouldReturn` "hand-owned binding\n"-                reportDispositions second-                    `shouldSatisfy` any (\(moduleValue, disposition) -> modulePath moduleValue == "Example/Artifact/KeiroBindings.hs" && disposition == Skipped)-        it "fresh binding skeletons compile at the application boundary" $-            withTempDirectory "keiro-dsl-binding-compiles" $ \out -> do-                spec <- specOf "test/fixtures/structural-conformance.keiro"-                let ctx = defaultContext (specContext spec)-                    bindingSource = out </> "Conformance/Structural/Bindings.hs"-                    ghcOutput = out </> ".ghc"-                _ <- executePlannedScaffold out "structural-conformance.keiro" ctx spec-                createDirectoryIfMissing True ghcOutput-                (exitCode, standardOutput, standardError) <--                    readProcessWithExitCode-                        "cabal"-                        [ "exec"-                        , "--"-                        , "ghc"-                        , "-XGHC2024"-                        , "-XOverloadedStrings"-                        , "-fno-code"-                        , "-fforce-recomp"-                        , "-outputdir"-                        , ghcOutput-                        , "-i" <> out-                        , "-itest/conformance-structural"-                        , "-i../keiro-core/src"-                        , bindingSource-                        ]-                        ""-                unless (exitCode == ExitSuccess) $-                    expectationFailure (standardOutput <> standardError)-        it "keeps consumer types in Domain while the generated Codec owns keys, tags, and defaults" $ do-            spec <- specOf "test/fixtures/consumer-types.keiro"-            let modules = scaffoldModules (defaultContext (specContext spec)) spec-                domain = generatedTextEndingIn "Catalog/Domain.hs" modules-                codec = generatedTextEndingIn "Catalog/Codec.hs" modules-            domain `shouldSatisfy` T.isInfixOf "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 <kind> 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 "<stale-rename>" loweringAggregateSpec-                first <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext spec)) spec-                let renamed = spec{specNodes = map renameCounter (specNodes spec)}-                second <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext renamed)) renamed-                let oldDomain = onlyPathEndingIn "Counter/Domain.hs" (map fst (reportDispositions first))-                    oldHoles = onlyPathEndingIn "Counter/Holes.hs" (map fst (reportDispositions first))-                reportStale second `shouldSatisfy` \stale -> StaleModule Generated oldDomain `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 "<stale-root>" loweringAggregateSpec-                let initialCtx = defaultContext (specContext spec)-                    rootedCtx = initialCtx{moduleRoot = "Acme"}-                first <- executePlannedScaffold out "counter.keiro" initialCtx spec-                second <- executePlannedScaffold out "moved-counter.keiro" rootedCtx spec-                reportStale second-                    `shouldMatchList` [StaleModule (kind m) (modulePath m) | (m, _) <- reportDispositions first]-                forM_ (reportStale second) $ \stale -> doesFileExist (out </> stalePath stale) `shouldReturn` True-                renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "previous scaffold record used spec counter.keiro")-        it "reports moved generated modules across a layout flip" $-            withTempDirectory "keiro-dsl-stale-layout" $ \out -> do-                spec <- parseInlineSpec "<stale-layout>" loweringAggregateSpec-                let initialCtx = defaultContext (specContext spec)-                    collocatedCtx = initialCtx{placement = CollocatedLeaf}-                first <- executePlannedScaffold out "counter.keiro" initialCtx spec-                second <- executePlannedScaffold out "counter.keiro" collocatedCtx spec-                let oldGenerated = [StaleModule Generated (modulePath m) | (m, _) <- reportDispositions first, kind m == Generated]-                reportStale second `shouldSatisfy` all (`elem` oldGenerated)-                length (reportStale second) `shouldBe` length oldGenerated-        it "writes a parseable record and no stale section for a fresh output" $-            withTempDirectory "keiro-dsl-record" $ \out -> do-                spec <- parseInlineSpec "<fresh-record>" loweringAggregateSpec-                let ctx = defaultContext (specContext spec)-                report <- executePlannedScaffold out "counter.keiro" ctx spec-                reportStale report `shouldBe` []-                renderScaffoldReport report `shouldSatisfy` all (not . T.isPrefixOf "stale:")-                contents <- TIO.readFile (out </> recordFileName (specContext spec))-                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 "<register-initials>" loweringAggregateSpec-            let modules = scaffoldAggregate (defaultContext (specContext spec)) spec =<< [aggregate | NAggregate aggregate <- specNodes spec]-                domain = generatedTextEndingIn "Domain.hs" modules-            domain `shouldSatisfy` T.isInfixOf "RCons (Proxy @\"note\") \"hello world\""-            scaffoldRefusals spec `shouldBe` []-            bare <- parseInlineSpec "<bare-text-initial>" (T.replace "\"hello world\"" "hello" loweringAggregateSpec)-            scaffoldRefusals bare `shouldSatisfy` any (T.isInfixOf "RegTextInitialNotQuoted")-            unsupported <- parseInlineSpec "<unsupported-field>" (T.replace "count:Int" "count: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 "<exponential-backoff>" exponentialSource-            case [publisher | NPublisher publisher <- specNodes exponential] of-                publisher : _ -> do-                    let generated = generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext exponential)) publisher)-                    generated `shouldSatisfy` T.isInfixOf "ExponentialBackoff ExponentialBackoffOptions { initial = 2, maxDelay = 60, multiplier = 2.0 }"-                    parseSpec "<exponential-round-trip>" (renderSpec exponential) `shouldBe` Right exponential-                [] -> expectationFailure "emit fixture has no publisher"-            constant <- parseInlineSpec "<constant-backoff>" (T.replace "backoff constant 2s" "backoff constant 2m" emitSource)-            case [publisher | NPublisher publisher <- specNodes constant] of-                publisher : _ -> generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext constant)) publisher) `shouldSatisfy` T.isInfixOf "ConstantBackoff 120"-                [] -> expectationFailure "emit fixture has no publisher"-        it "refuses incomplete exponential backoff and rejects unknown window units" $ do-            emitSource <- readTestText "test/fixtures/emit.keiro"-            incomplete <- parseInlineSpec "<incomplete-backoff>" (T.replace "backoff constant 2s" "backoff exponential 2s" emitSource)-            scaffoldRefusals incomplete `shouldSatisfy` any (T.isInfixOf "BackoffExponentialIncomplete")-            parseSpec "<bad-window>" (T.replace "backoff constant 2s" "backoff constant 2x" emitSource)-                `shouldSatisfy` leftContains "time unit: s, m, or h"-        it "lowers workqueue retry windows in minutes to seconds" $ do-            queueSource <- readTestText "test/fixtures/reservation-work.keiro"-            queueSpec <- parseInlineSpec "<minute-queue>" (T.replace "5s" "5m" queueSource)-            case [workqueue | NWorkqueue workqueue <- specNodes queueSpec] of-                workqueue : _ -> do-                    let policy = generatedTextEndingIn "QueuePolicy.hs" (scaffoldWorkqueue (defaultContext (specContext queueSpec)) workqueue)-                    policy `shouldSatisfy` T.isInfixOf "defaultRetryDelay = RetryDelay 300"-                    policy `shouldSatisfy` T.isInfixOf "Retry (RetryDelay 300)"-                [] -> expectationFailure "queue fixture has no workqueue"-        it "uses exact status-map keys and emits total Int harness samples" $ do-            statusSpec <- parseInlineSpec "<exact-status>" exactStatusSpec-            case [aggregate | NAggregate aggregate <- specNodes statusSpec] of-                aggregate : _ -> do-                    let ctx = defaultContext (specContext statusSpec)-                        projection = generatedTextEndingIn "Projection.hs" (scaffoldAggregate ctx statusSpec aggregate)-                        harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx statusSpec aggregate)-                    projection `shouldSatisfy` T.isInfixOf "ReservationUnHeld {} -> Just \"available\""-                    harness `shouldSatisfy` T.isInfixOf "CountBumpedData 0"-                    harness `shouldNotSatisfy` T.isInfixOf "sample: unsupported"-                [] -> expectationFailure "exact-status spec has no aggregate"--    describe "scaffold" $ do-        it "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 "<shared-upcaster-source>" 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 "<forward-replay-samples>" (T.replace "command Bump { count:Int }" "command Bump { count:Int noteText:Text echo:Text }" loweringAggregateSpec)-            case [aggregate | NAggregate aggregate <- specNodes spec] of-                aggregate : _ -> do-                    let ctx = defaultContext (specContext spec)-                        harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx spec aggregate)-                    harness `shouldSatisfy` T.isInfixOf "\"sample-noteText\" \"sample-echo\""-                    harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: Bump from CounterPending -- \""-                    harness `shouldSatisfy` T.isInfixOf "prefix <> \"register note\""-                [] -> expectationFailure "forward/replay sample spec has no aggregate"-        it "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 \<kind\>@ skeleton parses and validates with zero-error-severity diagnostics.--}-assertSkeletonValid :: T.Text -> IO ()-assertSkeletonValid kind = case skeletonFor kind of-    Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err))-    Right src -> case parseSpec ("new:" <> T.unpack kind) src of-        Left perr -> expectationFailure (T.unpack ("skeleton for " <> kind <> " failed to parse: " <> perr))-        Right spec ->-            [code d | d <- validateSpec spec, severity d == Error]-                `shouldBe` ([] :: [DiagnosticCode])--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 "<gen>" (renderSpec s) === Right s+                         in cover 5 (not (null (specMapped s))) "mapped" $+                                foldr (\family -> cover 1 (family `elem` families) family) roundTrip allNodeTags+            it "round-trips an aggregate with no states" $+                parseSpec "<empty-states>" (renderSpec emptyStatesSpec) `shouldBe` Right emptyStatesSpec+            it "separates transition emit clauses from following nodes" $ do+                spec <- parseInlineSpec "<cross-family-boundaries>" crossFamilyBoundarySpec+                case specNodes spec of+                    [NAggregate first, NEmit _, NAggregate second, NPgmqDispatch _] -> do+                        concatMap tEmits (aggTransitions first) `shouldBe` ["Changed"]+                        aggStates second `shouldBe` []+                    nodes -> expectationFailure ("unexpected node sequence: " <> show (map nodeTag nodes))++    describe "mapped types (EP-149)" $ do+        it "round-trips the canonical structural and opaque consumer fixture" $ do+            source <- TIO.readFile "test/fixtures/consumer-types.keiro"+            spec <- parseInlineSpec "test/fixtures/consumer-types.keiro" source+            parseSpec "<consumer-types-round-trip>" (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 "<escaped-map>" src of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> case [row | NEmit e <- specNodes spec, row <- emMap e] of+                    [row] -> do+                        emrValue row `shouldBe` "a\" => Wat \"b"+                        emrEvent row `shouldBe` "ThingAccepted"+                    rows -> expectationFailure ("expected one emit-map row, got " <> show (length rows))+        it "rejects a raw newline inside a quoted string" $ do+            let src = "context svc\n\ncontract c {\n  schemaVersion 1\n  discriminator kind\n  topic events \"first\nsecond\"\n}\n"+            parseSpec "<raw-newline>" src `shouldSatisfy` leftContains "unescaped newline"+        it "rejects an unknown escape sequence" $ do+            let src = "context svc\n\ncontract c {\n  schemaVersion 1\n  discriminator kind\n  topic events \"bad\\q\"\n}\n"+            parseSpec "<unknown-escape>" src `shouldSatisfy` leftContains "unknown escape"+        it "round-trips adversarial text through topics, emit maps, and quoted bindings" $+            property $+                forAll genAdversarialText $ \t ->+                    let spec = escapedSpec t+                        rendered = renderSpec spec+                     in counterexample (T.unpack rendered) (parseSpec "<escaped-round-trip>" rendered === Right spec)++    describe "partial status maps" $ do+        it "suppresses totality only when the partial marker is present" $ do+            partial <- parseInlineSpec "<partial-status-map>" (statusMapSpec " partial")+            totalSpec <- parseInlineSpec "<total-status-map>" (statusMapSpec "")+            map code (validateSpec partial) `shouldNotContain` [StatusMapNotTotal]+            map code (validateSpec totalSpec) `shouldContain` [StatusMapNotTotal]+            parseSpec "<partial-round-trip>" (renderSpec partial) `shouldBe` Right partial++    describe "positioned parser diagnostics" $ do+        it "rejects a duplicate goto at the second clause" $ do+            err <- parseErrorOf "<duplicate-goto>" duplicateGotoSpec+            err `shouldSatisfy` T.isInfixOf "duplicate goto"+            err `shouldSatisfy` T.isInfixOf "<duplicate-goto>:10:"+        it "rejects duplicate wire and projection blocks at their second occurrences" $ do+            wireErr <- parseErrorOf "<duplicate-wire>" duplicateWireSpec+            wireErr `shouldSatisfy` T.isInfixOf "duplicate wire block"+            wireErr `shouldSatisfy` T.isInfixOf "<duplicate-wire>:8:"+            projectionErr <- parseErrorOf "<duplicate-projection>" duplicateProjectionSpec+            projectionErr `shouldSatisfy` T.isInfixOf "duplicate projection block"+            projectionErr `shouldSatisfy` T.isInfixOf "<duplicate-projection>:9:"+        it "anchors a missing goto on the transition line" $ do+            err <- parseErrorOf "<missing-goto>" missingGotoSpec+            err `shouldSatisfy` T.isInfixOf "missing a goto clause"+            err `shouldSatisfy` T.isInfixOf "<missing-goto>:8:"+        it "stops before a misplaced dispatch-id and expects schedule at its start" $ do+            let src = misplacedDispatchIdSpec+                expectedPosition =+                    "<misplaced-dispatch-id>:"+                        <> T.pack (show (lineNumberContaining "dispatch-id" src))+                        <> ":5:"+            err <- parseErrorOf "<misplaced-dispatch-id>" src+            err `shouldSatisfy` T.isInfixOf "schedule"+            err `shouldSatisfy` T.isInfixOf expectedPosition+        it "keeps a malformed register declaration's equals error" $ do+            err <- parseErrorOf "<malformed-register>" malformedRegisterSpec+            err `shouldSatisfy` T.isInfixOf "expecting '='"++    describe "bounded decimal literals" $ do+        forM_ decimalOverflowSpecs $ \(site, src) ->+            it ("rejects overflow at " <> site) $ do+                err <- parseErrorOf ("<overflow-" <> site <> ">") src+                err `shouldSatisfy` T.isInfixOf ("decimal literal " <> decimalOverflow <> " is out of range")+        it "accepts maxBound without changing its value" $ do+            spec <- parseInlineSpec "<max-bound>" (wireDecimalSpec (T.pack (show (maxBound :: Int))))+            [wireSchemaVersion wire | NAggregate aggregate <- specNodes spec, Just wire <- [aggWire aggregate]]+                `shouldBe` [maxBound]++    describe "identifier hygiene" $ do+        it "reports constructor shape and Haskell keywords at their owning declarations" $ do+            spec <- parseInlineSpec "<identifier-hygiene>" 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 "<vertex-collision>" 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 "<underscore-node>" underscoreNodeSpec+            [(code diagnostic, line diagnostic) | diagnostic <- validateSpec spec, code diagnostic == IdentNotConstructorSafe]+                `shouldBe` [(IdentNotConstructorSafe, 3)]+        it "rejects non-ASCII identifier characters in the parser" $+            parseSpec "<unicode-identifier>" 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 "<retiring-without-emitter>" (T.replace " ; emit TransferReservationConfirmed" "" source)+            [code d | d <- validateSpec spec, severity d == Error]+                `shouldContain` [EventRetirementInProgress]+        it "warns when a deprecated event has no replay-only emitting transition" $ do+            diagnostics <- diagnosticsOf "test/fixtures/reservation-deprecated.keiro"+            [code d | d <- diagnostics, severity d == Error] `shouldBe` []+            [code d | d <- diagnostics, severity d == Warning]+                `shouldContain` [DeprecatedEventReplayHazard]+        it "recognises deprecated plus replay-only as the replay-safe cutover" $ do+            diagnostics <- diagnosticsOf "test/fixtures/reservation-deprecated-replay-only.keiro"+            [code d | d <- diagnostics, severity d == Error] `shouldBe` []+            [code d | d <- diagnostics, severity d == Warning]+                `shouldContain` [EventRetirementInProgress]+            [code d | d <- diagnostics] `shouldNotContain` [DeprecatedEventReplayHazard]+        it "requires exact, unique status-map event keys" $ do+            dangling <- errorCodesOf "test/fixtures/statusmap-dangling.keiro"+            mapM_ (\expected -> dangling `shouldContain` [expected]) [StatusMapDanglingKey, StatusMapNotTotal]+            duplicate <- errorCodesOf "test/fixtures/statusmap-dup-key.keiro"+            duplicate `shouldContain` [StatusMapDuplicateKey]+        it "rejects duplicate spec and aggregate names" $ do+            codes <- errorCodesOf "test/fixtures/duplicate-names.keiro"+            mapM_+                (\expected -> codes `shouldContain` [expected])+                [ DuplicateNodeName+                , DuplicateEnumCtor+                , DuplicateEnumWire+                , DuplicateIdPrefix+                , DuplicateCommandName+                , DuplicateEventName+                ]+        it "rejects aggregate-local references that do not resolve" $ do+            codes <- errorCodesOf "test/fixtures/aggregate-bad-refs.keiro"+            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 "<unreachable-row>" src of+                Left err -> expectationFailure (T.unpack err)+                Right spec ->+                    [line d | d <- validateSpec spec, code d == UnreachableState]+                        `shouldBe` [7]+        it "accepts a replay-only twin with a live sibling (plan 143)" $ do+            codes <- errorCodesOf "test/fixtures/reservation-guard-tightened-twin.keiro"+            codes `shouldBe` []+        it "rejects a replay-only transition that emits nothing" $ do+            case parseSpec "<replay-only-no-emit>" (replayOnlySpecWith ["    write reservationState := Held", "    goto  Held"]) of+                Left err -> expectationFailure (T.unpack err)+                Right spec ->+                    [code d | d <- validateSpec spec, severity d == Error]+                        `shouldContain` [ReplayOnlyEmitsNothing]+        it "warns when a replay-only transition has no live sibling" $ do+            case parseSpec "<replay-only-orphan>" (replayOnlySpecWith ["    emit  TransferReservationCreated", "    goto  Held"]) of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> do+                    [code d | d <- validateSpec spec, severity d == Warning]+                        `shouldContain` [ReplayOnlyCommandStillLive]+                    [code d | d <- validateSpec spec, severity d == Error]+                        `shouldNotContain` [ReplayOnlyCommandStillLive]++    describe "complementExpr (plan 143)" $ do+        it "applies De Morgan over and/or and flips comparison operators" $ do+            let a = EAtom (AName "a")+                b = EAtom (AName "b")+            complementExpr (EAnd a b)+                `shouldBe` EOr (ECmp OpEq a (EAtom (ABool False))) (ECmp OpEq b (EAtom (ABool False)))+            complementExpr (ECmp OpLt a b) `shouldBe` ECmp OpGe a b+            complementExpr (ECmp OpEq a b) `shouldBe` ECmp OpNeq a b+            complementExpr (ECmp OpLe a b) `shouldBe` ECmp OpGt a b+            complementExpr (ECmp OpGt a b) `shouldBe` ECmp OpLe a b+            complementExpr (ECmp OpGe a b) `shouldBe` ECmp OpLt a b+            complementExpr (ECmp OpNeq a b) `shouldBe` ECmp OpEq a b+        it "flips boolean literals and grounds bare names as == false" $ do+            complementExpr (EAtom (ABool True)) `shouldBe` EAtom (ABool False)+            complementExpr (EAtom (AName "open"))+                `shouldBe` ECmp OpEq (EAtom (AName "open")) (EAtom (ABool False))+        it "stays inside the grammar: the complement of any guard re-parses" $+            property $+                forAll genExpr $ \e ->+                    let twin =+                            replayOnlySpecWith+                                [ "    guard " <> renderExprText (complementExpr e)+                                , "    emit  TransferReservationCreated"+                                , "    goto  Held"+                                ]+                     in case parseSpec "<complement>" twin of+                            Left err -> counterexample (T.unpack err) False+                            Right spec ->+                                [tGuard t | NAggregate a <- specNodes spec, t <- aggTransitions a]+                                    === [Just (complementExpr e)]++    describe "evolution parsing" $ do+        it "parses event version and upcaster from reservation-v2.keiro" $ do+            input <- readTestText "test/fixtures/reservation-v2.keiro"+            case parseSpec "test/fixtures/reservation-v2.keiro" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> case [e | NAggregate a <- specNodes spec, e <- aggEvents a, evName e == "TransferReservationCreated"] of+                    (e : _) -> do+                        evVersion e `shouldBe` 2+                        evUpcastFrom e `shouldBe` Just (1, Hole)+                    [] -> expectationFailure "TransferReservationCreated not found"+        it "round-trips the retiring marker" $ do+            spec <- specOf "test/fixtures/reservation-retiring.keiro"+            parseSpec "<retiring-round-trip>" (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-retirement-markers>" conflicting `shouldSatisfy` isLeft++    describe "aggregate snapshots (EP-109)" $ do+        it "parses, validates, and round-trips a snapshot policy with codec fixture" $ do+            spec <- specOf "test/fixtures/reservation-snapshot.keiro"+            errorCodesOf "test/fixtures/reservation-snapshot.keiro" `shouldReturn` []+            parseSpec "<snapshot-round-trip>" (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 "<snapshot-zero>" (T.replace "snapshot every 100" "snapshot every 0" source)+            map code (validateSpec interval) `shouldContain` [SnapshotIntervalInvalid]+            version <- parseInlineSpec "<snapshot-version-zero>" (T.replace "state-codec version=1" "state-codec version=0" source)+            map code (validateSpec version) `shouldContain` [SnapshotCodecFixtureInvalid]+            emptyHash <- parseInlineSpec "<snapshot-empty-hash>" (T.replace "shape-hash=\"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 "<first>" source+            second <- parseInlineSpec "<second>" ("\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 "<rule-change>" (T.replace "RedTag => true" "RedTag => false" source)+            let baseFingerprint = aggregateFoldFingerprint base (onlyAggregate base)+            aggregateFoldFingerprint writeChanged (onlyAggregate writeChanged) `shouldNotBe` baseFingerprint+            aggregateFoldFingerprint guardChanged (onlyAggregate guardChanged) `shouldNotBe` baseFingerprint+            aggregateFoldFingerprint ruleChanged (onlyAggregate ruleChanged) `shouldNotBe` baseFingerprint+        it "ignores wire and projection changes" $ do+            base <- specOf "test/fixtures/reservation.keiro"+            wireChanged <- specOf "test/fixtures/reservation-wire.keiro"+            source <- readTestText "test/fixtures/reservation.keiro"+            projectionChanged <- parseInlineSpec "<projection-change>" (T.replace "projection transfer_decisions" "projection renamed_projection" source)+            let surface = aggregateFoldSurface base (onlyAggregate base)+            aggregateFoldSurface wireChanged (onlyAggregate wireChanged) `shouldBe` surface+            aggregateFoldSurface projectionChanged (onlyAggregate projectionChanged) `shouldBe` surface+        it "invalidates mapped-register snapshots when binding or wire identity changes" $ do+            base <- specOf "test/fixtures/consumer-types.keiro"+            bindingChanged <- specOf "test/fixtures/consumer-types-binding-change.keiro"+            wireChanged <- specOf "test/fixtures/consumer-types-wirekey.keiro"+            let baseFingerprint = aggregateFoldFingerprint base (onlyAggregate base)+            aggregateFoldFingerprint bindingChanged (onlyAggregate bindingChanged) `shouldNotBe` baseFingerprint+            aggregateFoldFingerprint wireChanged (onlyAggregate wireChanged) `shouldNotBe` baseFingerprint++    describe "process/timer (EP-3)" $ do+        it "parses the hospital-surge process + nested timer" $ do+            input <- readTestText "test/fixtures/hospital-surge.keiro"+            case parseSpec "test/fixtures/hospital-surge.keiro" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> case [p | NProcess p <- specNodes spec] of+                    (p : _) -> do+                        procId p `shouldBe` "HospitalSurge"+                        procName p `shouldBe` "hospital-surge"+                        procRejected p `shouldBe` PolHalt+                        procPoison p `shouldBe` PolHalt+                        sagaCategory (procSaga p) `shouldBe` "hospitalSurge"+                        tmName (procTimer p) `shouldBe` "surgeFollowUp"+                        onReject (fireDisposition (tmFire (procTimer p))) `shouldBe` OFired+                        onAmbiguous (fireDisposition (tmFire (procTimer p))) `shouldBe` ORetry+                        tmMaxAttempts (procTimer p) `shouldBe` 5+                    [] -> expectationFailure "no process node parsed"+        it "round-trips the hospital-surge spec through parse . pretty" $ do+            input <- readTestText "test/fixtures/hospital-surge.keiro"+            case parseSpec "in" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> 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 "<legacy-saga>" (T.replace "saga Surge category \"hospitalSurge\"" "saga Surge stream=\"hospital-surge-\" <> correlationId" source)+                `shouldSatisfy` isLeft+        it "rejects a wall-clock fireAt as ProcessFireAtNotInjected" $ do+            codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro"+            codes `shouldContain` [ProcessFireAtNotInjected]+        it "reports one ProcessFireAtNotInjected for a wholly unknown fireAt field" $ do+            codes <- errorCodesOf "test/fixtures/hospital-surge-clock.keiro"+            length (filter (== ProcessFireAtNotInjected) codes) `shouldBe` 1+        it "rejects a user-supplied dispatch id as ProcessDispatchIdSupplied" $ do+            codes <- errorCodesOf "test/fixtures/hospital-surge-dispatchid.keiro"+            codes `shouldContain` [ProcessDispatchIdSupplied]+        it "rejects an unresolved saga reference as ProcessUnresolvedRef" $ do+            codes <- errorCodesOf "test/fixtures/hospital-surge-badref.keiro"+            codes `shouldContain` [ProcessUnresolvedRef]+        it "rejects unresolved process commands, projections, schedules, and advance ids" $ do+            codes <- errorCodesOf "test/fixtures/process-ghost-refs.keiro"+            length (filter (== ProcessUnresolvedRef) codes) `shouldBe` 5+            codes `shouldContain` [ProcessDispatchIdSupplied]++    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 "<missing-poison>" (T.replace "  poison => halt\n" "" source) `shouldSatisfy` isLeft+            parseSpec "<missing-ambiguous>" (T.replace " ; on-ambiguous Retry" "" source) `shouldSatisfy` isLeft+        it "scaffolds firewall-clean router wiring, policies, and typed-hole guidance" $ do+            spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+            case [router | NRouter router <- specNodes spec] of+                [router] -> do+                    let ctx = defaultContext (specContext spec)+                        modules = scaffoldRouter ctx router+                        generated = [m | m <- modules, kind m == Generated]+                        holes = [m | m <- modules, kind m == HoleStub]+                    firewallBreaches generated `shouldBe` []+                    case (generated, holes) of+                        ([generatedModule], [holeModule]) -> do+                            moduleText generatedModule `shouldSatisfy` T.isInfixOf "pagingRouterWorkerOptions"+                            moduleText generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedDeadLetter"+                            moduleText holeModule `shouldSatisfy` T.isInfixOf "UNION of resolved target identities"+                            moduleText holeModule `shouldSatisfy` T.isInfixOf "confirmBenignDuplicate"+                        _ -> expectationFailure "expected one generated router module and one router hole module"+                routers -> expectationFailure ("expected one router, got " <> show (length routers))+        it "requires a caller callback for non-halting poison policies" $ do+            spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+            case [router | NRouter router <- specNodes spec] of+                [router] -> do+                    let ctx = defaultContext (specContext spec)+                        generatedFor choice = [moduleText m | m <- scaffoldRouter ctx router{rtPoison = choice}, kind m == Generated]+                    mapM_+                        ( \(choice, constructor) -> case generatedFor choice of+                            [generatedModule] -> do+                                generatedModule `shouldSatisfy` T.isInfixOf "(Envelope msg -> Eff es ()) -> WorkerOptions es msg"+                                generatedModule `shouldSatisfy` T.isInfixOf (constructor <> " poisonCallback")+                            _ -> expectationFailure "expected one generated router module"+                        )+                        [(PolDeadLetter, "PoisonDeadLetter"), (PolSkip, "PoisonSkip")]+                    case [moduleText m | m <- scaffoldRouter ctx router{rtRejected = PolSkip}, kind m == Generated] of+                        [generatedModule] -> generatedModule `shouldSatisfy` T.isInfixOf "rejectedCommandPolicy = RejectedSkip"+                        _ -> expectationFailure "expected one generated router module"+                routers -> expectationFailure ("expected one router, got " <> show (length routers))+        it "emits router harness facts that pin policy and target-keyed identity" $ do+            spec <- specOf "test/fixtures/incident-paging/incident-paging.keiro"+            case [router | NRouter router <- specNodes spec] of+                [router] -> case harnessRouter (defaultContext (specContext spec)) router of+                    [facts] -> do+                        moduleText facts `shouldSatisfy` T.isInfixOf "(\"rejectedPolicy\", \"deadLetter\")"+                        moduleText facts `shouldSatisfy` T.isInfixOf "targetStreamName, occurrence"+                    modules -> expectationFailure ("expected one router harness, got " <> show (length modules))+                routers -> expectationFailure ("expected one router, got " <> show (length routers))+        it "rejects invalid timer ceilings and target field bindings" $ do+            codes <- errorCodesOf "test/fixtures/process-bad-timer.keiro"+            mapM_+                (\expected -> codes `shouldContain` [expected])+                [ProcessTimerCeilingInvalid, ProcessFieldBindingUnresolved]+        it "accepts resolved process projection references" $ do+            codes <- errorCodesOf "test/fixtures/surge-service.keiro"+            codes `shouldBe` []+        it "scaffolds the process: Generated wiring is firewall-clean + a HoleStub" $ do+            mods <- 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 "<unresolved-group-key>" (T.replace "group key from reservationId" "group key from missingId" source)+            map code (validateSpec unresolved) `shouldContain` [WqGroupKeyUnresolved]+        it "warns on unlogged storage and rejects empty partition settings" $ do+            warningCodes <- diagnosticCodesOf "test/fixtures/reservation-work-unlogged.keiro"+            warningCodes `shouldContain` [WqUnloggedDurability]+            partitionCodes <- errorCodesOf "test/fixtures/reservation-work-partitioned-empty.keiro"+            partitionCodes `shouldContain` [WqPartitionSpecEmpty]+        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 "<projection-without-consistency>" projectionWithoutConsistencySpec+            case [projection | NAggregate aggregate <- specNodes spec, Just projection <- [aggProjection aggregate]] of+                [projection] -> projConsistency projection `shouldBe` Nothing+                projections -> expectationFailure ("expected one projection, got " <> show (length projections))+        it "pins the canonical UTF-8 shape digest and runtime identities" $ do+            spec <- specOf "test/fixtures/readmodel.keiro"+            case [readModel | NReadModel readModel <- specNodes spec] of+                (subscriptionModel : inlineModel : _) -> do+                    canonicalShape subscriptionModel+                        `shouldBe` "transfer_decisions|reservation_id:text:req|hospital_id:text:req|status:text:req|decided_at:timestamptz:null"+                    deriveShapeHash subscriptionModel `shouldBe` "fnv1a:3717f6d9e3c44bd6"+                    deriveShapeHash inlineModel `shouldBe` "fnv1a:f54d9bb2f40a6738"+                    registryNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions"+                    subscriptionNameFor (specContext spec) subscriptionModel `shouldBe` "hospital-capacity-transfer-decisions-sub"+                    subscriptionNameFor "billing" inlineModel `shouldBe` "billing-subscriptions-sub"+                nodes -> expectationFailure ("expected readmodel nodes, got " <> show (length nodes))+        it "accepts the positive readmodel fixture with all references resolved" $ do+            spec <- specOf "test/fixtures/readmodel.keiro"+            validateSpec spec `shouldBe` []+        it "rejects shape drift and unknown SQL column types" $ do+            codes <- errorCodesOf "test/fixtures/readmodel-shape-drift.keiro"+            codes `shouldContain` [RmShapeHashDrift, RmUnknownColumnType]+        it "rejects Strong on inline and standalone projections" $ do+            inlineCodes <- errorCodesOf "test/fixtures/readmodel-strong-inline.keiro"+            inlineCodes `shouldContain` [RmStrongInlineOnly]+            standalone <- specOf "test/fixtures/readmodel-strong-standalone.keiro"+            let diagnostics = validateSpec standalone+            map code diagnostics `shouldContain` [RmStrongInlineOnly, RmProjectionWithoutNode]+            [severity diagnostic | diagnostic <- diagnostics, code diagnostic == RmProjectionWithoutNode]+                `shouldBe` [Warning]+        it "rejects scope without Strong and an unreferenced inline feed" $ do+            scopeCodes <- errorCodesOf "test/fixtures/readmodel-scope-eventual.keiro"+            scopeCodes `shouldContain` [RmScopeWithoutStrong]+            inlineCodes <- errorCodesOf "test/fixtures/readmodel-inline-unreferenced.keiro"+            inlineCodes `shouldContain` [RmInlineFeedUnreferenced]+        it "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 "<formatted>" (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-twin>" pasted of+                Left err -> expectationFailure (T.unpack err)+                Right pastedSpec -> do+                    [code d | d <- validateSpec pastedSpec, severity d == Error] `shouldBe` []+                    base <- specOf "test/fixtures/reservation.keiro"+                    [k | Advisory k <- diffSpecs base pastedSpec, ckCode k == AggGuardTightened]+                        `shouldBe` []+        it "omits the twin advisory when the twin is already present (plan 143)" $ do+            cs <- diffFixtures "test/fixtures/reservation.keiro" "test/fixtures/reservation-guard-tightened-twin.keiro"+            [k | Advisory k <- cs, ckCode k == AggGuardTightened] `shouldBe` []+        it "classifies a removed contract event as ContractEventRemoved" $ do+            cs <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-eventdrop.keiro"+            [ckCode k | Breaking k <- cs] `shouldContain` [ContractEventRemoved]+        it "classifies contract field type changes and unversioned additions as ContractFieldChanged" $ do+            changed <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldtype.keiro"+            [ckCode k | Breaking k <- changed] `shouldContain` [ContractFieldChanged]+            added <- diffFixtures "test/fixtures/contract.keiro" "test/fixtures/contract-fieldadd.keiro"+            [ckCode k | Breaking k <- added] `shouldContain` [ContractFieldChanged]+        it "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 "<formatted-process>" (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.<Ctx>.<Node>, holes at <Ctx>.<Node>)" $ do+            let ctx = defaultContext "hospital-capacity"+            genPrefixFor ctx "Reservation" `shouldBe` "Generated.HospitalCapacity.Reservation"+            holePrefixFor ctx "Reservation" `shouldBe` "HospitalCapacity.Reservation"+        it "module-root prefixes both layers" $ do+            let ctx = (defaultContext "hospital-capacity"){moduleRoot = "Acme"}+            genPrefixFor ctx "Reservation" `shouldBe` "Acme.Generated.HospitalCapacity.Reservation"+            holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation"+        it "CollocatedLeaf places the generated layer under the domain leaf" $ do+            let ctx = (defaultContext "hospital-capacity"){moduleRoot = "Acme", placement = CollocatedLeaf}+            genPrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation.Generated"+            holePrefixFor ctx "Reservation" `shouldBe` "Acme.HospitalCapacity.Reservation"+        it "parses and preserves the module/layout clauses through parse . pretty" $ do+            let src = "context hospital-capacity\nmodule Acme.Services\nlayout collocated\n\naggregate Reservation\n  regs\n  states Open\n"+            case parseSpec "<m1>" src of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> do+                    specModuleRoot spec `shouldBe` Just "Acme.Services"+                    specLayout spec `shouldBe` Just CollocatedLeaf+                    parseSpec "<m1>" (renderSpec spec) `shouldBe` Right spec+        it "a spec without the clauses leaves placement at the default" $ do+            input <- readTestText "test/fixtures/reservation.keiro"+            case parseSpec "test/fixtures/reservation.keiro" input of+                Left err -> expectationFailure (T.unpack err)+                Right spec -> do+                    specModuleRoot spec `shouldBe` Nothing+                    specLayout spec `shouldBe` Nothing++    describe "structural scaffold" $ do+        it "emits one private shape module per structural declaration and one context facade" $ do+            spec <- specOf "test/fixtures/consumer-types.keiro"+            let modules = scaffoldModules (defaultContext (specContext spec)) spec+                paths = map modulePath modules+            paths+                `shouldContain` [ "Generated/ConsumerDemo/Structural/Shape/ArtifactInfo.hs"+                                , "Generated/ConsumerDemo/Structural/Shape/ArtifactKind.hs"+                                , "Generated/ConsumerDemo/Structural/Shape/ArtifactLocation.hs"+                                , "Generated/ConsumerDemo/StructuralProjections.hs"+                                ]+            paths `shouldNotContain` ["Generated/ConsumerDemo/Structural/Shape/VendorGeometry.hs"]+            firewallBreaches modules `shouldBe` []+        it "emits one create-once binding skeleton per owning module and derives Generic for private shapes" $ do+            spec <- specOf "test/fixtures/consumer-types.keiro"+            let modules = scaffoldModules (defaultContext (specContext spec)) spec+                skeletons = [moduleValue | moduleValue <- modules, kind moduleValue == HoleStub, modulePath moduleValue == "Example/Artifact/KeiroBindings.hs"]+                shape = generatedTextEndingIn "Structural/Shape/ArtifactInfo.hs" modules+            case skeletons of+                [skeleton] -> do+                    moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactInfoBinding :: StructuralBinding"+                    moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactKindBinding :: StructuralBinding"+                    moduleText skeleton `shouldSatisfy` T.isInfixOf "artifactLocationBinding :: StructuralBinding"+                    moduleText skeleton `shouldSatisfy` T.isInfixOf "HOLE: fill ArtifactInfo bindingToShape.key"+                _ -> expectationFailure ("expected exactly one shared binding skeleton, got " <> show (map modulePath skeletons))+            shape `shouldSatisfy` T.isInfixOf "deriving stock (Eq, Generic, Show)"+            shape `shouldSatisfy` T.isInfixOf "import GHC.Generics (Generic)"+        it "never overwrites an existing binding skeleton" $+            withTempDirectory "keiro-dsl-binding-create-once" $ \out -> do+                spec <- specOf "test/fixtures/consumer-types.keiro"+                let ctx = defaultContext (specContext spec)+                    bindingPath = out </> "Example/Artifact/KeiroBindings.hs"+                _ <- executePlannedScaffold out "consumer-types.keiro" ctx spec+                TIO.writeFile bindingPath "hand-owned binding\n"+                second <- executePlannedScaffold out "consumer-types.keiro" ctx spec+                TIO.readFile bindingPath `shouldReturn` "hand-owned binding\n"+                reportDispositions second+                    `shouldSatisfy` any (\(moduleValue, disposition) -> modulePath moduleValue == "Example/Artifact/KeiroBindings.hs" && disposition == Skipped)+        it "fresh binding skeletons compile at the application boundary" $+            withTempDirectory "keiro-dsl-binding-compiles" $ \out -> do+                spec <- specOf "test/fixtures/structural-conformance.keiro"+                let ctx = defaultContext (specContext spec)+                    bindingSource = out </> "Conformance/Structural/Bindings.hs"+                    ghcOutput = out </> ".ghc"+                _ <- executePlannedScaffold out "structural-conformance.keiro" ctx spec+                createDirectoryIfMissing True ghcOutput+                (exitCode, standardOutput, standardError) <-+                    readProcessWithExitCode+                        "cabal"+                        [ "exec"+                        , "--"+                        , "ghc"+                        , "-XGHC2024"+                        , "-XOverloadedStrings"+                        , "-fno-code"+                        , "-fforce-recomp"+                        , "-outputdir"+                        , ghcOutput+                        , "-i" <> out+                        , "-itest/conformance-structural"+                        , "-i../keiro-core/src"+                        , bindingSource+                        ]+                        ""+                unless (exitCode == ExitSuccess) $+                    expectationFailure (standardOutput <> standardError)+        it "keeps consumer types in Domain while the generated Codec owns keys, tags, and defaults" $ do+            spec <- specOf "test/fixtures/consumer-types.keiro"+            let modules = scaffoldModules (defaultContext (specContext spec)) spec+                domain = generatedTextEndingIn "Catalog/Domain.hs" modules+                codec = generatedTextEndingIn "Catalog/Codec.hs" modules+            domain `shouldSatisfy` T.isInfixOf "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 <kind> 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 "<stale-rename>" loweringAggregateSpec+                first <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext spec)) spec+                let renamed = spec{specNodes = map renameCounter (specNodes spec)}+                second <- executePlannedScaffold out "counter.keiro" (defaultContext (specContext renamed)) renamed+                let oldDomain = onlyPathEndingIn "Counter/Domain.hs" (map fst (reportDispositions first))+                    oldHoles = onlyPathEndingIn "Counter/Holes.hs" (map fst (reportDispositions first))+                reportStale second `shouldSatisfy` \stale -> StaleModule Generated oldDomain `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 "<stale-root>" loweringAggregateSpec+                let initialCtx = defaultContext (specContext spec)+                    rootedCtx = initialCtx{moduleRoot = "Acme"}+                first <- executePlannedScaffold out "counter.keiro" initialCtx spec+                second <- executePlannedScaffold out "moved-counter.keiro" rootedCtx spec+                reportStale second+                    `shouldMatchList` [StaleModule (kind m) (modulePath m) | (m, _) <- reportDispositions first]+                forM_ (reportStale second) $ \stale -> doesFileExist (out </> stalePath stale) `shouldReturn` True+                renderScaffoldReport second `shouldSatisfy` any (T.isInfixOf "previous scaffold record used spec counter.keiro")+        it "reports moved generated modules across a layout flip" $+            withTempDirectory "keiro-dsl-stale-layout" $ \out -> do+                spec <- parseInlineSpec "<stale-layout>" loweringAggregateSpec+                let initialCtx = defaultContext (specContext spec)+                    collocatedCtx = initialCtx{placement = CollocatedLeaf}+                first <- executePlannedScaffold out "counter.keiro" initialCtx spec+                second <- executePlannedScaffold out "counter.keiro" collocatedCtx spec+                let oldGenerated = [StaleModule Generated (modulePath m) | (m, _) <- reportDispositions first, kind m == Generated]+                reportStale second `shouldSatisfy` all (`elem` oldGenerated)+                length (reportStale second) `shouldBe` length oldGenerated+        it "writes a parseable record and no stale section for a fresh output" $+            withTempDirectory "keiro-dsl-record" $ \out -> do+                spec <- parseInlineSpec "<fresh-record>" loweringAggregateSpec+                let ctx = defaultContext (specContext spec)+                report <- executePlannedScaffold out "counter.keiro" ctx spec+                reportStale report `shouldBe` []+                renderScaffoldReport report `shouldSatisfy` all (not . T.isPrefixOf "stale:")+                contents <- TIO.readFile (out </> recordFileName (specContext spec))+                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 "<register-initials>" loweringAggregateSpec+            let modules = scaffoldAggregate (defaultContext (specContext spec)) spec =<< [aggregate | NAggregate aggregate <- specNodes spec]+                domain = generatedTextEndingIn "Domain.hs" modules+            domain `shouldSatisfy` T.isInfixOf "RCons (Proxy @\"note\") \"hello world\""+            scaffoldRefusals spec `shouldBe` []+            bare <- parseInlineSpec "<bare-text-initial>" (T.replace "\"hello world\"" "hello" loweringAggregateSpec)+            scaffoldRefusals bare `shouldSatisfy` any (T.isInfixOf "RegTextInitialNotQuoted")+            unsupported <- parseInlineSpec "<unsupported-field>" (T.replace "count:Int" "count: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 "<exponential-backoff>" exponentialSource+            case [publisher | NPublisher publisher <- specNodes exponential] of+                publisher : _ -> do+                    let generated = generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext exponential)) publisher)+                    generated `shouldSatisfy` T.isInfixOf "ExponentialBackoff ExponentialBackoffOptions { initial = 2, maxDelay = 60, multiplier = 2.0 }"+                    parseSpec "<exponential-round-trip>" (renderSpec exponential) `shouldBe` Right exponential+                [] -> expectationFailure "emit fixture has no publisher"+            constant <- parseInlineSpec "<constant-backoff>" (T.replace "backoff constant 2s" "backoff constant 2m" emitSource)+            case [publisher | NPublisher publisher <- specNodes constant] of+                publisher : _ -> generatedTextEndingIn "Publisher.hs" (scaffoldPublisher (defaultContext (specContext constant)) publisher) `shouldSatisfy` T.isInfixOf "ConstantBackoff 120"+                [] -> expectationFailure "emit fixture has no publisher"+        it "refuses incomplete exponential backoff and rejects unknown window units" $ do+            emitSource <- readTestText "test/fixtures/emit.keiro"+            incomplete <- parseInlineSpec "<incomplete-backoff>" (T.replace "backoff constant 2s" "backoff exponential 2s" emitSource)+            scaffoldRefusals incomplete `shouldSatisfy` any (T.isInfixOf "BackoffExponentialIncomplete")+            parseSpec "<bad-window>" (T.replace "backoff constant 2s" "backoff constant 2x" emitSource)+                `shouldSatisfy` leftContains "time unit: s, m, or h"+        it "lowers workqueue retry windows in minutes to seconds" $ do+            queueSource <- readTestText "test/fixtures/reservation-work.keiro"+            queueSpec <- parseInlineSpec "<minute-queue>" (T.replace "5s" "5m" queueSource)+            case [workqueue | NWorkqueue workqueue <- specNodes queueSpec] of+                workqueue : _ -> do+                    let policy = generatedTextEndingIn "QueuePolicy.hs" (scaffoldWorkqueue (defaultContext (specContext queueSpec)) workqueue)+                    policy `shouldSatisfy` T.isInfixOf "defaultRetryDelay = RetryDelay 300"+                    policy `shouldSatisfy` T.isInfixOf "Retry (RetryDelay 300)"+                [] -> expectationFailure "queue fixture has no workqueue"+        it "uses exact status-map keys and emits total Int harness samples" $ do+            statusSpec <- parseInlineSpec "<exact-status>" exactStatusSpec+            case [aggregate | NAggregate aggregate <- specNodes statusSpec] of+                aggregate : _ -> do+                    let ctx = defaultContext (specContext statusSpec)+                        projection = generatedTextEndingIn "Projection.hs" (scaffoldAggregate ctx statusSpec aggregate)+                        harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx statusSpec aggregate)+                    projection `shouldSatisfy` T.isInfixOf "ReservationUnHeld {} -> Just \"available\""+                    harness `shouldSatisfy` T.isInfixOf "CountBumpedData 0"+                    harness `shouldNotSatisfy` T.isInfixOf "sample: unsupported"+                [] -> expectationFailure "exact-status spec has no aggregate"++    describe "scaffold" $ do+        it "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 "<shared-upcaster-source>" 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 "<forward-replay-samples>" (T.replace "command Bump { count:Int }" "command Bump { count:Int noteText:Text echo:Text }" loweringAggregateSpec)+            case [aggregate | NAggregate aggregate <- specNodes spec] of+                aggregate : _ -> do+                    let ctx = defaultContext (specContext spec)+                        harness = generatedTextEndingIn "Harness.hs" (harnessFor ctx spec aggregate)+                    harness `shouldSatisfy` T.isInfixOf "\"sample-noteText\" \"sample-echo\""+                    harness `shouldSatisfy` T.isInfixOf "prefix = \"forward/replay equality: Bump from CounterPending -- \""+                    harness `shouldSatisfy` T.isInfixOf "prefix <> \"register note\""+                [] -> expectationFailure "forward/replay sample spec has no aggregate"+        it "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 "<reordered>" $+                        T.unlines+                            [ "service demo-project"+                            , "layout collocated"+                            , "spec domain/shared.keiro"+                            , "module Demo.Modules.Project"+                            , "spec domain/project.keiro"+                            , "spec ./domain/project-artifact.keiro"+                            ]+                reordered `shouldBe` canonical+                renderWorkspaceManifest reordered `shouldBe` renderWorkspaceManifest canonical+            it "satisfies parse . render == id and render . parse . render == render" $+                property $+                    forAll genWorkspaceManifest $ \manifest ->+                        let rendered = renderWorkspaceManifest manifest+                         in case parseWorkspaceManifest "<generated>" rendered of+                                Left err -> counterexample (T.unpack err) False+                                Right reparsed ->+                                    counterexample (T.unpack rendered) $+                                        reparsed == manifest && renderWorkspaceManifest reparsed == rendered+            it "recognizes a workspace manifest by extension, case-insensitively" $ do+                map+                    isWorkspacePath+                    [ "service.keiro-workspace"+                    , "a/b/Service.KEIRO-Workspace"+                    , "service.keiro"+                    , ".keiro-workspace"+                    , "keiro-workspace"+                    ]+                    `shouldBe` [True, True, False, False, False]+        describe "manifest refusals" $ do+            let rejects label source expected =+                    it label $ case parseWorkspaceManifest "<manifest>" source of+                        Right _ -> expectationFailure ("expected a refusal, got a manifest for:\n" <> T.unpack source)+                        Left err -> T.unpack err `shouldContain` expected+            rejects+                "an empty manifest"+                "# only a comment\n"+                "must begin with a 'service <name>' clause"+            rejects+                "a manifest with no service clause"+                "spec domain/a.keiro\n"+                "first clause of a workspace manifest must be 'service <name>'"+            rejects+                "a manifest whose first clause is not service"+                "module Demo\nservice demo\nspec domain/a.keiro\n"+                "first clause of a workspace manifest must be 'service <name>'"+            rejects+                "a duplicate service clause"+                "service demo\nservice demo\nspec domain/a.keiro\n"+                "duplicate 'service' clause"+            rejects+                "a duplicate module clause"+                "service demo\nmodule Demo\nmodule Demo\nspec domain/a.keiro\n"+                "duplicate 'module' clause"+            rejects+                "a duplicate layout clause"+                "service demo\nlayout prefixed\nlayout prefixed\nspec domain/a.keiro\n"+                "duplicate 'layout' clause"+            rejects+                "a manifest with no members"+                "service demo\nmodule Demo\n"+                "must list at least one 'spec <path>.keiro' member"+            rejects+                "the same member listed twice"+                "service demo\nspec domain/a.keiro\nspec ./domain/a.keiro\n"+                "duplicate workspace member 'domain/a.keiro'"+            rejects+                "two members that differ only by case"+                "service demo\nspec domain/a.keiro\nspec domain/A.keiro\n"+                "differ only by case"+            rejects+                "an absolute member path"+                "service demo\nspec /etc/a.keiro\n"+                "must be relative, not absolute"+            rejects+                "a member path escaping the manifest directory"+                "service demo\nspec ../escape.keiro\n"+                "must not contain '..' segments"+            rejects+                "a member that is not a .keiro spec"+                "service demo\nspec domain/a.txt\n"+                "must name a .keiro spec"+            rejects+                "a manifest listing another manifest"+                "service demo\nspec domain/other.keiro-workspace\n"+                "must name a .keiro spec"+        describe "line relocation" $ do+            it "shifts every location the AST carries, and only the locations" $ do+                spec <- specOf "test/fixtures/reservation.keiro"+                let shifted = relocateLocs (+ 1000) spec+                collectLocs spec `shouldSatisfy` (not . null)+                collectLocs shifted `shouldBe` map (+ 1000) (collectLocs spec)+                -- Loc's Eq deliberately ignores the line, so relocation cannot+                -- change any equality-based behavior anywhere downstream.+                shifted `shouldBe` spec+            it "leaves the placeholder location alone so it never lands inside a member range" $ do+                spec <- specOf "test/fixtures/reservation.keiro"+                let blanked = relocateLocs (const 0) spec+                    reshifted = relocateLocs (\n -> if n <= 0 then n else n + 500) blanked+                collectLocs reshifted `shouldBe` map (const 0) (collectLocs spec)+        describe "composition" $ do+            it "resolves cross-file ids, enums, mapped types, and read-model feeds" $ do+                workspace <- shouldComposeWorkspace canonicalWorkspacePath+                wsService workspace `shouldBe` "demo-project"+                wsContext workspace `shouldBe` "demo-project"+                wsModuleRoot workspace `shouldBe` Just "Demo.Modules.Project"+                wsLayout workspace `shouldBe` Just CollocatedLeaf+                map wmPath (wsMembers workspace)+                    `shouldBe` [ "domain/project-artifact.keiro"+                               , "domain/project.keiro"+                               , "domain/shared.keiro"+                               ]+                -- Every member is individually incomplete; together they check.+                checkWorkspace workspace `shouldBe` []+            it "records which member owns each shared declaration and node" $ do+                workspace <- shouldComposeWorkspace canonicalWorkspacePath+                let ownership = wsOwnership workspace+                fmap fst (declarationOwner ownership "id" "ProjectId")+                    `shouldBe` Just "domain/shared.keiro"+                fmap fst (declarationOwner ownership "enum" "ProjectPhase")+                    `shouldBe` Just "domain/shared.keiro"+                fmap fst (declarationOwner ownership "rule" "phaseIsTerminal")+                    `shouldBe` Just "domain/shared.keiro"+                fmap fst (declarationOwner ownership "mapped" "ProjectSummary")+                    `shouldBe` Just "domain/shared.keiro"+                fmap fst (nodeOwner ownership "aggregate" "Project")+                    `shouldBe` Just "domain/project.keiro"+                fmap fst (nodeOwner ownership "aggregate" "ProjectArtifact")+                    `shouldBe` Just "domain/project-artifact.keiro"+                fmap fst (nodeOwner ownership "readmodel" "project_activity")+                    `shouldBe` Just "domain/project-artifact.keiro"+            it "maps every merged line back to the member that wrote it" $ do+                workspace <- shouldComposeWorkspace canonicalWorkspacePath+                let bases = [(wmPath m, wmLineBase m, wmLineCount m) | m <- wsMembers workspace]+                -- Ranges are disjoint and contiguous from zero.+                map (\(_, base, _) -> base) bases `shouldBe` scanl (+) 0 (init [c | (_, _, c) <- bases])+                sequence_+                    [ resolveWorkspaceLine workspace (base + offset) `shouldBe` Just (path, offset)+                    | (path, base, memberLines) <- bases+                    , offset <- [1, memberLines]+                    ]+                resolveWorkspaceLine workspace 0 `shouldBe` Nothing+            it "is insensitive to the order members are listed in" $ do+                canonical <- shouldComposeWorkspace canonicalWorkspacePath+                reordered <- shouldComposeWorkspace reorderedWorkspacePath+                reordered{wsManifestPath = wsManifestPath canonical} `shouldBe` canonical+            it "checks a single .keiro file as a one-member workspace, diagnostic for diagnostic" $ do+                let fixtures =+                        [ "test/fixtures/reservation.keiro"+                        , "test/fixtures/consumer-types.keiro"+                        , "test/fixtures/aggregate-bad-refs.keiro"+                        , "test/fixtures/readmodel.keiro"+                        ]+                forM_ fixtures $ \path -> do+                    spec <- specOf path+                    let workspace = oneMemberWorkspace path spec+                        viaWorkspace = map (renderWorkspaceDiagnostic path) (checkWorkspace workspace)+                        direct = map (renderDiagnostic path) (validateSpec spec)+                    viaWorkspace `shouldBe` direct+                -- At least one of those fixtures must actually produce errors,+                -- or the equivalence claim is vacuous.+                badRefs <- specOf "test/fixtures/aggregate-bad-refs.keiro"+                checkWorkspace (oneMemberWorkspace "test/fixtures/aggregate-bad-refs.keiro" badRefs)+                    `shouldSatisfy` any ((== Error) . wdSeverity)+        describe "composition refusals" $ do+            let refusesWith path expectedCode expectedFiles = do+                    diagnostics <- shouldRefuseWorkspace path+                    map wdCode (NE.toList diagnostics) `shouldContain` [expectedCode]+                    let cited =+                            [ wlFile location+                            | diagnostic <- NE.toList diagnostics+                            , wdCode diagnostic == expectedCode+                            , location <- NE.toList (wdLocations diagnostic)+                            ]+                    sort (nubOrd cited) `shouldBe` sort expectedFiles+            it "refuses members that declare different contexts, citing every context clause" $+                refusesWith+                    "test/fixtures/workspace-context-mismatch/service.keiro-workspace"+                    WorkspaceContextMismatch+                    [WorkspaceMemberFile "domain/a.keiro", WorkspaceMemberFile "domain/b.keiro"]+            it "refuses a member layout clause that contradicts the manifest authority" $+                refusesWith+                    "test/fixtures/workspace-authority-conflict/service.keiro-workspace"+                    WorkspaceAuthorityConflict+                    [WorkspaceManifestFile, WorkspaceMemberFile "domain/b.keiro"]+            it "refuses a textually identical shared declaration owned by two members" $+                refusesWith+                    "test/fixtures/workspace-dup-decl/service.keiro-workspace"+                    WorkspaceDuplicateDeclaration+                    [WorkspaceMemberFile "domain/project.keiro", WorkspaceMemberFile "domain/shared.keiro"]+            it "refuses one aggregate defined in two members" $+                refusesWith+                    "test/fixtures/workspace-dup-node/service.keiro-workspace"+                    WorkspaceDuplicateNodeName+                    [WorkspaceMemberFile "domain/a.keiro", WorkspaceMemberFile "domain/b.keiro"]+            it "refuses generated paths that collide across members under case folding" $+                refusesWith+                    "test/fixtures/workspace-path-collision/service.keiro-workspace"+                    WorkspacePathCollision+                    [WorkspaceMemberFile "domain/a.keiro", WorkspaceMemberFile "domain/b.keiro"]+            it "reports a listed member that is missing from disk" $+                refusesWith+                    "test/fixtures/workspace-missing-member/service.keiro-workspace"+                    WorkspaceMemberUnreadable+                    [WorkspaceManifestFile]+            it "reports a member that does not parse" $+                refusesWith+                    "test/fixtures/workspace-member-parse-failed/service.keiro-workspace"+                    WorkspaceMemberParseFailed+                    [WorkspaceManifestFile]+            it "surfaces a cross-file unresolved reference through the merged validator" $ do+                workspace <- shouldComposeWorkspace "test/fixtures/workspace-unresolved/service.keiro-workspace"+                let errors = [d | d <- checkWorkspace workspace, wdSeverity d == Error]+                map wdCode errors `shouldContain` [GuardAtomOutOfScope]+                [wlFile location | d <- errors, location <- NE.toList (wdLocations d)]+                    `shouldContain` [WorkspaceMemberFile "domain/project.keiro"]+        describe "multi-file diagnostic rendering" $ do+            it "puts the primary location in the established shape and every other file on a note line" $ do+                diagnostics <- shouldRefuseWorkspace "test/fixtures/workspace-dup-decl/service.keiro-workspace"+                let manifest = "keiro-dsl/test/fixtures/workspace-dup-decl/service.keiro-workspace"+                map (renderWorkspaceDiagnostic manifest) (NE.toList diagnostics)+                    `shouldBe` [ T.intercalate+                                    "\n"+                                    [ "keiro-dsl/test/fixtures/workspace-dup-decl/domain/project.keiro: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 \<kind\>@ skeleton parses and validates with zero+error-severity diagnostics.+-}+assertSkeletonValid :: T.Text -> IO ()+assertSkeletonValid kind = case skeletonFor kind of+    Left err -> expectationFailure (T.unpack ("skeleton for " <> kind <> ": " <> err))+    Right src -> case parseSpec ("new:" <> T.unpack kind) src of+        Left perr -> expectationFailure (T.unpack ("skeleton for " <> kind <> " failed to parse: " <> perr))+        Right spec ->+            [code d | d <- validateSpec spec, severity d == Error]+                `shouldBe` ([] :: [DiagnosticCode])++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 \<Name\>@ header is rewritten, so declarations that merely share the+prefix (@ProjectId@, @ProjectSummary@) are untouched.+-}+renameMemberAggregate :: FilePath -> FilePath -> T.Text -> T.Text -> IO WorkspaceSpec+renameMemberAggregate root member from to = do+    source <- TIO.readFile (root </> member)+    TIO.writeFile (root </> member) (T.replace ("aggregate " <> from <> "\n") ("aggregate " <> to <> "\n") source)+    loadTempWorkspace root++{- | Move the @ProjectArtifact@ aggregate from the artifact member into the+project member, and recompose.++It is prepended, so the merged spec's node order — and therefore every emitted+byte, including the replay-audit assembly's aggregate list — is exactly what it+was. That isolates the change to ownership, which is the point of the test.+-}+moveArtifactAggregate :: FilePath -> IO WorkspaceSpec+moveArtifactAggregate root = do+    artifact <- TIO.readFile (root </> "domain/project-artifact.keiro")+    project <- TIO.readFile (root </> "domain/project.keiro")+    case T.breakOn "aggregate ProjectArtifact" artifact of+        (kept, moved) | not (T.null moved) -> do+            TIO.writeFile (root </> "domain/project-artifact.keiro") kept+            TIO.writeFile+                (root </> "domain/project.keiro")+                (T.replace "aggregate Project\n" (moved <> "\naggregate Project\n") project)+            loadTempWorkspace root+        _ -> expectationFailure "artifact member has no ProjectArtifact aggregate" >> error "unreachable"++{- | Every regular file under a directory, as @(relative path, contents)@ sorted+by path — the comparison unit for "byte-identical output".+-}+treeSnapshot :: FilePath -> IO [(FilePath, T.Text)]+treeSnapshot root = do+    exists <- doesDirectoryExist root+    if not exists then pure [] else sort <$> walk ""+  where+    walk relative = do+        entries <- listDirectory (root </> relative)+        fmap concat . forM (sort entries) $ \entry -> do+            let child = if null relative then entry else relative </> entry+            isDirectory <- doesDirectoryExist (root </> child)+            if isDirectory+                then walk child+                else do+                    contents <- TIO.readFile (root </> child)+                    pure [(child, contents)]++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