Migrate.hs

module Seihou.CLI.Migrate
  ( -- * Options
    MigrateOpts (..),

    -- * Handlers
    handleMigrate,
    runMigrate,
    MigrateError (..),
    MigrateResult (..),

    -- * Helpers for upgrade/status integration
    pendingChainFor,

    -- * Auto-commit helper
    commitMigratedFiles,
  )
where

import Control.Monad (unless, when)
import Data.Aeson (ToJSON, object, (.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.Generics.Labels ()
import Data.Maybe (isJust)
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.Time.Clock (getCurrentTime)
import Effectful (runEff)
import Seihou.CLI.CommitMessage (generateCommitMessage)
import Seihou.CLI.Git (gitAdd, gitCheckIgnore, gitCommit, gitDiffCached, isGitRepo)
import Seihou.CLI.InstallShared
  ( InstallOutcome (..),
    OriginInfo (..),
    cloneRepo,
    installModuleDir,
    readOriginInfo,
    summarizeInstallRefusal,
  )
import Seihou.CLI.ManifestGuard
  ( ArtifactCheck,
    blockingChecks,
    checkAppliedArtifactsFor,
    formatGuardOverride,
    formatGuardRefusal,
  )
import Seihou.CLI.Shared (logIO, resolveAppliedArtifactDir)
import Seihou.CLI.Style (bold, dim, green, red, useColor, yellow)
import Seihou.Core.ArtifactRef (ArtifactRefError, renderArtifactRefError)
import Seihou.Core.Migration
  ( Migration (..),
    MigrationOp (..),
    MigrationPlan (..),
    MigrationPlanError (..),
    planMigrationChain,
  )
import Seihou.Core.Module (defaultSearchPaths)
import Seihou.Core.Registry
  ( Registry (..),
    RegistryEntry (..),
    RepoContents (..),
    discoverRepoContents,
  )
import Seihou.Core.Types
  ( AppliedModule (..),
    LogLevel (..),
    Manifest (..),
    Module (..),
    ModuleName (..),
  )
import Seihou.Core.Version (Version, parseVersion, renderVersion)
import Seihou.Dhall.Eval (evalModuleFromFile, evalRegistryFromFile)
import Seihou.Effect.FilesystemInterp (runFilesystem)
import Seihou.Effect.Logger (logWarn)
import Seihou.Effect.ManifestStore (readManifest, writeManifest)
import Seihou.Effect.ManifestStoreInterp (runManifestStore)
import Seihou.Effect.ProcessInterp (runProcessIO)
import Seihou.Engine.Migrate
  ( ExecutedMigrationPlan (..),
    MigrationExecError (..),
    MigrationFileStatus (..),
    MigrationOpInstance (..),
    classifyMigration,
    executeMigration,
  )
import Seihou.Prelude
import System.Directory (doesFileExist, getCurrentDirectory)
import System.Exit (ExitCode (..), exitFailure, exitSuccess)
import System.FilePath (takeFileName, (</>))
import System.IO (stderr)
import System.IO.Temp (withSystemTempDirectory)

-- ----------------------------------------------------------------------------
-- Options
-- ----------------------------------------------------------------------------

-- | Options for @seihou migrate@: applies module-declared migrations to
-- the current project's working tree and manifest.
data MigrateOpts = MigrateOpts
  { module_ :: !ModuleName,
    -- | Override the target version. Defaults to the installed
    -- module's current version (i.e. "migrate up to where the
    -- installed copy is now"). Under the gap-tolerant planner, the
    -- target is just the manifest's landing version: every declared
    -- migration whose @to@ does not exceed the target is applied,
    -- and the manifest advances to the target on success.
    to :: !(Maybe Text),
    dryRun :: !Bool,
    -- | Proceed even when the plan touches files the user has edited
    -- since they were generated. Mirrors @seihou remove --force@.
    force :: !Bool,
    json :: !Bool,
    verbose :: !Bool,
    -- | Skip the default fetch-and-refresh step that clones the module's
    -- source repo and refreshes @~/.config/seihou/installed/<name>/@
    -- before planning the chain. When 'True', the command performs no
    -- network IO and uses only the locally installed copy as the source
    -- of truth. Default: 'False' (fetch is the new default after EP-2;
    -- before EP-2 the only behavior was local-only).
    noFetch :: !Bool,
    -- | When 'True', and only on success branches that mutated the
    -- project's working tree, stage the touched files plus
    -- @.seihou/manifest.json@ and create a git commit. The commit
    -- message is supplied by 'migrateCommitMessage' if set, otherwise
    -- generated by 'Seihou.CLI.CommitMessage.generateCommitMessage'.
    -- Has no effect for dry-run or no-op outcomes. Has no effect
    -- outside a git work tree.
    commit :: !Bool,
    -- | Custom commit message; implies @commit = True@.
    -- When 'Nothing', the AI-generated message is used.
    commitMessage :: !(Maybe Text),
    -- | When 'True', plan a migration even though the copy of the module
    -- installed on this machine is older than the version
    -- @.seihou\/manifest.json@ records, or came from a different origin
    -- than it records. When 'False' (the default), 'handleMigrate'
    -- refuses before planning. A stale copy is especially damaging here:
    -- the chain is computed from the local module's declared migration
    -- list, so an older copy produces a chain that stops short of where
    -- the project already is.
    --
    -- Only 'handleMigrate' consults this. 'runMigrate' is the guard-free
    -- core that @seihou run --with-migrations@ and @seihou upgrade@ call
    -- once they have done their own checking.
    allowDowngrade :: !Bool
  }
  deriving stock (Eq, Show, Generic)

-- ----------------------------------------------------------------------------
-- Errors and results
-- ----------------------------------------------------------------------------

-- | Reasons the @seihou migrate@ handler exits non-zero. Each variant
-- carries a human-readable message that the IO shell prints and uses
-- as its error message.
data MigrateError
  = MigrateNoManifest FilePath
  | MigrateModuleNotApplied ModuleName
  | MigrateNoRecordedVersion ModuleName
  | MigrateInstalledModuleEvalFailed FilePath Text
  | MigrateInstalledModuleHasNoVersion ModuleName FilePath
  | MigrateUnparseableInstalledVersion Text
  | MigrateUnparseableTargetVersion Text
  | MigrateUnparseableManifestVersion Text
  | MigratePlanFailed MigrationPlanError
  | MigrateExecFailed MigrationExecError
  | -- | The manifest records the module, but its recorded origin does not
    -- resolve to anything on this machine.
    MigrateArtifactUnresolved ArtifactRefError
  | -- | The copy of the module installed here is older than, or came from
    -- somewhere other than, what the manifest records. Carries the blocking
    -- checks, rendered by 'formatGuardRefusal'.
    MigrateArtifactGuardFailed [ArtifactCheck]
  deriving stock (Eq, Show, Generic)

-- | Outcome of a successful @runMigrate@ call.
--
-- Three shapes only:
--
--   * 'MigrateNoOp' — the manifest already records the target version;
--     no work to do.
--   * 'MigrateApplied' — the manifest advanced from @from@ to @to@.
--     The carried 'ExecutedMigrationPlan' lists every step that
--     actually ran; it may be empty (a pure version bump where no
--     declared migration falls in the @[from, to]@ window).
--   * 'MigrateDryRunOK' — dry-run companion of 'MigrateApplied'.
data MigrateResult
  = MigrateNoOp Version
  | MigrateApplied ExecutedMigrationPlan Manifest Version Version
  | MigrateDryRunOK ExecutedMigrationPlan Version Version
  deriving stock (Eq, Show, Generic)

-- ----------------------------------------------------------------------------
-- IO shell
-- ----------------------------------------------------------------------------

-- | The IO entry point dispatched from @main@. Loads the manifest,
-- delegates planning + execution to 'runMigrate' (which handles the
-- fetch-and-refresh dance unless @--no-fetch@ was passed), and renders
-- the result.
handleMigrate :: MigrateOpts -> IO ()
handleMigrate opts = do
  let manifestPath = ".seihou" </> "manifest.json"
      modName = (opts ^. #module_)

  manifestRes <- runEff $ runFilesystem $ runManifestStore manifestPath readManifest
  manifest <- case manifestRes of
    Left err -> die (MigrateNoManifest (T.unpack err))
    Right Nothing -> die (MigrateNoManifest manifestPath)
    Right (Just m) -> pure m

  applied <- case findApplied manifest modName of
    Nothing -> die (MigrateModuleNotApplied modName)
    Just am -> pure am

  _fromV <- case applied ^. #moduleVersion >>= parseVersion of
    Just v -> pure v
    Nothing -> case applied ^. #moduleVersion of
      Nothing -> die (MigrateNoRecordedVersion modName)
      Just t -> die (MigrateUnparseableManifestVersion t)

  -- Refuse before planning if the copy installed here is not the copy the
  -- manifest describes. A stale local copy is especially damaging to a
  -- migration: the chain is computed from the local module's declared
  -- migration list, so an older copy yields a chain that stops short of where
  -- the project already is, and the manifest would be rewound to match.
  projectRoot <- getCurrentDirectory
  searchPaths <- defaultSearchPaths
  guardChecks <-
    checkAppliedArtifactsFor projectRoot searchPaths (Just (Set.singleton modName)) manifest
  case blockingChecks guardChecks of
    [] -> pure ()
    blocking
      | opts ^. #allowDowngrade -> TIO.putStr (formatGuardOverride blocking)
      | otherwise -> die (MigrateArtifactGuardFailed blocking)

  -- The manifest records a portable origin, never a path, so the module has
  -- to be located on this machine before it can be re-read.
  resolved <- resolveAppliedArtifactDir "module.dhall" (applied ^. #origin)
  installedDir <- either (die . MigrateArtifactUnresolved) pure resolved

  result <- runMigrate opts manifest installedDir

  colorEnabled <- useColor
  case result of
    Left err -> die err
    Right (MigrateNoOp toV) -> do
      TIO.putStrLn $
        applyColor colorEnabled green "✓"
          <> " "
          <> modName ^. #unModuleName
          <> " is already at version "
          <> renderVersion toV
          <> "; nothing to do."
      exitSuccess
    Right (MigrateDryRunOK plan fromV toV) -> do
      if opts ^. #json
        then LBS.putStr (encodePretty (planToJson plan))
        else do
          renderPlan colorEnabled plan fromV toV
          TIO.putStrLn ""
          TIO.putStrLn $ applyColor colorEnabled dim "(dry run — no changes made)"
      exitSuccess
    Right (MigrateApplied plan manifest' fromV toV) -> do
      if opts ^. #json
        then LBS.putStr (encodePretty (planToJson plan))
        else renderPlan colorEnabled plan fromV toV
      runEff $
        runFilesystem $
          runManifestStore manifestPath $
            writeManifest manifest'
      when (opts ^. #commit || isJust (opts ^. #commitMessage)) $
        commitMigratedFiles opts manifestPath plan
      unless (opts ^. #json) $ do
        TIO.putStrLn ""
        TIO.putStrLn $
          applyColor colorEnabled green "✓"
            <> " Migrated "
            <> applyColor colorEnabled bold (modName ^. #unModuleName)
            <> " "
            <> renderVersion fromV
            <> " → "
            <> renderVersion toV
            <> "."

-- | The non-IO core of the handler. Useful as a building block for
-- other CLI surfaces (e.g. @seihou upgrade --with-migrations@) that
-- already have a manifest and an installed-module dir in hand.
--
-- Behavior depends on @opts.noFetch@:
--
--   * @True@ — operate purely on the supplied @installedDir@. This is
--     the legacy behavior used by @seihou upgrade --with-migrations@,
--     which has already refreshed the installed copy.
--   * @False@ (default) — read @<installedDir>\/.seihou-origin.json@,
--     clone the source repository shallowly, use the clone's module
--     dir as the source of truth for planning the chain, and on a
--     successful non-dry-run application refresh @installedDir@ from
--     the clone via 'installModuleDir'. Failures (missing origin file,
--     clone failure, module not present in remote) silently fall back
--     to the local-only path.
runMigrate ::
  MigrateOpts ->
  Manifest ->
  -- | Installed-module directory, the path that holds @module.dhall@
  FilePath ->
  IO (Either MigrateError MigrateResult)
runMigrate opts manifest installedDir
  | (opts ^. #noFetch) = runMigrateLocal opts manifest installedDir
  | otherwise = runMigrateWithFetch opts manifest installedDir

-- | Plan and (optionally) execute a migration chain using @sourceDir@
-- as the source of truth for the module's @module.dhall@ and migrations
-- list. Performs no network IO.
runMigrateLocal ::
  MigrateOpts ->
  Manifest ->
  -- | Directory holding the module's @module.dhall@ — either the
  -- locally installed copy or a freshly cloned moduleDir.
  FilePath ->
  IO (Either MigrateError MigrateResult)
runMigrateLocal opts manifest sourceDir = do
  let modName = (opts ^. #module_)
  case findApplied manifest modName of
    Nothing -> pure (Left (MigrateModuleNotApplied modName))
    Just applied -> case applied ^. #moduleVersion of
      Nothing -> pure (Left (MigrateNoRecordedVersion modName))
      Just fromText ->
        case parseVersion fromText of
          Nothing -> pure (Left (MigrateUnparseableManifestVersion fromText))
          Just fromV -> do
            let sourceDhall = sourceDir </> "module.dhall"
            exists <- doesFileExist sourceDhall
            if not exists
              then
                pure
                  ( Left
                      ( MigrateInstalledModuleEvalFailed
                          sourceDhall
                          "module.dhall not found at installed dir"
                      )
                  )
              else do
                r <- evalModuleFromFile sourceDhall
                case r of
                  Left err ->
                    pure
                      ( Left
                          ( MigrateInstalledModuleEvalFailed
                              sourceDhall
                              (T.pack (show err))
                          )
                      )
                  Right sourceModule -> case resolveTarget opts sourceModule modName sourceDhall of
                    Left e -> pure (Left e)
                    Right toV ->
                      case planMigrationChain
                        (modName ^. #unModuleName)
                        (sourceModule ^. #migrations)
                        fromV
                        toV of
                        Left e -> pure (Left (MigratePlanFailed e))
                        Right Nothing -> pure (Right (MigrateNoOp toV))
                        Right (Just plan) ->
                          dispatchPlan opts manifest plan

-- | The fetch-and-refresh wrapper. Reads @<installedDir>\/.seihou-origin.json@,
-- clones the source repo to a temp dir, locates the module within the
-- clone, and dispatches to 'runMigrateLocal' with the cloned module
-- dir. On a successful non-dry-run apply, refreshes @installedDir@
-- from the clone so the next @seihou status@/@migrate@ call sees the
-- new version locally.
--
-- Any soft failure in the fetch path (missing origin metadata, clone
-- failure, module not in remote) emits a one-line note (unless JSON
-- output is requested, in which case the path stays silent so JSON
-- consumers aren't disturbed) and falls back to 'runMigrateLocal'
-- against the original 'installedDir'.
runMigrateWithFetch ::
  MigrateOpts ->
  Manifest ->
  FilePath ->
  IO (Either MigrateError MigrateResult)
runMigrateWithFetch opts manifest installedDir = do
  origin <- readOriginInfo installedDir
  case origin of
    Nothing -> do
      note opts $
        "  no origin metadata at "
          <> T.pack (installedDir </> ".seihou-origin.json")
          <> "; using locally installed copy."
      runMigrateLocal opts manifest installedDir
    Just o -> withSystemTempDirectory "seihou-migrate-fetch" $ \tmp -> do
      let cloneDir = tmp </> "clone"
      note opts ("  Fetching " <> o ^. #sourceUrl <> "...")
      cloneRes <- cloneRepo (o ^. #sourceUrl) cloneDir
      case cloneRes of
        Left err -> do
          note opts ("  fetch failed: " <> err <> "; using locally installed copy.")
          runMigrateLocal opts manifest installedDir
        Right () -> do
          contents <- discoverRepoContents evalRegistryFromFile cloneDir
          case findRemoteModuleDir cloneDir contents (opts ^. #module_) of
            Nothing -> do
              note opts $
                "  module '"
                  <> opts ^. #module_ . #unModuleName
                  <> "' not present in remote; using locally installed copy."
              runMigrateLocal opts manifest installedDir
            Just (moduleDir, tags) -> do
              -- Plan and execute against the clone's module dir. The
              -- chain operates on the project's working tree; the
              -- moduleDir only supplies the migrations list and the
              -- target version.
              cloneResult <- runMigrateLocal opts manifest moduleDir
              -- EP-27 / EP-35 M5: when the local install declares more
              -- in-window migrations than the clone, prefer the local
              -- plan. The user's installed copy may still declare an
              -- applicable edge that the remote dropped; honour it
              -- rather than silently skip.
              result <- maybeFallbackToLocal opts manifest installedDir cloneResult
              -- Refresh the installed copy on the disk so future
              -- commands see the new version locally. Any successful
              -- apply (with or without ops) updates the disk; dry-run
              -- and no-op outcomes leave it untouched.
              case result of
                Right (MigrateApplied {})
                  | not (opts ^. #dryRun) ->
                      refreshInstalledFromClone moduleDir installedDir o tags
                _ -> pure ()
              pure result

-- | If the local install yields a plan with strictly more in-window
-- migrations than the clone-based plan, prefer the local result.
-- Otherwise the clone's plan stands. The check fires on any successful
-- result (Applied, DryRunOK, NoOp); errors are passed through
-- unchanged.
maybeFallbackToLocal ::
  MigrateOpts ->
  Manifest ->
  FilePath ->
  Either MigrateError MigrateResult ->
  IO (Either MigrateError MigrateResult)
maybeFallbackToLocal opts manifest installedDir cloneResult = case cloneResult of
  Left _ -> pure cloneResult
  Right cloneOk -> do
    localResult <- runMigrateLocal opts manifest installedDir
    pure $ case localResult of
      Right localOk
        | resultStepCount localOk > resultStepCount cloneOk -> localResult
      _ -> cloneResult

-- | Number of migration steps a result actually carries (or would
-- carry, in dry-run form). Used by 'maybeFallbackToLocal'.
resultStepCount :: MigrateResult -> Int
resultStepCount = \case
  MigrateNoOp {} -> 0
  MigrateApplied execPlan _ _ _ -> length (execPlan ^. #source . #steps)
  MigrateDryRunOK execPlan _ _ -> length (execPlan ^. #source . #steps)

-- | Print a one-line note unless JSON output is requested. Using JSON
-- output requires a clean, parseable stdout.
note :: MigrateOpts -> Text -> IO ()
note opts msg = unless (opts ^. #json) (TIO.putStrLn msg)

-- | Locate the module's directory inside a cloned repo and return any
-- registry-declared tags. Returns 'Nothing' for empty repos or
-- recipe-only repos, or for multi-module repos that do not list the
-- requested module.
findRemoteModuleDir ::
  FilePath ->
  RepoContents ->
  ModuleName ->
  Maybe (FilePath, [Text])
findRemoteModuleDir cloneDir contents modName = case contents of
  SingleModule rootDir -> Just (rootDir, [])
  MultiModule registry ->
    case filter (\e -> e ^. #name == modName) (registry ^. #modules) of
      (entry : _) -> Just (cloneDir </> entry ^. #path, entry ^. #tags)
      [] -> Nothing
  SingleRecipe _ -> Nothing
  SingleBlueprint _ -> Nothing
  SinglePrompt _ -> Nothing
  EmptyRepo -> Nothing

-- | Refresh the on-disk installed module directory from a cloned
-- module dir. Reads the clone's @module.dhall@ for its declared
-- version, then calls 'installModuleDir' with the same name as the
-- existing installation (basename of @installedDir@) so the XDG-derived
-- destination matches the original install path.
refreshInstalledFromClone ::
  FilePath ->
  FilePath ->
  OriginInfo ->
  [Text] ->
  IO ()
refreshInstalledFromClone moduleDir installedDir origin tags = do
  let dhallFile = moduleDir </> "module.dhall"
  modulRes <- evalModuleFromFile dhallFile
  case modulRes of
    Left _ -> pure ()
    Right modul -> do
      let installedName = takeFileName installedDir
      -- Pass force = False deliberately. The URL passed here was read out of
      -- the installed copy's own @.seihou-origin.json@ a moment ago, so this
      -- is structurally the same-source case and must never refuse. If it
      -- does, the cache disagrees with its own provenance file — real news,
      -- and reported rather than overridden. Do not "fix" it by passing True.
      outcome <-
        installModuleDir
          False
          moduleDir
          installedName
          (origin ^. #sourceUrl)
          (origin ^. #repoName)
          (modul ^. #version)
          tags
      case outcome of
        InstallPerformed -> pure ()
        InstallRefused collision ->
          logIO LogNormal . logWarn $
            "could not refresh the installed copy of '"
              <> T.pack installedName
              <> "': "
              <> summarizeInstallRefusal (origin ^. #sourceUrl) collision
              <> ". The migration was applied to this project; the shared cache still holds the older copy."

-- ----------------------------------------------------------------------------
-- Pending-migration detection (used by status / upgrade)
-- ----------------------------------------------------------------------------

-- | Detect whether the manifest's recorded version of an applied module
-- has fallen behind the installed copy. Returns:
--
--   * @Nothing@ — versions equal, manifest version unrecorded,
--     installed-module version unrecorded, parse failure anywhere, or
--     the planner reported a hard error.
--   * @Just plan@ — a non-trivial plan whose 'planSteps' may be empty
--     (a pure version bump) or non-empty.
--
-- Parse failures and planner errors are treated as "no pending
-- migration" rather than surfaced — this is the soft-warning path for
-- @seihou status@. Hard errors land on the user when they actually
-- run @seihou migrate@.
pendingChainFor ::
  AppliedModule ->
  Module ->
  Maybe MigrationPlan
pendingChainFor applied installed = do
  fromText <- (applied ^. #moduleVersion)
  fromV <- parseVersion fromText
  toText <- (installed ^. #version)
  toV <- parseVersion toText
  case planMigrationChain
    (applied ^. #name . #unModuleName)
    (installed ^. #migrations)
    fromV
    toV of
    Right (Just plan) -> Just plan
    _ -> Nothing

-- ----------------------------------------------------------------------------
-- Helpers
-- ----------------------------------------------------------------------------

-- | Decide what to do with a 'MigrationPlan' returned by the planner.
-- Pure-IO: classifies the plan, optionally executes it, and packs the
-- outcome into a 'MigrateResult' variant the renderer knows how to
-- print.
--
-- The plan from the gap-tolerant walker is always one shape — an
-- ordered list of in-window migrations plus the supplied @from@
-- and @to@. The dispatcher branches only on @from == to@
-- (no work) and dry-run vs apply.
dispatchPlan ::
  MigrateOpts ->
  Manifest ->
  MigrationPlan ->
  IO (Either MigrateError MigrateResult)
dispatchPlan opts manifest plan
  | plan ^. #from == (plan ^. #to) = pure (Right (MigrateNoOp (plan ^. #to)))
  | otherwise = applyOrDryRun opts manifest plan

-- | Classify the plan, optionally execute it, and return the
-- appropriate 'MigrateResult' variant. Empty 'planSteps' is fine —
-- 'executeMigration' runs zero file ops but still advances the
-- manifest's recorded @moduleVersion@ to @to@.
applyOrDryRun ::
  MigrateOpts ->
  Manifest ->
  MigrationPlan ->
  IO (Either MigrateError MigrateResult)
applyOrDryRun opts manifest plan = do
  classifyResult <-
    runEff $
      runFilesystem $
        classifyMigration manifest plan
  case classifyResult of
    Left err -> pure (Left (MigrateExecFailed err))
    Right executedPlan ->
      if opts ^. #dryRun
        then pure (Right (MigrateDryRunOK executedPlan (plan ^. #from) (plan ^. #to)))
        else do
          now <- getCurrentTime
          execRes <-
            runEff $
              runFilesystem $
                runProcessIO $
                  executeMigration (opts ^. #force) executedPlan manifest now
          case execRes of
            Left err -> pure (Left (MigrateExecFailed err))
            Right manifest' ->
              pure (Right (MigrateApplied executedPlan manifest' (plan ^. #from) (plan ^. #to)))

-- | Stage and commit the files touched by a successful migration plan.
-- Mirrors the @seihou run --commit@ post-execution helper. No-op
-- outside a git work tree, when every staged path is git-ignored, or
-- when both flags are off (callers gate on the flags before invoking
-- this). 'RunCommandInst' ops contribute no paths — their filesystem
-- effects are opaque, so any extra working-tree changes need a
-- separate manual commit.
commitMigratedFiles ::
  MigrateOpts ->
  -- | Manifest path (added to the staged set).
  FilePath ->
  ExecutedMigrationPlan ->
  IO ()
commitMigratedFiles opts manifestPath plan = do
  let touched = concatMap pathsForOp (plan ^. #ops)
      filesToStage = touched ++ [manifestPath]
  inGit <- runEff $ runProcessIO isGitRepo
  when inGit $ do
    ignored <- runEff $ runProcessIO $ gitCheckIgnore filesToStage
    let staged = filter (`notElem` ignored) filesToStage
    unless (null staged) $ do
      (addExit, _, addErr) <- runEff $ runProcessIO $ gitAdd staged
      case addExit of
        ExitFailure _ -> TIO.hPutStrLn stderr ("git add failed: " <> addErr)
        ExitSuccess -> do
          msg <- case opts ^. #commitMessage of
            Just m -> pure m
            Nothing -> do
              diffText <- runEff $ runProcessIO gitDiffCached
              generateCommitMessage [opts ^. #module_] diffText
          (cExit, _, cErr) <- runEff $ runProcessIO $ gitCommit msg
          case cExit of
            ExitSuccess -> pure ()
            ExitFailure _ ->
              TIO.hPutStrLn stderr ("git commit failed: " <> cErr)
  where
    pathsForOp inst = case inst of
      MoveFileInst src dest _ -> [src, dest]
      MoveDirInst src dest -> [src, dest]
      DeleteFileInst path _ -> [path]
      DeleteDirInst path -> [path]
      RunCommandInst _ _ -> []

resolveTarget ::
  MigrateOpts -> Module -> ModuleName -> FilePath -> Either MigrateError Version
resolveTarget opts installedModule modName installedDhall =
  case opts ^. #to of
    Just t -> case parseVersion t of
      Just v -> Right v
      Nothing -> Left (MigrateUnparseableTargetVersion t)
    Nothing -> case installedModule ^. #version of
      Nothing -> Left (MigrateInstalledModuleHasNoVersion modName installedDhall)
      Just t -> case parseVersion t of
        Just v -> Right v
        Nothing -> Left (MigrateUnparseableInstalledVersion t)

findApplied :: Manifest -> ModuleName -> Maybe AppliedModule
findApplied m name =
  case filter (\am -> am ^. #name == name) (m ^. #modules) of
    (am : _) -> Just am
    [] -> Nothing

-- | Render a classified plan to stdout in the human-readable format.
-- The supplied versions are the user-visible "X → Y" header taken from
-- the source plan's @from@ and @to@; the manifest will land at
-- @to@ even when 'planSteps' is empty.
renderPlan :: Bool -> ExecutedMigrationPlan -> Version -> Version -> IO ()
renderPlan c plan fromV toV = do
  let src = (plan ^. #source)
  TIO.putStrLn $
    "Migration plan: "
      <> applyColor c bold (src ^. #module_)
      <> "  "
      <> renderVersion fromV
      <> " → "
      <> renderVersion toV
  if null (src ^. #steps)
    then TIO.putStrLn "  (no migration ops)"
    else mapM_ (renderStep c) (src ^. #steps)
  let conflictCount =
        length
          [ () | inst <- plan ^. #ops, isConflict inst
          ]
      affectedCount =
        length
          [ () | inst <- plan ^. #ops, touchesFs inst
          ]
  TIO.putStrLn ""
  TIO.putStrLn $
    T.pack (show affectedCount)
      <> " operation(s), "
      <> T.pack (show conflictCount)
      <> " conflict(s)."
  where
    isConflict (MoveFileInst _ _ MFConflict) = True
    isConflict (DeleteFileInst _ MFConflict) = True
    isConflict _ = False

    touchesFs (RunCommandInst _ _) = True
    touchesFs _ = True

renderStep :: Bool -> Migration -> IO ()
renderStep c step = do
  TIO.putStrLn $ "  " <> step ^. #from <> " → " <> step ^. #to <> ":"
  mapM_ (renderOp c) (step ^. #ops)

renderOp :: Bool -> MigrationOp -> IO ()
renderOp c op = case op of
  MoveFile {src, dest} ->
    TIO.putStrLn $ "    " <> applyColor c green "move-file " <> T.pack src <> " -> " <> T.pack dest
  MoveDir {src, dest} ->
    TIO.putStrLn $ "    " <> applyColor c green "move-dir  " <> T.pack src <> " -> " <> T.pack dest
  DeleteFile {path} ->
    TIO.putStrLn $ "    " <> applyColor c yellow "delete    " <> T.pack path
  DeleteDir {path} ->
    TIO.putStrLn $ "    " <> applyColor c yellow "delete-dir" <> " " <> T.pack path
  RunCommand {run, workDir} ->
    let suffix = case workDir of
          Just wd -> applyColor c dim (" (in " <> T.pack wd <> ")")
          Nothing -> ""
     in TIO.putStrLn $ "    " <> applyColor c green "run       " <> run <> suffix

-- ----------------------------------------------------------------------------
-- JSON output
-- ----------------------------------------------------------------------------

planToJson :: ExecutedMigrationPlan -> Aeson.Value
planToJson plan =
  let src = (plan ^. #source)
   in object
        [ "module" .= (plan ^. #module_ . #unModuleName),
          "from" .= renderVersion (src ^. #from),
          "to" .= renderVersion (src ^. #to),
          "steps"
            .= [ object
                   [ "from" .= (step ^. #from),
                     "to" .= (step ^. #to),
                     "ops" .= map opToJson (step ^. #ops)
                   ]
               | step <- src ^. #steps
               ],
          "operations" .= map instToJson (plan ^. #ops)
        ]

opToJson :: MigrationOp -> Aeson.Value
opToJson op = case op of
  MoveFile {src, dest} ->
    object ["op" .= ("move-file" :: Text), "src" .= T.pack src, "dest" .= T.pack dest]
  MoveDir {src, dest} ->
    object ["op" .= ("move-dir" :: Text), "src" .= T.pack src, "dest" .= T.pack dest]
  DeleteFile {path} ->
    object ["op" .= ("delete-file" :: Text), "path" .= T.pack path]
  DeleteDir {path} ->
    object ["op" .= ("delete-dir" :: Text), "path" .= T.pack path]
  RunCommand {run, workDir} ->
    object ["op" .= ("run-command" :: Text), "run" .= run, "workDir" .= fmap T.pack workDir]

instToJson :: MigrationOpInstance -> Aeson.Value
instToJson inst = case inst of
  MoveFileInst src dest status ->
    object
      [ "op" .= ("move-file" :: Text),
        "src" .= T.pack src,
        "dest" .= T.pack dest,
        "status" .= statusToJson status
      ]
  MoveDirInst src dest ->
    object
      ["op" .= ("move-dir" :: Text), "src" .= T.pack src, "dest" .= T.pack dest]
  DeleteFileInst p status ->
    object
      [ "op" .= ("delete-file" :: Text),
        "path" .= T.pack p,
        "status" .= statusToJson status
      ]
  DeleteDirInst p ->
    object ["op" .= ("delete-dir" :: Text), "path" .= T.pack p]
  RunCommandInst run wd ->
    object ["op" .= ("run-command" :: Text), "run" .= run, "workDir" .= fmap T.pack wd]

statusToJson :: MigrationFileStatus -> Text
statusToJson MFSafe = "safe"
statusToJson MFConflict = "conflict"
statusToJson MFGone = "gone"

-- ----------------------------------------------------------------------------
-- Misc
-- ----------------------------------------------------------------------------

-- | Apply ANSI styling when colour is enabled.
applyColor :: Bool -> (Text -> Text) -> Text -> Text
applyColor True f = f
applyColor False _ = id

-- | Print the error and exit non-zero. The IO shell calls this; the
-- pure 'runMigrate' returns 'Left' instead.
die :: MigrateError -> IO a
die err = do
  c <- useColor
  TIO.putStrLn $ applyColor c red "Error: " <> renderError err
  exitFailure

renderError :: MigrateError -> Text
renderError (MigrateNoManifest path) =
  "no Seihou manifest at " <> T.pack path <> "; run from a project that has been initialized."
renderError (MigrateModuleNotApplied modName) =
  "module '" <> modName ^. #unModuleName <> "' is not applied in this project."
renderError (MigrateNoRecordedVersion modName) =
  "module '"
    <> modName ^. #unModuleName
    <> "' has no version recorded in the manifest. Re-apply the module with 'seihou run' to record one before migrating."
renderError (MigrateInstalledModuleEvalFailed path msg) =
  "could not evaluate installed module at " <> T.pack path <> ": " <> msg
renderError (MigrateInstalledModuleHasNoVersion modName path) =
  "installed module '"
    <> modName ^. #unModuleName
    <> "' at "
    <> T.pack path
    <> " has no version field; either pass --to or add a version to its module.dhall."
renderError (MigrateUnparseableInstalledVersion v) =
  "installed module's version '" <> v <> "' is not a valid dotted version."
renderError (MigrateUnparseableTargetVersion v) =
  "--to value '" <> v <> "' is not a valid dotted version."
renderError (MigrateUnparseableManifestVersion v) =
  "manifest's recorded module version '" <> v <> "' is not a valid dotted version."
renderError (MigratePlanFailed e) = renderPlanError e
renderError (MigrateExecFailed e) = renderExecError e
renderError (MigrateArtifactUnresolved e) =
  "cannot plan a migration.\n\n" <> renderArtifactRefError e
renderError (MigrateArtifactGuardFailed checks) =
  "cannot plan a migration.\n\n" <> formatGuardRefusal checks

renderPlanError :: MigrationPlanError -> Text
renderPlanError (MigrationVersionUnparseable t) =
  "a migration declares an unparseable version: '" <> t <> "'"
renderPlanError (MigrationDowngradeNotSupported installed target) =
  "downgrade not supported: installed "
    <> renderVersion installed
    <> ", requested target "
    <> renderVersion target
    <> "."
renderPlanError (MigrationDuplicateEdge fromV _) =
  "two or more migrations declare the same 'from = "
    <> renderVersion fromV
    <> "'. The chain is ambiguous; the module author needs to merge or remove the duplicate."

renderExecError :: MigrationExecError -> Text
renderExecError (MigrationConflict paths) =
  "the following file(s) have been modified since they were generated:\n"
    <> T.intercalate "\n" ["  - " <> T.pack p | p <- paths]
    <> "\n\nRe-run with --force to overwrite them, or revert your edits first."
renderExecError (MigrationCommandFailed msg code) =
  "a run-command op exited with code "
    <> T.pack (show code)
    <> ":\n  "
    <> msg
renderExecError (MigrationUnsafePath label path reason) =
  "unsafe migration "
    <> label
    <> " '"
    <> T.pack path
    <> "': "
    <> reason

-- Aeson ToJSON pass-through for ExecutedMigrationPlan: routed through
-- planToJson manually rather than deriving so we have the field shape
-- documented above.
instance ToJSON ExecutedMigrationPlan where
  toJSON = planToJson