keiro-dsl-0.6.0.0: app/Main.hs

-- | The @keiro-dsl@ command-line tool. EP-1 ships the @parse@ and @check@
-- subcommands; a later milestone adds @scaffold@ to the same
-- optparse-applicative command tree.
module Main (main) where

import Control.Monad (when)
import Data.Aeson ((.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Text qualified as AesonText
import Data.List.NonEmpty qualified as NE
import Data.Maybe (fromMaybe)
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.Text.Lazy.IO qualified as TLIO
import Keiro.Dsl.Coverage qualified as Coverage
import Keiro.Dsl.Diff (Change (..), CompatibilitySurface, diffSources, gateWith, gatedBreaking)
import Keiro.Dsl.DiffReport (diffReport, parseSurfaceName, renderExplainBlock, renderFinding)
import Keiro.Dsl.ExplainBindings (bindingObligations, renderBindingObligations)
import Keiro.Dsl.Goldens (emitGoldenPayloads, loadGoldenPayloads)
import Keiro.Dsl.Grammar (Placement (..), Spec (..))
import Keiro.Dsl.LanguageVersion (ParsedSource (..), SourceLanguage, declaredLanguageVersionMaybe, effectiveLanguageVersion, sourceFormText)
import Keiro.Dsl.Parser (parseSource, renderParseFailure)
import Keiro.Dsl.PrettyPrint (renderSource, renderSpec)
import Keiro.Dsl.ReplayImpact (renderReplayImpact, replayImpact)
import Keiro.Dsl.Scaffold (Context (..), ScaffoldModule (..), codecComparisonBanner, codecComparisonModule)
import Keiro.Dsl.ScaffoldRun (executeScaffoldWithLanguage, 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 (isAbsolute, makeRelative, normalise, takeDirectory, takeFileName, (</>))
import System.IO (hPutStrLn, stderr)
import System.Process (readProcessWithExitCode)

data Command
  = Parse FilePath
  | Pretty FilePath
  | Check FilePath Bool Bool (Maybe CheckCoverageOptions)
  | Inspect FilePath InspectionFormat
  | Scaffold FilePath FilePath (Maybe String) Bool Bool (Maybe FilePath) (Maybe (String, FilePath))
  | Diff FilePath String (Maybe FilePath) (Maybe FilePath) [CompatibilitySurface] Bool (Maybe FilePath) (Maybe DiffCoverageOptions)
  | New String

data InspectionFormat = InspectionJson

data CheckCoverageOptions = CheckCoverageOptions
  { checkCoveragePath :: !FilePath,
    checkFailOnOpaque :: !Bool
  }

data DiffCoverageOptions = DiffCoverageOptions
  { diffCoveragePath :: !FilePath,
    diffFailOnOpaqueIncrease :: !Bool
  }

main :: IO ()
main = run =<< execParser opts
  where
    opts =
      info
        (commands <**> helper)
        (fullDesc <> progDesc "keiro-dsl: a typed-specification toolchain for keiro services")

commands :: Parser Command
commands =
  subparser
    ( command
        "parse"
        (info (Parse <$> fileArg <**> helper) (progDesc "Parse a .keiro file and pretty-print it back"))
        <> command
          "pretty"
          (info (Pretty <$> fileArg <**> helper) (progDesc "Parse a .keiro file and print its canonical source form"))
        <> command
          "check"
          (info (Check <$> fileArg <*> emitSwitch <*> explainBindingsSwitch <*> checkCoverageOptions <**> helper) (progDesc "Validate a .keiro file; print diagnostics and exit non-zero on any error"))
        <> command
          "inspect"
          (info (Inspect <$> fileArg <*> inspectionFormatOpt <**> helper) (progDesc "Inspect source-language provenance for a .keiro file or workspace as JSON"))
        <> command
          "scaffold"
          (info (Scaffold <$> fileArg <*> outOpt <*> optional moduleRootOpt <*> collocateSwitch <*> forceGeneratedOverwriteSwitch <*> optional goldensOpt <*> codecComparisonOpts <**> helper) (progDesc "Emit the generated layer + typed holes from a .keiro file"))
        <> command
          "diff"
          (info (Diff <$> fileArg <*> sinceOpt <*> optional emitGoldensOpt <*> optional replayImpactOutOpt <*> many gateOpt <*> explainSwitch <*> optional reportOutOpt <*> diffCoverageOptions <**> helper) (progDesc "Classify spec changes since a git ref as per-surface compatibility vectors; exit non-zero on any gated BREAKING surface"))
        <> command
          "new"
          (info (New <$> kindArg <**> helper) (progDesc "Print a minimal valid .keiro skeleton for a node kind (aggregate, process, router, contract, intake, emit, publisher, workqueue, dispatch, workflow, operation)"))
    )

outOpt :: Parser FilePath
outOpt = strOption (long "out" <> metavar "DIR" <> help "Output directory for the scaffolded modules")

moduleRootOpt :: Parser String
moduleRootOpt = strOption (long "module-root" <> metavar "PREFIX" <> help "Namespace prefix for emitted modules, e.g. Acme or Acme.Services (overrides the spec's module clause)")

collocateSwitch :: Parser Bool
collocateSwitch = switch (long "collocate" <> help "Place the generated layer as a leaf under the domain (<Ctx>.<Node>.Generated) instead of a parallel Generated.* tree")

forceGeneratedOverwriteSwitch :: Parser Bool
forceGeneratedOverwriteSwitch = switch (long "force-generated-overwrite" <> help "Overwrite a Generated path even when the existing file lacks the @generated banner")

goldensOpt :: Parser FilePath
goldensOpt = strOption (long "goldens" <> metavar "DIR" <> help "Golden-payload root to embed in generated aggregate harnesses")

codecComparisonOpts :: Parser (Maybe (String, FilePath))
codecComparisonOpts =
  optional
    ( (,)
        <$> strOption (long "codec-comparison" <> metavar "MAPPED-NAME" <> help "Emit a non-production historical-codec comparison module for one structural mapped type (requires --comparison-out)")
        <*> strOption (long "comparison-out" <> metavar "FILE" <> help "Exact generated comparison-module path under --out (requires --codec-comparison)")
    )

emitGoldensOpt :: Parser FilePath
emitGoldensOpt = strOption (long "emit-goldens" <> metavar "DIR" <> help "Write old-shape payload fixtures for event version bumps without overwriting existing files")

replayImpactOutOpt :: Parser FilePath
replayImpactOutOpt = strOption (long "replay-impact-out" <> metavar "FILE" <> help "Write the replay-neutral or affected audit input as JSON")

gateOpt :: Parser CompatibilitySurface
gateOpt = option (eitherReader parseSurfaceName) (long "gate" <> metavar "SURFACE" <> help "Also fail on a breaking verdict for this compatibility surface (repeatable)")

explainSwitch :: Parser Bool
explainSwitch = switch (long "explain" <> help "Print containing paths, failing directions, and remediation choices")

reportOutOpt :: Parser FilePath
reportOutOpt = strOption (long "report-out" <> metavar "FILE" <> help "Write the full keiro-dsl/diff-report/1 compatibility report as JSON")

coverageReportOpt :: Parser FilePath
coverageReportOpt = strOption (long "coverage-report" <> metavar "FILE" <> help "Write reporting-only structural/opaque mapped-root coverage as JSON")

checkCoverageOptions :: Parser (Maybe CheckCoverageOptions)
checkCoverageOptions =
  optional
    ( CheckCoverageOptions
        <$> coverageReportOpt
        <*> switch (long "fail-on-opaque" <> help "Fail when a private persisted root contains an opaque boundary (requires --coverage-report)")
    )

diffCoverageOptions :: Parser (Maybe DiffCoverageOptions)
diffCoverageOptions =
  optional
    ( DiffCoverageOptions
        <$> coverageReportOpt
        <*> switch (long "fail-on-opaque-increase" <> help "Fail when diff adds a named opaque boundary (requires --coverage-report)")
    )

emitSwitch :: Parser Bool
emitSwitch = switch (long "emit" <> help "On success, pretty-print the parsed spec to stdout (folds parse + check into one call)")

explainBindingsSwitch :: Parser Bool
explainBindingsSwitch = switch (long "explain-bindings" <> help "On success, list the consumer-owned binding, fixture, and register-initial symbols required by structural mapped types")

sinceOpt :: Parser String
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 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")

inspectionFormatOpt :: Parser InspectionFormat
inspectionFormatOpt =
  option
    (eitherReader parseFormat)
    (long "format" <> metavar "json" <> value InspectionJson <> help "Inspection output format (json)")
  where
    parseFormat "json" = Right InspectionJson
    parseFormat other = Left ("unsupported inspection format: " <> other <> " (expected json)")

run :: Command -> IO ()
run (Pretty fp) = run (Parse fp)
-- 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 (Inspect fp format)
  | isWorkspacePath fp = runWorkspaceInspect fp format
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 parseSource fp input of
    Left failure -> do
      hPutStrLn stderr (T.unpack (renderParseFailure failure))
      exitFailure
    Right parsedSource -> TIO.putStrLn (renderSource parsedSource)
run (Check fp emit explainBindings coverageOptions) = do
  input <- TIO.readFile fp
  case parseSource fp input of
    Left failure -> do
      hPutStrLn stderr (T.unpack (renderParseFailure failure))
      exitFailure
    Right parsedSource -> do
      let spec = parsedSpec parsedSource
      let diags = validateSpec spec
      mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags
      if any ((== Error) . severity) diags
        then exitFailure
        else do
          when emit (TIO.putStrLn (renderSource parsedSource))
          if explainBindings
            then case bindingObligations spec of
              Left graphErrors -> do
                hPutStrLn stderr ("validated spec did not resolve its mapped type graph: " <> show graphErrors)
                exitFailure
              Right obligations -> TIO.putStrLn (renderBindingObligations (specContext spec) obligations)
            else pure ()
          coverageOk <- runCheckCoverage fp spec coverageOptions
          when (coverageOk && not emit && not explainBindings) (putStrLn "OK")
          when (not coverageOk) exitFailure
run (Scaffold fp out cliRoot cliCollocate forceGeneratedOverwrite cliGoldens comparisonRequest) = do
  input <- TIO.readFile fp
  case parseSource fp input of
    Left failure -> do
      hPutStrLn stderr (T.unpack (renderParseFailure failure))
      exitFailure
    Right parsedSource -> do
      let spec = parsedSpec parsedSource
      -- Validation gate: never scaffold an invalid spec. Abort on any
      -- error-severity diagnostic before writing a single module.
      let diags = validateSpec spec
      mapM_ (TIO.hPutStrLn stderr . renderDiagnostic fp) diags
      when (any ((== Error) . severity) diags) exitFailure
      let ctx = mkContext cliRoot cliCollocate spec
          goldenRoot = fromMaybe (takeDirectory fp </> "golden-payloads") cliGoldens
      goldens <- loadGoldenPayloads goldenRoot spec
      case (planScaffoldWithGoldens goldens ctx spec, 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 modules, Right comparisonModule) -> do
          comparisonReady <- preflightComparison out comparisonRequest comparisonModule
          case comparisonReady of
            Left comparisonError -> TIO.hPutStrLn stderr comparisonError >> exitFailure
            Right () -> do
              result <- executeScaffoldWithLanguage out forceGeneratedOverwrite fp (parsedSourceLanguage parsedSource) ctx spec modules
              case result of
                Left refusals -> do
                  mapM_ (TIO.hPutStrLn stderr) (renderRefusals refusals)
                  exitFailure
                Right report -> do
                  mapM_ (TIO.hPutStrLn stderr) (renderScaffoldReport report)
                  writeComparison comparisonRequest comparisonModule
run (New kind) =
  case skeletonFor (T.pack kind) of
    Left err -> hPutStrLn stderr (T.unpack err) >> exitFailure
    Right skel -> TIO.putStr skel
run (Inspect fp InspectionJson) = do
  input <- TIO.readFile fp
  case parseSource fp input of
    Left failure -> hPutStrLn stderr (T.unpack (renderParseFailure failure)) >> exitFailure
    Right parsedSource -> TLIO.putStrLn (AesonText.encodeToLazyText (sourceInspection fp (parsedSourceLanguage parsedSource)))
run (Diff fp ref emitGoldensRoot replayImpactOut gatedSurfaces explain reportOut coverageOptions) = do
  -- Resolve the spec to a repo-relative path so `git show <ref>:<relpath>` works.
  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 relPath = makeRelative repoRoot absFp
      oldRes <- git repoRoot ["show", ref <> ":" <> relPath]
      case oldRes of
        Left err -> hPutStrLn stderr ("git show " <> ref <> ":" <> relPath <> " failed:\n" <> err) >> exitFailure
        Right oldText -> do
          newText <- TIO.readFile fp
          case (,) <$> parseSource (ref <> ":" <> relPath) (T.pack oldText) <*> parseSource fp newText of
            Left failure -> hPutStrLn stderr (T.unpack (renderParseFailure failure)) >> exitFailure
            Right (oldSource, newSource) -> do
              let oldSpec = parsedSpec oldSource
                  newSpec = parsedSpec newSource
              written <- maybe (pure []) (\root -> emitGoldenPayloads root oldSpec newSpec) emitGoldensRoot
              mapM_ (putStrLn . ("golden: wrote synthesized weak stand-in " <>)) written
              let changes = diffSources oldSource newSource
                  impact = replayImpact oldSpec newSpec
                  effectiveGate = gateWith gatedSurfaces
              mapM_ (TIO.putStrLn . renderFinding) changes
              when explain $
                mapM_ (TIO.putStrLn . renderExplainBlock) (filter shouldExplain changes)
              TIO.putStrLn (renderReplayImpact impact)
              mapM_ (`Aeson.encodeFile` impact) replayImpactOut
              mapM_ (\path -> Aeson.encodeFile path (diffReport effectiveGate changes)) reportOut
              coverageOk <- runDiffCoverage fp (T.pack ref) oldSpec newSpec coverageOptions
              if any (gatedBreaking effectiveGate) changes || not coverageOk then exitFailure else pure ()

-- | @parse@ on a workspace manifest: read it, parse it, and print it back in
-- canonical form (clauses in order, members codepoint-sorted).
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)

sourceInspection :: FilePath -> SourceLanguage -> Aeson.Value
sourceInspection path sourceLanguage =
  Aeson.object
    [ "schema" .= ("keiro-dsl/source-inspection/1" :: T.Text),
      "kind" .= ("source" :: T.Text),
      "path" .= path,
      "sourceForm" .= sourceFormText sourceLanguage,
      "declaredLanguageVersion" .= declaredLanguageVersionMaybe sourceLanguage,
      "effectiveLanguageVersion" .= effectiveLanguageVersion sourceLanguage
    ]

runWorkspaceInspect :: FilePath -> InspectionFormat -> IO ()
runWorkspaceInspect fp InspectionJson = do
  loaded <- loadWorkspace (fileContentSource (takeDirectory fp)) fp
  case loaded of
    Left failure -> do
      mapM_ (TIO.hPutStrLn stderr) (renderWorkspaceFailure fp failure)
      exitFailure
    Right workspace ->
      TLIO.putStrLn
        ( AesonText.encodeToLazyText
            ( Aeson.object
                [ "schema" .= ("keiro-dsl/source-inspection/1" :: T.Text),
                  "kind" .= ("workspace" :: T.Text),
                  "path" .= fp,
                  "service" .= wsService workspace,
                  "members" .= map memberInspection (wsMembers workspace)
                ]
            )
        )
  where
    memberInspection member =
      Aeson.object
        [ "path" .= wmPath member,
          "sourceForm" .= sourceFormText sourceLanguage,
          "declaredLanguageVersion" .= declaredLanguageVersionMaybe sourceLanguage,
          "effectiveLanguageVersion" .= effectiveLanguageVersion sourceLanguage
        ]
      where
        sourceLanguage = wmSourceLanguage member

-- | @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
shouldExplain Advisory {} = True
shouldExplain Breaking {} = True

-- | Run git in a directory, returning trimmed stdout or stderr.
git :: FilePath -> [String] -> IO (Either String String)
git dir args = do
  (ec, out, err) <- readProcessWithExitCode "git" (["-C", dir] <> args) ""
  pure $ case ec of
    ExitSuccess -> Right out
    ExitFailure _ -> Left (if null err then out else err)

trim :: String -> String
trim = f . f where f = reverse . dropWhile (`elem` (" \t\r\n" :: String))

preflightComparison :: FilePath -> Maybe (String, FilePath) -> Maybe ScaffoldModule -> IO (Either T.Text ())
preflightComparison _ Nothing Nothing = pure (Right ())
preflightComparison out (Just (_, requestedPath)) (Just comparisonModule) = do
  let expectedPath = normalise (out </> modulePath comparisonModule)
      actualPath = normalise requestedPath
  if actualPath /= expectedPath
    then
      pure
        ( Left
            ( "--comparison-out must match the generated module path under --out: expected "
                <> T.pack expectedPath
            )
        )
    else do
      exists <- doesFileExist actualPath
      if not exists
        then pure (Right ())
        else do
          existing <- TIO.readFile actualPath
          pure
            ( if codecComparisonBanner `elem` T.lines existing
                then Right ()
                else Left ("refusing to overwrite non-comparison output: " <> T.pack actualPath)
            )
preflightComparison _ _ _ = pure (Left "internal error: incomplete codec-comparison option pair")

writeComparison :: Maybe (String, FilePath) -> Maybe ScaffoldModule -> IO ()
writeComparison Nothing Nothing = pure ()
writeComparison (Just (_, path)) (Just comparisonModule) = do
  createDirectoryIfMissing True (takeDirectory path)
  TIO.writeFile path (moduleText comparisonModule)
  TIO.hPutStrLn stderr ("comparison generated " <> T.pack path <> " (migration evidence only)")
writeComparison _ _ = hPutStrLn stderr "internal error: incomplete codec-comparison output" >> exitFailure

runCheckCoverage :: FilePath -> Spec -> Maybe CheckCoverageOptions -> IO Bool
runCheckCoverage _ _ Nothing = pure True
runCheckCoverage specPath spec (Just options) =
  case Coverage.coverageReport specPath spec of
    Left graphErrors -> do
      hPutStrLn stderr ("validated spec did not resolve its mapped type graph for coverage: " <> show graphErrors)
      pure False
    Right baseReport -> do
      let report = if checkFailOnOpaque options then Coverage.failOnOpaque baseReport else baseReport
      emitCoverageReport (checkCoveragePath options) report

runDiffCoverage :: FilePath -> T.Text -> Spec -> Spec -> Maybe DiffCoverageOptions -> IO Bool
runDiffCoverage _ _ _ _ Nothing = pure True
runDiffCoverage specPath reference oldSpec newSpec (Just options) =
  case Coverage.coverageDiffReport specPath reference oldSpec newSpec of
    Left graphErrors -> do
      hPutStrLn stderr ("diff specs did not resolve their mapped type graph for coverage: " <> show graphErrors)
      pure False
    Right baseReport -> do
      let report = if diffFailOnOpaqueIncrease options then Coverage.failOnOpaqueIncrease baseReport else baseReport
      emitCoverageReport (diffCoveragePath options) report

emitCoverageReport :: FilePath -> Coverage.CoverageReport -> IO Bool
emitCoverageReport path report = do
  mapM_ (TIO.hPutStrLn stderr . Coverage.renderCoverageFinding (Coverage.coverageSpec report)) (Coverage.coverageFindings report)
  TIO.putStr (Coverage.renderCoverageSummary report)
  Coverage.writeCoverageReport path report
  putStrLn ("coverage report written to " <> path)
  pure (Coverage.coverageSucceeded report)

-- | Fold the spec's @module@/@layout@ clauses with the CLI overrides to a
-- 'Context'. Precedence is CLI flag > spec clause > built-in default.
mkContext :: Maybe String -> Bool -> Spec -> Context
mkContext cliRoot cliCollocate spec =
  Context
    { contextName = specContext spec,
      moduleRoot = maybe (fromMaybe "" (specModuleRoot spec)) T.pack cliRoot,
      placement =
        if cliCollocate
          then CollocatedLeaf
          else fromMaybe GeneratedPrefix (specLayout spec)
    }